From f371a87ddef304791d9f8016a9672dd9283f95f8 Mon Sep 17 00:00:00 2001 From: Martyn Clark Date: Wed, 26 Nov 2025 08:40:07 -0700 Subject: [PATCH 01/16] minor changes to get working on a mac --- build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 | 2 +- build/FUSE_SRC/FUSE_NETCDF/def_output.f90 | 14 +++++++------- build/FUSE_SRC/FUSE_NETCDF/put_output.f90 | 4 ++-- build/Makefile | 22 ++++++++-------------- 4 files changed, 18 insertions(+), 24 deletions(-) diff --git a/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 b/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 index b64355c..bca594e 100644 --- a/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 +++ b/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 @@ -247,7 +247,7 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! 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 + IF (IERR.NE.0) THEN; PRINT *, TRIM(MESSAGE); STOP 1; ENDIF ! perform overland flow routing CALL Q_OVERLAND() diff --git a/build/FUSE_SRC/FUSE_NETCDF/def_output.f90 b/build/FUSE_SRC/FUSE_NETCDF/def_output.f90 index 6e71c93..f04bbb5 100644 --- a/build/FUSE_SRC/FUSE_NETCDF/def_output.f90 +++ b/build/FUSE_SRC/FUSE_NETCDF/def_output.f90 @@ -64,9 +64,9 @@ SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,NPSET,NTIM) !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) + 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 @@ -141,23 +141,23 @@ SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,NPSET,NTIM) 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_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_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_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_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 diff --git a/build/FUSE_SRC/FUSE_NETCDF/put_output.f90 b/build/FUSE_SRC/FUSE_NETCDF/put_output.f90 index bc2e361..8d1b13e 100644 --- a/build/FUSE_SRC/FUSE_NETCDF/put_output.f90 +++ b/build/FUSE_SRC/FUSE_NETCDF/put_output.f90 @@ -71,7 +71,7 @@ SUBROUTINE PUT_OUTPUT(iSpat1,iSpat2,ITIM,IMOD,IPAR) ! 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 + 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) @@ -180,7 +180,7 @@ SUBROUTINE PUT_GOUTPUT_3D(istart_sim,istart_in,numtim,IPSET) 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 + 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) diff --git a/build/Makefile b/build/Makefile index 4019dfc..01cb576 100644 --- a/build/Makefile +++ b/build/Makefile @@ -7,7 +7,7 @@ #======================================================================== # Define core directory below which everything resides -F_MASTER = ${HOME}/fuse/ +F_MASTER = ${HOME}/Documents/analysis/diffModel/FUSE/source/fuse/ # Core directory that contains FUSE source code F_KORE_DIR = $(F_MASTER)build/FUSE_SRC/ @@ -22,14 +22,9 @@ EXE_PATH = $(F_MASTER)bin/ # PART 1: Define the libraries, driver programs, and executables #======================================================================== -# Define the fortran compiler. You have a few options: i) set the FC -# variable in your environment, ii) set it when you compile this -# Make file (e.g. make FC=ifort), iii) or if don't define it, the compiler -# specified below is used -ifndef FC - #FC = ifort - FC = gfortran -endif +# Define the fortran compiler. +#FC = ifort +FC = gfortran # Define the NetCDF and HDF5 libraries. Use the libraries associated with # the compiler you selected above. Note that these paths are machine-dependent @@ -41,13 +36,12 @@ ifeq "$(FC)" "ifort" endif ifeq "$(FC)" "gfortran" - NCDF_LIB_PATH = /usr/lib/x86_64-linux-gnu#${NCDF_PATH} - HDF_LIB_PATH = /usr/lib/x86_64-linux-gnu/hdf5/serial#${HDF_PATH} - INCLUDE_PATH = /usr#${IN_PATH} + INC_NETCDF := $(shell nf-config --fflags) + LIB_NETCDF := $(shell nf-config --flibs) $(shell nc-config --libs) endif -LIBRARIES = -L$(NCDF_LIB_PATH)/lib -lnetcdff -lnetcdf -L$(HDF_LIB_PATH)/lib -lhdf5_hl -lhdf5 -INCLUDE = -I$(INCLUDE_PATH)/include -I$(INCLUDE_PATH)/include +LIBRARIES = $(LIB_NETCDF) +INCLUDE = $(INC_NETCDF) # Define the driver program and associated subroutines for the fidelity test FUSE_DRIVER = \ From 1cf34cac4498a6866920c0f369d7584e9c75a8b3 Mon Sep 17 00:00:00 2001 From: Martyn Clark Date: Sat, 29 Nov 2025 08:32:08 -0700 Subject: [PATCH 02/16] new scaffolding for differentiable model --- build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 | 3 +- build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 | 44 +++- build/FUSE_SRC/FUSE_ENGINE/assign_par.f90 | 3 +- build/FUSE_SRC/FUSE_ENGINE/getnumerix.f90 | 10 +- build/FUSE_SRC/FUSE_ENGINE/getpar_str.f90 | 3 +- build/FUSE_SRC/FUSE_ENGINE/getparmeta.f90 | 2 +- build/FUSE_SRC/FUSE_ENGINE/multi_flux.f90 | 42 --- build/FUSE_SRC/FUSE_ENGINE/multistate.f90 | 53 ---- build/FUSE_SRC/FUSE_ENGINE/multistats.f90 | 35 --- build/FUSE_SRC/FUSE_ENGINE/putpar_str.f90 | 3 +- build/FUSE_SRC/FUSE_ENGINE/str_2_xtry.f90 | 2 +- .../multiparam.f90 => dshare/data_types.f90} | 201 +++++++++++++-- .../{FUSE_ENGINE => dshare}/model_defn.f90 | 0 .../model_defnames.f90 | 0 .../{FUSE_ENGINE => dshare}/model_numerix.f90 | 3 + build/FUSE_SRC/dshare/multi_flux.f90 | 11 + .../{FUSE_ENGINE => dshare}/multibands.f90 | 0 .../{FUSE_ENGINE => dshare}/multiconst.f90 | 0 .../{FUSE_ENGINE => dshare}/multiforce.f90 | 31 +-- build/FUSE_SRC/dshare/multiparam.f90 | 22 ++ .../{FUSE_ENGINE => dshare}/multiroute.f90 | 0 build/FUSE_SRC/dshare/multistate.f90 | 27 ++ build/FUSE_SRC/dshare/multistats.f90 | 9 + build/FUSE_SRC/physics/evap_lower_diff.f90 | 88 +++++++ build/FUSE_SRC/physics/evap_upper_diff.f90 | 91 +++++++ build/FUSE_SRC/physics/fix_ovshoot.f90 | 139 ++++++++++ build/FUSE_SRC/physics/get_parent.f90 | 26 ++ build/FUSE_SRC/physics/implicit_solve.f90 | 244 ++++++++++++++++++ build/FUSE_SRC/physics/mod_derivs_diff.f90 | 50 ++++ build/FUSE_SRC/physics/mstate_rhs_diff.f90 | 77 ++++++ build/FUSE_SRC/physics/q_baseflow_diff.f90 | 69 +++++ build/FUSE_SRC/physics/q_misscell_diff.f90 | 116 +++++++++ build/FUSE_SRC/physics/qinterflow_diff.f90 | 52 ++++ build/FUSE_SRC/physics/qpercolate_diff.f90 | 61 +++++ build/FUSE_SRC/physics/qsatexcess_diff.f90 | 106 ++++++++ build/Makefile | 37 ++- 36 files changed, 1455 insertions(+), 205 deletions(-) delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/multi_flux.f90 delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/multistate.f90 delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/multistats.f90 rename build/FUSE_SRC/{FUSE_ENGINE/multiparam.f90 => dshare/data_types.f90} (52%) rename build/FUSE_SRC/{FUSE_ENGINE => dshare}/model_defn.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => dshare}/model_defnames.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => dshare}/model_numerix.f90 (96%) create mode 100644 build/FUSE_SRC/dshare/multi_flux.f90 rename build/FUSE_SRC/{FUSE_ENGINE => dshare}/multibands.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => dshare}/multiconst.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => dshare}/multiforce.f90 (84%) create mode 100644 build/FUSE_SRC/dshare/multiparam.f90 rename build/FUSE_SRC/{FUSE_ENGINE => dshare}/multiroute.f90 (100%) create mode 100644 build/FUSE_SRC/dshare/multistate.f90 create mode 100644 build/FUSE_SRC/dshare/multistats.f90 create mode 100644 build/FUSE_SRC/physics/evap_lower_diff.f90 create mode 100644 build/FUSE_SRC/physics/evap_upper_diff.f90 create mode 100644 build/FUSE_SRC/physics/fix_ovshoot.f90 create mode 100644 build/FUSE_SRC/physics/get_parent.f90 create mode 100644 build/FUSE_SRC/physics/implicit_solve.f90 create mode 100644 build/FUSE_SRC/physics/mod_derivs_diff.f90 create mode 100644 build/FUSE_SRC/physics/mstate_rhs_diff.f90 create mode 100644 build/FUSE_SRC/physics/q_baseflow_diff.f90 create mode 100644 build/FUSE_SRC/physics/q_misscell_diff.f90 create mode 100644 build/FUSE_SRC/physics/qinterflow_diff.f90 create mode 100644 build/FUSE_SRC/physics/qpercolate_diff.f90 create mode 100644 build/FUSE_SRC/physics/qsatexcess_diff.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 b/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 index 4d2c7d0..085cdb9 100644 --- a/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 +++ b/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 @@ -46,7 +46,8 @@ PROGRAM DISTRIBUTED_DRIVER USE multistate, only: ncid_out ! NetCDF output file ID USE multibands ! basin band stuctures -USE multiparam, ONLY: LPARAM, PARATT, NUMPAR ! parameter metadata structures +USE data_types, ONLY: PARATT ! data type for metadata +USE multiparam, ONLY: LPARAM, NUMPAR ! parameter metadata structures USE multistate, only: gState ! gridded state variables USE multistate, only: gState_3d ! gridded state variables with a time dimension USE multiroute, ONLY: AROUTE ! model routing structures diff --git a/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 b/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 index bca594e..c269eff 100644 --- a/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 +++ b/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 @@ -52,6 +52,11 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG 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 + ! differentiable model + use data_types, only: parent ! fuse parent data type + use get_parent_module, only: get_parent ! populate the parent data structure + use implicit_solve_module, only:implicit_solve ! simple implicit solve for differnetiable ODE + ! interface blocks USE interfaceb, ONLY:ode_int,fuse_solve ! provide access to FUSE_SOLVE through ODE_INT @@ -93,6 +98,10 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG CHARACTER(LEN=CLEN) :: CMESSAGE ! error message of downwind routine INTEGER(I4B),PARAMETER::UNT=6 !1701 ! 6 + ! differentiable model + type(parent) :: fuseStruct ! parent fuse data structure + + ! --------------------------------------------------------------------------------------- ! allocate state vectors ALLOCATE(STATE0(NSTATE),STATE1(NSTATE),STAT=IERR) @@ -245,9 +254,38 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG 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); STOP 1; ENDIF + ! ----- start of soil physics code ------------------------------------------------------------ + + ! temporally integrate the ordinary differential equations + select case(diff_mode) + + ! original code + case(original) + CALL ODE_INT(FUSE_SOLVE,STATE0,STATE1,DT_SUB,DT_FULL,IERR,MESSAGE) + IF (IERR.NE.0) THEN; PRINT *, TRIM(MESSAGE); STOP 1; ENDIF + + !print*, state1 + !if(ITIM_IN > sim_beg+100) stop + + ! differentiable code + case(differentiable) + + ! populate parent fuse structure + call get_parent(fuseStruct) + + ! solve differentiable ODEs + call implicit_solve(fuseStruct, state0, state1, nState) + !print*, state1 + !if(ITIM_IN > sim_beg+100) stop + + ! save fluxes + W_FLUX = fuseStruct%flux + + ! check options + case default; print*, "Cannot identify diff_mode"; stop 1 + end select + + ! ----- end of soil physics code -------------------------------------------------------------- ! perform overland flow routing CALL Q_OVERLAND() diff --git a/build/FUSE_SRC/FUSE_ENGINE/assign_par.f90 b/build/FUSE_SRC/FUSE_ENGINE/assign_par.f90 index 5558eae..3bf82e9 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/assign_par.f90 +++ b/build/FUSE_SRC/FUSE_ENGINE/assign_par.f90 @@ -16,7 +16,8 @@ SUBROUTINE ASSIGN_PAR() USE nrtype ! variable types, etc. USE model_defn ! model definition structure USE model_defnames -USE multiparam, ONLY : lparam, paratt, numpar ! model parameter structures +USE data_types, ONLY : paratt ! data type for metadata +USE multiparam, ONLY : lparam, numpar ! model parameter structures USE getpar_str_module ! access to SUBROUTINE get_par_str IMPLICIT NONE INTEGER(I4B) :: MPAR ! counter for number of parameters diff --git a/build/FUSE_SRC/FUSE_ENGINE/getnumerix.f90 b/build/FUSE_SRC/FUSE_ENGINE/getnumerix.f90 index 9a4d3c5..43b15e7 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/getnumerix.f90 +++ b/build/FUSE_SRC/FUSE_ENGINE/getnumerix.f90 @@ -18,13 +18,15 @@ SUBROUTINE GETNUMERIX(err,message) USE model_numerix,only:SOLUTION_METHOD,& ! defines numerix decisions TEMPORAL_ERROR_CONTROL,INITIAL_NEWTON,JAC_RECOMPUTE,CHECK_OVERSHOOT,SMALL_ENDSTEP,& ERR_TRUNC_ABS,ERR_TRUNC_REL,ERR_ITER_FUNC,ERR_ITER_DX,THRESH_FRZE,FRACSTATE_MIN,& - SAFETY,RMIN,RMAX,NITER_TOTAL,MIN_TSTEP,MAX_TSTEP + SAFETY,RMIN,RMAX,NITER_TOTAL,MIN_TSTEP,MAX_TSTEP,diff_mode +USE model_numerix,only:original,differentiable ! named variables for diff_mode IMPLICIT NONE ! dummies integer(I4B),intent(out) :: err character(*),intent(out) :: message ! locals INTEGER(I4B) :: IUNIT ! file unit +integer(i4b) :: ios ! io status flag integer(i4b),parameter::lenPath=1024 !DK/2008/10/21: allows longer file paths CHARACTER(LEN=lenPath) :: CFILE ! name of constraints file LOGICAL(LGT) :: LEXIST ! .TRUE. if file exists @@ -65,6 +67,12 @@ SUBROUTINE GETNUMERIX(err,message) READ(IUNIT,*) NITER_TOTAL ! Total number of iterations used in the implicit scheme READ(IUNIT,*) MIN_TSTEP ! Minimum time step length (minutes) READ(IUNIT,*) MAX_TSTEP ! Maximum time step length (minutes) +! new option -- ensure backwards compatible +read(iunit,*, iostat=ios) diff_mode ! Mode for differentiable models (non-differentiable; differentiable) +if(ios/=0)then + diff_mode = original + print*, "WARNING: diff_mode is not specified; setting option to original. Continuing" +endif ! if problem reading CLOSE(IUNIT) MIN_TSTEP = MIN_TSTEP/(24._SP*60._SP) ! Convert from minutes to days MAX_TSTEP = MAX_TSTEP/(24._SP*60._SP) ! Convert from minutes to days diff --git a/build/FUSE_SRC/FUSE_ENGINE/getpar_str.f90 b/build/FUSE_SRC/FUSE_ENGINE/getpar_str.f90 index 4b51b3e..bf3fd77 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/getpar_str.f90 +++ b/build/FUSE_SRC/FUSE_ENGINE/getpar_str.f90 @@ -13,7 +13,8 @@ SUBROUTINE GETPAR_STR(PARNAME,METADAT) ! Inserts parameter metadata into data structures ! --------------------------------------------------------------------------------------- USE nrtype ! variable types, etc. -USE multiparam, ONLY : PARATT, PARMETA ! derived type for parameter metadata +USE data_types, ONLY : PARATT ! derived type for parameter metadata +USE multiparam, ONLY : PARMETA ! parameter metadata IMPLICIT NONE ! input CHARACTER(*), INTENT(IN) :: PARNAME ! parameter name diff --git a/build/FUSE_SRC/FUSE_ENGINE/getparmeta.f90 b/build/FUSE_SRC/FUSE_ENGINE/getparmeta.f90 index 8c6313d..774fd7b 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/getparmeta.f90 +++ b/build/FUSE_SRC/FUSE_ENGINE/getparmeta.f90 @@ -14,7 +14,7 @@ SUBROUTINE GETPARMETA(err,message) ! --------------------------------------------------------------------------------------- USE nrtype ! variable types, etc. USE fuse_fileManager,only:SETNGS_PATH,CONSTRAINTS ! defines data directory -USE multiparam, ONLY: PARATT ! parameter attribute structure +USE data_types, ONLY: PARATT ! parameter attribute structure USE putpar_str_module ! provide access to SUBROUTINE putpar_str USE par_insert_module ! provide access to SUBROUTINE par_insert IMPLICIT NONE diff --git a/build/FUSE_SRC/FUSE_ENGINE/multi_flux.f90 b/build/FUSE_SRC/FUSE_ENGINE/multi_flux.f90 deleted file mode 100644 index b3c884f..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/multi_flux.f90 +++ /dev/null @@ -1,42 +0,0 @@ -MODULE multi_flux - USE nrtype - TYPE FLUXES - REAL(SP) :: EFF_PPT ! effective precipitation (mm day-1) - REAL(SP) :: SATAREA ! saturated area (-) - REAL(SP) :: QSURF ! surface runoff (mm day-1) - REAL(SP) :: EVAP_1A ! evaporation from soil excess zone (mm day-1) - REAL(SP) :: EVAP_1B ! evaporation from soil recharge zone (mm day-1) - REAL(SP) :: EVAP_1 ! evaporation from upper soil layer (mm day-1) - REAL(SP) :: EVAP_2 ! evaporation from lower soil layer (mm day-1) - REAL(SP) :: RCHR2EXCS ! flow from recharge to excess (mm day-1) - REAL(SP) :: TENS2FREE_1 ! flow from tension storage to free storage (mm day-1) - REAL(SP) :: TENS2FREE_2 ! flow from tension storage to free storage (mm day-1) - REAL(SP) :: QINTF_1 ! interflow from free water (mm day-1) - REAL(SP) :: QPERC_12 ! percolation from upper to lower soil layers (mm day-1) - REAL(SP) :: QBASE_2 ! baseflow (mm day-1) - REAL(SP) :: QBASE_2A ! baseflow from primary linear resvr (mm day-1) - REAL(SP) :: QBASE_2B ! baseflow from secondary linear resvr (mm day-1) - REAL(SP) :: OFLOW_1 ! bucket overflow (mm day-1) - REAL(SP) :: OFLOW_2 ! bucket overflow (mm day-1) - REAL(SP) :: OFLOW_2A ! bucket overflow (mm day-1) - REAL(SP) :: OFLOW_2B ! bucket overflow (mm day-1) - REAL(SP) :: ERR_WATR_1 ! excessive extrapolation: total storage in layer1 (mm day-1) - REAL(SP) :: ERR_TENS_1 ! excessive extrapolation: tension storage in layer1 (mm day-1) - REAL(SP) :: ERR_FREE_1 ! excessive extrapolation: free storage in layer 1 (mm day-1) - REAL(SP) :: ERR_TENS_1A ! excessive extrapolation: storage in the recharge zone (mm day-1) - REAL(SP) :: ERR_TENS_1B ! excessive extrapolation: storage in the lower zone (mm day-1) - REAL(SP) :: ERR_WATR_2 ! excessive extrapolation: total storage in layer2 (mm day-1) - REAL(SP) :: ERR_TENS_2 ! excessive extrapolation: tension storage in layer2 (mm day-1) - REAL(SP) :: ERR_FREE_2 ! excessive extrapolation: free storage in layer2 (mm day-1) - REAL(SP) :: ERR_FREE_2A ! excessive extrapolation: storage in the primary resvr (mm day-1) - 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 diff --git a/build/FUSE_SRC/FUSE_ENGINE/multistate.f90 b/build/FUSE_SRC/FUSE_ENGINE/multistate.f90 deleted file mode 100644 index 51c563c..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/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/FUSE_ENGINE/multistats.f90 b/build/FUSE_SRC/FUSE_ENGINE/multistats.f90 deleted file mode 100644 index 74096ca..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/multistats.f90 +++ /dev/null @@ -1,35 +0,0 @@ -MODULE multistats - USE nrtype - TYPE SUMMARY - ! 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) - REAL(SP) :: QOBS_CVAR ! coefficient of variation of observed runoff (-) - REAL(SP) :: QSIM_CVAR ! coefficient of variation of simulated runoff (-) - REAL(SP) :: QOBS_LAG1 ! lag-1 correlation of observed runoff (-) - REAL(SP) :: QSIM_LAG1 ! lag-1 correlation of simulated runoff (-) - REAL(SP) :: RAW_RMSE ! root-mean-squared-error of flow (mm day-1) - REAL(SP) :: LOG_RMSE ! root-mean-squared-error of LOG flow (mm day-1) - REAL(SP) :: NASH_SUTT ! Nash-Sutcliffe score - ! attributes of model output - REAL(SP) :: NUM_RMSE ! error of the approximate solution - REAL(SP) :: NUM_FUNCS ! number of function calls - REAL(SP) :: NUM_JACOBIAN ! number of times Jacobian is calculated - REAL(SP) :: NUMSUB_ACCEPT ! number of sub-steps taken - REAL(SP) :: NUMSUB_REJECT ! number of sub-steps taken - 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 diff --git a/build/FUSE_SRC/FUSE_ENGINE/putpar_str.f90 b/build/FUSE_SRC/FUSE_ENGINE/putpar_str.f90 index 139aea3..3481b65 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/putpar_str.f90 +++ b/build/FUSE_SRC/FUSE_ENGINE/putpar_str.f90 @@ -13,7 +13,8 @@ SUBROUTINE PUTPAR_STR(METADAT,PARNAME) ! Inserts parameter metadata into data structures ! --------------------------------------------------------------------------------------- USE nrtype ! variable types, etc. -USE multiparam, ONLY : PARATT, PARMETA ! derived type for parameter metadata +USE data_types, ONLY : PARATT ! derived type for parameter metadata +USE multiparam, ONLY : PARMETA ! parameter metadata IMPLICIT NONE ! input TYPE(PARATT), INTENT(IN) :: METADAT ! parameter metadata diff --git a/build/FUSE_SRC/FUSE_ENGINE/str_2_xtry.f90 b/build/FUSE_SRC/FUSE_ENGINE/str_2_xtry.f90 index cb0ac71..71875e9 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/str_2_xtry.f90 +++ b/build/FUSE_SRC/FUSE_ENGINE/str_2_xtry.f90 @@ -14,7 +14,7 @@ SUBROUTINE STR_2_XTRY(TMPSTR,X_TRY) USE nrtype ! Numerical Recipes data types USE model_defn, ONLY: CSTATE,NSTATE ! model definitions USE model_defnames -USE multistate, ONLY: STATEV ! model state structure +USE data_types, ONLY: STATEV ! model state structure IMPLICIT NONE ! input TYPE(STATEV), INTENT(IN) :: TMPSTR ! temporary state structure diff --git a/build/FUSE_SRC/FUSE_ENGINE/multiparam.f90 b/build/FUSE_SRC/dshare/data_types.f90 similarity index 52% rename from build/FUSE_SRC/FUSE_ENGINE/multiparam.f90 rename to build/FUSE_SRC/dshare/data_types.f90 index dd1188e..b27a0f7 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/multiparam.f90 +++ b/build/FUSE_SRC/dshare/data_types.f90 @@ -1,15 +1,120 @@ -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark -! Modified by Brian Henn to include snow model, 6/2013 -! --------------------------------------------------------------------------------------- -MODULE multiparam - USE nrtype - USE model_defn,ONLY:NTDH_MAX - ! -------------------------------------------------------------------------------------- - ! (1) PARAMETER METADATA +module data_types + + use nrtype + use model_defn, only:NTDH_MAX + ! -------------------------------------------------------------------------------------- + ! model time structure + ! -------------------------------------------------------------------------------------- + TYPE M_TIME + REAL(SP) :: STEP ! (time interval to advance model states) + END TYPE M_TIME + + ! -------------------------------------------------------------------------------------- + ! model forcing structures + ! -------------------------------------------------------------------------------------- + + ! 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 + + ! -------------------------------------------------------------------------------------- + ! 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 flux structure + ! -------------------------------------------------------------------------------------- + TYPE FLUXES + REAL(SP) :: EFF_PPT ! effective precipitation (mm day-1) + REAL(SP) :: SATAREA ! saturated area (-) + REAL(SP) :: QSURF ! surface runoff (mm day-1) + REAL(SP) :: EVAP_1A ! evaporation from soil excess zone (mm day-1) + REAL(SP) :: EVAP_1B ! evaporation from soil recharge zone (mm day-1) + REAL(SP) :: EVAP_1 ! evaporation from upper soil layer (mm day-1) + REAL(SP) :: EVAP_2 ! evaporation from lower soil layer (mm day-1) + REAL(SP) :: RCHR2EXCS ! flow from recharge to excess (mm day-1) + REAL(SP) :: TENS2FREE_1 ! flow from tension storage to free storage (mm day-1) + REAL(SP) :: TENS2FREE_2 ! flow from tension storage to free storage (mm day-1) + REAL(SP) :: QINTF_1 ! interflow from free water (mm day-1) + REAL(SP) :: QPERC_12 ! percolation from upper to lower soil layers (mm day-1) + REAL(SP) :: QBASE_2 ! baseflow (mm day-1) + REAL(SP) :: QBASE_2A ! baseflow from primary linear resvr (mm day-1) + REAL(SP) :: QBASE_2B ! baseflow from secondary linear resvr (mm day-1) + REAL(SP) :: OFLOW_1 ! bucket overflow (mm day-1) + REAL(SP) :: OFLOW_2 ! bucket overflow (mm day-1) + REAL(SP) :: OFLOW_2A ! bucket overflow (mm day-1) + REAL(SP) :: OFLOW_2B ! bucket overflow (mm day-1) + REAL(SP) :: ERR_WATR_1 ! excessive extrapolation: total storage in layer1 (mm day-1) + REAL(SP) :: ERR_TENS_1 ! excessive extrapolation: tension storage in layer1 (mm day-1) + REAL(SP) :: ERR_FREE_1 ! excessive extrapolation: free storage in layer 1 (mm day-1) + REAL(SP) :: ERR_TENS_1A ! excessive extrapolation: storage in the recharge zone (mm day-1) + REAL(SP) :: ERR_TENS_1B ! excessive extrapolation: storage in the lower zone (mm day-1) + REAL(SP) :: ERR_WATR_2 ! excessive extrapolation: total storage in layer2 (mm day-1) + REAL(SP) :: ERR_TENS_2 ! excessive extrapolation: tension storage in layer2 (mm day-1) + REAL(SP) :: ERR_FREE_2 ! excessive extrapolation: free storage in layer2 (mm day-1) + REAL(SP) :: ERR_FREE_2A ! excessive extrapolation: storage in the primary resvr (mm day-1) + 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 + + ! -------------------------------------------------------------------------------------- + ! model runoff structure + ! -------------------------------------------------------------------------------------- + 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 + + ! -------------------------------------------------------------------------------------- + ! parameter metadata + ! -------------------------------------------------------------------------------------- + ! data structure to hold metadata for adjustable model parameters TYPE PARATT LOGICAL(LGT) :: PARFIT ! flag to determine if parameter is fitted @@ -29,6 +134,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) @@ -48,7 +154,7 @@ MODULE multiparam TYPE(PARATT) :: FPRIMQB ! SAC: fraction of baseflow in primary resvr (-) ! evaporation (adjustable) TYPE(PARATT) :: RTFRAC1 ! fraction of roots in the upper layer (-) - ! percolation (adjustable) + ! percolation (adjustable) TYPE(PARATT) :: PERCRTE ! percolation rate (mm day-1) TYPE(PARATT) :: PERCEXP ! percolation exponent (-) TYPE(PARATT) :: SACPMLT ! multiplier in the SAC model for dry lower layer (-) @@ -75,11 +181,12 @@ MODULE multiparam TYPE(PARATT) :: MFMAX ! maximum melt factor (mm melt deg C.-1 6hrs-1) TYPE(PARATT) :: MFMIN ! minimum melt factor (mm melt deg C.-1 6hrs-1) TYPE(PARATT) :: PXTEMP ! rain-snow partition temperature (deg. C) - TYPE(PARATT) :: OPG ! precipitation gradient (-) + TYPE(PARATT) :: OPG ! precipitation gradient (-) TYPE(PARATT) :: LAPSE ! temperature gradient (deg. C) ENDTYPE PARINFO + ! -------------------------------------------------------------------------------------- - ! (2) ADJUSTABLE PARAMETERS + ! adjustable parameters ! -------------------------------------------------------------------------------------- TYPE PARADJ ! rainfall error parameters (adjustable) @@ -126,11 +233,12 @@ MODULE multiparam REAL(SP) :: MFMAX ! maximum melt factor (mm melt deg C.-1 6hrs-1) REAL(SP) :: MFMIN ! minimum melt factor (mm melt deg C.-1 6hrs-1) REAL(SP) :: PXTEMP ! rain-snow partition temperature (deg. C) - REAL(SP) :: OPG ! precipitation gradient (-) + REAL(SP) :: OPG ! precipitation gradient (-) REAL(SP) :: LAPSE ! temperature gradient (deg. C) END TYPE PARADJ + ! -------------------------------------------------------------------------------------- - ! (3) DERIVED PARAMETERS + ! derived parameters ! -------------------------------------------------------------------------------------- TYPE PARDVD ! bucket sizes (derived) @@ -153,22 +261,61 @@ 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 + ! list of parameters for a given model ! -------------------------------------------------------------------------------------- TYPE PAR_ID CHARACTER(LEN=9) :: PARNAME ! list of parameter names ENDTYPE PAR_ID + + ! -------------------------------------------------------------------------------------- + ! model statistics structure ! -------------------------------------------------------------------------------------- - ! (5) FINAL DATA STRUCTURES + TYPE SUMMARY + ! 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) + REAL(SP) :: QOBS_CVAR ! coefficient of variation of observed runoff (-) + REAL(SP) :: QSIM_CVAR ! coefficient of variation of simulated runoff (-) + REAL(SP) :: QOBS_LAG1 ! lag-1 correlation of observed runoff (-) + REAL(SP) :: QSIM_LAG1 ! lag-1 correlation of simulated runoff (-) + REAL(SP) :: RAW_RMSE ! root-mean-squared-error of flow (mm day-1) + REAL(SP) :: LOG_RMSE ! root-mean-squared-error of LOG flow (mm day-1) + REAL(SP) :: NASH_SUTT ! Nash-Sutcliffe score + ! attributes of model output + REAL(SP) :: NUM_RMSE ! error of the approximate solution + REAL(SP) :: NUM_FUNCS ! number of function calls + REAL(SP) :: NUM_JACOBIAN ! number of times Jacobian is calculated + REAL(SP) :: NUMSUB_ACCEPT ! number of sub-steps taken + REAL(SP) :: NUMSUB_REJECT ! number of sub-steps taken + 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 + ! -------------------------------------------------------------------------------------- - 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 + ! parent FUSE structure ! -------------------------------------------------------------------------------------- -END MODULE multiparam + type parent + type(m_time) :: time ! time step + 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 + 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 + type(summary) :: sim_stats ! simulation statistics + end type parent + +end module data_types diff --git a/build/FUSE_SRC/FUSE_ENGINE/model_defn.f90 b/build/FUSE_SRC/dshare/model_defn.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/model_defn.f90 rename to build/FUSE_SRC/dshare/model_defn.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/model_defnames.f90 b/build/FUSE_SRC/dshare/model_defnames.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/model_defnames.f90 rename to build/FUSE_SRC/dshare/model_defnames.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/model_numerix.f90 b/build/FUSE_SRC/dshare/model_numerix.f90 similarity index 96% rename from build/FUSE_SRC/FUSE_ENGINE/model_numerix.f90 rename to build/FUSE_SRC/dshare/model_numerix.f90 index 8aefa42..030073e 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/model_numerix.f90 +++ b/build/FUSE_SRC/dshare/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/dshare/multi_flux.f90 b/build/FUSE_SRC/dshare/multi_flux.f90 new file mode 100644 index 0000000..fa393ff --- /dev/null +++ b/build/FUSE_SRC/dshare/multi_flux.f90 @@ -0,0 +1,11 @@ +MODULE multi_flux + USE nrtype + use data_types, only: 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 diff --git a/build/FUSE_SRC/FUSE_ENGINE/multibands.f90 b/build/FUSE_SRC/dshare/multibands.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/multibands.f90 rename to build/FUSE_SRC/dshare/multibands.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/multiconst.f90 b/build/FUSE_SRC/dshare/multiconst.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/multiconst.f90 rename to build/FUSE_SRC/dshare/multiconst.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/multiforce.f90 b/build/FUSE_SRC/dshare/multiforce.f90 similarity index 84% rename from build/FUSE_SRC/FUSE_ENGINE/multiforce.f90 rename to build/FUSE_SRC/dshare/multiforce.f90 index 900befd..46f205a 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/multiforce.f90 +++ b/build/FUSE_SRC/dshare/multiforce.f90 @@ -4,40 +4,13 @@ ! Martyn Clark ! Modified by Brian Henn to include snow model, 6/2013 ! Modified by Nans Addor to enable distributed modeling, 9/2016 +! Modified by Martyn Clark to separate derived types from shard data, 12/2025 ! --------------------------------------------------------------------------------------- MODULE multiforce USE nrtype + USE data_types, only: tdata, vdata, adata, fdata 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 diff --git a/build/FUSE_SRC/dshare/multiparam.f90 b/build/FUSE_SRC/dshare/multiparam.f90 new file mode 100644 index 0000000..7f7938d --- /dev/null +++ b/build/FUSE_SRC/dshare/multiparam.f90 @@ -0,0 +1,22 @@ +! --------------------------------------------------------------------------------------- +! Creator: +! -------- +! Martyn Clark +! Modified by Brian Henn to include snow model, 6/2013 +! Modified by Martyn Clark to separate derived types from shard data, 12/2025 +! --------------------------------------------------------------------------------------- +MODULE multiparam + USE nrtype + USE model_defn,ONLY:NTDH_MAX + USE data_types,ONLY:par_id,parinfo,paradj,pardvd + ! -------------------------------------------------------------------------------------- + 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 diff --git a/build/FUSE_SRC/FUSE_ENGINE/multiroute.f90 b/build/FUSE_SRC/dshare/multiroute.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/multiroute.f90 rename to build/FUSE_SRC/dshare/multiroute.f90 diff --git a/build/FUSE_SRC/dshare/multistate.f90 b/build/FUSE_SRC/dshare/multistate.f90 new file mode 100644 index 0000000..3a9a3a6 --- /dev/null +++ b/build/FUSE_SRC/dshare/multistate.f90 @@ -0,0 +1,27 @@ +MODULE multistate + USE nrtype + use data_types, only: statev, m_time ! <— import canonical types + + ! 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/dshare/multistats.f90 b/build/FUSE_SRC/dshare/multistats.f90 new file mode 100644 index 0000000..70907f7 --- /dev/null +++ b/build/FUSE_SRC/dshare/multistats.f90 @@ -0,0 +1,9 @@ +MODULE multistats + USE nrtype + Use data_types, only: 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 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..a07a76a --- /dev/null +++ b/build/FUSE_SRC/physics/evap_lower_diff.f90 @@ -0,0 +1,88 @@ +module EVAP_LOWER_DIFF_MODULE + + implicit none + + private + public :: EVAP_LOWER_DIFF + +contains + + SUBROUTINE EVAP_LOWER_DIFF(fuseStruct) + ! ------------------------------------------------------------------------------------------------- + ! 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 data_types, only: parent ! fuse parent data type + USE model_defn ! model definition structure + USE model_defnames + IMPLICIT NONE + ! input-output + type(parent), intent(inout) :: fuseStruct ! parent fuse data structure + ! ------------------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + MFORCE => fuseStruct%force , & ! model forcing data + M_FLUX => fuseStruct%flux , & ! fluxes + TSTATE => fuseStruct%state1 , & ! trial state variables (end of step) + MPARAM => fuseStruct%param_adjust , & ! adjustable model parameters + DPARAM => fuseStruct%param_derive & ! derived model parameters + ) ! (associate) + ! ------------------------------------------------------------------------------------------------- + + ! --------------------------------------------------------------------------------------- + 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..fa0fd2d --- /dev/null +++ b/build/FUSE_SRC/physics/evap_upper_diff.f90 @@ -0,0 +1,91 @@ +module EVAP_UPPER_DIFF_module + + implicit none + + private + public :: EVAP_UPPER_DIFF + +contains + + SUBROUTINE EVAP_UPPER_DIFF(fuseStruct) + ! ------------------------------------------------------------------------------------------------- + ! 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 data_types, only: parent ! fuse parent data type + USE model_defn ! model definition structure + USE model_defnames + IMPLICIT NONE + ! input-output + type(parent), intent(inout) :: fuseStruct ! parent fuse data structure + ! ------------------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + MFORCE => fuseStruct%force , & ! model forcing data + M_FLUX => fuseStruct%flux , & ! fluxes + TSTATE => fuseStruct%state1 , & ! trial state variables (end of step) + MPARAM => fuseStruct%param_adjust , & ! adjustable model parameters + DPARAM => fuseStruct%param_derive & ! derived model parameters + ) ! (associate) + ! ------------------------------------------------------------------------------------------------- + + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH1) ! upper layer architecture + + ! -------------------------------------------------------------------------------------- + CASE(iopt_tension2_1) ! tension storage sub-divided into recharge and excess + ! -------------------------------------------------------------------------------------- + + ! use different evaporation schemes for the upper layer + ! ----------------------------------------------------- + SELECT CASE(SMODL%iESOIL) + CASE(iopt_sequential) + M_FLUX%EVAP_1A = MFORCE%PET * TSTATE%TENS_1A/DPARAM%MAXTENS_1A + M_FLUX%EVAP_1B = (MFORCE%PET - M_FLUX%EVAP_1A) * TSTATE%TENS_1B/DPARAM%MAXTENS_1B + M_FLUX%EVAP_1 = M_FLUX%EVAP_1A + M_FLUX%EVAP_1B + CASE(iopt_rootweight) + M_FLUX%EVAP_1A = MFORCE%PET * MPARAM%RTFRAC1 * TSTATE%TENS_1A/DPARAM%MAXTENS_1A + M_FLUX%EVAP_1B = MFORCE%PET * DPARAM%RTFRAC2 * TSTATE%TENS_1B/DPARAM%MAXTENS_1B + M_FLUX%EVAP_1 = M_FLUX%EVAP_1A + M_FLUX%EVAP_1B + CASE DEFAULT + print *, "SMODL%iESOIL must be either iopt_sequential or iopt_rootweight" + STOP + END SELECT + ! -------------------------------------------------------------------------------------- + CASE(iopt_tension1_1,iopt_onestate_1) ! single tension store or single state + ! -------------------------------------------------------------------------------------- + + ! use different evaporation schemes for the upper layer + ! ----------------------------------------------------- + SELECT CASE(SMODL%iESOIL) + CASE(iopt_sequential) + M_FLUX%EVAP_1A = 0._sp + M_FLUX%EVAP_1B = 0._sp + M_FLUX%EVAP_1 = MFORCE%PET * TSTATE%TENS_1/DPARAM%MAXTENS_1 + CASE(iopt_rootweight) + M_FLUX%EVAP_1A = 0._sp + M_FLUX%EVAP_1B = 0._sp + M_FLUX%EVAP_1 = MFORCE%PET * MPARAM%RTFRAC1 * TSTATE%TENS_1/DPARAM%MAXTENS_1 + CASE DEFAULT + print *, "SMODL%iESOIL must be either iopt_sequential or iopt_rootweight" + END SELECT ! (evaporation schemes) + + ! -------------------------------------------------------------------------------------- + CASE DEFAULT + print *, "SMODL%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" + STOP + ! -------------------------------------------------------------------------------------- + + END SELECT ! (upper-layer architechure) + + 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..9e51da3 --- /dev/null +++ b/build/FUSE_SRC/physics/fix_ovshoot.f90 @@ -0,0 +1,139 @@ +module overshoot_module + + USE nrtype ! variable types, etc. + USE data_types, only: parent ! fuse parent data type + USE model_defn, only: CSTATE,NSTATE,SMODL ! model definition structures + USE model_defnames + implicit none + + private + public :: get_bounds + public :: fix_ovshoot + +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 + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + SUBROUTINE fix_ovshoot(X_TRY, lower, upper) + ! --------------------------------------------------------------------------------------- + ! 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 + ! internal + integer(i4b) :: i ! index of model state variable + real(sp), parameter :: alpha=10_sp ! controls sharpness in smoothing + + ! apply soft constraint to model states + do i=1,NSTATE + x_try(i) = lower(i) + softplus(x_try(i)-lower(i), alpha) - softplus(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(parent), intent(in) :: fuseStruct ! parent fuse data 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%param_adjust, & ! adjuustable model parameters + DPARAM => fuseStruct%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_parent.f90 b/build/FUSE_SRC/physics/get_parent.f90 new file mode 100644 index 0000000..1a79e0d --- /dev/null +++ b/build/FUSE_SRC/physics/get_parent.f90 @@ -0,0 +1,26 @@ +module get_parent_module + use data_types, only: parent + implicit none + +contains + + subroutine get_parent(fuseStruct) + use multiforce, only: mForce + use multistate, only: mState + use multi_flux, only: m_flux + use multiparam, only: parMeta,mParam,dParam + implicit none + type(parent), intent(out) :: fuseStruct + ! populate parent fuse structures + fuseStruct%force = mForce + fuseStruct%state0 = mState + fuseStruct%state1 = mState + fuseStruct%flux = m_flux + fuseStruct%param_meta = parMeta + fuseStruct%param_adjust = mParam + fuseStruct%param_derive = dParam + + end subroutine get_parent + + +end module get_parent_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..6ee2325 --- /dev/null +++ b/build/FUSE_SRC/physics/implicit_solve.f90 @@ -0,0 +1,244 @@ +module implicit_solve_module + + ! data types + use nrtype ! variable types, etc. + use data_types, only: parent ! parent fuse data 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 model_numerix, only: NUM_FUNCS ! number of function calls + use model_numerix, only: NUM_JACOBIAN ! number of times Jacobian is calculated + + implicit none + + ! provide access to the fuse parent structure + type(parent), pointer, save :: ctx => null() + + private + public :: implicit_solve + + contains + + ! ----- point to the fuse parent structure --------------------------------------------- + + subroutine set_dxdt_context(fuseStruct) + type(parent), target, intent(inout) :: fuseStruct + ctx => fuseStruct + end subroutine set_dxdt_context + + subroutine clear_dxdt_context() + nullify(ctx) + end subroutine clear_dxdt_context + + ! -------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------- + + ! ----- calculate dx/dt=g(x) ----------------------------------------------------------- + function dx_dt(x_try) result(g_x) + use MOD_DERIVS_DIFF_module, only: MOD_DERIVS_DIFF ! compute dx/dt + implicit none + ! input + real(sp) , intent(in) :: x_try(:) ! trial state vector + ! output + real(sp) :: g_x(size(x_try)) ! dx/dt=g(x) + + ! check made the association to ctx (ctx=>fuseStruct) + if (.not. associated(ctx)) stop "dx_dt: context not set" + + ! put data in structure + call XTRY_2_STR(x_try, ctx%state1) + + ! run the fuse physics + call mod_derivs_diff(ctx) + + ! extract dx_dt from fuse structure + call STR_2_XTRY(ctx%dx_dt, g_x) + + ! track the total number of function calls + NUM_FUNCS = NUM_FUNCS + 1 + + end function dx_dt + + ! ----- calculate the Jacobian of g(x) ------------------------------------------------- + SUBROUTINE jac_flux(x,g_x,Jac) + IMPLICIT NONE + REAL(SP), DIMENSION(:), INTENT(IN) :: g_x + REAL(SP), DIMENSION(:), INTENT(INOUT) :: x + REAL(SP), DIMENSION(:,:), INTENT(OUT) :: Jac + REAL(SP), PARAMETER :: EPS=-1.0e-4_sp ! NOTE force h to be negative + INTEGER(I4B) :: j,n + REAL(SP), DIMENSION(size(x)) :: xsav,xph,h + xsav=x + n=size(x) + h=EPS*abs(xsav) + where (h == 0.0) h=EPS + xph=xsav+h + h=xph-xsav + do j=1,n + x(j)=xph(j) + Jac(:,j)=(dx_dt(x)-g_x(:))/h(j) + x(j)=xsav(j) + end do + NUM_JACOBIAN = NUM_JACOBIAN + 1 ! keep track of the number of iterations + call XTRY_2_STR(xsav, ctx%state1) ! restores consistency after finite differencing + end SUBROUTINE jac_flux + + ! ----- simple implicit solve for differentiable model -------------------------- + + subroutine implicit_solve(fuseStruct, x0, x1, nx) + 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 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(parent), intent(inout) :: fuseStruct ! parent fuse data 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 + ! internal: newton iterations + 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) :: 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) :: lambda ! backtrack length multiplier (lambda*dx) + real(sp) :: lower(nx) ! lower bound + real(sp) :: upper(nx) ! lower bound + real(sp) :: x_trial(nx) ! state vectorfor 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 + ! line search params + real(sp), parameter :: shrink = 0.5_sp + real(sp), parameter :: c_armijo = 1e-4_sp + integer(i4b), parameter :: ls_max = 5 + + ! check dimension size + if (nx /= nState) stop "implicit_solve: nx /= nState" + + ! initialize number of calls + NUM_FUNCS = 0 ! number of function calls + NUM_JACOBIAN = 0 ! number of times Jacobian is calculated + + ! 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) + + ! point to the fuse parent structure so that it is available in other routines + call set_dxdt_context(fuseStruct) + + ! put state vector into the fuse data structure + call XTRY_2_STR(x0, fuseStruct%state0) + + ! intialize state vector and convergence flag + x_try = x0 + accepted = .false. + converged = .false. + + ! --- F(x) and objective phi = 0.5*||F||^2 + g_x = dx_dt(x_try) + res = x_try - (x0 + g_x*dt) + phi = 0.5_sp * sum(res*res) + + ! iterate + do it = 1, maxit + + if (sqrt(2.0_sp*phi) < ERR_ITER_FUNC) then + converged = .true. + exit ! exit iteration loop + end if + + ! --- J(x) + call jac_flux(x_try, g_x, Jg) + Jac = -dt*Jg ! multiply dt + do i=1,nx; Jac(i,i) = Jac(i,i) + 1.0_sp; end do ! add identity matrix + + ! --- 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 + + ! initialize flag to check if line search is accepted + accepted = .false. + + ! ---- backtracking line search w/ overshoot reject ---- + lambda = 1.0_sp + do ls_it = 1, ls_max + x_trial = x_try + lambda*dx + + ! check overshoot + ovshoot = any(x_trial < lower) .or. any(x_trial > upper) + if (.not. ovshoot) then + ! new function and residual + g_trial = dx_dt(x_trial) + res_trial = x_trial - (x0 + dt*g_trial) + phi_new = 0.5_sp * sum(res_trial*res_trial) + ! check for sufficient decrease (Armijo-lite) + if (phi_new <= (1.0_sp - c_armijo*lambda) * phi)then + accepted = .true. + exit + endif + end if + lambda = lambda * shrink + end do ! line search + + if (accepted) then + x_try = x_trial + g_x = g_trial + res = res_trial + phi = phi_new + else + ! ----- fallback: soft clamp a very small Newton step ----- + x_trial = x_try + lambda*dx + call fix_ovshoot(x_trial, lower, upper) + ! get new function evaluation + x_try = x_trial + g_x = dx_dt(x_try) + res = x_try - (x0 + g_x*dt) + phi = 0.5_sp * sum(res*res) + end if + + ! re-populate fuse data structure + call XTRY_2_STR(x_try, fuseStruct%state1) + + ! tiny-step convergence + if (maxval(abs(lambda*dx)) < ERR_ITER_DX) then + converged = .true. + exit ! exit iteration loop + end if + + end do ! loop through iterations + + ! save final state + x1 = x_try + + ! nullify pointer to the fuse structure + call clear_dxdt_context() + + ! check convergence + if( .not. converged) STOP "failed to converge in implicit_solve" + + 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..5dc1752 --- /dev/null +++ b/build/FUSE_SRC/physics/mod_derivs_diff.f90 @@ -0,0 +1,50 @@ +module MOD_DERIVS_DIFF_module + + USE nrtype + USE data_types, only: parent, 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) + ! --------------------------------------------------------------------------------------- + ! 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 + type(parent), intent(inout) :: fuseStruct ! parent fuse data structure + + ! compute fluxes + call qsatexcess_diff(fuseStruct) ! compute the saturated area and surface runoff + call evap_upper_diff(fuseStruct) ! compute evaporation from the upper layer + call evap_lower_diff(fuseStruct) ! compute evaporation from the lower layer + call qinterflow_diff(fuseStruct) ! compute interflow from free water in the upper layer + call qpercolate_diff(fuseStruct) ! compute percolation from the upper to lower soil layers + call q_baseflow_diff(fuseStruct) ! compute baseflow from the lower soil layer + call q_misscell_diff(fuseStruct) ! compute miscellaneous fluxes (NOTE: need sat area, evap, and perc) + + ! compute the time derivative (dx/dt) of all model states (x) + call mstate_rhs_diff(fuseStruct) + + 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..1ab0107 --- /dev/null +++ b/build/FUSE_SRC/physics/mstate_rhs_diff.f90 @@ -0,0 +1,77 @@ +module MSTATE_RHS_DIFF_module + + implicit none + + private + public :: MSTATE_RHS_DIFF + +contains + + SUBROUTINE MSTATE_RHS_DIFF(fuseStruct) + ! --------------------------------------------------------------------------------------- + ! 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 data_types, only: parent ! fuse parent data type + USE model_defn ! model definition structure + USE model_defnames + ! input-output + type(parent), intent(inout) :: fuseStruct ! parent fuse data structure + ! ------------------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + M_FLUX => fuseStruct%flux , & ! fluxes + MPARAM => fuseStruct%param_adjust , & ! adjustable model parameters + DX_DT => fuseStruct%dx_dt & ! time derivative in states + ) ! (associate) + + ! --------------------------------------------------------------------------------------- + ! (1) COMPUTE TIME DERIVATIVES FOR STATES IN THE UPPER LAYER + ! --------------------------------------------------------------------------------------- + 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 architechure) + + ! --------------------------------------------------------------------------------------- + ! (2) COMPUTE TIME DERIVATIVES FOR STATES IN THE LOWER LAYER + ! --------------------------------------------------------------------------------------- + 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 + ! --------------------------------------------------------------------------------------- + + 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..29386f4 --- /dev/null +++ b/build/FUSE_SRC/physics/q_baseflow_diff.f90 @@ -0,0 +1,69 @@ +module Q_BASEFLOW_DIFF_module + + implicit none + + private + public :: Q_BASEFLOW_DIFF + +contains + + + SUBROUTINE Q_BASEFLOW_DIFF(fuseStruct) + ! --------------------------------------------------------------------------------------- + ! 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 data_types, only: parent ! fuse parent data type + USE model_defn ! model definition structure + USE model_defnames + IMPLICIT NONE + ! input-output + type(parent), intent(inout) :: fuseStruct ! parent fuse data structure + ! ------------------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + M_FLUX => fuseStruct%flux , & ! fluxes + TSTATE => fuseStruct%state1 , & ! trial state variables (end of step) + MPARAM => fuseStruct%param_adjust , & ! adjustable model parameters + DPARAM => fuseStruct%param_derive & ! derived model parameters + ) ! (associate) + + ! --------------------------------------------------------------------------------------- + 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 + ! -------------------------------------------------------------------------------------- + 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) + ! -------------------------------------------------------------------------------------- + CASE(iopt_unlimpow_2) ! baseflow resvr of unlimited size (0-HUGE), power recession + M_FLUX%QBASE_2 = DPARAM%QBSAT * (TSTATE%WATR_2/MPARAM%MAXWATR_2)**MPARAM%QB_POWR + ! -------------------------------------------------------------------------------------- + CASE(iopt_topmdexp_2) ! topmodel exponential reservoir (-HUGE to HUGE) + M_FLUX%QBASE_2 = DPARAM%QBSAT * EXP( -(1. - TSTATE%WATR_2/MPARAM%MAXWATR_2) ) + ! -------------------------------------------------------------------------------------- + CASE(iopt_fixedsiz_2) ! baseflow reservoir of fixed size + M_FLUX%QBASE_2 = MPARAM%BASERTE * (TSTATE%WATR_2/MPARAM%MAXWATR_2)**MPARAM%QB_POWR + ! -------------------------------------------------------------------------------------- + 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_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..1801c7b --- /dev/null +++ b/build/FUSE_SRC/physics/q_misscell_diff.f90 @@ -0,0 +1,116 @@ +module Q_MISSCELL_DIFF_module + + implicit none + + private + public :: Q_MISSCELL_DIFF + +contains + + SUBROUTINE Q_MISSCELL_DIFF(fuseStruct) + ! --------------------------------------------------------------------------------------- + ! 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 data_types, only: parent ! fuse parent data type + USE model_defn ! model definition structure + USE model_defnames + IMPLICIT NONE + ! input-output + type(parent), intent(inout) :: fuseStruct ! parent fuse data structure + ! internal + REAL(SP) :: LOGISMOOTH ! FUNCTION logistic smoothing + REAL(SP), PARAMETER :: PSMOOTH=0.01_SP ! smoothing parameter + REAL(SP) :: W_FUNC ! result from LOGISMOOTH + ! ------------------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + M_FLUX => fuseStruct%flux , & ! fluxes + TSTATE => fuseStruct%state1 , & ! trial state variables (end of step) + MPARAM => fuseStruct%param_adjust , & ! adjustable model parameters + DPARAM => fuseStruct%param_derive & ! derived model parameters + ) ! (associate) + ! --------------------------------------------------------------------------------------- + + ! --------------------------------------------------------------------------------------- + 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 = LOGISMOOTH(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 = LOGISMOOTH(TSTATE%TENS_1B,DPARAM%MAXTENS_1B,PSMOOTH) + M_FLUX%TENS2FREE_1 = W_FUNC * M_FLUX%RCHR2EXCS + ! compute over-flow of free water + W_FUNC = LOGISMOOTH(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 = LOGISMOOTH(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 = LOGISMOOTH(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 + W_FUNC = LOGISMOOTH(TSTATE%WATR_1,MPARAM%MAXWATR_1,PSMOOTH) + M_FLUX%OFLOW_1 = W_FUNC * (M_FLUX%EFF_PPT - M_FLUX%QSURF) + 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 = LOGISMOOTH(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 = LOGISMOOTH(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 = LOGISMOOTH(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 = LOGISMOOTH(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..9b1ed32 --- /dev/null +++ b/build/FUSE_SRC/physics/qinterflow_diff.f90 @@ -0,0 +1,52 @@ +module QINTERFLOW_DIFF_module + + implicit none + + private + public :: QINTERFLOW_DIFF + +contains + + SUBROUTINE QINTERFLOW_DIFF(fuseStruct) + ! --------------------------------------------------------------------------------------- + ! 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 data_types, only: parent ! fuse parent data type + USE model_defn ! model definition structure + USE model_defnames + IMPLICIT NONE + ! input-output + type(parent), intent(inout) :: fuseStruct ! parent fuse data structure + ! ------------------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + M_FLUX => fuseStruct%flux , & ! fluxes + TSTATE => fuseStruct%state1 , & ! trial state variables (end of step) + MPARAM => fuseStruct%param_adjust , & ! adjustable model parameters + DPARAM => fuseStruct%param_derive & ! derived model parameters + ) ! (associate) + + ! --------------------------------------------------------------------------------------- + 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..9ff599c --- /dev/null +++ b/build/FUSE_SRC/physics/qpercolate_diff.f90 @@ -0,0 +1,61 @@ +module QPERCOLATE_DIFF_module + + implicit none + + private + public :: QPERCOLATE_DIFF + +contains + + SUBROUTINE QPERCOLATE_DIFF(fuseStruct) + ! --------------------------------------------------------------------------------------- + ! 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 data_types, only: parent ! fuse parent data type + USE model_defn ! model definition structure + USE model_defnames + IMPLICIT NONE + ! input-output + type(parent), intent(inout) :: fuseStruct ! parent fuse data structure + ! internal + REAL(SP) :: LZ_PD ! lower zone percolation demand + ! --------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + M_FLUX => fuseStruct%flux , & ! fluxes + TSTATE => fuseStruct%state1 , & ! trial state variables (end of step) + MPARAM => fuseStruct%param_adjust , & ! adjustable model parameters + DPARAM => fuseStruct%param_derive & ! derived model parameters + ) ! (associate) + ! --------------------------------------------------------------------------------------- + + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iQPERC) + CASE(iopt_perc_f2sat) ! water from (field cap to sat) avail for percolation + M_FLUX%QPERC_12 = MPARAM%PERCRTE * (TSTATE%FREE_1/DPARAM%MAXFREE_1)**MPARAM%PERCEXP + CASE(iopt_perc_w2sat) ! water from (wilt pt to sat) avail for percolation + M_FLUX%QPERC_12 = MPARAM%PERCRTE * (TSTATE%WATR_1/MPARAM%MAXWATR_1)**MPARAM%PERCEXP + CASE(iopt_perc_lower) ! perc defined by moisture content in lower layer (SAC) + ! (compute lower-zone percolation demand -- multiplier on maximum percolation, then percolation) + 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) + !print *, 'lz_pd = ', LZ_PD, MPARAM%SACPMLT, TSTATE%WATR_2/MPARAM%MAXWATR_2, MPARAM%SACPEXP + !print *, 'qperc_12 = ', M_FLUX%QPERC_12, DPARAM%QBSAT, LZ_PD, TSTATE%FREE_1/DPARAM%MAXFREE_1 + CASE DEFAULT ! check for errors + print *, "SMODL%iQPERC must be iopt_perc_f2sat, iopt_perc_w2sat, or iopt_perc_lower" + STOP + 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..fa454a2 --- /dev/null +++ b/build/FUSE_SRC/physics/qsatexcess_diff.f90 @@ -0,0 +1,106 @@ +module QSATEXCESS_DIFF_MODULE + + implicit none + + private + public :: QSATEXCESS_DIFF + +contains + + SUBROUTINE QSATEXCESS_DIFF(fuseStruct) + ! ------------------------------------------------------------------------------------------------- + ! 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 data_types, only: parent ! fuse parent data type + USE nr, ONLY : gammp ! interface for the incomplete gamma function + USE model_defn ! model definition structure + USE model_defnames + IMPLICIT NONE + ! input-output + type(parent), intent(inout) :: fuseStruct ! parent fuse data structure + ! internal variables + 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 + ! ------------------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + M_FLUX => fuseStruct%flux , & ! fluxes + TSTATE => fuseStruct%state1 , & ! trial state variables (end of step) + MPARAM => fuseStruct%param_adjust , & ! adjustable model parameters + DPARAM => fuseStruct%param_derive & ! derived model parameters + ) ! (associate) + ! ------------------------------------------------------------------------------------------------- + + ! saturated area method + SELECT CASE(SMODL%iQSURF) + + ! ------------------------------------------------------------------------------------------------ + ! ----- ARNO/Xzang/VIC parameterization (upper zone control) ------------------------------------- + ! ------------------------------------------------------------------------------------------------ + CASE(iopt_arno_x_vic) + + ! ----- compute flux ---------------------------------------------------------------------------- + M_FLUX%SATAREA = 1._sp - ( 1._sp - MIN(TSTATE%WATR_1/MPARAM%MAXWATR_1, 1._sp) )**MPARAM%AXV_BEXP + + ! ------------------------------------------------------------------------------------------------ + ! ----- 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 + + ! ------------------------------------------------------------------------------------------------ + ! ----- 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 + + ! ------------------------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------------------------ + ! 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/Makefile b/build/Makefile index 01cb576..5b960bc 100644 --- a/build/Makefile +++ b/build/Makefile @@ -59,13 +59,15 @@ DRIVER_EX = fuse.exe #======================================================================== # Define directories -NUMREC_DIR = $(F_KORE_DIR)FUSE_NR -HOOKUP_DIR = $(F_KORE_DIR)FUSE_HOOK -DRIVER_DIR = $(F_KORE_DIR)FUSE_DMSL -NETCDF_DIR = $(F_KORE_DIR)FUSE_NETCDF -ENGINE_DIR = $(F_KORE_DIR)FUSE_ENGINE -SCE_DIR = $(F_KORE_DIR)FUSE_SCE -TIME_DIR = $(F_KORE_DIR)FUSE_TIME +NUMREC_DIR = $(F_KORE_DIR)FUSE_NR +HOOKUP_DIR = $(F_KORE_DIR)FUSE_HOOK +DRIVER_DIR = $(F_KORE_DIR)FUSE_DMSL +NETCDF_DIR = $(F_KORE_DIR)FUSE_NETCDF +DSHARE_DIR = $(F_KORE_DIR)dshare +PHYSICS_DIR = $(F_KORE_DIR)physics +ENGINE_DIR = $(F_KORE_DIR)FUSE_ENGINE +SCE_DIR = $(F_KORE_DIR)FUSE_SCE +TIME_DIR = $(F_KORE_DIR)FUSE_TIME # Utility modules FUSE_UTILMS= \ @@ -83,6 +85,7 @@ NRUTIL = $(patsubst %, $(NUMREC_DIR)/%, $(FUSE_NRUTIL)) # Data modules FUSE_DATAMS= \ model_defn.f90 \ + data_types.f90 \ model_defnames.f90 \ multiconst.f90 \ multiforce.f90 \ @@ -93,7 +96,7 @@ FUSE_DATAMS= \ multiroute.f90 \ multistats.f90 \ model_numerix.f90 -DATAMS = $(patsubst %, $(ENGINE_DIR)/%, $(FUSE_DATAMS)) +DATAMS = $(patsubst %, $(DSHARE_DIR)/%, $(FUSE_DATAMS)) # Time I/O modules FUSE_TIMEMS= \ @@ -122,6 +125,22 @@ FUSE_NR_SUB= \ gammln.f90 gammp.f90 gcf.f90 gser.f90 NR_SUB = $(patsubst %, $(NUMREC_DIR)/%, $(FUSE_NR_SUB)) +# FUSE physics +FUSE_PHYSICS= \ + get_parent.f90 \ + qsatexcess_diff.f90 \ + evap_upper_diff.f90 \ + evap_lower_diff.f90 \ + qinterflow_diff.f90 \ + qpercolate_diff.f90 \ + q_baseflow_diff.f90 \ + q_misscell_diff.f90 \ + mstate_rhs_diff.f90 \ + mod_derivs_diff.f90 \ + fix_ovshoot.f90 \ + implicit_solve.f90 +PHYSICS = $(patsubst %, $(PHYSICS_DIR)/%, $(FUSE_PHYSICS)) + # Model guts FUSE_MODGUT=\ mod_derivs.f90 \ @@ -208,7 +227,7 @@ SCE = \ # ... and stitch it all together... FUSE_ALL = $(UTILMS) $(NRUTIL) $(DATAMS) $(TIMUTILS) $(INFOMS) \ - $(NR_SUB) $(MODGUT) $(SOLVER) $(PRELIM) $(MODRUN) \ + $(NR_SUB) $(PHYSICS) $(MODGUT) $(SOLVER) $(PRELIM) $(MODRUN) \ $(NETCDF) $(SCE) #======================================================================== From 849b836dd16bca3009373bc6333501f90ad088f7 Mon Sep 17 00:00:00 2001 From: Martyn Clark Date: Sat, 29 Nov 2025 11:20:02 -0700 Subject: [PATCH 03/16] add global data and remove print statements --- build/FUSE_SRC/FUSE_DMSL/functn.f90 | 7 ++-- build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 | 11 +++--- build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 | 42 +++++++++++++---------- build/FUSE_SRC/FUSE_ENGINE/fuse_solve.f90 | 4 +-- build/FUSE_SRC/FUSE_ENGINE/get_mbands.f90 | 7 ++-- build/FUSE_SRC/FUSE_ENGINE/mean_stats.f90 | 22 ++++++------ build/FUSE_SRC/FUSE_ENGINE/q_misscell.f90 | 3 +- build/FUSE_SRC/FUSE_NETCDF/def_output.f90 | 2 +- build/FUSE_SRC/FUSE_NETCDF/def_params.f90 | 2 +- build/FUSE_SRC/FUSE_NETCDF/def_sstats.f90 | 2 +- build/FUSE_SRC/FUSE_NETCDF/get_gforce.f90 | 2 +- build/FUSE_SRC/FUSE_NETCDF/put_output.f90 | 6 ++-- build/FUSE_SRC/dshare/globaldata.f90 | 21 ++++++++++++ build/FUSE_SRC/dshare/model_defn.f90 | 17 +++------ build/FUSE_SRC/dshare/multi_flux.f90 | 1 - build/FUSE_SRC/dshare/multiforce.f90 | 4 --- build/FUSE_SRC/dshare/multiparam.f90 | 1 - build/FUSE_SRC/dshare/multistate.f90 | 6 ---- build/Makefile | 1 + 19 files changed, 86 insertions(+), 75 deletions(-) create mode 100644 build/FUSE_SRC/dshare/globaldata.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/functn.f90 b/build/FUSE_SRC/FUSE_DMSL/functn.f90 index b7cfa89..a0e78fe 100644 --- a/build/FUSE_SRC/FUSE_DMSL/functn.f90 +++ b/build/FUSE_SRC/FUSE_DMSL/functn.f90 @@ -9,13 +9,13 @@ FUNCTION FUNCTN(NOPT,A) ! Wrapper for SCE (used to compute the objective function) ! --------------------------------------------------------------------------------------- USE nrtype ! variable types, etc. -USE FUSE_RMSE_MODULE ! run model and compute the root mean squared error -USE multiforce, only: ncid_forc ! NetCDF forcing file ID +USE FUSE_RMSE_MODULE ! run model and compute the root mean squared error +USE multiforce, only: ncid_forc ! NetCDF forcing file ID IMPLICIT NONE ! input INTEGER(I4B) :: NOPT ! number of parameters -REAL(MSP), DIMENSION(100), INTENT(IN) :: A ! model parameter set - can be bumped up to 100 elements +REAL(MSP), DIMENSION(100), INTENT(IN) :: A ! model parameter set - can be bumped up to 100 elements ! internal REAL(SP), DIMENSION(:), ALLOCATABLE :: SCE_PAR ! sce parameter set @@ -39,7 +39,6 @@ FUNCTION FUNCTN(NOPT,A) ! deallocate parameter set DEALLOCATE(SCE_PAR, STAT=IERR); IF (IERR.NE.0) STOP ' problem deallocating space ' -print *, 'RMSE =', RMSE ! save objective function value FUNCTN = RMSE diff --git a/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 b/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 index 085cdb9..582e5d2 100644 --- a/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 +++ b/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 @@ -23,6 +23,7 @@ PROGRAM DISTRIBUTED_DRIVER ! data modules USE model_defn,nstateFUSE=>nstate ! model definition structures USE model_defnames ! defines the integer model options +USE globaldata, ONLY: isPrint ! flag for printing progress to screen USE multiforce, ONLY: forcefile,vname_aprecip ! model forcing structures USE multiforce, ONLY: AFORCE, aValid ! time series of lumped forcing/response data USE multiforce, ONLY: nspat1, nspat2 ! grid dimensions @@ -43,7 +44,7 @@ PROGRAM DISTRIBUTED_DRIVER USE multiforce, only: ncid_forc ! NetCDF forcing file ID USE multiforce, only: ncid_var ! NetCDF forcing variable ID -USE multistate, only: ncid_out ! NetCDF output file ID +USE globaldata, only: ncid_out ! NetCDF output file ID USE multibands ! basin band stuctures USE data_types, ONLY: PARATT ! data type for metadata @@ -346,9 +347,9 @@ PROGRAM DISTRIBUTED_DRIVER ! assign algorithmic control parameters for SCE ! convert characters to interger/MSP - READ (MAXN_STR,*) MAXN ! maximum number of trials before optimization is terminated + READ (MAXN_STR,*) MAXN ! maximum number of trials before optimization is terminated READ (KSTOP_STR,*) KSTOP ! number of shuffling loops the value must change by PCENTO (MAX=9) - READ (PCENTO_STR,*) PCENTO ! the percentage + READ (PCENTO_STR,*) PCENTO ! the percentage PRINT *, 'SCE parameters read from file manager:' PRINT *, 'Maximum number of trials before SCE optimization is stopped (MAXN) = ', MAXN_STR @@ -439,11 +440,13 @@ PROGRAM DISTRIBUTED_DRIVER FNAME_ASCII = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_sce_output.txt' + ! turn off printing to screen + isPrint = .false. + ! convert from SP used in FUSE to MSP used in SCE ALLOCATE(APAR_MSP(NUMPAR),BL_MSP(NUMPAR),BU_MSP(NUMPAR),URAND_MSP(NUMPAR)) APAR_MSP=APAR - PRINT *, 'BL=',BL BL_MSP=BL BU_MSP=BU URAND_MSP=URAND diff --git a/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 b/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 index c269eff..7996ebb 100644 --- a/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 +++ b/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 @@ -22,6 +22,9 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! 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: fracstate0 ! fraction of initial state (used for initialization) + USE globaldata, ONLY: NA_VALUE, NA_VALUE_SP ! NA_VALUE for the forcing 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 @@ -34,9 +37,7 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG 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:TSTATE,MSTATE,FSTATE,HSTATE ! model state variables 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 @@ -116,13 +117,16 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! add parameter set to the data structure CALL PUT_PARSET(XPAR) - PRINT *, 'Parameter set added to data structure:' - PRINT *, XPAR + if(isPrint) PRINT *, 'Parameter set added to data structure:' + if(isPrint) 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 + if(isPrint) PRINT *, 'Writing parameter values...' + CALL PUT_PARAMS(PCOUNT) + ! initialize model states over the 2D gridded domain (1x1 domain in catchment mode) DO iSpat2=1,nSpat2 DO iSpat1=1,nSpat1 @@ -130,10 +134,10 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG 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' + if(isPrint) PRINT *, 'Model states initialized over the 2D gridded domain' ! initialize elevations bands if snow module is on - PRINT *, 'N_BANDS =', N_BANDS + if(isPrint) PRINT *, 'N_BANDS =', N_BANDS IF (SMODL%iSNOWM.EQ.iopt_temp_index) THEN DO iSpat2=1,nSpat2 @@ -146,7 +150,7 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG END DO END DO END DO - PRINT *, 'Snow states initiatlized over the 2D gridded domain ' + if(isPrint) PRINT *, 'Snow states initiatlized over the 2D gridded domain ' ENDIF ! allocate 3d data structure for fluxes @@ -186,10 +190,10 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG 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' + if(isPrint) 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...' + if(isPrint) PRINT *, 'Forcing loaded. Running FUSE...' ENDIF @@ -345,15 +349,15 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! if end of subperiod: write to output file and save states IF(itim_sub.EQ.numtim_sub_cur)THEN - PRINT *, 'End of subperiod reached:' + if(isPrint) 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 + if(isPrint) 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' + if(isPrint) PRINT *, 'Done writing output' ELSE - PRINT *, 'OUTPUT_FLAG is set on FALSE, no output written' + if(isPrint) PRINT *, 'OUTPUT_FLAG is set on FALSE, no output written' END IF ! TODO: set gState_3d and MBANDS_VAR_4d to NA @@ -382,20 +386,20 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! get timing information CALL CPU_TIME(T2) - WRITE(*,*) "TIME ELAPSED = ", t2-t1 + if(isPrint) WRITE(*,*) "TIME ELAPSED = ", t2-t1 ! calculate mean summary statistics IF(.NOT.GRID_FLAG)THEN - PRINT *, 'Calculating performance metrics...' + if(isPrint) PRINT *, 'Calculating performance metrics...' CALL MEAN_STATS() RMSE = MSTATS%RAW_RMSE + print*, "NSE = ", MSTATS%NASH_SUTT + ENDIF - PRINT *, 'Writing parameter values...' - CALL PUT_PARAMS(PCOUNT) - PRINT *, 'Writing model statistics...' + if(isPrint) PRINT *, 'Writing model statistics...' CALL PUT_SSTATS(PCOUNT) ! deallocate vectors diff --git a/build/FUSE_SRC/FUSE_ENGINE/fuse_solve.f90 b/build/FUSE_SRC/FUSE_ENGINE/fuse_solve.f90 index dd4ec5b..5ae59e3 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/fuse_solve.f90 +++ b/build/FUSE_SRC/FUSE_ENGINE/fuse_solve.f90 @@ -10,8 +10,8 @@ SUBROUTINE FUSE_SOLVE(CALCDSDT,IE_SOLVE,SI_SOLVE,B_IMPOSE,AVG_FLUX,ADD_FLUX,NEWS ! (6) add fluxes from accepted sub-steps to the total timestep flux ! (7) estimate state at end of a full step, based on sum of fluxes USE nrtype ! variable definitions, etc. -USE multi_flux, ONLY: M_FLUX,FLUX_0,FLUX_1,W_FLUX,& ! model fluxes - CURRENT_DT ! model fluxes (continued) +USE globaldata, ONLY: CURRENT_DT +USE multi_flux, ONLY: M_FLUX,FLUX_0,FLUX_1,W_FLUX ! model fluxes USE multistate, ONLY: FSTATE,MSTATE,BSTATE,ESTATE,& ! model states DY_DT,DYDT_0,DYDT_1,HSTATE ! model states (continued) USE fminln, ONLY: fmin_x0p,fmin_dtp,fmin_dt2p,fmin_dseep ! variables used for residual vector in IE diff --git a/build/FUSE_SRC/FUSE_ENGINE/get_mbands.f90 b/build/FUSE_SRC/FUSE_ENGINE/get_mbands.f90 index f05a6ba..efd006c 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/get_mbands.f90 +++ b/build/FUSE_SRC/FUSE_ENGINE/get_mbands.f90 @@ -147,11 +147,12 @@ SUBROUTINE GET_MBANDS_INFO(ELEV_BANDS_NC,err,message) use nrtype,only:I4B,LGT,SP use utilities_dmsl_kit_FUSE,only:getSpareUnit,stripTrailString USE fuse_fileManager,only:INPUT_PATH,SETNGS_PATH ! defines data directory -USE fuse_fileManager,only:MBANDS_NC ! defines elevation bands +USE fuse_fileManager,only:MBANDS_NC ! defines elevation bands USE multibands,only:N_BANDS,MBANDS,MBANDS_INFO_3d,Z_FORCING,& - Z_FORCING_grid,elev_mask ! model band structures -USE multiforce,only:nspat1,nspat2,startSpat2,NA_VALUE_SP ! dimension lengths, na_value + Z_FORCING_grid,elev_mask ! model band structures +USE multiforce,only:nspat1,nspat2,startSpat2 ! dimension lengths +USE globaldata,only:NA_VALUE_SP IMPLICIT NONE ! dummies diff --git a/build/FUSE_SRC/FUSE_ENGINE/mean_stats.f90 b/build/FUSE_SRC/FUSE_ENGINE/mean_stats.f90 index 106c3e3..28fde13 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/mean_stats.f90 +++ b/build/FUSE_SRC/FUSE_ENGINE/mean_stats.f90 @@ -19,6 +19,8 @@ SUBROUTINE MEAN_STATS() USE multiroute ! routed runoff USE multi_flux ! fluxes USE multistats ! summary statistics +USE globaldata, ONLY: isPrint ! flag for printing progress to screen +USE globaldata, only: NA_VALUE_SP ! missing value USE model_numerix ! model numerix parameters and data IMPLICIT NONE @@ -51,7 +53,7 @@ SUBROUTINE MEAN_STATS() ! --------------------------------------------------------------------------------------- ! define sample size NS = eval_end-eval_beg+1 -PRINT *, 'Number of time steps in evaluation period (EP) = ', NS +if(isPrint) PRINT *, 'Number of time steps in evaluation period (EP) = ', NS ! allocate space for observed and simulated runoff ALLOCATE(QOBS(NS),QOBS_MASK(NS),QSIM(NS),STAT=IERR) @@ -63,10 +65,10 @@ SUBROUTINE MEAN_STATS() QOBS = aValid(1,1,eval_beg-sim_beg+1:eval_end-sim_beg+1)%OBSQ ! check for missing QOBS values -QOBS_MASK = QOBS.ne.REAL(NA_VALUE, KIND(SP)) ! find the time steps for which QOBS is available -NUM_AVAIL = COUNT(QOBS_MASK) ! number of time steps for which QOBS is available +QOBS_MASK = QOBS.ne.NA_VALUE_SP ! find the time steps for which QOBS is available +NUM_AVAIL = COUNT(QOBS_MASK) ! number of time steps for which QOBS is available -PRINT *, 'Number of time steps with observed streamflow in EP = ', NUM_AVAIL +if(isPrint) PRINT *, 'Number of time steps with observed streamflow in EP = ', NUM_AVAIL IF (NUM_AVAIL.EQ.0) THEN @@ -80,11 +82,11 @@ SUBROUTINE MEAN_STATS() ALLOCATE(QOBS_AVAIL(NUM_AVAIL),QSIM_AVAIL(NUM_AVAIL),DOBS(NUM_AVAIL),DSIM(NUM_AVAIL),RAWD(NUM_AVAIL),LOGD(NUM_AVAIL),STAT=IERR) QOBS_AVAIL=PACK(QOBS,QOBS_MASK,QOBS_AVAIL) ! moves QOBS time steps indicated by QOBS_MASK to QOBS_AVAIL, - ! if no values is missing (i.e. NS = NUM_AVAIL) then QOBS_AVAIL - ! should be a copy of QOBS + ! if no values is missing (i.e. NS = NUM_AVAIL) then QOBS_AVAIL + ! should be a copy of QOBS QSIM_AVAIL=PACK(QSIM,QOBS_MASK,QSIM_AVAIL) ! moves QSIM time steps indicated by QOBS_MASK to QSIM_AVAIL - ! if no values is missing (i.e. NS = NUM_AVAIL) then QSIM_AVAIL - ! should be a copy of QSIM + ! if no values is missing (i.e. NS = NUM_AVAIL) then QSIM_AVAIL + ! should be a copy of QSIM ! compute mean XB_OBS = SUM(QOBS_AVAIL(:)) / REAL(NUM_AVAIL, KIND(SP)) @@ -130,8 +132,8 @@ SUBROUTINE MEAN_STATS() END IF -PRINT *, 'NSE = ', MSTATS%NASH_SUTT -PRINT *, 'RAW_RMSE = ', MSTATS%RAW_RMSE +if(isPrint) PRINT *, 'NSE = ', MSTATS%NASH_SUTT +if(isPrint) PRINT *, 'RAW_RMSE = ', MSTATS%RAW_RMSE ! --------------------------------------------------------------------------------------- ! (3§) COMPUTE STATISTICS ON NUMERICAL ACCURACY AND EFFICIENCY diff --git a/build/FUSE_SRC/FUSE_ENGINE/q_misscell.f90 b/build/FUSE_SRC/FUSE_ENGINE/q_misscell.f90 index b40328a..b84bad5 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/q_misscell.f90 +++ b/build/FUSE_SRC/FUSE_ENGINE/q_misscell.f90 @@ -20,9 +20,10 @@ SUBROUTINE Q_MISSCELL() USE nrtype ! variable types, etc. USE model_defn ! model definition structure USE model_defnames +USE globaldata, ONLY: CURRENT_DT USE multiparam, ONLY: MPARAM,DPARAM ! model parameters USE multistate, ONLY: MSTATE,TSTATE ! model states -USE multi_flux, ONLY: M_FLUX,CURRENT_DT ! model fluxes +USE multi_flux, ONLY: M_FLUX ! model fluxes USE model_numerix ! access model numerix decisions IMPLICIT NONE REAL(SP) :: LOGISMOOTH ! FUNCTION logistic smoothing diff --git a/build/FUSE_SRC/FUSE_NETCDF/def_output.f90 b/build/FUSE_SRC/FUSE_NETCDF/def_output.f90 index f04bbb5..ebd3dc9 100644 --- a/build/FUSE_SRC/FUSE_NETCDF/def_output.f90 +++ b/build/FUSE_SRC/FUSE_NETCDF/def_output.f90 @@ -19,7 +19,7 @@ SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,NPSET,NTIM) 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: ncid_out ! NetCDF output file ID IMPLICIT NONE diff --git a/build/FUSE_SRC/FUSE_NETCDF/def_params.f90 b/build/FUSE_SRC/FUSE_NETCDF/def_params.f90 index 46b2cdb..0c9ea24 100644 --- a/build/FUSE_SRC/FUSE_NETCDF/def_params.f90 +++ b/build/FUSE_SRC/FUSE_NETCDF/def_params.f90 @@ -13,7 +13,7 @@ SUBROUTINE DEF_PARAMS(NPAR) USE model_defn ! model definition (includes filename) USE metaparams ! metadata for all model parameters USE multistats, ONLY: MSTATS ! model statistics structure -USE multistate, only: ncid_out ! NetCDF output file ID +USE globaldata, only: ncid_out ! NetCDF output file ID IMPLICIT NONE ! input INTEGER(I4B), INTENT(IN) :: NPAR ! number of parameter sets diff --git a/build/FUSE_SRC/FUSE_NETCDF/def_sstats.f90 b/build/FUSE_SRC/FUSE_NETCDF/def_sstats.f90 index 2d4b4ac..f75b1e2 100644 --- a/build/FUSE_SRC/FUSE_NETCDF/def_sstats.f90 +++ b/build/FUSE_SRC/FUSE_NETCDF/def_sstats.f90 @@ -12,7 +12,7 @@ SUBROUTINE DEF_SSTATS() USE model_defn ! model definition (includes filename) USE meta_stats ! metadata for summary statistics USE model_numerix ! model numerix decisions -USE multistate, only: ncid_out ! NetCDF output file ID +USE globaldata, only: ncid_out ! NetCDF output file ID IMPLICIT NONE ! internal INTEGER(I4B) :: IERR ! error code; NetCDF ID diff --git a/build/FUSE_SRC/FUSE_NETCDF/get_gforce.f90 b/build/FUSE_SRC/FUSE_NETCDF/get_gforce.f90 index f990a04..1445c3e 100644 --- a/build/FUSE_SRC/FUSE_NETCDF/get_gforce.f90 +++ b/build/FUSE_SRC/FUSE_NETCDF/get_gforce.f90 @@ -2,6 +2,7 @@ module get_gforce_module USE nrtype USE netcdf USE time_io +USE globaldata, only: NA_VALUE, NA_VALUE_SP ! missing value implicit none private public::read_ginfo @@ -75,7 +76,6 @@ SUBROUTINE read_ginfo(ncid,ierr,message) USE multiforce,only:latUnits,lonUnits,timeUnits ! units string for time USE multiforce,only:vname_dtime ! variable name: time sice reference time USE multiforce, only: nForce, nInput ! number of parameter set and their names - USE multiforce, only: NA_VALUE ! NA_VALUE for the forcing #ifdef __MPI__ use mpi diff --git a/build/FUSE_SRC/FUSE_NETCDF/put_output.f90 b/build/FUSE_SRC/FUSE_NETCDF/put_output.f90 index 8d1b13e..99d6676 100644 --- a/build/FUSE_SRC/FUSE_NETCDF/put_output.f90 +++ b/build/FUSE_SRC/FUSE_NETCDF/put_output.f90 @@ -15,7 +15,7 @@ SUBROUTINE PUT_OUTPUT(iSpat1,iSpat2,ITIM,IMOD,IPAR) 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 + USE globaldata, only: ncid_out ! NetCDF output file ID IMPLICIT NONE ! input @@ -95,10 +95,10 @@ SUBROUTINE PUT_GOUTPUT_3D(istart_sim,istart_in,numtim,IPSET) 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 + USE multiforce, only: GRID_FLAG ! .true. if distributed + USE globaldata, only: ncid_out ! NetCDF output file ID IMPLICIT NONE diff --git a/build/FUSE_SRC/dshare/globaldata.f90 b/build/FUSE_SRC/dshare/globaldata.f90 new file mode 100644 index 0000000..0029c83 --- /dev/null +++ b/build/FUSE_SRC/dshare/globaldata.f90 @@ -0,0 +1,21 @@ +MODULE globaldata + + USE nrtype + + ! time step + REAL(SP), save :: CURRENT_DT ! current time step (days) + + ! 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 + + ! NetCDF + integer(i4b), save :: ncid_out=-1 ! NetCDF output file ID + + ! initial store fraction (initialization) + real(sp), parameter :: fracState0=0.25_sp + + ! print flag + logical(lgt) :: isPrint=.true. + +end MODULE globaldata diff --git a/build/FUSE_SRC/dshare/model_defn.f90 b/build/FUSE_SRC/dshare/model_defn.f90 index 9a0c80a..0dcd28b 100644 --- a/build/FUSE_SRC/dshare/model_defn.f90 +++ b/build/FUSE_SRC/dshare/model_defn.f90 @@ -27,36 +27,27 @@ MODULE model_defn 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 + 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 + ! 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 diff --git a/build/FUSE_SRC/dshare/multi_flux.f90 b/build/FUSE_SRC/dshare/multi_flux.f90 index fa393ff..b00bb06 100644 --- a/build/FUSE_SRC/dshare/multi_flux.f90 +++ b/build/FUSE_SRC/dshare/multi_flux.f90 @@ -7,5 +7,4 @@ MODULE multi_flux 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/dshare/multiforce.f90 b/build/FUSE_SRC/dshare/multiforce.f90 index 46f205a..468f649 100644 --- a/build/FUSE_SRC/dshare/multiforce.f90 +++ b/build/FUSE_SRC/dshare/multiforce.f90 @@ -124,9 +124,5 @@ MODULE multiforce 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/multiparam.f90 b/build/FUSE_SRC/dshare/multiparam.f90 index 7f7938d..cfaa939 100644 --- a/build/FUSE_SRC/dshare/multiparam.f90 +++ b/build/FUSE_SRC/dshare/multiparam.f90 @@ -7,7 +7,6 @@ ! --------------------------------------------------------------------------------------- MODULE multiparam USE nrtype - USE model_defn,ONLY:NTDH_MAX USE data_types,ONLY:par_id,parinfo,paradj,pardvd ! -------------------------------------------------------------------------------------- INTEGER(I4B), PARAMETER :: MAXPAR=50 ! maximum number of parameters for a single model diff --git a/build/FUSE_SRC/dshare/multistate.f90 b/build/FUSE_SRC/dshare/multistate.f90 index 3a9a3a6..f7724f0 100644 --- a/build/FUSE_SRC/dshare/multistate.f90 +++ b/build/FUSE_SRC/dshare/multistate.f90 @@ -18,10 +18,4 @@ MODULE multistate 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/Makefile b/build/Makefile index 5b960bc..9c2edfb 100644 --- a/build/Makefile +++ b/build/Makefile @@ -87,6 +87,7 @@ FUSE_DATAMS= \ model_defn.f90 \ data_types.f90 \ model_defnames.f90 \ + globaldata.f90 \ multiconst.f90 \ multiforce.f90 \ multibands.f90 \ From f359f5d1dabee8512892c339e285db8508a25bac Mon Sep 17 00:00:00 2001 From: Martyn Clark Date: Sat, 29 Nov 2025 11:36:58 -0700 Subject: [PATCH 04/16] add random seed to obtain same results for different optimization trials --- build/FUSE_SRC/FUSE_DMSL/functn.f90 | 4 ++++ build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 | 9 +++++++-- build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 | 3 ++- build/FUSE_SRC/dshare/globaldata.f90 | 3 +++ 4 files changed, 16 insertions(+), 3 deletions(-) diff --git a/build/FUSE_SRC/FUSE_DMSL/functn.f90 b/build/FUSE_SRC/FUSE_DMSL/functn.f90 index a0e78fe..1d2e813 100644 --- a/build/FUSE_SRC/FUSE_DMSL/functn.f90 +++ b/build/FUSE_SRC/FUSE_DMSL/functn.f90 @@ -11,6 +11,7 @@ FUNCTION FUNCTN(NOPT,A) USE nrtype ! variable types, etc. USE FUSE_RMSE_MODULE ! run model and compute the root mean squared error USE multiforce, only: ncid_forc ! NetCDF forcing file ID +USE globaldata, only: nFUSE_eval ! # fuse evaluations IMPLICIT NONE ! input @@ -29,6 +30,9 @@ FUNCTION FUNCTN(NOPT,A) REAL(MSP) :: FUNCTN ! objective function value ! --------------------------------------------------------------------------------------- + +nFUSE_eval = nFUSE_eval + 1 + ! get SCE parameter set ALLOCATE(SCE_PAR(NOPT), STAT=IERR); IF (IERR.NE.0) STOP ' problem allocating space ' SCE_PAR(1:NOPT) = A(1:NOPT) ! convert from MSP used in SCE to SP used in FUSE diff --git a/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 b/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 index 582e5d2..1060413 100644 --- a/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 +++ b/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 @@ -24,6 +24,7 @@ PROGRAM DISTRIBUTED_DRIVER USE model_defn,nstateFUSE=>nstate ! model definition structures USE model_defnames ! defines the integer model options USE globaldata, ONLY: isPrint ! flag for printing progress to screen +USE globaldata, only: nFUSE_eval ! number of fuse evaluations USE multiforce, ONLY: forcefile,vname_aprecip ! model forcing structures USE multiforce, ONLY: AFORCE, aValid ! time series of lumped forcing/response data USE multiforce, ONLY: nspat1, nspat2 ! grid dimensions @@ -440,8 +441,9 @@ PROGRAM DISTRIBUTED_DRIVER FNAME_ASCII = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_sce_output.txt' - ! turn off printing to screen - isPrint = .false. + ! printing + isPrint = .false. ! ! turn off printing to screen + nFUSE_eval = 0 ! number of fuse eevaluations ! convert from SP used in FUSE to MSP used in SCE ALLOCATE(APAR_MSP(NUMPAR),BL_MSP(NUMPAR),BU_MSP(NUMPAR),URAND_MSP(NUMPAR)) @@ -451,6 +453,9 @@ PROGRAM DISTRIBUTED_DRIVER BU_MSP=BU URAND_MSP=URAND + ! set random seed + ISEED = 1 + ! open up ASCII output file print *, 'Creating SCE output file:', trim(FNAME_ASCII) ISCE = 96; OPEN(ISCE,FILE=TRIM(FNAME_ASCII)) diff --git a/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 b/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 index 7996ebb..76226d0 100644 --- a/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 +++ b/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 @@ -23,6 +23,7 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG 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 globaldata, ONLY: fracstate0 ! fraction of initial state (used for initialization) USE globaldata, ONLY: NA_VALUE, NA_VALUE_SP ! NA_VALUE for the forcing USE multiparam, ONLY: LPARAM,NUMPAR,MPARAM ! list of model parameters @@ -395,7 +396,7 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG CALL MEAN_STATS() RMSE = MSTATS%RAW_RMSE - print*, "NSE = ", MSTATS%NASH_SUTT + write(*,'(i6,1x,a6,1x,f12.6,1x)') nFUSE_eval, "NSE = ", MSTATS%NASH_SUTT ENDIF diff --git a/build/FUSE_SRC/dshare/globaldata.f90 b/build/FUSE_SRC/dshare/globaldata.f90 index 0029c83..d9edb1d 100644 --- a/build/FUSE_SRC/dshare/globaldata.f90 +++ b/build/FUSE_SRC/dshare/globaldata.f90 @@ -18,4 +18,7 @@ MODULE globaldata ! print flag logical(lgt) :: isPrint=.true. + ! number of fuse evaluations + integer(i4b), save :: nFUSE_eval + end MODULE globaldata From fa48f628dcc0f130c7f8a8e66ddc7f64b73bb17c Mon Sep 17 00:00:00 2001 From: Martyn Clark Date: Sat, 29 Nov 2025 12:24:55 -0700 Subject: [PATCH 05/16] fix run_pre option --- build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 | 86 ++++++++---------------- 1 file changed, 27 insertions(+), 59 deletions(-) diff --git a/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 b/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 index 1060413..0c54a36 100644 --- a/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 +++ b/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 @@ -41,7 +41,6 @@ PROGRAM DISTRIBUTED_DRIVER USE multiforce, only: sim_beg,sim_end ! timestep indices USE multiforce, only: eval_beg,eval_end ! timestep indices USE multiforce, only: SUB_PERIODS_FLAG ! .true. if subperiods are used to run FUSE -USE multiforce, only: NUMPSET,name_psets ! number of parameter set and their names USE multiforce, only: ncid_forc ! NetCDF forcing file ID USE multiforce, only: ncid_var ! NetCDF forcing variable ID @@ -86,14 +85,15 @@ PROGRAM DISTRIBUTED_DRIVER CHARACTER(LEN=256) :: DatString ! file manager CHARACTER(LEN=256) :: dom_id ! ID of the domain CHARACTER(LEN=10) :: fuse_mode=' ' ! fuse execution mode (run_def, run_best, run_pre, calib_sce) -CHARACTER(LEN=256) :: file_para_list ! txt file containing list of parameter sets +CHARACTER(LEN=256) :: file_param ! name of parameter file +CHARACTER(LEN=10) :: index_param ! index of desired parameter set ! --------------------------------------------------------------------------------------- ! SETUP MODELS FOR SIMULATION -- POPULATE DATA STRUCTURES ! --------------------------------------------------------------------------------------- ! fuse_file_manager -CHARACTER(LEN=1024) :: FFMFILE ! name of fuse_file_manager file -CHARACTER(LEN=1024) :: ELEV_BANDS_NC ! name of NetCDF file for elevation bands +CHARACTER(LEN=1024) :: FFMFILE ! name of fuse_file_manager file +CHARACTER(LEN=1024) :: ELEV_BANDS_NC ! name of NetCDF file for elevation bands ! get model forcing data INTEGER(I4B) :: NTIM ! number of time steps - still needed ? INTEGER(I4B) :: INFERN_START ! start of inference period - still needed? @@ -121,7 +121,7 @@ PROGRAM DISTRIBUTED_DRIVER ! --------------------------------------------------------------------------------------- INTEGER(I4B) :: ITIM ! loop thru time steps INTEGER(I4B) :: IPAR ! loop thru model parameters -INTEGER(I4B) :: IPSET ! loop thru model parameter sets +INTEGER(I4B) :: IPSET ! index of desired model parameter set TYPE(PARATT) :: PARAM_META ! parameter metadata (model parameters) REAL(SP), DIMENSION(:), ALLOCATABLE :: BL ! vector of lower parameter bounds REAL(SP), DIMENSION(:), ALLOCATABLE :: BU ! vector of upper parameter bounds @@ -129,7 +129,7 @@ PROGRAM DISTRIBUTED_DRIVER INTEGER(KIND=4) :: ISEED ! seed for the random sequence REAL(KIND=4),DIMENSION(:), ALLOCATABLE :: URAND ! vector of quasi-random numbers U[0,1] REAL(SP) :: RMSE ! error from the simulation - +integer(i4b) :: NUMPSET ! number of parameter sets ! --------------------------------------------------------------------------------------- ! SCE VARIABLES ! --------------------------------------------------------------------------------------- @@ -179,22 +179,28 @@ PROGRAM DISTRIBUTED_DRIVER CALL GETARG(1,DatString) ! string defining forcinginfo file CALL GETARG(2,dom_id) ! ID of the domain CALL GETARG(3,fuse_mode) ! fuse execution mode (run_def, run_best, calib_sce) -IF(TRIM(fuse_mode).EQ.'run_pre') CALL GETARG(4,file_para_list) ! fuse execution mode txt file containing list of parameter sets +IF(TRIM(fuse_mode).EQ.'run_pre')then + CALL GETARG(4,file_param) ! name of parameter file + CALL GETARG(5,index_param) ! index of desired parameter set + IF(LEN_TRIM(index_param).EQ.0) IPSET = 1 + IF(LEN_TRIM(index_param).GT.0) read(index_param,*) IPSET +ENDIF ! check command-line arguments IF (LEN_TRIM(DatString).EQ.0) STOP '1st command-line argument is missing (fileManager)' IF (LEN_TRIM(dom_id).EQ.0) STOP '2nd command-line argument is missing (dom_id)' IF (LEN_TRIM(fuse_mode).EQ.0) STOP '3rd command-line argument is missing (fuse_mode)' IF(TRIM(fuse_mode).EQ.'run_pre')THEN - IF(LEN_TRIM(file_para_list).EQ.0) STOP '4th command-line argument is missing (file_para_list) and is required in mode run_pre' + IF(LEN_TRIM(file_param).EQ.0) STOP '4th command-line argument is missing (file_param) and is required in mode run_pre' ENDIF ! print command-line arguments -print*, '1st command-line argument (fileManager) = ', trim(DatString) -print*, '2nd command-line argument (dom_id) = ', trim(dom_id) -print*, '3rd command-line argument (fuse_mode) = ', fuse_mode +print*, '1st command-line argument (fileManager) = ', trim(DatString) +print*, '2nd command-line argument (dom_id) = ', trim(dom_id) +print*, '3rd command-line argument (fuse_mode) = ', fuse_mode IF(TRIM(fuse_mode).EQ.'run_pre')THEN - print*, '4th command-line argument (file_para_list) = ', file_para_list + print*, '4th command-line argument (file_param) = ', file_param + print*, '5th command-line argument (index_param) = ', IPSET ENDIF ! --------------------------------------------------------------------------------------- @@ -301,45 +307,14 @@ PROGRAM DISTRIBUTED_DRIVER FNAME_NETCDF_PARA = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_para_def.nc' #endif - NUMPSET=1 ! only the default parameter set is run - ALLOCATE(name_psets(NUMPSET)) - name_psets(1)='default_param_set' - ELSE IF(fuse_mode == 'run_pre')THEN ! run FUSE with pre-defined parameter values - ! read file_para_list twice: - ! 1st pass: determine number of parameter set and allocate name_psets accordingly - ! 2st pass: save the names of parameter sets in name_psets - - do file_pass = 1, 2 - - NUMPSET=0 ! intialize counter - - OPEN(21,FILE=TRIM(file_para_list)) - DO ! loop through parameter files - - READ(21,*,IOSTAT=ERR) dummy_string - IF (ERR.NE.0) EXIT - NUMPSET=NUMPSET+1 ! increment counter - - if (file_pass.eq.2) THEN - name_psets(NUMPSET) = dummy_string ! save file names - ENDIF - - END DO ! looping through parameter files - - CLOSE(21) - - if(file_pass.eq.1) THEN - print *, 'NUMPSET=', NUMPSET, 'based on the number of lines in ', TRIM(file_para_list) - ALLOCATE(name_psets(NUMPSET)) - END IF - end do - ! files to which model run and parameter set will be saved FNAME_NETCDF_RUNS = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_runs_pre.nc' FNAME_NETCDF_PARA = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_para_pre_out.nc' + NUMPSET=1 ! only the one "desired" parameter set is run + ELSE IF(fuse_mode == 'calib_sce')THEN ! calibrate FUSE using SCE ! files to which model run and parameter set will be saved @@ -417,22 +392,15 @@ PROGRAM DISTRIBUTED_DRIVER OUTPUT_FLAG=.TRUE. - do IPSET = 1, NUMPSET - - FNAME_NETCDF_PARA_PRE=TRIM(OUTPUT_PATH)//name_psets(IPSET) - PRINT *, 'Loading parameter set ',IPSET,':' - - ! load specific parameter set - ! 2nd argument is 1 because first (and only) parameter set should be loaded - CALL GET_PRE_PARAM(FNAME_NETCDF_PARA_PRE,1,ONEMOD,NUMPAR,APAR) - - print *, 'Running FUSE with pre-defined parameter set' - CALL FUSE_RMSE(APAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET) - print *, 'Done running FUSE with pre-defined parameter set' + FNAME_NETCDF_PARA_PRE=TRIM(OUTPUT_PATH)//file_param + PRINT *, 'Loading parameter set ',IPSET,':' - end do + ! load specific parameter set + CALL GET_PRE_PARAM(FNAME_NETCDF_PARA_PRE,IPSET,ONEMOD,NUMPAR,APAR) - DEALLOCATE(name_psets) + print *, 'Running FUSE with pre-defined parameter set' + CALL FUSE_RMSE(APAR,GRID_FLAG,NCID_FORC,RMSE,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 From c00d202650903abe75e1a418ef0b92c53360e30b Mon Sep 17 00:00:00 2001 From: Martyn Clark Date: Mon, 1 Dec 2025 09:21:48 -0700 Subject: [PATCH 06/16] updates to IE solve --- build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 | 12 +- build/FUSE_SRC/FUSE_ENGINE/logismooth.f90 | 22 -- build/FUSE_SRC/FUSE_ENGINE/q_misscell.f90 | 2 +- build/FUSE_SRC/dshare/globaldata.f90 | 3 +- build/FUSE_SRC/physics/fix_ovshoot.f90 | 30 +- build/FUSE_SRC/physics/implicit_solve.f90 | 407 ++++++++++++++------- build/FUSE_SRC/physics/mstate_rhs_diff.f90 | 19 + build/FUSE_SRC/physics/q_baseflow_diff.f90 | 2 + build/FUSE_SRC/physics/q_misscell_diff.f90 | 26 +- build/FUSE_SRC/physics/smoothers.f90 | 132 +++++++ build/Makefile | 10 +- 11 files changed, 492 insertions(+), 173 deletions(-) delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/logismooth.f90 create mode 100644 build/FUSE_SRC/physics/smoothers.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 b/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 index 76226d0..1aa8567 100644 --- a/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 +++ b/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 @@ -103,7 +103,6 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! differentiable model type(parent) :: fuseStruct ! parent fuse data structure - ! --------------------------------------------------------------------------------------- ! allocate state vectors ALLOCATE(STATE0(NSTATE),STATE1(NSTATE),STAT=IERR) @@ -277,9 +276,16 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! populate parent fuse structure call get_parent(fuseStruct) - ! solve differentiable ODEs - call implicit_solve(fuseStruct, state0, state1, nState) + call implicit_solve(fuseStruct, state0, state1, nState, ierr, cmessage) + if(ierr/=0)then + print*, trim(cmessage) + print*, 'state0 = ', state0 + call implicit_solve(fuseStruct, state0, state1, nState, ierr, cmessage, isVerbose=.true.) + stop 1 + endif + + !print*, state1 !if(ITIM_IN > sim_beg+100) stop diff --git a/build/FUSE_SRC/FUSE_ENGINE/logismooth.f90 b/build/FUSE_SRC/FUSE_ENGINE/logismooth.f90 deleted file mode 100644 index b149654..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/logismooth.f90 +++ /dev/null @@ -1,22 +0,0 @@ -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) :: ASMOOTH ! actual smoothing -REAL(SP) :: LOGISMOOTH ! FUNCTION name -! --------------------------------------------------------------------------------------- -ASMOOTH = PSMOOTH*STATE_MAX ! actual smoothing -LOGISMOOTH = 1._SP / ( 1._SP + EXP(-(STATE - (STATE_MAX - ASMOOTH*5._SP) ) / ASMOOTH) ) -! --------------------------------------------------------------------------------------- -END FUNCTION LOGISMOOTH diff --git a/build/FUSE_SRC/FUSE_ENGINE/q_misscell.f90 b/build/FUSE_SRC/FUSE_ENGINE/q_misscell.f90 index b84bad5..2dc7257 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/q_misscell.f90 +++ b/build/FUSE_SRC/FUSE_ENGINE/q_misscell.f90 @@ -25,8 +25,8 @@ SUBROUTINE Q_MISSCELL() USE multistate, ONLY: MSTATE,TSTATE ! model states USE multi_flux, ONLY: M_FLUX ! model fluxes USE model_numerix ! access model numerix decisions +USE smoothers, only: logismooth ! logistic smoothing function IMPLICIT NONE -REAL(SP) :: LOGISMOOTH ! FUNCTION logistic smoothing REAL(SP), PARAMETER :: PSMOOTH=0.01_SP ! smoothing parameter REAL(SP) :: W_FUNC ! result from LOGISMOOTH REAL(SP) :: DT ! current time step diff --git a/build/FUSE_SRC/dshare/globaldata.f90 b/build/FUSE_SRC/dshare/globaldata.f90 index d9edb1d..9d551d3 100644 --- a/build/FUSE_SRC/dshare/globaldata.f90 +++ b/build/FUSE_SRC/dshare/globaldata.f90 @@ -16,7 +16,8 @@ MODULE globaldata real(sp), parameter :: fracState0=0.25_sp ! print flag - logical(lgt) :: isPrint=.true. + logical(lgt), save :: isPrint=.true. + logical(lgt), save :: isDebug=.false. ! number of fuse evaluations integer(i4b), save :: nFUSE_eval diff --git a/build/FUSE_SRC/physics/fix_ovshoot.f90 b/build/FUSE_SRC/physics/fix_ovshoot.f90 index 9e51da3..16feb4b 100644 --- a/build/FUSE_SRC/physics/fix_ovshoot.f90 +++ b/build/FUSE_SRC/physics/fix_ovshoot.f90 @@ -9,6 +9,7 @@ module overshoot_module private public :: get_bounds public :: fix_ovshoot + public :: sigmoid contains @@ -28,10 +29,21 @@ pure real(sp) function softplus(x, alpha) result(y) 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) + SUBROUTINE fix_ovshoot(X_TRY, lower, upper, dclamp) ! --------------------------------------------------------------------------------------- ! Creator: ! -------- @@ -45,13 +57,23 @@ SUBROUTINE fix_ovshoot(X_TRY, lower, upper) 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 - - ! apply soft constraint to model states + do i=1,NSTATE - x_try(i) = lower(i) + softplus(x_try(i)-lower(i), alpha) - softplus(x_try(i)-upper(i), alpha) + + ! 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 diff --git a/build/FUSE_SRC/physics/implicit_solve.f90 b/build/FUSE_SRC/physics/implicit_solve.f90 index 6ee2325..39a30c7 100644 --- a/build/FUSE_SRC/physics/implicit_solve.f90 +++ b/build/FUSE_SRC/physics/implicit_solve.f90 @@ -11,55 +11,36 @@ module implicit_solve_module ! 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 - ! provide access to the fuse parent structure - type(parent), pointer, save :: ctx => null() - private public :: implicit_solve contains - ! ----- point to the fuse parent structure --------------------------------------------- - - subroutine set_dxdt_context(fuseStruct) - type(parent), target, intent(inout) :: fuseStruct - ctx => fuseStruct - end subroutine set_dxdt_context - - subroutine clear_dxdt_context() - nullify(ctx) - end subroutine clear_dxdt_context - - ! -------------------------------------------------------------------------------------- - ! -------------------------------------------------------------------------------------- - ! -------------------------------------------------------------------------------------- - ! ----- calculate dx/dt=g(x) ----------------------------------------------------------- - function dx_dt(x_try) result(g_x) + function dx_dt(fuseStruct, x_try) result(g_x) use MOD_DERIVS_DIFF_module, only: MOD_DERIVS_DIFF ! compute dx/dt implicit none ! input + type(parent) , intent(inout) :: fuseStruct ! parent fuse data structure real(sp) , intent(in) :: x_try(:) ! trial state vector ! output real(sp) :: g_x(size(x_try)) ! dx/dt=g(x) - ! check made the association to ctx (ctx=>fuseStruct) - if (.not. associated(ctx)) stop "dx_dt: context not set" - ! put data in structure - call XTRY_2_STR(x_try, ctx%state1) + call XTRY_2_STR(x_try, fuseStruct%state1) ! run the fuse physics - call mod_derivs_diff(ctx) + call mod_derivs_diff(fuseStruct) ! extract dx_dt from fuse structure - call STR_2_XTRY(ctx%dx_dt, g_x) + call STR_2_XTRY(fuseStruct%dx_dt, g_x) ! track the total number of function calls NUM_FUNCS = NUM_FUNCS + 1 @@ -67,72 +48,123 @@ function dx_dt(x_try) result(g_x) end function dx_dt ! ----- calculate the Jacobian of g(x) ------------------------------------------------- - SUBROUTINE jac_flux(x,g_x,Jac) + SUBROUTINE jac_flux(fuseStruct, x_try, g_x, lower, upper, Jac) IMPLICIT NONE - REAL(SP), DIMENSION(:), INTENT(IN) :: g_x - REAL(SP), DIMENSION(:), INTENT(INOUT) :: x + ! input-output + type(parent) , intent(inout) :: fuseStruct ! parent fuse data structure + REAL(SP), DIMENSION(:), INTENT(IN) :: g_x, lower, upper + REAL(SP), DIMENSION(:), INTENT(IN) :: x_try REAL(SP), DIMENSION(:,:), INTENT(OUT) :: Jac - REAL(SP), PARAMETER :: EPS=-1.0e-4_sp ! NOTE force h to be negative + ! locals + type(parent) :: ctx_sav + 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)) :: xsav,xph,h - xsav=x - n=size(x) - h=EPS*abs(xsav) - where (h == 0.0) h=EPS - xph=xsav+h - h=xph-xsav + REAL(SP), DIMENSION(size(x_try)) :: x, xsav, g_ph + real(sp) :: h_try, h_act + + ! preliminaries + n = size(x) + ctx_sav = fuseStruct + x = x_try + xsav = x + + ! loop through columns do j=1,n - x(j)=xph(j) - Jac(:,j)=(dx_dt(x)-g_x(:))/h(j) - x(j)=xsav(j) - end do + + ! safety: save full vector and data structure + fuseStruct = ctx_sav + x=xsav + + ! propose one-sided step + 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 + g_ph = dx_dt(fuseStruct, x) + h_act = x(j) - xsav(j) + + ! compute column in the Jacobian + Jac(:,j) = (g_ph - g_x) / h_act + + end do ! looping through Jacobian columns + NUM_JACOBIAN = NUM_JACOBIAN + 1 ! keep track of the number of iterations - call XTRY_2_STR(xsav, ctx%state1) ! restores consistency after finite differencing + fuseStruct = ctx_sav ! restores consistency after finite differencing end SUBROUTINE jac_flux ! ----- simple implicit solve for differentiable model -------------------------- - subroutine implicit_solve(fuseStruct, x0, x1, nx) + 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 model_numerix, only: ERR_ITER_FUNC ! Iteration convergence tolerance for function values - USE model_numerix, only: ERR_ITER_DX ! Iteration convergence tolerance for dx + USE overshoot_module, only : get_bounds ! get state bounds + USE overshoot_module, only : fix_ovshoot ! fix overshoot (soft clamp) + 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(parent), intent(inout) :: fuseStruct ! parent fuse data 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 - ! internal: newton iterations - 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) :: 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 + type(parent), intent(inout) :: fuseStruct ! parent fuse data 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 control + 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) :: 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) :: lambda ! backtrack length multiplier (lambda*dx) - real(sp) :: lower(nx) ! lower bound - real(sp) :: upper(nx) ! lower bound - real(sp) :: x_trial(nx) ! state vectorfor 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 - ! line search params - real(sp), parameter :: shrink = 0.5_sp - real(sp), parameter :: c_armijo = 1e-4_sp - integer(i4b), parameter :: ls_max = 5 + type(parent) :: ctx ! save the fuse structure + 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 + ! 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" @@ -141,89 +173,216 @@ subroutine implicit_solve(fuseStruct, x0, x1, nx) 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 + + ! save the fuse structure + ctx = fuseStruct + ! 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) - ! point to the fuse parent structure so that it is available in other routines - call set_dxdt_context(fuseStruct) - ! put state vector into the fuse data structure call XTRY_2_STR(x0, fuseStruct%state0) - ! intialize state vector and convergence flag - x_try = x0 + ! 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) and objective phi = 0.5*||F||^2 - g_x = dx_dt(x_try) + if(isPrint) isDebug = .true. + + ! --- F(x) and objective phi + g_x = dx_dt(fuseStruct, x_try) res = x_try - (x0 + g_x*dt) - phi = 0.5_sp * sum(res*res) + phi = 0.5_sp * dot_product(res, res) + + if(isPrint) isDebug = .false. ! iterate do it = 1, maxit - if (sqrt(2.0_sp*phi) < ERR_ITER_FUNC) then + ! save x + x_old = x_try + + if(isPrint) print*, '***** start of iteration *****' + + ! check + if(isPrint)then + print*, 'x_try = ', x_try + print*, 'g_x = ', g_x + print*, 'res = ', res + print*, 'phi = ', phi + print*, 'dclamp = ', dclamp + if(it > 10) stop 1 + endif + + if (phi < ERR_ITER_FUNC) then converged = .true. exit ! exit iteration loop end if + if(isPrint) print*, 'x_try 0 = ', x_try + ! --- J(x) - call jac_flux(x_try, g_x, Jg) - Jac = -dt*Jg ! multiply dt - do i=1,nx; Jac(i,i) = Jac(i,i) + 1.0_sp; end do ! add identity matrix + call jac_flux(fuseStruct, x_try, g_x, lower, upper, Jg) + do i=1,nx + Jac(:,i) = -dt*Jg(:,i) !* dclamp(i) ! multiply dt and clamp derivative + Jac(i,i) = Jac(i,i) + 1.0_sp + end do + + if(isPrint) print*, 'x_try 1 = ', x_try + + ! --- 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 + + if(isPrint) print*, 'x_try 2 = ', x_try + + if(isPrint)then + print*, 'dx = ', dx + print*, 'Jg = ', Jg + endif - ! initialize flag to check if line search is accepted - accepted = .false. + ! --- Modify dx + + ! modify dx if norm > stpmax + dxnorm = sqrt( sum(dx*dx) ) + if (dxnorm > stpmax) then + dxScale = stpmax / dxnorm + dx = dxScale * dx + end if - ! ---- backtracking line search w/ overshoot reject ---- - lambda = 1.0_sp + ! 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 + + ! modify dx if Newton step not descending for psi + slope = dot_product(gpsi, dx) + if (slope >= 0._sp) dx = -gpsi ! fallback + + if(isPrint) print*, 'x_try 3 = ', x_try + ! ---- backtracking line search -------------- + + ! save the fuse structure to re-use in subsequent linesearch calls + ctx = fuseStruct ! <--- snapshot *now*, for this Newton step + + ! 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) ) + + ! compute maximum lambda + lam_max = 1.0_sp + ! do i=1,nx + ! if (dx(i) > 0._sp) then + ! lam_i = (upper(i) - x_try(i) - epsb) / dx(i) + ! if (lam_i < lam_max) lam_max = max(0._sp, lam_i) + ! else if (dx(i) < 0._sp) then + ! lam_i = (lower(i) - x_try(i) + epsb) / dx(i) ! dx<0 so this is positive + ! if (lam_i < lam_max) lam_max = max(0._sp, lam_i) + ! end if + ! end do + + ! check + if(isPrint)then + print*, 'alamin = ', alamin + print*, 'slope = ', slope + print*, 'gpsi = ', gpsi + endif + + if(isPrint) isDebug = .true. + + lambda = lam_max do ls_it = 1, ls_max - x_trial = x_try + lambda*dx - - ! check overshoot - ovshoot = any(x_trial < lower) .or. any(x_trial > upper) - if (.not. ovshoot) then - ! new function and residual - g_trial = dx_dt(x_trial) - res_trial = x_trial - (x0 + dt*g_trial) - phi_new = 0.5_sp * sum(res_trial*res_trial) - ! check for sufficient decrease (Armijo-lite) - if (phi_new <= (1.0_sp - c_armijo*lambda) * phi)then - accepted = .true. - exit - endif - end if + + if(isPrint)then + print*, '***** new linesearch *****', ls_it + print*, 'dx = ', dx + endif + + ! update x + x_trial = x_try + lambda*dx + + if(isPrint)then + print*, 'x_try = ', x_try + print*, 'x_trial = ', x_trial + print *, "delta = ", x_trial - x_try + print *, "lambda*dx = ", lambda*dx + endif + + ! exit if violate bounds: line search direction is not valid + if(any(x_trial < lower) .or. any(x_trial > upper))then + accepted = .false.; exit + !lambda = lambda * shrink + !cycle + endif + + ! compute function and function eval + fuseStruct = ctx + g_trial = dx_dt(fuseStruct, x_trial) + res_trial = x_trial - (x0 + dt*g_trial) + phi_new = 0.5_sp * dot_product(res_trial, res_trial) + + if(isPrint)then + print*, 'ls_it, lambda, phi, phi_new', ls_it, lambda, phi, phi_new + print*, 'phi, phi_new, slope=', phi, phi_new, slope + print*, 'x_trial = ', x_trial + print*, 'g_trial = ', g_trial + print*, 'res _trial= ', res_trial + 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 + if(isPrint) isDebug = .false. + if (accepted) then x_try = x_trial g_x = g_trial res = res_trial phi = phi_new else - ! ----- fallback: soft clamp a very small Newton step ----- - x_trial = x_try + lambda*dx - call fix_ovshoot(x_trial, lower, upper) + ! ----- fallback: try a small step along the direction of steepest descent ----- + !dx = -gpsi ! use steepest descent + x_trial = x_try + dampen*dx + if(any(x_trial < lower) .or. any(x_trial > upper)) & + call fix_ovshoot(x_trial, lower, upper, dclamp) ! get new function evaluation - x_try = x_trial - g_x = dx_dt(x_try) - res = x_try - (x0 + g_x*dt) - phi = 0.5_sp * sum(res*res) + x_try = x_trial + fuseStruct = ctx + g_x = dx_dt(fuseStruct, x_try) + res = x_try - (x0 + g_x*dt) + phi = 0.5_sp * dot_product(res, res) end if - ! re-populate fuse data structure - call XTRY_2_STR(x_try, fuseStruct%state1) - ! tiny-step convergence - if (maxval(abs(lambda*dx)) < ERR_ITER_DX) then + 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 @@ -233,11 +392,11 @@ subroutine implicit_solve(fuseStruct, x0, x1, nx) ! save final state x1 = x_try - ! nullify pointer to the fuse structure - call clear_dxdt_context() - ! check convergence - if( .not. converged) STOP "failed to converge in implicit_solve" + if( .not. converged)then + message=trim(message)//"failed to converge" + ierr=10; return + endif end subroutine implicit_solve diff --git a/build/FUSE_SRC/physics/mstate_rhs_diff.f90 b/build/FUSE_SRC/physics/mstate_rhs_diff.f90 index 1ab0107..b34eb90 100644 --- a/build/FUSE_SRC/physics/mstate_rhs_diff.f90 +++ b/build/FUSE_SRC/physics/mstate_rhs_diff.f90 @@ -1,5 +1,7 @@ module MSTATE_RHS_DIFF_module + use globaldata, only: isDebug ! print flag + implicit none private @@ -32,6 +34,8 @@ SUBROUTINE MSTATE_RHS_DIFF(fuseStruct) DX_DT => fuseStruct%dx_dt & ! time derivative in states ) ! (associate) + if(isDebug) print*, 'M_FLUX%QPERC_12 = ', M_FLUX%QPERC_12 + ! --------------------------------------------------------------------------------------- ! (1) COMPUTE TIME DERIVATIVES FOR STATES IN THE UPPER LAYER ! --------------------------------------------------------------------------------------- @@ -71,6 +75,21 @@ SUBROUTINE MSTATE_RHS_DIFF(fuseStruct) END SELECT ! --------------------------------------------------------------------------------------- + if(isDebug) print*, '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 = ', & + 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 + + if(isDebug) print*, 'DX_DT%WATR_2, M_FLUX%QPERC_12, M_FLUX%EVAP_2, M_FLUX%QBASE_2, M_FLUX%OFLOW_2 = ', & + DX_DT%WATR_2, M_FLUX%QPERC_12, M_FLUX%EVAP_2, M_FLUX%QBASE_2, M_FLUX%OFLOW_2 + + ! if(isDebug) print*, 'DX_DT%TENS_1, M_FLUX%EFF_PPT, M_FLUX%QSURF, M_FLUX%EVAP_1, M_FLUX%TENS2FREE_1 = ', & + ! DX_DT%TENS_1, M_FLUX%EFF_PPT, M_FLUX%QSURF, M_FLUX%EVAP_1, M_FLUX%TENS2FREE_1 + ! + ! if(isDebug) print*, 'DX_DT%TENS_2, M_FLUX%QPERC_12*(1._SP-MPARAM%PERCFRAC), M_FLUX%EVAP_2, M_FLUX%TENS2FREE_2 = ', & + ! DX_DT%TENS_2, M_FLUX%QPERC_12*(1._SP-MPARAM%PERCFRAC), M_FLUX%EVAP_2, M_FLUX%TENS2FREE_2 + ! + ! if(isDebug) print*, '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 = ', & + ! 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 + end associate ! end association with variables in the data structures END SUBROUTINE MSTATE_RHS_DIFF diff --git a/build/FUSE_SRC/physics/q_baseflow_diff.f90 b/build/FUSE_SRC/physics/q_baseflow_diff.f90 index 29386f4..d63adb6 100644 --- a/build/FUSE_SRC/physics/q_baseflow_diff.f90 +++ b/build/FUSE_SRC/physics/q_baseflow_diff.f90 @@ -1,5 +1,7 @@ module Q_BASEFLOW_DIFF_module + USE globaldata, only: isDebug + implicit none private diff --git a/build/FUSE_SRC/physics/q_misscell_diff.f90 b/build/FUSE_SRC/physics/q_misscell_diff.f90 index 1801c7b..c347455 100644 --- a/build/FUSE_SRC/physics/q_misscell_diff.f90 +++ b/build/FUSE_SRC/physics/q_misscell_diff.f90 @@ -27,13 +27,13 @@ SUBROUTINE Q_MISSCELL_DIFF(fuseStruct) USE data_types, only: parent ! fuse parent data type USE model_defn ! model definition structure USE model_defnames + USE smoothers, only: smoother ! smoothing function IMPLICIT NONE ! input-output type(parent), intent(inout) :: fuseStruct ! parent fuse data structure ! internal - REAL(SP) :: LOGISMOOTH ! FUNCTION logistic smoothing - REAL(SP), PARAMETER :: PSMOOTH=0.01_SP ! smoothing parameter - REAL(SP) :: W_FUNC ! result from LOGISMOOTH + REAL(SP), PARAMETER :: PSMOOTH=0.05_SP ! smoothing parameter + REAL(SP) :: W_FUNC ! result from smoother ! ------------------------------------------------------------------------------------------------- ! associate variables with elements of data structure associate(& @@ -48,29 +48,29 @@ SUBROUTINE Q_MISSCELL_DIFF(fuseStruct) 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 = LOGISMOOTH(TSTATE%TENS_1A,DPARAM%MAXTENS_1A,PSMOOTH) + 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 = LOGISMOOTH(TSTATE%TENS_1B,DPARAM%MAXTENS_1B,PSMOOTH) + 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 = LOGISMOOTH(TSTATE%FREE_1,DPARAM%MAXFREE_1,PSMOOTH) + 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 = LOGISMOOTH(TSTATE%TENS_1,DPARAM%MAXTENS_1,PSMOOTH) + 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 = LOGISMOOTH(TSTATE%FREE_1,DPARAM%MAXFREE_1,PSMOOTH) + 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 - W_FUNC = LOGISMOOTH(TSTATE%WATR_1,MPARAM%MAXWATR_1,PSMOOTH) + W_FUNC = SMOOTHER(TSTATE%WATR_1,MPARAM%MAXWATR_1,PSMOOTH) M_FLUX%OFLOW_1 = W_FUNC * (M_FLUX%EFF_PPT - M_FLUX%QSURF) CASE DEFAULT print *, "SMODL%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" @@ -81,13 +81,13 @@ SUBROUTINE Q_MISSCELL_DIFF(fuseStruct) 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 = LOGISMOOTH(TSTATE%TENS_2,DPARAM%MAXTENS_2,PSMOOTH) + 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 = LOGISMOOTH(TSTATE%FREE_2A,DPARAM%MAXFREE_2A,PSMOOTH) + 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 = LOGISMOOTH(TSTATE%FREE_2B,DPARAM%MAXFREE_2B,PSMOOTH) + 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 @@ -97,7 +97,7 @@ SUBROUTINE Q_MISSCELL_DIFF(fuseStruct) M_FLUX%OFLOW_2A = 0._SP M_FLUX%OFLOW_2B = 0._SP ! compute over-flow of free water - W_FUNC = LOGISMOOTH(TSTATE%WATR_2,MPARAM%MAXWATR_2,PSMOOTH) + 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 diff --git a/build/FUSE_SRC/physics/smoothers.f90 b/build/FUSE_SRC/physics/smoothers.f90 new file mode 100644 index 0000000..71f5277 --- /dev/null +++ b/build/FUSE_SRC/physics/smoothers.f90 @@ -0,0 +1,132 @@ +module smoothers + + implicit none + + private + public:: LOGISMOOTH + public:: smoother + +contains + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + PURE FUNCTION smoother(STATE,STATE_MAX,PSMOOTH) result(w_func) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2025 + ! --------------------------------------------------------------------------------------- + ! 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/Makefile b/build/Makefile index 9c2edfb..b0c04f6 100644 --- a/build/Makefile +++ b/build/Makefile @@ -128,6 +128,7 @@ NR_SUB = $(patsubst %, $(NUMREC_DIR)/%, $(FUSE_NR_SUB)) # FUSE physics FUSE_PHYSICS= \ + smoothers.f90 \ get_parent.f90 \ qsatexcess_diff.f90 \ evap_upper_diff.f90 \ @@ -154,7 +155,6 @@ FUSE_MODGUT=\ qpercolate.f90 \ q_baseflow.f90 \ q_misscell.f90 \ - logismooth.f90 \ mstate_eqn.f90 \ fix_states.f90 \ meanfluxes.f90 \ @@ -248,15 +248,15 @@ endif ifeq "$(FC)" "gfortran" FLAGS_NORMA = -O3 -ffree-line-length-none -fmax-errors=0 -cpp - FLAGS_DEBUG = -p -g -Wall -ffree-line-length-none -fmax-errors=0 -fbacktrace -fcheck=bounds -cpp - FLAGS_DEBUG = -p -Og -ffree-line-length-none -fmax-errors=0 -fcheck=bounds -cpp # without -warn all + #FLAGS_DEBUG = -Wall -ffree-line-length-none -fmax-errors=0 -fbacktrace -fcheck=bounds -cpp + FLAGS_DEBUG = -O0 -ffree-line-length-none -fmax-errors=0 -fcheck=bounds -cpp # without -warn all FLAGS_FIXED = -O2 -c -ffixed-form endif # select a set of flags -FLAGS = $(FLAGS_NORMA) -#FLAGS = $(FLAGS_DEBUG) +#FLAGS = $(FLAGS_NORMA) +FLAGS = $(FLAGS_DEBUG) # MPI: FUSE with MPI has been compiled successfully with mpif90 and mpiifort. # Note: override must be specifed to enable FC passed as argument to be overridden From ee8c182184fc6b72db03b5b0484f2c0b500e6979 Mon Sep 17 00:00:00 2001 From: Martyn Clark Date: Mon, 1 Dec 2025 12:00:18 -0700 Subject: [PATCH 07/16] fix uninitialized error code in get_mbands --- build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 | 1 + build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 | 3 -- build/FUSE_SRC/FUSE_ENGINE/get_mbands.f90 | 54 +++++++++++------------ 3 files changed, 28 insertions(+), 30 deletions(-) diff --git a/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 b/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 index 0c54a36..8f1d81b 100644 --- a/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 +++ b/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 @@ -264,6 +264,7 @@ PROGRAM DISTRIBUTED_DRIVER ! get elevation band info, in particular N_BANDS CALL GET_MBANDS_INFO(ELEV_BANDS_NC,err,message) ! read band data from NetCDF file +if(err/=0)then; write(*,*) trim(message); stop; endif ! allocate space for elevation bands allocate(MBANDS_VAR_4d(nspat1,nspat2,N_BANDS,numtim_sub+1),stat=err) diff --git a/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 b/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 index 1aa8567..e1d30e2 100644 --- a/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 +++ b/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 @@ -268,9 +268,6 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG CALL ODE_INT(FUSE_SOLVE,STATE0,STATE1,DT_SUB,DT_FULL,IERR,MESSAGE) IF (IERR.NE.0) THEN; PRINT *, TRIM(MESSAGE); STOP 1; ENDIF - !print*, state1 - !if(ITIM_IN > sim_beg+100) stop - ! differentiable code case(differentiable) diff --git a/build/FUSE_SRC/FUSE_ENGINE/get_mbands.f90 b/build/FUSE_SRC/FUSE_ENGINE/get_mbands.f90 index efd006c..6ec4fcb 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/get_mbands.f90 +++ b/build/FUSE_SRC/FUSE_ENGINE/get_mbands.f90 @@ -161,7 +161,7 @@ SUBROUTINE GET_MBANDS_INFO(ELEV_BANDS_NC,err,message) character(*), intent(out) :: message ! internal integer(i4b),parameter::lenPath=1024 ! DK/2008/10/21: allows longer file paths -INTEGER(I4B),DIMENSION(2) :: IERR ! error codes +INTEGER(I4B) :: IERR ! error code INTEGER(I4B) :: IUNIT ! input file unit CHARACTER(LEN=lenPath) :: CFILE ! name of control file CHARACTER(LEN=lenPath) :: BFILE ! name of band file @@ -181,21 +181,21 @@ SUBROUTINE GET_MBANDS_INFO(ELEV_BANDS_NC,err,message) ! internal: NetCDF read integer(i4b) :: ivarid_af,ivarid_me ! NetCDF variable ID for area_frac and mean_area integer(i4b),parameter :: ndims=3 ! number of dimensions for frac_area -integer(i4b) :: dimid_eb ! ID elevation bands +integer(i4b) :: dimid_eb ! ID elevation bands integer(i4b) :: iDimID ! dimension ID integer(i4b) :: dimLen ! dimension length ! --------------------------------------------------------------------------------------- ! read in NetCDF file defining the elevation bands -err=0 +err=0; ierr=0 CFILE = TRIM(INPUT_PATH)//ELEV_BANDS_NC ! control file info shared in MODULE directory print *, 'Loading elevation bands from:',TRIM(CFILE) INQUIRE(FILE=CFILE,EXIST=LEXIST) ! check that control file exists IF (.NOT.LEXIST) THEN - print *, 'f-GET_MBANDS_GRID/NetCDF file ',TRIM(CFILE),' for elevation bands does not exist ' - STOP + print *, 'f-GET_MBANDS_GRID/NetCDF file ',TRIM(CFILE),' for elevation bands does not exist ' + STOP ENDIF !open netcdf file @@ -221,14 +221,14 @@ SUBROUTINE GET_MBANDS_INFO(ELEV_BANDS_NC,err,message) if(err/=0)then; message=trim(message)//trim(nf90_strerror(err)); return; endif ! allocate 1 data stucture -ALLOCATE(MBANDS(N_BANDS),STAT=IERR(1)) +ALLOCATE(MBANDS(N_BANDS),STAT=IERR) ! allocate data structures ALLOCATE(Z_FORCING_grid(nspat1,nspat2),MBANDS_INFO_3d(nspat1,nspat2,n_bands),& - AF_TEMP(nspat1,nspat2,n_bands),ME_TEMP(nspat1,nspat2,n_bands),& - elev_mask(nspat1,nspat2),STAT=IERR(1)) + AF_TEMP(nspat1,nspat2,n_bands),ME_TEMP(nspat1,nspat2,n_bands),& + elev_mask(nspat1,nspat2),STAT=IERR) -IF (ANY(IERR.NE.0)) THEN +IF (IERR.NE.0) THEN message="f-GET_MBANDS/problem allocating elevation band data structures" err=100; return ENDIF @@ -243,26 +243,26 @@ SUBROUTINE GET_MBANDS_INFO(ELEV_BANDS_NC,err,message) ! populate MBANDS_INFO_3d, Z_FORCING_grid and elev_mask DO iSpat2=1,nSpat2 - DO iSpat1=1,nSpat1 + DO iSpat1=1,nSpat1 - MBANDS_INFO_3d(iSpat1,iSpat2,:)%Z_MID = me_TEMP(iSpat1,iSpat2,:) - MBANDS_INFO_3d(iSpat1,iSpat2,:)%AF = af_TEMP(iSpat1,iSpat2,:) - Z_FORCING_grid(iSpat1,iSpat2) = sum(me_TEMP(iSpat1,iSpat2,:)*af_TEMP(iSpat1,iSpat2,:)) ! estimate mean elevation of forcing using weighted mean of EB elevation - elev_mask(iSpat1,iSpat2) = me_TEMP(iSpat1,iSpat2,1) .EQ. NA_VALUE_SP ! if mean elevation first band is NA_VALUE, mask this grid cell + MBANDS_INFO_3d(iSpat1,iSpat2,:)%Z_MID = me_TEMP(iSpat1,iSpat2,:) + MBANDS_INFO_3d(iSpat1,iSpat2,:)%AF = af_TEMP(iSpat1,iSpat2,:) + Z_FORCING_grid(iSpat1,iSpat2) = sum(me_TEMP(iSpat1,iSpat2,:)*af_TEMP(iSpat1,iSpat2,:)) ! estimate mean elevation of forcing using weighted mean of EB elevation + elev_mask(iSpat1,iSpat2) = me_TEMP(iSpat1,iSpat2,1) .EQ. NA_VALUE_SP ! if mean elevation first band is NA_VALUE, mask this grid cell + + if(.NOT.elev_mask(iSpat1,iSpat2)) THEN ! only check area fraction sum to 1 if not NA_VALUE + + if (abs(sum(MBANDS_INFO_3d(iSpat1,iSpat2,:)%AF)-1).GT.1E-2) then ! check that area fraction sum to 1 + + print *, "The area fraction of all the elevation bands do not add up to 1" + !print *, 'Difference with 1 = ', abs(sum(MBANDS_INFO_3d(iSpat1,iSpat2,:)%AF)-1) + print *, 'AF', MBANDS_INFO_3d(iSpat1,iSpat2,:)%AF + stop + + end if + end if - if(.NOT.elev_mask(iSpat1,iSpat2)) THEN ! only check area fraction sum to 1 if not NA_VALUE - - if (abs(sum(MBANDS_INFO_3d(iSpat1,iSpat2,:)%AF)-1).GT.1E-2) then ! check that area fraction sum to 1 - - print *, "The area fraction of all the elevation bands do not add up to 1" - !print *, 'Difference with 1 = ', abs(sum(MBANDS_INFO_3d(iSpat1,iSpat2,:)%AF)-1) - print *, 'AF', MBANDS_INFO_3d(iSpat1,iSpat2,:)%AF - stop - - end if - end if - - END DO + END DO END DO err = nf90_close(ncid_eb) From 40f4015bc43505817eb6002922f8aca37b0d3d20 Mon Sep 17 00:00:00 2001 From: Martyn Clark Date: Tue, 2 Dec 2025 05:07:04 -0700 Subject: [PATCH 08/16] further improvements to implicit solve --- build/FUSE_SRC/FUSE_ENGINE/fix_states.f90 | 4 +- build/FUSE_SRC/physics/conserve_clamp.f90 | 303 ++++++++++++++++++++++ build/FUSE_SRC/physics/implicit_solve.f90 | 114 ++++---- build/Makefile | 1 + 4 files changed, 366 insertions(+), 56 deletions(-) create mode 100644 build/FUSE_SRC/physics/conserve_clamp.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/fix_states.f90 b/build/FUSE_SRC/FUSE_ENGINE/fix_states.f90 index 01a3bb2..5ef6ce0 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/fix_states.f90 +++ b/build/FUSE_SRC/FUSE_ENGINE/fix_states.f90 @@ -255,14 +255,14 @@ SUBROUTINE FIX_STATES(DT,ERROR_FLAG) ! ------------------------------------------------------------------------------------- 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_1)/DT ! error (L/T) + 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%FREE_2B.GT.DPARAM%MAXFREE_2B) THEN + 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) diff --git a/build/FUSE_SRC/physics/conserve_clamp.f90 b/build/FUSE_SRC/physics/conserve_clamp.f90 new file mode 100644 index 0000000..03ec0d1 --- /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 data_types, only: parent ! parent fuse data 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 parent 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(parent) , intent(inout) :: fuseStruct ! parent fuse data 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%flux , & ! fluxes + BSTATE => fuseStruct%state0 , & ! state variables (start of step) + ESTATE => fuseStruct%state1 , & ! trial state variables (end of step) + MPARAM => fuseStruct%param_adjust , & ! adjustable model parameters + DPARAM => fuseStruct%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/implicit_solve.f90 b/build/FUSE_SRC/physics/implicit_solve.f90 index 39a30c7..db92b58 100644 --- a/build/FUSE_SRC/physics/implicit_solve.f90 +++ b/build/FUSE_SRC/physics/implicit_solve.f90 @@ -51,12 +51,12 @@ end function dx_dt SUBROUTINE jac_flux(fuseStruct, x_try, g_x, lower, upper, Jac) IMPLICIT NONE ! input-output - type(parent) , intent(inout) :: fuseStruct ! parent fuse data structure + type(parent) , intent(in) :: fuseStruct ! parent fuse data 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(parent) :: ctx_sav + type(parent) :: 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 @@ -66,18 +66,14 @@ SUBROUTINE jac_flux(fuseStruct, x_try, g_x, lower, upper, Jac) ! preliminaries n = size(x) - ctx_sav = fuseStruct + fuseStruct_local = fuseStruct x = x_try xsav = x ! loop through columns do j=1,n - ! safety: save full vector and data structure - fuseStruct = ctx_sav - x=xsav - - ! propose one-sided step + ! propose one-sided step (NOTE: negative) h_try = -max(eps_rel*abs(xsav(j)), eps_abs) ! flip sign if necessary @@ -85,16 +81,19 @@ SUBROUTINE jac_flux(fuseStruct, x_try, g_x, lower, upper, Jac) ! compute function from the perturbed vector x(j) = xsav(j) + h_try - g_ph = dx_dt(fuseStruct, x) + g_ph = dx_dt(fuseStruct_local, x) 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 - fuseStruct = ctx_sav ! restores consistency after finite differencing end SUBROUTINE jac_flux ! ----- simple implicit solve for differentiable model -------------------------- @@ -103,6 +102,7 @@ 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 @@ -132,7 +132,6 @@ subroutine implicit_solve(fuseStruct, x0, x1, nx, ierr, message, isVerbose) integer(i4b), parameter :: maxit=100 ! maximum number of iterations logical(lgt) :: converged ! flag for convergence ! internal: backtracking line search w/ overshoot reject - type(parent) :: ctx ! save the fuse structure real(sp) :: xnorm ! norm used in maximum step real(sp) :: dxnorm ! norm used to evaluate step size real(sp) :: stpmax ! the maximum step @@ -153,6 +152,11 @@ subroutine implicit_solve(fuseStruct, x0, x1, nx, ierr, message, isVerbose) 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 @@ -169,6 +173,9 @@ subroutine implicit_solve(fuseStruct, x0, x1, nx, ierr, message, isVerbose) ! 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 @@ -176,9 +183,6 @@ subroutine implicit_solve(fuseStruct, x0, x1, nx, ierr, message, isVerbose) ! get the flag for printing isPrint = .false.; if (present(isVerbose)) isPrint = isVerbose - ! save the fuse structure - ctx = fuseStruct - ! 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) @@ -235,8 +239,6 @@ subroutine implicit_solve(fuseStruct, x0, x1, nx, ierr, message, isVerbose) exit ! exit iteration loop end if - if(isPrint) print*, 'x_try 0 = ', x_try - ! --- J(x) call jac_flux(fuseStruct, x_try, g_x, lower, upper, Jg) do i=1,nx @@ -244,8 +246,6 @@ subroutine implicit_solve(fuseStruct, x0, x1, nx, ierr, message, isVerbose) Jac(i,i) = Jac(i,i) + 1.0_sp end do - if(isPrint) print*, 'x_try 1 = ', x_try - ! --- function gradient: before Jac is modified in ludcmp gpsi = matmul(transpose(Jac), res) ! assumes func = 0.5_sp * sum(res*res) @@ -254,8 +254,6 @@ subroutine implicit_solve(fuseStruct, x0, x1, nx, ierr, message, isVerbose) call ludcmp(Jac, indx, d) ! J overwritten with LU call lubksb(Jac, indx, dx) ! dx becomes solution - if(isPrint) print*, 'x_try 2 = ', x_try - if(isPrint)then print*, 'dx = ', dx print*, 'Jg = ', Jg @@ -270,38 +268,22 @@ subroutine implicit_solve(fuseStruct, x0, x1, nx, ierr, message, isVerbose) 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 - ! modify dx if Newton step not descending for psi - slope = dot_product(gpsi, dx) - if (slope >= 0._sp) dx = -gpsi ! fallback - - if(isPrint) print*, 'x_try 3 = ', x_try ! ---- backtracking line search -------------- - ! save the fuse structure to re-use in subsequent linesearch calls - ctx = fuseStruct ! <--- snapshot *now*, for this Newton step - ! 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) ) - ! compute maximum lambda - lam_max = 1.0_sp - ! do i=1,nx - ! if (dx(i) > 0._sp) then - ! lam_i = (upper(i) - x_try(i) - epsb) / dx(i) - ! if (lam_i < lam_max) lam_max = max(0._sp, lam_i) - ! else if (dx(i) < 0._sp) then - ! lam_i = (lower(i) - x_try(i) + epsb) / dx(i) ! dx<0 so this is positive - ! if (lam_i < lam_max) lam_max = max(0._sp, lam_i) - ! end if - ! end do - ! check if(isPrint)then print*, 'alamin = ', alamin @@ -311,7 +293,7 @@ subroutine implicit_solve(fuseStruct, x0, x1, nx, ierr, message, isVerbose) if(isPrint) isDebug = .true. - lambda = lam_max + lambda = 1.0_sp do ls_it = 1, ls_max if(isPrint)then @@ -325,19 +307,19 @@ subroutine implicit_solve(fuseStruct, x0, x1, nx, ierr, message, isVerbose) if(isPrint)then print*, 'x_try = ', x_try print*, 'x_trial = ', x_trial + print*, 'lower = ', lower + print*, 'upper = ', upper print *, "delta = ", x_trial - x_try print *, "lambda*dx = ", lambda*dx endif - ! exit if violate bounds: line search direction is not valid + ! shrink lambda until find a value in the feasible space if(any(x_trial < lower) .or. any(x_trial > upper))then - accepted = .false.; exit - !lambda = lambda * shrink - !cycle + lambda = lambda * shrink + cycle endif ! compute function and function eval - fuseStruct = ctx g_trial = dx_dt(fuseStruct, x_trial) res_trial = x_trial - (x0 + dt*g_trial) phi_new = 0.5_sp * dot_product(res_trial, res_trial) @@ -349,7 +331,15 @@ subroutine implicit_solve(fuseStruct, x0, x1, nx, ierr, message, isVerbose) print*, 'g_trial = ', g_trial print*, 'res _trial= ', res_trial endif - + + ! 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 @@ -375,10 +365,16 @@ subroutine implicit_solve(fuseStruct, x0, x1, nx, ierr, message, isVerbose) call fix_ovshoot(x_trial, lower, upper, dclamp) ! get new function evaluation x_try = x_trial - fuseStruct = ctx g_x = dx_dt(fuseStruct, x_try) 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 end if ! tiny-step convergence @@ -389,15 +385,25 @@ subroutine implicit_solve(fuseStruct, x0, x1, nx, ierr, message, isVerbose) 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) g_best = dx_dt(fuseStruct, x0) + + ! 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%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 - ! check convergence - if( .not. converged)then - message=trim(message)//"failed to converge" - ierr=10; return - endif - end subroutine implicit_solve end module implicit_solve_module diff --git a/build/Makefile b/build/Makefile index b0c04f6..8b9f6f7 100644 --- a/build/Makefile +++ b/build/Makefile @@ -139,6 +139,7 @@ FUSE_PHYSICS= \ q_misscell_diff.f90 \ mstate_rhs_diff.f90 \ mod_derivs_diff.f90 \ + conserve_clamp.f90 \ fix_ovshoot.f90 \ implicit_solve.f90 PHYSICS = $(patsubst %, $(PHYSICS_DIR)/%, $(FUSE_PHYSICS)) From 26b355169259dd79c0f9c1a5d51fc1d20fe909cd Mon Sep 17 00:00:00 2001 From: Martyn Clark Date: Sun, 14 Dec 2025 08:47:51 -0700 Subject: [PATCH 09/16] initial implementation of analytical Jacobian --- build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 | 17 ++- build/FUSE_SRC/FUSE_ENGINE/str_2_xtry.f90 | 2 +- build/FUSE_SRC/FUSE_ENGINE/xtry_2_str.f90 | 6 +- build/FUSE_SRC/dshare/data_types.f90 | 1 + build/FUSE_SRC/dshare/globaldata.f90 | 3 + build/FUSE_SRC/physics/evap_lower_diff.f90 | 8 +- build/FUSE_SRC/physics/evap_upper_diff.f90 | 113 ++++++++++++----- build/FUSE_SRC/physics/get_parent.f90 | 13 +- build/FUSE_SRC/physics/implicit_solve.f90 | 141 +++++++-------------- build/FUSE_SRC/physics/mod_derivs_diff.f90 | 36 ++++-- build/FUSE_SRC/physics/mstate_rhs_diff.f90 | 65 ++++++---- build/FUSE_SRC/physics/q_baseflow_diff.f90 | 46 ++++++- build/FUSE_SRC/physics/q_misscell_diff.f90 | 17 ++- build/FUSE_SRC/physics/qinterflow_diff.f90 | 9 +- build/FUSE_SRC/physics/qpercolate_diff.f90 | 79 ++++++++++-- build/FUSE_SRC/physics/qsatexcess_diff.f90 | 62 ++++++++- build/FUSE_SRC/physics/smoothers.f90 | 107 ++++++++++++++++ 17 files changed, 525 insertions(+), 200 deletions(-) diff --git a/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 b/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 index e1d30e2..3f4c8a6 100644 --- a/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 +++ b/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 @@ -106,8 +106,12 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! --------------------------------------------------------------------------------------- ! allocate state vectors ALLOCATE(STATE0(NSTATE),STATE1(NSTATE),STAT=IERR) - IF (IERR.NE.0) STOP ' problem allocating space for state vectors in fuse_rmse ' + IF (IERR.NE.0) STOP ' problem allocating space for state vectors in fuse_rmse' + ! allocate flux derivative vector + allocate(fuseStruct%df_dS(nState), stat=ierr) + if(ierr/=0) STOP ' problem allocating space for the flux derivative vector' + ! increment parameter counter for model output IF (.NOT.PRESENT(MPARAM_FLAG)) THEN PCOUNT = PCOUNT + 1 @@ -131,6 +135,8 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG DO iSpat2=1,nSpat2 DO iSpat1=1,nSpat1 CALL INIT_STATE(fracState0) ! define FSTATE using fracState0 + CALL STR_2_XTRY(FSTATE,STATE0) ! set state at the start of the time step (STATE0) using FSTATE + CALL XTRY_2_STR(STATE0,FSTATE) ! update structure, including derived state variables gState_3d(iSpat1,iSpat2,1) = FSTATE ! put the state into first time step of 3D structure END DO END DO @@ -231,7 +237,7 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG 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 @@ -273,6 +279,7 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! populate parent fuse structure call get_parent(fuseStruct) + ! solve differentiable ODEs call implicit_solve(fuseStruct, state0, state1, nState, ierr, cmessage) if(ierr/=0)then @@ -399,7 +406,8 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG CALL MEAN_STATS() RMSE = MSTATS%RAW_RMSE - write(*,'(i6,1x,a6,1x,f12.6,1x)') nFUSE_eval, "NSE = ", MSTATS%NASH_SUTT + 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 @@ -408,7 +416,8 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! deallocate vectors DEALLOCATE(W_FLUX_3d); IF (IERR.NE.0) STOP ' problem deallocating W_FLUX_3d in fuse_rmse ' - DEALLOCATE(STATE0,STATE1,STAT=IERR); IF (IERR.NE.0) STOP ' problem deallocating state vectors in fuse_rmse ' + DEALLOCATE(STATE0,STATE1,STAT=IERR); IF (IERR.NE.0) STOP ' problem deallocating state vectors in fuse_rmse' + deallocate(fuseStruct%df_dS, stat=ierr); if(ierr/=0) STOP ' problem deallocating space for the flux derivative vector' END SUBROUTINE FUSE_RMSE END MODULE FUSE_RMSE_MODULE diff --git a/build/FUSE_SRC/FUSE_ENGINE/str_2_xtry.f90 b/build/FUSE_SRC/FUSE_ENGINE/str_2_xtry.f90 index 71875e9..0da2581 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/str_2_xtry.f90 +++ b/build/FUSE_SRC/FUSE_ENGINE/str_2_xtry.f90 @@ -12,9 +12,9 @@ SUBROUTINE STR_2_XTRY(TMPSTR,X_TRY) ! Copy model states into vector X_TRY ! --------------------------------------------------------------------------------------- USE nrtype ! Numerical Recipes data types +USE data_types, ONLY: STATEV ! model state structure USE model_defn, ONLY: CSTATE,NSTATE ! model definitions USE model_defnames -USE data_types, ONLY: STATEV ! model state structure IMPLICIT NONE ! input TYPE(STATEV), INTENT(IN) :: TMPSTR ! temporary state structure diff --git a/build/FUSE_SRC/FUSE_ENGINE/xtry_2_str.f90 b/build/FUSE_SRC/FUSE_ENGINE/xtry_2_str.f90 index b68b583..33ed995 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/xtry_2_str.f90 +++ b/build/FUSE_SRC/FUSE_ENGINE/xtry_2_str.f90 @@ -16,10 +16,10 @@ SUBROUTINE XTRY_2_STR(X_TRY,TMPSTR) ! Temporary model states updated in MODULE multistate ! --------------------------------------------------------------------------------------- USE nrtype ! Numerical Recipes data types +USE data_types, ONLY: STATEV ! model state definitions USE model_defn, ONLY: CSTATE,NSTATE,SMODL ! model definitions USE model_defnames -USE multistate, ONLY: STATEV ! model states -USE multiparam, ONLY: DPARAM ! model parameters +USE multiparam, ONLY: DPARAM ! derived model parameters IMPLICIT NONE ! input REAL(SP), DIMENSION(:), INTENT(IN) :: X_TRY ! vector of model states @@ -73,7 +73,7 @@ SUBROUTINE XTRY_2_STR(X_TRY,TMPSTR) TMPSTR%TENS_2 = MIN(TMPSTR%WATR_2, DPARAM%MAXTENS_2) ! tension storage TMPSTR%FREE_2 = MAX(0._sp, TMPSTR%WATR_2 - DPARAM%MAXTENS_2) ! free storage TMPSTR%FREE_2A = missingValue ! primary reservoir (undefined) - TMPSTR%FREE_2A = missingValue ! secondary reservoir (undefined) + TMPSTR%FREE_2B = missingValue ! secondary reservoir (undefined) CASE DEFAULT ! (error check) print *, "MDEFN(IMOD)%ARCH2 must be 'tens2pll_2', 'unlimfrc_2', 'unlimpow_2'" print *, " 'topmdexp_2', or 'fixedsiz_2'" diff --git a/build/FUSE_SRC/dshare/data_types.f90 b/build/FUSE_SRC/dshare/data_types.f90 index b27a0f7..afbc701 100644 --- a/build/FUSE_SRC/dshare/data_types.f90 +++ b/build/FUSE_SRC/dshare/data_types.f90 @@ -310,6 +310,7 @@ module data_types type(statev) :: state1 ! state variables (end of step) type(statev) :: dx_dt ! time derivative in state variables type(fluxes) :: flux ! fluxes + type(fluxes), allocatable :: df_dS(:) ! derivative in fluxes w.r.t. states type(runoff) :: route ! hillslope routing type(par_id) :: param_name ! parameter names type(parinfo) :: param_meta ! metadata on model parameters diff --git a/build/FUSE_SRC/dshare/globaldata.f90 b/build/FUSE_SRC/dshare/globaldata.f90 index 9d551d3..bd95d54 100644 --- a/build/FUSE_SRC/dshare/globaldata.f90 +++ b/build/FUSE_SRC/dshare/globaldata.f90 @@ -15,6 +15,9 @@ MODULE globaldata ! initial store fraction (initialization) real(sp), parameter :: fracState0=0.25_sp + ! original code + logical(lgt), save :: isOriginal=.true. + ! print flag logical(lgt), save :: isPrint=.true. logical(lgt), save :: isDebug=.false. diff --git a/build/FUSE_SRC/physics/evap_lower_diff.f90 b/build/FUSE_SRC/physics/evap_lower_diff.f90 index a07a76a..96a1f2d 100644 --- a/build/FUSE_SRC/physics/evap_lower_diff.f90 +++ b/build/FUSE_SRC/physics/evap_lower_diff.f90 @@ -7,7 +7,7 @@ module EVAP_LOWER_DIFF_MODULE contains - SUBROUTINE EVAP_LOWER_DIFF(fuseStruct) + SUBROUTINE EVAP_LOWER_DIFF(fuseStruct, want_dflux) ! ------------------------------------------------------------------------------------------------- ! Creator: ! -------- @@ -25,6 +25,9 @@ SUBROUTINE EVAP_LOWER_DIFF(fuseStruct) IMPLICIT NONE ! input-output type(parent), intent(inout) :: fuseStruct ! parent fuse data 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(& @@ -36,6 +39,9 @@ SUBROUTINE EVAP_LOWER_DIFF(fuseStruct) ) ! (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) diff --git a/build/FUSE_SRC/physics/evap_upper_diff.f90 b/build/FUSE_SRC/physics/evap_upper_diff.f90 index fa0fd2d..030fa60 100644 --- a/build/FUSE_SRC/physics/evap_upper_diff.f90 +++ b/build/FUSE_SRC/physics/evap_upper_diff.f90 @@ -7,7 +7,7 @@ module EVAP_UPPER_DIFF_module contains - SUBROUTINE EVAP_UPPER_DIFF(fuseStruct) + SUBROUTINE EVAP_UPPER_DIFF(fuseStruct, want_dflux) ! ------------------------------------------------------------------------------------------------- ! Creator: ! -------- @@ -21,21 +21,38 @@ SUBROUTINE EVAP_UPPER_DIFF(fuseStruct) USE nrtype ! variable types, etc. USE data_types, only: parent ! fuse parent data type USE model_defn ! model definition structure - USE model_defnames + USE model_defnames ! model definition names + use smoothers, only : sfrac, dsfrac ! smoothed fraction, derivative IMPLICIT NONE ! input-output type(parent), intent(inout) :: fuseStruct ! parent fuse data 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 ! ------------------------------------------------------------------------------------------------- ! associate variables with elements of data structure associate(& MFORCE => fuseStruct%force , & ! model forcing data M_FLUX => fuseStruct%flux , & ! fluxes + dfx_dS => fuseStruct%df_dS , & ! deriv in fluxes w.r.t. states TSTATE => fuseStruct%state1 , & ! trial state variables (end of step) MPARAM => fuseStruct%param_adjust , & ! adjustable model parameters DPARAM => fuseStruct%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 @@ -43,47 +60,77 @@ SUBROUTINE EVAP_UPPER_DIFF(fuseStruct) CASE(iopt_tension2_1) ! tension storage sub-divided into recharge and excess ! -------------------------------------------------------------------------------------- - ! use different evaporation schemes for the upper layer - ! ----------------------------------------------------- + ! calculate the smoothed fraction of tension storage (NOTE: use WATR_1) + phi_1a = sfrac(TSTATE%TENS_1A, DPARAM%MAXTENS_1A) + phi_1b = sfrac(TSTATE%TENS_1B, DPARAM%MAXTENS_1B) + + ! calculate the maximum evap rate for the storage SELECT CASE(SMODL%iESOIL) CASE(iopt_sequential) - M_FLUX%EVAP_1A = MFORCE%PET * TSTATE%TENS_1A/DPARAM%MAXTENS_1A - M_FLUX%EVAP_1B = (MFORCE%PET - M_FLUX%EVAP_1A) * TSTATE%TENS_1B/DPARAM%MAXTENS_1B - M_FLUX%EVAP_1 = M_FLUX%EVAP_1A + M_FLUX%EVAP_1B + maxrate_1a = MFORCE%PET + maxrate_1b = MFORCE%PET - MFORCE%PET*phi_1a CASE(iopt_rootweight) - M_FLUX%EVAP_1A = MFORCE%PET * MPARAM%RTFRAC1 * TSTATE%TENS_1A/DPARAM%MAXTENS_1A - M_FLUX%EVAP_1B = MFORCE%PET * DPARAM%RTFRAC2 * TSTATE%TENS_1B/DPARAM%MAXTENS_1B - M_FLUX%EVAP_1 = M_FLUX%EVAP_1A + M_FLUX%EVAP_1B - CASE DEFAULT - print *, "SMODL%iESOIL must be either iopt_sequential or iopt_rootweight" - STOP + 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 ! -------------------------------------------------------------------------------------- - ! use different evaporation schemes for the upper layer - ! ----------------------------------------------------- + ! 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) + case(iopt_onestate_1); phi = sfrac(TSTATE%WATR_1, DPARAM%MAXTENS_1) ! 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) - M_FLUX%EVAP_1A = 0._sp - M_FLUX%EVAP_1B = 0._sp - M_FLUX%EVAP_1 = MFORCE%PET * TSTATE%TENS_1/DPARAM%MAXTENS_1 - CASE(iopt_rootweight) - M_FLUX%EVAP_1A = 0._sp - M_FLUX%EVAP_1B = 0._sp - M_FLUX%EVAP_1 = MFORCE%PET * MPARAM%RTFRAC1 * TSTATE%TENS_1/DPARAM%MAXTENS_1 - CASE DEFAULT - print *, "SMODL%iESOIL must be either iopt_sequential or iopt_rootweight" + 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) - - ! -------------------------------------------------------------------------------------- - CASE DEFAULT - print *, "SMODL%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" - STOP - ! -------------------------------------------------------------------------------------- - - END SELECT ! (upper-layer architechure) + + ! ----- 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) + case(iopt_onestate_1); dphi_dx = dsfrac(TSTATE%WATR_1, DPARAM%MAXTENS_1) ! 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 diff --git a/build/FUSE_SRC/physics/get_parent.f90 b/build/FUSE_SRC/physics/get_parent.f90 index 1a79e0d..c142bb2 100644 --- a/build/FUSE_SRC/physics/get_parent.f90 +++ b/build/FUSE_SRC/physics/get_parent.f90 @@ -1,5 +1,7 @@ module get_parent_module + use nrtype use data_types, only: parent + USE model_defn, ONLY:NSTATE implicit none contains @@ -10,16 +12,23 @@ subroutine get_parent(fuseStruct) use multi_flux, only: m_flux use multiparam, only: parMeta,mParam,dParam implicit none - type(parent), intent(out) :: fuseStruct + type(parent), intent(inout) :: fuseStruct + integer(i4b) :: iState + ! populate parent fuse structures fuseStruct%force = mForce fuseStruct%state0 = mState fuseStruct%state1 = mState - fuseStruct%flux = m_flux + fuseStruct%flux = m_flux ! initialized at zero fuseStruct%param_meta = parMeta fuseStruct%param_adjust = mParam fuseStruct%param_derive = dParam + ! initialize derivatives + do iState=1,nState + fuseStruct%df_dS(iState) = m_flux ! initialized at zero + end do + end subroutine get_parent diff --git a/build/FUSE_SRC/physics/implicit_solve.f90 b/build/FUSE_SRC/physics/implicit_solve.f90 index db92b58..f008e29 100644 --- a/build/FUSE_SRC/physics/implicit_solve.f90 +++ b/build/FUSE_SRC/physics/implicit_solve.f90 @@ -24,28 +24,35 @@ module implicit_solve_module contains ! ----- calculate dx/dt=g(x) ----------------------------------------------------------- - function dx_dt(fuseStruct, x_try) result(g_x) - use MOD_DERIVS_DIFF_module, only: MOD_DERIVS_DIFF ! compute dx/dt + 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(parent) , intent(inout) :: fuseStruct ! parent fuse data structure - real(sp) , intent(in) :: x_try(:) ! trial state vector + type(parent) , intent(inout) :: fuseStruct ! parent fuse data structure + real(sp) , intent(in) :: x_try(:) ! trial state vector ! output - real(sp) :: g_x(size(x_try)) ! dx/dt=g(x) + 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%state1) ! run the fuse physics - call mod_derivs_diff(fuseStruct) + if (present(J_g)) then + call mod_derivs_diff(fuseStruct, g_x, J_g) + else + call mod_derivs_diff(fuseStruct, g_x) + end if - ! extract dx_dt from fuse structure - call STR_2_XTRY(fuseStruct%dx_dt, g_x) - ! track the total number of function calls NUM_FUNCS = NUM_FUNCS + 1 - end function dx_dt + end subroutine dx_dt ! ----- calculate the Jacobian of g(x) ------------------------------------------------- SUBROUTINE jac_flux(fuseStruct, x_try, g_x, lower, upper, Jac) @@ -81,7 +88,7 @@ SUBROUTINE jac_flux(fuseStruct, x_try, g_x, lower, upper, Jac) ! compute function from the perturbed vector x(j) = xsav(j) + h_try - g_ph = dx_dt(fuseStruct_local, x) + call dx_dt(fuseStruct_local, x, g_ph) h_act = x(j) - xsav(j) ! compute column in the Jacobian @@ -121,6 +128,7 @@ subroutine implicit_solve(fuseStruct, x0, x1, nx, ierr, message, isVerbose) 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 @@ -207,42 +215,27 @@ subroutine implicit_solve(fuseStruct, x0, x1, nx, ierr, message, isVerbose) accepted = .false. converged = .false. - if(isPrint) isDebug = .true. - - ! --- F(x) and objective phi - g_x = dx_dt(fuseStruct, x_try) + ! --- 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) - if(isPrint) isDebug = .false. - ! iterate do it = 1, maxit ! save x x_old = x_try - if(isPrint) print*, '***** start of iteration *****' - - ! check - if(isPrint)then - print*, 'x_try = ', x_try - print*, 'g_x = ', g_x - print*, 'res = ', res - print*, 'phi = ', phi - print*, 'dclamp = ', dclamp - if(it > 10) stop 1 - endif - + ! check convergence if (phi < ERR_ITER_FUNC) then converged = .true. exit ! exit iteration loop end if - ! --- J(x) - call jac_flux(fuseStruct, x_try, g_x, lower, upper, Jg) + ! --- 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) !* dclamp(i) ! multiply dt and clamp derivative + Jac(:,i) = -dt*Jg(:,i) Jac(i,i) = Jac(i,i) + 1.0_sp end do @@ -254,11 +247,6 @@ subroutine implicit_solve(fuseStruct, x0, x1, nx, ierr, message, isVerbose) call ludcmp(Jac, indx, d) ! J overwritten with LU call lubksb(Jac, indx, dx) ! dx becomes solution - if(isPrint)then - print*, 'dx = ', dx - print*, 'Jg = ', Jg - endif - ! --- Modify dx ! modify dx if norm > stpmax @@ -284,54 +272,23 @@ subroutine implicit_solve(fuseStruct, x0, x1, nx, ierr, message, isVerbose) accepted = .false. ! flag to check if line search is accepted alamin = ERR_ITER_DX / maxval( abs(dx) / max(abs(x_try), 1.0_sp) ) - ! check - if(isPrint)then - print*, 'alamin = ', alamin - print*, 'slope = ', slope - print*, 'gpsi = ', gpsi - endif - - if(isPrint) isDebug = .true. - lambda = 1.0_sp do ls_it = 1, ls_max - if(isPrint)then - print*, '***** new linesearch *****', ls_it - print*, 'dx = ', dx - endif - ! update x x_trial = x_try + lambda*dx - if(isPrint)then - print*, 'x_try = ', x_try - print*, 'x_trial = ', x_trial - print*, 'lower = ', lower - print*, 'upper = ', upper - print *, "delta = ", x_trial - x_try - print *, "lambda*dx = ", lambda*dx - endif - ! 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 - g_trial = dx_dt(fuseStruct, x_trial) + ! 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) - if(isPrint)then - print*, 'ls_it, lambda, phi, phi_new', ls_it, lambda, phi, phi_new - print*, 'phi, phi_new, slope=', phi, phi_new, slope - print*, 'x_trial = ', x_trial - print*, 'g_trial = ', g_trial - print*, 'res _trial= ', res_trial - endif - ! save best function evaluation if (phi_new < phi_best) then phi_best = phi_new @@ -350,32 +307,26 @@ subroutine implicit_solve(fuseStruct, x0, x1, nx, ierr, message, isVerbose) end do ! line search - if(isPrint) isDebug = .false. - - if (accepted) then - x_try = x_trial - g_x = g_trial - res = res_trial - phi = phi_new - else - ! ----- fallback: try a small step along the direction of steepest descent ----- - !dx = -gpsi ! use steepest descent + ! ----- 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) - ! get new function evaluation - x_try = x_trial - g_x = dx_dt(fuseStruct, x_try) - 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 - end if + 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 @@ -389,7 +340,7 @@ subroutine implicit_solve(fuseStruct, x0, x1, nx, ierr, message, isVerbose) if( .not. converged)then ! use explicit Euler if did not find anything - if( .not. have_best) g_best = dx_dt(fuseStruct, x0) + if( .not. have_best) call dx_dt(fuseStruct, x0, g_best) ! use dx/dt = g(x_best) x_try = x0 + dt*g_best @@ -398,7 +349,7 @@ subroutine implicit_solve(fuseStruct, x0, x1, nx, ierr, message, isVerbose) call XTRY_2_STR(x_try, fuseStruct%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 diff --git a/build/FUSE_SRC/physics/mod_derivs_diff.f90 b/build/FUSE_SRC/physics/mod_derivs_diff.f90 index 5dc1752..5bdd3ce 100644 --- a/build/FUSE_SRC/physics/mod_derivs_diff.f90 +++ b/build/FUSE_SRC/physics/mod_derivs_diff.f90 @@ -18,7 +18,7 @@ module MOD_DERIVS_DIFF_module contains - SUBROUTINE MOD_DERIVS_DIFF(fuseStruct) + SUBROUTINE MOD_DERIVS_DIFF(fuseStruct, g_x, J_g) ! --------------------------------------------------------------------------------------- ! Creator: ! -------- @@ -29,21 +29,35 @@ SUBROUTINE MOD_DERIVS_DIFF(fuseStruct) ! Purpose: ! -------- ! compute the time derivative (dx/dt) of all model states (x) - ! --------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------- implicit none - type(parent), intent(inout) :: fuseStruct ! parent fuse data structure + ! input + type(parent) , intent(inout) :: fuseStruct ! parent fuse data 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) ! compute the saturated area and surface runoff - call evap_upper_diff(fuseStruct) ! compute evaporation from the upper layer - call evap_lower_diff(fuseStruct) ! compute evaporation from the lower layer - call qinterflow_diff(fuseStruct) ! compute interflow from free water in the upper layer - call qpercolate_diff(fuseStruct) ! compute percolation from the upper to lower soil layers - call q_baseflow_diff(fuseStruct) ! compute baseflow from the lower soil layer - call q_misscell_diff(fuseStruct) ! compute miscellaneous fluxes (NOTE: need sat area, evap, and perc) + 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) - call mstate_rhs_diff(fuseStruct) + 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 diff --git a/build/FUSE_SRC/physics/mstate_rhs_diff.f90 b/build/FUSE_SRC/physics/mstate_rhs_diff.f90 index b34eb90..c73502a 100644 --- a/build/FUSE_SRC/physics/mstate_rhs_diff.f90 +++ b/build/FUSE_SRC/physics/mstate_rhs_diff.f90 @@ -9,7 +9,7 @@ module MSTATE_RHS_DIFF_module contains - SUBROUTINE MSTATE_RHS_DIFF(fuseStruct) + SUBROUTINE MSTATE_RHS_DIFF(fuseStruct, g_x, J_g) ! --------------------------------------------------------------------------------------- ! Creator: ! -------- @@ -20,12 +20,18 @@ SUBROUTINE MSTATE_RHS_DIFF(fuseStruct) ! -------- ! Computes time derivatives of all states for all model combinations ! --------------------------------------------------------------------------------------- - USE nrtype ! variable types, etc. - USE data_types, only: parent ! fuse parent data type - USE model_defn ! model definition structure - USE model_defnames + USE nrtype ! variable types, etc. + USE data_types, only: parent ! fuse parent 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(parent), intent(inout) :: fuseStruct ! parent fuse data 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(& @@ -33,12 +39,16 @@ SUBROUTINE MSTATE_RHS_DIFF(fuseStruct) MPARAM => fuseStruct%param_adjust , & ! adjustable model parameters DX_DT => fuseStruct%dx_dt & ! time derivative in states ) ! (associate) + ! ------------------------------------------------------------------------------------------------- - if(isDebug) print*, 'M_FLUX%QPERC_12 = ', M_FLUX%QPERC_12 + ! check if Jacobian is desired + comp_dflux = present(J_g) ! --------------------------------------------------------------------------------------- - ! (1) COMPUTE TIME DERIVATIVES FOR STATES IN THE UPPER LAYER + ! (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 @@ -53,11 +63,19 @@ SUBROUTINE MSTATE_RHS_DIFF(fuseStruct) CASE DEFAULT print *, "SMODL%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" STOP - END SELECT ! (upper layer architechure) + 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*fuseStruct%df_dS%SATAREA - fuseStruct%df_dS%EVAP_1 - fuseStruct%df_dS%QPERC_12 + endif ! --------------------------------------------------------------------------------------- - ! (2) COMPUTE TIME DERIVATIVES FOR STATES IN THE LOWER LAYER + ! (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 @@ -73,22 +91,23 @@ SUBROUTINE MSTATE_RHS_DIFF(fuseStruct) 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,:) = fuseStruct%df_dS%QPERC_12 - fuseStruct%df_dS%QBASE_2 + endif + ! --------------------------------------------------------------------------------------- - if(isDebug) print*, '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 = ', & - 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 - - if(isDebug) print*, 'DX_DT%WATR_2, M_FLUX%QPERC_12, M_FLUX%EVAP_2, M_FLUX%QBASE_2, M_FLUX%OFLOW_2 = ', & - DX_DT%WATR_2, M_FLUX%QPERC_12, M_FLUX%EVAP_2, M_FLUX%QBASE_2, M_FLUX%OFLOW_2 - - ! if(isDebug) print*, 'DX_DT%TENS_1, M_FLUX%EFF_PPT, M_FLUX%QSURF, M_FLUX%EVAP_1, M_FLUX%TENS2FREE_1 = ', & - ! DX_DT%TENS_1, M_FLUX%EFF_PPT, M_FLUX%QSURF, M_FLUX%EVAP_1, M_FLUX%TENS2FREE_1 - ! - ! if(isDebug) print*, 'DX_DT%TENS_2, M_FLUX%QPERC_12*(1._SP-MPARAM%PERCFRAC), M_FLUX%EVAP_2, M_FLUX%TENS2FREE_2 = ', & - ! DX_DT%TENS_2, M_FLUX%QPERC_12*(1._SP-MPARAM%PERCFRAC), M_FLUX%EVAP_2, M_FLUX%TENS2FREE_2 - ! - ! if(isDebug) print*, '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 = ', & - ! 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 + ! --------------------------------------------------------------------------------------- + ! (3) FINALIZE + ! --------------------------------------------------------------------------------------- + + ! extract dx_dt from fuse structure + call STR_2_XTRY(fuseStruct%dx_dt, g_x) + ! --------------------------------------------------------------------------------------- end associate ! end association with variables in the data structures END SUBROUTINE MSTATE_RHS_DIFF diff --git a/build/FUSE_SRC/physics/q_baseflow_diff.f90 b/build/FUSE_SRC/physics/q_baseflow_diff.f90 index d63adb6..805f42b 100644 --- a/build/FUSE_SRC/physics/q_baseflow_diff.f90 +++ b/build/FUSE_SRC/physics/q_baseflow_diff.f90 @@ -1,7 +1,5 @@ module Q_BASEFLOW_DIFF_module - USE globaldata, only: isDebug - implicit none private @@ -10,7 +8,7 @@ module Q_BASEFLOW_DIFF_module contains - SUBROUTINE Q_BASEFLOW_DIFF(fuseStruct) + SUBROUTINE Q_BASEFLOW_DIFF(fuseStruct, want_dflux) ! --------------------------------------------------------------------------------------- ! Creator: ! -------- @@ -28,43 +26,83 @@ SUBROUTINE Q_BASEFLOW_DIFF(fuseStruct) IMPLICIT NONE ! input-output type(parent), intent(inout) :: fuseStruct ! parent fuse data 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(& M_FLUX => fuseStruct%flux , & ! fluxes + dfx_dS => fuseStruct%df_dS , & ! deriv in fluxes w.r.t. states TSTATE => fuseStruct%state1 , & ! trial state variables (end of step) MPARAM => fuseStruct%param_adjust , & ! adjustable model parameters DPARAM => fuseStruct%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 - M_FLUX%QBASE_2 = DPARAM%QBSAT * (TSTATE%WATR_2/MPARAM%MAXWATR_2)**MPARAM%QB_POWR + + 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 diff --git a/build/FUSE_SRC/physics/q_misscell_diff.f90 b/build/FUSE_SRC/physics/q_misscell_diff.f90 index c347455..8282832 100644 --- a/build/FUSE_SRC/physics/q_misscell_diff.f90 +++ b/build/FUSE_SRC/physics/q_misscell_diff.f90 @@ -1,5 +1,5 @@ module Q_MISSCELL_DIFF_module - + implicit none private @@ -7,7 +7,7 @@ module Q_MISSCELL_DIFF_module contains - SUBROUTINE Q_MISSCELL_DIFF(fuseStruct) + SUBROUTINE Q_MISSCELL_DIFF(fuseStruct, want_dflux) ! --------------------------------------------------------------------------------------- ! Creator: ! -------- @@ -31,7 +31,9 @@ SUBROUTINE Q_MISSCELL_DIFF(fuseStruct) IMPLICIT NONE ! input-output type(parent), intent(inout) :: fuseStruct ! parent fuse data 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 ! ------------------------------------------------------------------------------------------------- @@ -44,6 +46,9 @@ SUBROUTINE Q_MISSCELL_DIFF(fuseStruct) ) ! (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 @@ -70,8 +75,12 @@ SUBROUTINE Q_MISSCELL_DIFF(fuseStruct) M_FLUX%RCHR2EXCS = 0._SP M_FLUX%TENS2FREE_1 = 0._SP ! compute over-flow of free water - W_FUNC = SMOOTHER(TSTATE%WATR_1,MPARAM%MAXWATR_1,PSMOOTH) - M_FLUX%OFLOW_1 = W_FUNC * (M_FLUX%EFF_PPT - M_FLUX%QSURF) + 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 diff --git a/build/FUSE_SRC/physics/qinterflow_diff.f90 b/build/FUSE_SRC/physics/qinterflow_diff.f90 index 9b1ed32..221c2c5 100644 --- a/build/FUSE_SRC/physics/qinterflow_diff.f90 +++ b/build/FUSE_SRC/physics/qinterflow_diff.f90 @@ -7,7 +7,7 @@ module QINTERFLOW_DIFF_module contains - SUBROUTINE QINTERFLOW_DIFF(fuseStruct) + SUBROUTINE QINTERFLOW_DIFF(fuseStruct, want_dflux) ! --------------------------------------------------------------------------------------- ! Creator: ! -------- @@ -25,6 +25,9 @@ SUBROUTINE QINTERFLOW_DIFF(fuseStruct) IMPLICIT NONE ! input-output type(parent), intent(inout) :: fuseStruct ! parent fuse data 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(& @@ -33,6 +36,10 @@ SUBROUTINE QINTERFLOW_DIFF(fuseStruct) MPARAM => fuseStruct%param_adjust , & ! adjustable model parameters DPARAM => fuseStruct%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) diff --git a/build/FUSE_SRC/physics/qpercolate_diff.f90 b/build/FUSE_SRC/physics/qpercolate_diff.f90 index 9ff599c..8e19db5 100644 --- a/build/FUSE_SRC/physics/qpercolate_diff.f90 +++ b/build/FUSE_SRC/physics/qpercolate_diff.f90 @@ -7,7 +7,7 @@ module QPERCOLATE_DIFF_module contains - SUBROUTINE QPERCOLATE_DIFF(fuseStruct) + SUBROUTINE QPERCOLATE_DIFF(fuseStruct, want_dflux) ! --------------------------------------------------------------------------------------- ! Creator: ! -------- @@ -21,37 +21,92 @@ SUBROUTINE QPERCOLATE_DIFF(fuseStruct) USE nrtype ! variable types, etc. USE data_types, only: parent ! fuse parent data type USE model_defn ! model definition structure - USE model_defnames + USE model_defnames ! model definition names + use smoothers, only : sfrac, dsfrac ! smoothed fraction, derivative IMPLICIT NONE ! input-output type(parent), intent(inout) :: fuseStruct ! parent fuse data 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 ! --------------------------------------------------------------------------------------- ! associate variables with elements of data structure associate(& M_FLUX => fuseStruct%flux , & ! fluxes + dfx_dS => fuseStruct%df_dS , & ! deriv in fluxes w.r.t. states TSTATE => fuseStruct%state1 , & ! trial state variables (end of step) MPARAM => fuseStruct%param_adjust , & ! adjustable model parameters DPARAM => fuseStruct%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) - CASE(iopt_perc_f2sat) ! water from (field cap to sat) avail for percolation - M_FLUX%QPERC_12 = MPARAM%PERCRTE * (TSTATE%FREE_1/DPARAM%MAXFREE_1)**MPARAM%PERCEXP - CASE(iopt_perc_w2sat) ! water from (wilt pt to sat) avail for percolation - M_FLUX%QPERC_12 = MPARAM%PERCRTE * (TSTATE%WATR_1/MPARAM%MAXWATR_1)**MPARAM%PERCEXP + + ! -------------------------------------------------------------------------------------- + ! 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) + case(iopt_perc_f2sat); phi = sfrac(TSTATE%FREE_1, DPARAM%MAXFREE_1) + 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) + case(iopt_perc_f2sat); dphi_dx = dsfrac(TSTATE%FREE_1, DPARAM%MAXFREE_1) + 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 lower-zone percolation demand -- multiplier on maximum percolation, then percolation) + + ! ----- 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) - !print *, 'lz_pd = ', LZ_PD, MPARAM%SACPMLT, TSTATE%WATR_2/MPARAM%MAXWATR_2, MPARAM%SACPEXP - !print *, 'qperc_12 = ', M_FLUX%QPERC_12, DPARAM%QBSAT, LZ_PD, TSTATE%FREE_1/DPARAM%MAXFREE_1 - CASE DEFAULT ! check for errors - print *, "SMODL%iQPERC must be iopt_perc_f2sat, iopt_perc_w2sat, or iopt_perc_lower" - STOP + + ! ----- 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 ! -------------------------------------------------------------------------------------- diff --git a/build/FUSE_SRC/physics/qsatexcess_diff.f90 b/build/FUSE_SRC/physics/qsatexcess_diff.f90 index fa454a2..753dee2 100644 --- a/build/FUSE_SRC/physics/qsatexcess_diff.f90 +++ b/build/FUSE_SRC/physics/qsatexcess_diff.f90 @@ -7,7 +7,7 @@ module QSATEXCESS_DIFF_MODULE contains - SUBROUTINE QSATEXCESS_DIFF(fuseStruct) + SUBROUTINE QSATEXCESS_DIFF(fuseStruct, want_dflux) ! ------------------------------------------------------------------------------------------------- ! Creator: ! -------- @@ -20,13 +20,21 @@ SUBROUTINE QSATEXCESS_DIFF(fuseStruct) ! ------------------------------------------------------------------------------------------------- USE nrtype ! variable types, etc. USE data_types, only: parent ! fuse parent data type - USE nr, ONLY : gammp ! interface for the incomplete gamma function 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(parent), intent(inout) :: fuseStruct ! parent fuse data structure - ! internal variables + 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 @@ -34,16 +42,23 @@ SUBROUTINE QSATEXCESS_DIFF(fuseStruct) 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 ! ------------------------------------------------------------------------------------------------- ! associate variables with elements of data structure associate(& M_FLUX => fuseStruct%flux , & ! fluxes + dfx_dS => fuseStruct%df_dS , & ! deriv in fluxes w.r.t. states TSTATE => fuseStruct%state1 , & ! trial state variables (end of step) MPARAM => fuseStruct%param_adjust , & ! adjustable model parameters DPARAM => fuseStruct%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) @@ -52,9 +67,38 @@ SUBROUTINE QSATEXCESS_DIFF(fuseStruct) ! ------------------------------------------------------------------------------------------------ CASE(iopt_arno_x_vic) + ! define variables + associate(w=>TSTATE%WATR_1, wmax=>MPARAM%MAXWATR_1, b=>MPARAM%AXV_BEXP) + ! ----- compute flux ---------------------------------------------------------------------------- - M_FLUX%SATAREA = 1._sp - ( 1._sp - MIN(TSTATE%WATR_1/MPARAM%MAXWATR_1, 1._sp) )**MPARAM%AXV_BEXP - + u = 1._sp - w/wmax + xp = smax(u, 0._sp) ! 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) ! 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) ----------------------------------------- ! ------------------------------------------------------------------------------------------------ @@ -63,6 +107,9 @@ SUBROUTINE QSATEXCESS_DIFF(fuseStruct) ! ----- 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) ----------------------------------- ! ------------------------------------------------------------------------------------------------ @@ -87,6 +134,9 @@ SUBROUTINE QSATEXCESS_DIFF(fuseStruct) 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 @@ -95,7 +145,7 @@ SUBROUTINE QSATEXCESS_DIFF(fuseStruct) STOP END SELECT ! (different surface runoff options) - + ! ...and, compute surface runoff ! ------------------------------ M_FLUX%QSURF = M_FLUX%EFF_PPT * M_FLUX%SATAREA diff --git a/build/FUSE_SRC/physics/smoothers.f90 b/build/FUSE_SRC/physics/smoothers.f90 index 71f5277..246ed59 100644 --- a/build/FUSE_SRC/physics/smoothers.f90 +++ b/build/FUSE_SRC/physics/smoothers.f90 @@ -5,9 +5,116 @@ module smoothers private public:: LOGISMOOTH public:: smoother + public:: smax,dsmax + public:: sfrac,dsfrac contains + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + PURE FUNCTION sfrac(x,xmax) result(xf) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2025 + ! --------------------------------------------------------------------------------------- + ! 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) :: xp ! smooth min(x,xmax) + real(sp) :: xf ! smooth fraction x/xmax + xp = xmax - smax(xmax - x, 0._sp) ! 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) result(dxf_dx) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2025 + ! --------------------------------------------------------------------------------------- + ! 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) :: 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) ! note signs cancel out + dxf_dx = dxp_dx / xmax + end function dsfrac + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + PURE FUNCTION smax(x,xmin) result(xp) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2025 + ! --------------------------------------------------------------------------------------- + ! 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), parameter :: ms=1.e-4_sp ! 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) result(dxp) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2025 + ! --------------------------------------------------------------------------------------- + ! 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), parameter :: ms=1.e-4_sp ! 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 + ! --------------------------------------------------------------------------------------- ! --------------------------------------------------------------------------------------- From 3d4ef2d6d18504e7b148a9c4401a39827602936c Mon Sep 17 00:00:00 2001 From: Martyn Clark Date: Sun, 14 Dec 2025 19:37:14 -0700 Subject: [PATCH 10/16] initial version of the smooth snow model --- build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 | 31 ++-- build/FUSE_SRC/dshare/data_types.f90 | 2 +- build/FUSE_SRC/physics/get_parent.f90 | 2 + build/FUSE_SRC/physics/smoothers.f90 | 51 +++++- build/FUSE_SRC/physics/update_swe_diff.f90 | 171 +++++++++++++++++++++ build/Makefile | 1 + 6 files changed, 239 insertions(+), 19 deletions(-) create mode 100644 build/FUSE_SRC/physics/update_swe_diff.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 b/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 index 3f4c8a6..7d4bd41 100644 --- a/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 +++ b/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 @@ -9,6 +9,7 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! 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 Martyn Clark to call differentiable modeling routines, 12/2025 ! --------------------------------------------------------------------------------------- ! Purpose: ! -------- @@ -58,6 +59,7 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG use data_types, only: parent ! fuse parent data type use get_parent_module, only: get_parent ! populate the parent data structure use implicit_solve_module, only:implicit_solve ! simple implicit solve for differnetiable ODE + use update_swe_diff_module, only:update_swe_diff ! differentiable snow model ! interface blocks USE interfaceb, ONLY:ode_int,fuse_solve ! provide access to FUSE_SOLVE through ODE_INT @@ -241,6 +243,9 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! initialize model fluxes CALL INITFLUXES() ! set weighted sum of fluxes to zero + ! populate parent fuse structure + if(diff_mode==differentiable) call get_parent(fuseStruct) + ! 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) @@ -255,13 +260,18 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG 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) + ! run the snow model + select case(diff_mode) + case(original); CALL UPDATE_SWE(DELTIM) + case(differentiable); CALL UPDATE_SWE_DIFF(fuseStruct,DELTIM) + CASE DEFAULT; stop "fuse_rmse: cannot identify diff_mode" + end select CASE(iopt_no_snowmod) CALL QRAINERROR() CASE DEFAULT - message="f-fuse_rmse/SMODL%iSNOWM must be either iopt_temp_index or iopt_no_snowmod" - RETURN + message="fuse_rmse/SMODL%iSNOWM must be either iopt_temp_index or iopt_no_snowmod" + print*, trim(message); stop 1 END SELECT ! ----- start of soil physics code ------------------------------------------------------------ @@ -277,27 +287,14 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! differentiable code case(differentiable) - ! populate parent fuse structure - call get_parent(fuseStruct) - ! solve differentiable ODEs call implicit_solve(fuseStruct, state0, state1, nState, ierr, cmessage) - if(ierr/=0)then - print*, trim(cmessage) - print*, 'state0 = ', state0 - call implicit_solve(fuseStruct, state0, state1, nState, ierr, cmessage, isVerbose=.true.) - stop 1 - endif - - - !print*, state1 - !if(ITIM_IN > sim_beg+100) stop ! save fluxes W_FLUX = fuseStruct%flux ! check options - case default; print*, "Cannot identify diff_mode"; stop 1 + case default; print*, "fuse_rmse: Cannot identify diff_mode"; stop 1 end select ! ----- end of soil physics code -------------------------------------------------------------- diff --git a/build/FUSE_SRC/dshare/data_types.f90 b/build/FUSE_SRC/dshare/data_types.f90 index afbc701..f220bb7 100644 --- a/build/FUSE_SRC/dshare/data_types.f90 +++ b/build/FUSE_SRC/dshare/data_types.f90 @@ -304,7 +304,7 @@ module data_types ! parent FUSE structure ! -------------------------------------------------------------------------------------- type parent - type(m_time) :: time ! time 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) diff --git a/build/FUSE_SRC/physics/get_parent.f90 b/build/FUSE_SRC/physics/get_parent.f90 index c142bb2..ddc0b27 100644 --- a/build/FUSE_SRC/physics/get_parent.f90 +++ b/build/FUSE_SRC/physics/get_parent.f90 @@ -7,6 +7,7 @@ module get_parent_module contains subroutine get_parent(fuseStruct) + use multiforce, only: timDat use multiforce, only: mForce use multistate, only: mState use multi_flux, only: m_flux @@ -16,6 +17,7 @@ subroutine get_parent(fuseStruct) integer(i4b) :: iState ! populate parent fuse structures + fuseStruct%time = timdat fuseStruct%force = mForce fuseStruct%state0 = mState fuseStruct%state1 = mState diff --git a/build/FUSE_SRC/physics/smoothers.f90 b/build/FUSE_SRC/physics/smoothers.f90 index 246ed59..2fec3ce 100644 --- a/build/FUSE_SRC/physics/smoothers.f90 +++ b/build/FUSE_SRC/physics/smoothers.f90 @@ -3,6 +3,7 @@ module smoothers implicit none private + public:: sigmoid,dsigmoid public:: LOGISMOOTH public:: smoother public:: smax,dsmax @@ -117,7 +118,55 @@ end function dsmax ! --------------------------------------------------------------------------------------- ! --------------------------------------------------------------------------------------- - + + pure real(sp) function sigmoid(z, beta) result(s) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! A simple sigmoid smoother centered on zero + ! --------------------------------------------------------------------------------------- + use nrtype + implicit none + real(sp), intent(in) :: z, beta + real(sp) :: zb + + zb = beta * z + + 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_dx) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Derivative in the sigmoid given already have the sigmoid + ! --------------------------------------------------------------------------------------- + use nrtype + implicit none + real(sp), intent(in) :: s, beta + ds_dx = beta * s * (1._sp - s) + end function dsigmoid + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + PURE FUNCTION smoother(STATE,STATE_MAX,PSMOOTH) result(w_func) ! --------------------------------------------------------------------------------------- ! Creator: 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..40e2709 --- /dev/null +++ b/build/FUSE_SRC/physics/update_swe_diff.f90 @@ -0,0 +1,171 @@ +module update_swe_DIFF_MODULE + + USE model_defn ! model definition structure + USE model_defnames ! integer model definitions + + 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) + ! --------------------------------------------------------------------------------------- + ! 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, 9/2016 + ! + ! --------------------------------------------------------------------------------------- + ! 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 data_types, only: parent ! fuse parent data type + use smoothers, only: smax, sigmoid ! max and sigmoid smoothers + USE multibands ! NOTE: include in fuseStruct ! model basin band structure + IMPLICIT NONE + ! input + type(parent) , intent(inout) :: fuseStruct ! parent fuse data structure + REAL(SP), INTENT(IN) :: DT ! length of the time step + ! internal variables + 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 + REAL(SP) :: DZ ! vert. distance from forcing + real(sp) :: xOPG ! scaled Orographic Precipitation Gradient (OPG) + real(sp) :: xLapse ! scaled temperature lapse rate + real(sp) :: precip_adj ! adjusted precipitation (after multiplicative/additive error) + REAL(SP) :: PRECIP_Z ! band precipitation at timestep + REAL(SP) :: TEMP_Z ! band temperature at timestep + INTEGER(I4B) :: ISNW ! loop through snow model bands + 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=10._sp ! sigmoid sharpness for snow/rain partition (1/degC) + 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) + 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 + ! --------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + TIMDAT => fuseStruct%time , & ! fluxes + MFORCE => fuseStruct%force , & ! fluxes + M_FLUX => fuseStruct%flux , & ! fluxes + MPARAM => fuseStruct%param_adjust , & ! adjustable model parameters + DPARAM => fuseStruct%param_derive & ! derived model parameters + ) ! (associate) + ! --------------------------------------------------------------------------------------- + ! snow accumulation and melt calculations for each band + ! also calculates effective precipitation + ! --------------------------------------------------------------------------------------- + + ! ----- 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) + + ! ----- add error to the precipiation --------------------------------------------------- + + SELECT CASE(SMODL%iRFERR) + CASE(iopt_additive_e); precip_adj = MAX(0.0_sp, MFORCE%PPT + MPARAM%RFERR_ADD) ! 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 + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + ! initialize effective precip + M_FLUX%EFF_PPT = 0._sp + + ! check band rea fractions sum to 1 + if (abs(sum(MBANDS(:)%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 + + ! --- use the Orographic Precipitation Gradient (OPG) to adjust precip for elevation --- + + DZ = MBANDS(ISNW)%Z_MID - Z_FORCING + xOPG = MPARAM%OPG / 1000._sp ! scaled OPG + PRECIP_Z = precip_adj * exp(DZ * xOPG) ! NOTE: modified from the original branch structure + + ! ----- 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 + + ! ----- calculate the (smoothed) snow accumulation ------------------------------------- + + ! snowfall and rainfall fluxes + fsnow = sigmoid(MPARAM%PXTEMP - TEMP_Z, beta_px) ! beta_px is the sharpness, set large because originally a step function + snow = PRECIP_Z*fsnow + rain = PRECIP_Z*(1._sp - fsnow) + + MBANDS(ISNW)%SNOWACCMLTN = snow + + ! ----- calculate the (smoothed) snow melt --------------------------------------------- + + ! potenital melt + posTemp = smax(TEMP_Z - MPARAM%MBASE, 0._sp) ! smoothed max(TEMP_Z - MPARAM%MBASE, 0) + potMelt = MF*posTemp ! mm day-1 + + ! melt capped by availability of snow + meltCap = snow + MBANDS(ISNW)%SWE / DT + snowmelt = -smax(-potMelt, -meltCap) ! smooth min + + MBANDS(ISNW)%SNOWMELT = snowmelt + + ! ----- update SWE --------------------------------------------------------------------- + + MBANDS(ISNW)%DSWE_DT = MBANDS(ISNW)%SNOWACCMLTN - MBANDS(ISNW)%SNOWMELT + MBANDS(ISNW)%SWE = MBANDS(ISNW)%SWE + MBANDS(ISNW)%DSWE_DT*DT + MBANDS(ISNW)%SWE = smax(MBANDS(ISNW)%SWE, 0._sp) ! safety: clamp for small roundoff + + ! ----- calculate effective precip (rain + melt) --------------------------------------- + + M_FLUX%EFF_PPT = M_FLUX%EFF_PPT + MBANDS(ISNW)%AF * (rain + snowmelt) + + END DO ! looping through elevation bands + + end associate + + END SUBROUTINE UPDATE_SWE_DIFF + +end module update_swe_DIFF_MODULE diff --git a/build/Makefile b/build/Makefile index 8b9f6f7..22e71fe 100644 --- a/build/Makefile +++ b/build/Makefile @@ -130,6 +130,7 @@ NR_SUB = $(patsubst %, $(NUMREC_DIR)/%, $(FUSE_NR_SUB)) FUSE_PHYSICS= \ smoothers.f90 \ get_parent.f90 \ + update_swe_diff.f90 \ qsatexcess_diff.f90 \ evap_upper_diff.f90 \ evap_lower_diff.f90 \ From b649c54b16431facc1e268fbefb10dae61faebc5 Mon Sep 17 00:00:00 2001 From: Martyn Clark Date: Sat, 20 Dec 2025 06:24:07 -0600 Subject: [PATCH 11/16] first version of the differentiable snow model --- build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 | 39 ++++- build/FUSE_SRC/FUSE_ENGINE/assign_par.f90 | 49 +++--- build/FUSE_SRC/dshare/data_types.f90 | 40 +++++ build/FUSE_SRC/dshare/globaldata.f90 | 26 ++-- build/FUSE_SRC/dshare/multibands.f90 | 26 +--- build/FUSE_SRC/physics/evap_upper_diff.f90 | 13 +- build/FUSE_SRC/physics/qpercolate_diff.f90 | 11 +- build/FUSE_SRC/physics/qsatexcess_diff.f90 | 11 +- build/FUSE_SRC/physics/smoothers.f90 | 28 ++-- build/FUSE_SRC/physics/update_swe_diff.f90 | 171 ++++++++++++++++++--- 10 files changed, 299 insertions(+), 115 deletions(-) diff --git a/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 b/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 index 7d4bd41..c213e2c 100644 --- a/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 +++ b/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 @@ -21,6 +21,7 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG USE nrtype ! variable types, etc. ! data modules + USE globaldata, ONLY:NPAR_SNOW ! number of snow parameters 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 @@ -44,7 +45,7 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG 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 multibands ! NOTE: include N_BANDS ! elevation bands for snow modeling USE set_all_module ! code modules @@ -113,7 +114,20 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! allocate flux derivative vector allocate(fuseStruct%df_dS(nState), stat=ierr) if(ierr/=0) STOP ' problem allocating space for the flux derivative vector' - + + ! allocate elevation bands (for the snow model) + allocate(fuseStruct%sbands(n_bands), stat=ierr) + if(ierr/=0) STOP ' problem allocating space for the elevation bands' + + ! allocate parameter derivative for each elevation band + do iBands=1,n_bands + allocate(fuseStruct%sbands(iBands)%dx%dSWE_dParam(NPAR_SNOW), & + fuseStruct%sbands(iBands)%dx%dEffP_dParam(NUMPAR), stat=ierr) + if(ierr/=0) STOP ' problem allocating space for the parameter derivatives' + fuseStruct%sbands(iBands)%dx%dSWE_dparam(:) = 0._sp + fuseStruct%sbands(iBands)%dx%dEffP_dParam(:) = 0._sp + end do + ! increment parameter counter for model output IF (.NOT.PRESENT(MPARAM_FLAG)) THEN PCOUNT = PCOUNT + 1 @@ -146,7 +160,6 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! initialize elevations bands if snow module is on if(isPrint) PRINT *, 'N_BANDS =', N_BANDS - IF (SMODL%iSNOWM.EQ.iopt_temp_index) THEN DO iSpat2=1,nSpat2 DO iSpat1=1,nSpat1 @@ -260,6 +273,12 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG 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) + ! put data into the FUSE structure + if(diff_mode == differentiable)then + fuseStruct%sbands%var = MBANDS + fuseStruct%z_forcing = Z_FORCING + endif ! if diff_mode == differentiable + ! run the snow model select case(diff_mode) case(original); CALL UPDATE_SWE(DELTIM) @@ -319,6 +338,12 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG IF (SMODL%iSNOWM.EQ.iopt_temp_index) THEN + ! extract data from the FUSE structure + if(diff_mode == differentiable)then + MBANDS = fuseStruct%sbands%var + Z_FORCING = fuseStruct%z_forcing + endif ! if diff_mode == differentiable + ! 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) @@ -411,10 +436,18 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG if(isPrint) PRINT *, 'Writing model statistics...' CALL PUT_SSTATS(PCOUNT) + ! deallocate parameter derivative vectors + do iBands=1,n_bands + deallocate(fuseStruct%sbands(iBands)%dx%dSWE_dParam, & + fuseStruct%sbands(iBands)%dx%dEffP_dParam, stat=ierr) + if(ierr/=0) STOP ' problem deallocating space for the parameter derivatives' + end do + ! deallocate vectors DEALLOCATE(W_FLUX_3d); IF (IERR.NE.0) STOP ' problem deallocating W_FLUX_3d in fuse_rmse ' DEALLOCATE(STATE0,STATE1,STAT=IERR); IF (IERR.NE.0) STOP ' problem deallocating state vectors in fuse_rmse' deallocate(fuseStruct%df_dS, stat=ierr); if(ierr/=0) STOP ' problem deallocating space for the flux derivative vector' + deallocate(fuseStruct%sbands, stat=ierr); if(ierr/=0) STOP ' problem deallocating space for the elevation bands' END SUBROUTINE FUSE_RMSE END MODULE FUSE_RMSE_MODULE diff --git a/build/FUSE_SRC/FUSE_ENGINE/assign_par.f90 b/build/FUSE_SRC/FUSE_ENGINE/assign_par.f90 index 3bf82e9..e891af3 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/assign_par.f90 +++ b/build/FUSE_SRC/FUSE_ENGINE/assign_par.f90 @@ -27,9 +27,8 @@ SUBROUTINE ASSIGN_PAR() MPAR = 0 ! initialize the number of model parameters LPARAM(:)%PARNAME = 'PAR_NOUSE' ! --------------------------------------------------------------------------------------- -! (1) RAINFALL ERRORS +! (1) PRECIPITATION ERRORS ! --------------------------------------------------------------------------------------- - SELECT CASE(SMODL%iRFERR) CASE(iopt_additive_e) ! additive rainfall error MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'RFERR_ADD' ! additive rainfall error (mm day-1) @@ -58,7 +57,23 @@ SUBROUTINE ASSIGN_PAR() STOP END SELECT ! (different upper-layer architecture) ! --------------------------------------------------------------------------------------- -! (2) UPPER-LAYER ARCHITECTURE +! (2) SNOW MODEL +! --------------------------------------------------------------------------------------- +SELECT CASE(SMODL%iSNOWM) + CASE(iopt_temp_index) ! temperature index snow model + MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'MBASE ' ! snow base melting temperature + MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'MFMAX ' ! snow maximum melt factor + MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'MFMIN ' ! snow minimum melt factor + MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'PXTEMP ' ! rain snow partition temperature + MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'OPG ' ! precipitation gradient + MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'LAPSE ' ! temperature gradient + CASE(iopt_no_snowmod) ! if no snow model, no additional parameters + CASE DEFAULT + print *, "SMODL%SNOWM must be either 'temp_index' or 'no_snowmod'" + STOP +END SELECT +! --------------------------------------------------------------------------------------- +! (3) UPPER-LAYER ARCHITECTURE ! --------------------------------------------------------------------------------------- SELECT CASE(SMODL%iARCH1) CASE(iopt_tension2_1) ! tension storage sub-divided into recharge and excess @@ -74,7 +89,7 @@ SUBROUTINE ASSIGN_PAR() STOP END SELECT ! (different upper-layer architechure) ! --------------------------------------------------------------------------------------- -! (3) LOWER-LAYER ARCHITECTURE / BASEFLOW +! (4) LOWER-LAYER ARCHITECTURE / BASEFLOW ! --------------------------------------------------------------------------------------- SELECT CASE(SMODL%iARCH2) CASE(iopt_tens2pll_2) ! tension reservoir plus two parallel tanks @@ -105,7 +120,7 @@ SUBROUTINE ASSIGN_PAR() STOP END SELECT ! different lower-layer architecture / baseflow parameterizations) ! --------------------------------------------------------------------------------------- -! (4) EVAPORATION +! (5) EVAPORATION ! --------------------------------------------------------------------------------------- SELECT CASE(SMODL%iESOIL) CASE(iopt_sequential) @@ -116,7 +131,7 @@ SUBROUTINE ASSIGN_PAR() print *, "SMODL%iESOIL must be either iopt_sequential or iopt_rootweight'" END SELECT ! (different evaporation schemes) ! --------------------------------------------------------------------------------------- -! (5) PERCOLATION +! (6) PERCOLATION ! --------------------------------------------------------------------------------------- SELECT CASE(SMODL%iQPERC) CASE(iopt_perc_f2sat,iopt_perc_w2sat) ! standard equation k(theta)**c @@ -130,7 +145,7 @@ SUBROUTINE ASSIGN_PAR() STOP END SELECT ! (different percolation options) ! --------------------------------------------------------------------------------------- -! (6) INTERFLOW +! (7) INTERFLOW ! --------------------------------------------------------------------------------------- SELECT CASE(SMODL%iQINTF) CASE(iopt_intflwsome) ! interflow @@ -142,7 +157,7 @@ SUBROUTINE ASSIGN_PAR() STOP END SELECT ! (different interflow options) ! --------------------------------------------------------------------------------------- -! (7) SURFACE RUNOFF +! (8) SURFACE RUNOFF ! --------------------------------------------------------------------------------------- SELECT CASE(SMODL%iQSURF) CASE(iopt_arno_x_vic) ! ARNO/Xzang/VIC parameterization (upper zone control) @@ -166,7 +181,7 @@ SUBROUTINE ASSIGN_PAR() STOP END SELECT ! (different surface runoff options) ! --------------------------------------------------------------------------------------- -! (8) TIME DELAY IN RUNOFF +! (9) TIME DELAY IN RUNOFF ! --------------------------------------------------------------------------------------- SELECT CASE(SMODL%iQ_TDH) CASE(iopt_rout_gamma) ! use a Gamma distribution with shape parameter = 2.5 @@ -178,22 +193,6 @@ SUBROUTINE ASSIGN_PAR() STOP END SELECT ! --------------------------------------------------------------------------------------- -! (9) SNOW MODEL -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iSNOWM) - CASE(iopt_temp_index) ! temperature index snow model - MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'MBASE ' ! snow base melting temperature - MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'MFMAX ' ! snow maximum melt factor - MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'MFMIN ' ! snow minimum melt factor - MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'PXTEMP ' ! rain snow partition temperature - MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'OPG ' ! precipitation gradient - MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'LAPSE ' ! temperature gradient - CASE(iopt_no_snowmod) ! if no snow model, no additional parameters - CASE DEFAULT - print *, "SMODL%SNOWM must be either 'temp_index' or 'no_snowmod'" - STOP -END SELECT -! --------------------------------------------------------------------------------------- NUMPAR = MPAR ! save the number of model parameters used in a given model SMODL ! --------------------------------------------------------------------------------------- !DO MPAR=1,NUMPAR; WRITE(*,'(A11,1X)') LPARAM(MPAR)%PARNAME; END DO diff --git a/build/FUSE_SRC/dshare/data_types.f90 b/build/FUSE_SRC/dshare/data_types.f90 index f220bb7..d2282ee 100644 --- a/build/FUSE_SRC/dshare/data_types.f90 +++ b/build/FUSE_SRC/dshare/data_types.f90 @@ -269,6 +269,44 @@ module data_types CHARACTER(LEN=9) :: PARNAME ! list of parameter names ENDTYPE PAR_ID + ! -------------------------------------------------------------------------------------- + ! elevation bands + ! -------------------------------------------------------------------------------------- + + 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 variables + 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_dx ! derivatives + real(sp), allocatable :: dSWE_dParam(:) ! parameter derivative vector + real(sp), allocatable :: dEffP_dParam(:) ! parameter derivative vector + endtype bands_dx + + type ebands + type(bands) :: var ! time-dependent variables + type(bands_dx) :: dx ! derivatives + endtype + ! -------------------------------------------------------------------------------------- ! model statistics structure ! -------------------------------------------------------------------------------------- @@ -306,6 +344,7 @@ module data_types type parent type(tdata) :: time ! time data type(fdata) :: force ! model forcing data + type(ebands), allocatable :: sbands(:) ! info/variables for elevation bands (snow model) 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 @@ -317,6 +356,7 @@ module data_types type(paradj) :: param_adjust ! adjustable model parametrs type(pardvd) :: param_derive ! derived model parameters type(summary) :: sim_stats ! simulation statistics + real(sp) :: z_forcing ! elevation of forcing data (m) end type parent end module data_types diff --git a/build/FUSE_SRC/dshare/globaldata.f90 b/build/FUSE_SRC/dshare/globaldata.f90 index bd95d54..be2049c 100644 --- a/build/FUSE_SRC/dshare/globaldata.f90 +++ b/build/FUSE_SRC/dshare/globaldata.f90 @@ -1,28 +1,36 @@ MODULE globaldata USE nrtype + + implicit none + include "fuseversion.inc" ! time step - REAL(SP), save :: CURRENT_DT ! current time step (days) + REAL(SP), save :: CURRENT_DT ! current time step (days) ! 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 + 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 ! NetCDF - integer(i4b), save :: ncid_out=-1 ! NetCDF output file ID + integer(i4b), save :: ncid_out=-1 ! NetCDF output file ID ! initial store fraction (initialization) - real(sp), parameter :: fracState0=0.25_sp + real(sp), parameter :: fracState0=0.25_sp ! original code - logical(lgt), save :: isOriginal=.true. + logical(lgt), save :: isOriginal=.true. ! print flag - logical(lgt), save :: isPrint=.true. - logical(lgt), save :: isDebug=.false. + logical(lgt), save :: isPrint=.true. + logical(lgt), save :: isDebug=.false. + + ! snow parameters + integer(i4b), parameter :: NPAR_SNOW=7 + integer(i4b), parameter :: iMBASE=1, iMFMAX=2, iMFMIN=3, iPXTEMP=4, iOPG=5, iLAPSE=6 ! indices in vectors + integer(i4b), parameter :: iPERR=7 ! not a snow parameter, but used here ! number of fuse evaluations - integer(i4b), save :: nFUSE_eval + integer(i4b), save :: nFUSE_eval end MODULE globaldata diff --git a/build/FUSE_SRC/dshare/multibands.f90 b/build/FUSE_SRC/dshare/multibands.f90 index 101928d..8b962a6 100644 --- a/build/FUSE_SRC/dshare/multibands.f90 +++ b/build/FUSE_SRC/dshare/multibands.f90 @@ -2,35 +2,11 @@ ! 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 - + USE data_types, only: BANDS, BANDS_INFO, 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 diff --git a/build/FUSE_SRC/physics/evap_upper_diff.f90 b/build/FUSE_SRC/physics/evap_upper_diff.f90 index 030fa60..d8d8f51 100644 --- a/build/FUSE_SRC/physics/evap_upper_diff.f90 +++ b/build/FUSE_SRC/physics/evap_upper_diff.f90 @@ -38,6 +38,7 @@ SUBROUTINE EVAP_UPPER_DIFF(fuseStruct, want_dflux) 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(& @@ -61,8 +62,8 @@ SUBROUTINE EVAP_UPPER_DIFF(fuseStruct, want_dflux) ! -------------------------------------------------------------------------------------- ! calculate the smoothed fraction of tension storage (NOTE: use WATR_1) - phi_1a = sfrac(TSTATE%TENS_1A, DPARAM%MAXTENS_1A) - phi_1b = sfrac(TSTATE%TENS_1B, DPARAM%MAXTENS_1B) + 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) @@ -92,8 +93,8 @@ SUBROUTINE EVAP_UPPER_DIFF(fuseStruct, want_dflux) M_FLUX%EVAP_1B = 0._sp select case(SMODL%iARCH1) - case(iopt_tension1_1); phi = sfrac(TSTATE%TENS_1, DPARAM%MAXTENS_1) - case(iopt_onestate_1); phi = sfrac(TSTATE%WATR_1, DPARAM%MAXTENS_1) ! NOTE: use WATR_1 + 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 @@ -111,8 +112,8 @@ SUBROUTINE EVAP_UPPER_DIFF(fuseStruct, want_dflux) ! 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) - case(iopt_onestate_1); dphi_dx = dsfrac(TSTATE%WATR_1, DPARAM%MAXTENS_1) ! NOTE: use WATR_1 + 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 diff --git a/build/FUSE_SRC/physics/qpercolate_diff.f90 b/build/FUSE_SRC/physics/qpercolate_diff.f90 index 8e19db5..8d4b14d 100644 --- a/build/FUSE_SRC/physics/qpercolate_diff.f90 +++ b/build/FUSE_SRC/physics/qpercolate_diff.f90 @@ -35,6 +35,7 @@ SUBROUTINE QPERCOLATE_DIFF(fuseStruct, want_dflux) 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(& @@ -62,8 +63,8 @@ SUBROUTINE QPERCOLATE_DIFF(fuseStruct, want_dflux) ! compute fractions select case(SMODL%iQPERC) - case(iopt_perc_w2sat); phi = sfrac(TSTATE%WATR_1, MPARAM%MAXWATR_1) - case(iopt_perc_f2sat); phi = sfrac(TSTATE%FREE_1, DPARAM%MAXFREE_1) + 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 ---------------------------------------------------------------- @@ -74,8 +75,8 @@ SUBROUTINE QPERCOLATE_DIFF(fuseStruct, want_dflux) ! compute derivative in the fractions select case(SMODL%iQPERC) - case(iopt_perc_w2sat); dphi_dx = dsfrac(TSTATE%WATR_1, MPARAM%MAXWATR_1) - case(iopt_perc_f2sat); dphi_dx = dsfrac(TSTATE%FREE_1, DPARAM%MAXFREE_1) + 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 @@ -110,7 +111,7 @@ SUBROUTINE QPERCOLATE_DIFF(fuseStruct, want_dflux) END SELECT ! -------------------------------------------------------------------------------------- - end associate ! end association with variables in the data structures- + 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 index 753dee2..fbf8d5b 100644 --- a/build/FUSE_SRC/physics/qsatexcess_diff.f90 +++ b/build/FUSE_SRC/physics/qsatexcess_diff.f90 @@ -45,6 +45,7 @@ SUBROUTINE QSATEXCESS_DIFF(fuseStruct, want_dflux) ! 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(& @@ -72,17 +73,17 @@ SUBROUTINE QSATEXCESS_DIFF(fuseStruct, want_dflux) ! ----- compute flux ---------------------------------------------------------------------------- u = 1._sp - w/wmax - xp = smax(u, 0._sp) ! smooth version of max(u,0) + 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) ! 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 + 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 diff --git a/build/FUSE_SRC/physics/smoothers.f90 b/build/FUSE_SRC/physics/smoothers.f90 index 2fec3ce..b9da7de 100644 --- a/build/FUSE_SRC/physics/smoothers.f90 +++ b/build/FUSE_SRC/physics/smoothers.f90 @@ -14,7 +14,7 @@ module smoothers ! --------------------------------------------------------------------------------------- ! --------------------------------------------------------------------------------------- - PURE FUNCTION sfrac(x,xmax) result(xf) + PURE FUNCTION sfrac(x,xmax,ms) result(xf) ! --------------------------------------------------------------------------------------- ! Creator: ! -------- @@ -28,16 +28,17 @@ PURE FUNCTION sfrac(x,xmax) result(xf) 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) ! 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 + 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) result(dxf_dx) + PURE FUNCTION dsfrac(x,xmax,ms) result(dxf_dx) ! --------------------------------------------------------------------------------------- ! Creator: ! -------- @@ -51,17 +52,18 @@ PURE FUNCTION dsfrac(x,xmax) result(dxf_dx) 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) ! note signs cancel out + 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) result(xp) + PURE FUNCTION smax(x,xmin,ms) result(xp) ! --------------------------------------------------------------------------------------- ! Creator: ! -------- @@ -79,7 +81,7 @@ PURE FUNCTION smax(x,xmin) result(xp) implicit none real(sp), intent(in) :: x ! x value real(sp), intent(in) :: xmin ! minimum value - real(sp), parameter :: ms=1.e-4_sp ! smoothing parameter + 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) @@ -89,7 +91,7 @@ end function smax ! --------------------------------------------------------------------------------------- ! --------------------------------------------------------------------------------------- - PURE FUNCTION dsmax(x,xmin) result(dxp) + PURE FUNCTION dsmax(x,xmin,ms) result(dxp) ! --------------------------------------------------------------------------------------- ! Creator: ! -------- @@ -107,7 +109,7 @@ PURE FUNCTION dsmax(x,xmin) result(dxp) implicit none real(sp), intent(in) :: x ! x value real(sp), intent(in) :: xmin ! minimum value - real(sp), parameter :: ms=1.e-4_sp ! smoothing parameter + 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) @@ -134,7 +136,7 @@ pure real(sp) function sigmoid(z, beta) result(s) real(sp), intent(in) :: z, beta real(sp) :: zb - zb = beta * z + zb = z/beta if (zb >= 0._sp) then s = 1._sp / (1._sp + exp(-zb)) @@ -147,7 +149,7 @@ end function sigmoid ! --------------------------------------------------------------------------------------- ! --------------------------------------------------------------------------------------- - pure real(sp) function dsigmoid(s, beta) result(ds_dx) + pure real(sp) function dsigmoid(s, beta) result(ds_dz) ! --------------------------------------------------------------------------------------- ! Creator: ! -------- @@ -155,12 +157,12 @@ pure real(sp) function dsigmoid(s, beta) result(ds_dx) ! --------------------------------------------------------------------------------------- ! Purpose: ! -------- - ! Derivative in the sigmoid given already have the sigmoid + ! Derivative in the sigmoid w.r.t. z given already have the sigmoid ! --------------------------------------------------------------------------------------- use nrtype implicit none real(sp), intent(in) :: s, beta - ds_dx = beta * s * (1._sp - s) + ds_dz = (s/beta) * (1._sp - s) end function dsigmoid ! --------------------------------------------------------------------------------------- diff --git a/build/FUSE_SRC/physics/update_swe_diff.f90 b/build/FUSE_SRC/physics/update_swe_diff.f90 index 40e2709..9786387 100644 --- a/build/FUSE_SRC/physics/update_swe_diff.f90 +++ b/build/FUSE_SRC/physics/update_swe_diff.f90 @@ -19,7 +19,7 @@ end function is_leap_year ! --------------------------------------------------------------------------------------- ! --------------------------------------------------------------------------------------- - SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT) + SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) ! --------------------------------------------------------------------------------------- ! Creator: ! -------- @@ -28,7 +28,7 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT) ! ! Modified by Nans Addor to enable distributed modeling, 9/2016 ! - ! Modified by Martyn Clark to extend to a differentiable model, 9/2016 + ! Modified by Martyn Clark to extend to a differentiable model, 12/2025 ! ! --------------------------------------------------------------------------------------- ! Purpose: @@ -38,12 +38,17 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT) ! --------------------------------------------------------------------------------------- USE nrtype ! variable types, etc. (includes PI) USE data_types, only: parent ! fuse parent data type - use smoothers, only: smax, sigmoid ! max and sigmoid smoothers - USE multibands ! NOTE: include in fuseStruct ! model basin band structure + use smoothers, only: smax, dsmax ! max smoothers + 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(parent) , intent(inout) :: fuseStruct ! parent fuse data 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 LOGICAL(LGT) :: LEAP ! leap year flag REAL(SP) :: JDAY ! Julian day of year @@ -55,13 +60,15 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT) real(sp) :: xOPG ! scaled Orographic Precipitation Gradient (OPG) real(sp) :: xLapse ! scaled temperature lapse rate real(sp) :: precip_adj ! adjusted precipitation (after multiplicative/additive error) + real(sp) :: xEXP ! exponential scaling factor REAL(SP) :: PRECIP_Z ! band precipitation at timestep REAL(SP) :: TEMP_Z ! band temperature at timestep INTEGER(I4B) :: ISNW ! loop through snow model bands 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=10._sp ! sigmoid sharpness for snow/rain partition (1/degC) + real(sp), parameter :: beta_px=0.1_sp ! sigmoid width for snow/rain partition (degC) + real(sp), parameter :: ms=1.e-4_sp ! smoothing in smax function 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) @@ -69,12 +76,26 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT) 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) :: SWE_prev ! SWE at start of band update (mm) + real(sp) :: dMF(NP), dPadj(NP), dPrecZ(NP), dTempZ(NP) ! derivative vectors + real(sp) :: dfsnow(NP), dsnow(NP), drain(NP) ! derivative vectors + real(sp) :: df_dz + real(sp) :: dposTemp(NP), dpotMelt(NP), dmeltCap(NP), dsnowmelt(NP) + real(sp) :: dSWE(NP), dSWE_new(NP) ! persist dSWE between timesteps for each band + real(sp) :: w_pot, w_cap ! smooth-min weights + real(sp) :: g_pos, g_cap, g_u ! dsmax factors + real(sp) :: u_swe ! pre-clamp SWE update ! --------------------------------------------------------------------------------------- ! associate variables with elements of data structure associate(& - TIMDAT => fuseStruct%time , & ! fluxes - MFORCE => fuseStruct%force , & ! fluxes + TIMDAT => fuseStruct%time , & ! time information + MFORCE => fuseStruct%force , & ! forcing data + Z_FORC => fuseStruct%z_forcing , & ! elevation of the forcing data M_FLUX => fuseStruct%flux , & ! fluxes + MBANDS => fuseStruct%sbands , & ! elevation band variables: MBANDS(i)%var%x + DERIVS => fuseStruct%sbands , & ! parameter derivatives: DERIVS(i)%dx%x MPARAM => fuseStruct%param_adjust , & ! adjustable model parameters DPARAM => fuseStruct%param_derive & ! derived model parameters ) ! (associate) @@ -83,6 +104,14 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT) ! 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 @@ -100,14 +129,37 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT) ! 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 = MAX(0.0_sp, MFORCE%PPT + MPARAM%RFERR_ADD) ! additive error - CASE(iopt_multiplc_e); precip_adj = MFORCE%PPT*MPARAM%RFERR_MLT ! multiplicative error + CASE(iopt_additive_e); precip_adj = smax(MFORCE%PPT + MPARAM%RFERR_ADD, 0._sp, ms) ! 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) ! 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 + ! --------------------------------------------------------------------------------------- ! --------------------------------------------------------------------------------------- @@ -115,55 +167,126 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT) M_FLUX%EFF_PPT = 0._sp ! check band rea fractions sum to 1 - if (abs(sum(MBANDS(:)%AF) - 1._sp) > 1.e-6_sp) stop "Band area fractions do not sum to 1" + if (abs(sum(MBANDS(:)%var%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; dmeltCap(:)=0._sp; dsnowmelt(:)=0._sp + endif + + ! copy the stored sensitivity of SWE from the previous timestep to propagate it forward + if (comp_dparam) dSWE(:) = DERIVS(ISNW)%dx%dSWE_dparam(:) + ! --- use the Orographic Precipitation Gradient (OPG) to adjust precip for elevation --- - DZ = MBANDS(ISNW)%Z_MID - Z_FORCING + DZ = MBANDS(ISNW)%var%Z_MID - Z_FORC xOPG = MPARAM%OPG / 1000._sp ! scaled OPG - PRECIP_Z = precip_adj * exp(DZ * xOPG) ! NOTE: modified from the original branch structure + xEXP = exp(DZ * xOPG) ! exponential scaling factor + PRECIP_Z = precip_adj * xEXP ! NOTE: modified from the original branch structure + + ! compute derivatives + if(comp_dparam)then + + dPrecZ(:) = dPadj(:) * xEXP ! chain from precip_adj + dPrecZ(iOPG) = dPrecZ(iOPG) + PRECIP_Z * (DZ/1000._sp) + 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 sharpness, set large because originally a step function + 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)%SNOWACCMLTN = snow + 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) ! smoothed max(TEMP_Z - MPARAM%MBASE, 0) + posTemp = smax(TEMP_Z - MPARAM%MBASE, 0._sp, ms) ! smoothed max(TEMP_Z - MPARAM%MBASE, 0) potMelt = MF*posTemp ! mm day-1 ! melt capped by availability of snow - meltCap = snow + MBANDS(ISNW)%SWE / DT - snowmelt = -smax(-potMelt, -meltCap) ! smooth min + meltCap = smax(snow + SWE_prev/DT, 0._sp, ms) - MBANDS(ISNW)%SNOWMELT = snowmelt + ! smooth snowmelt + snowmelt = -smax(-potMelt, -meltCap, ms) ! smooth min(potMelt, meltCap) + 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) + dposTemp(:) = g_pos * dTempZ(:) + dposTemp(iMBASE) = dposTemp(iMBASE) - g_pos + + ! potential melt + dpotMelt(:) = dMF(:)*posTemp + MF*dposTemp(:) + + ! melt cap + g_cap = dsmax(snow + SWE_prev/DT, 0._sp, ms) + dmeltCap(:) = g_cap * (dsnow(:) + dSWE(:)/DT) + + ! cap on snowmelt: smooth min weights + w_pot = dsmax(-potMelt, -meltCap, ms) ! ∂snowmelt/∂potMelt -- NOTE: minus sign cancels + w_cap = 1._sp - w_pot ! ∂snowmelt/∂meltCap + dsnowmelt(:) = w_pot*dpotMelt(:) + w_cap*dmeltCap(:) + + endif ! computing derivatives + ! ----- update SWE --------------------------------------------------------------------- - MBANDS(ISNW)%DSWE_DT = MBANDS(ISNW)%SNOWACCMLTN - MBANDS(ISNW)%SNOWMELT - MBANDS(ISNW)%SWE = MBANDS(ISNW)%SWE + MBANDS(ISNW)%DSWE_DT*DT - MBANDS(ISNW)%SWE = smax(MBANDS(ISNW)%SWE, 0._sp) ! safety: clamp for small roundoff + u_swe = SWE_prev + DT*(snow - snowmelt) + MBANDS(ISNW)%var%SWE = smax(u_swe, 0._sp, ms) + + if(comp_dparam)then + g_u = dsmax(u_swe, 0._sp, ms) + dSWE_new(:) = g_u * ( dSWE(:) + DT*(dsnow(:) - dsnowmelt(:)) ) + DERIVS(ISNW)%dx%dSWE_dparam(:) = dSWE_new(:) + endif ! ----- calculate effective precip (rain + melt) --------------------------------------- - M_FLUX%EFF_PPT = M_FLUX%EFF_PPT + MBANDS(ISNW)%AF * (rain + snowmelt) - + M_FLUX%EFF_PPT = M_FLUX%EFF_PPT + MBANDS(ISNW)%var%AF * (rain + snowmelt) + + if(comp_dparam)then + DERIVS(ISNW)%dx%dEffP_dParam(1:NP) = DERIVS(ISNW)%dx%dEffP_dParam(1:NP) + & + MBANDS(ISNW)%var%AF * (drain(:) + dsnowmelt(:)) + endif + END DO ! looping through elevation bands - + end associate END SUBROUTINE UPDATE_SWE_DIFF From e5093609dde9f039e889dcdbf4a5f9f1f322b135 Mon Sep 17 00:00:00 2001 From: Martyn Clark Date: Sun, 21 Dec 2025 20:40:10 -0700 Subject: [PATCH 12/16] refactor to simplify driver and add elev band dimension to output --- build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 | 497 ------------ build/FUSE_SRC/FUSE_ENGINE/metaoutput.f90 | 228 +++--- build/FUSE_SRC/FUSE_ENGINE/metaparams.f90 | 223 +++--- build/FUSE_SRC/FUSE_ENGINE/parextract.f90 | 362 +++------ build/FUSE_SRC/FUSE_ENGINE/varextract.f90 | 739 ++++++------------ build/FUSE_SRC/FUSE_NETCDF/def_output.f90 | 163 ++-- build/FUSE_SRC/FUSE_NETCDF/def_params.f90 | 168 ++-- build/FUSE_SRC/FUSE_NETCDF/put_output.f90 | 289 ++++--- build/FUSE_SRC/FUSE_NETCDF/put_params.f90 | 163 ++-- .../.svn/all-wcprops | 0 .../.svn/entries | 0 .../text-base/qnewt_mcmc__driver.f90.svn-base | 0 .../URS_driver.f90 | 0 .../qnewt_mcmc__driver.f90 | 0 .../{FUSE_DRIVERS => FUSE_PARSENS}/sobol.f90 | 0 .../fuse_stdDmdl_dmsl_mod.f90 | 0 .../make_batea_parfiles.f90 | 0 .../{FUSE_SCE => deprecated}/sce_driver.f90 | 0 .../FUSE_SRC/{FUSE_DMSL => driver}/functn.f90 | 0 build/FUSE_SRC/driver/fuse_driver.f90 | 143 ++++ .../{FUSE_DMSL => driver}/fuse_rmse.f90 | 22 +- build/FUSE_SRC/driver/get_fuse_prelim.f90 | 203 +++++ build/FUSE_SRC/driver/sce_driver.f90 | 85 ++ build/FUSE_SRC/dshare/data_types.f90 | 18 +- build/FUSE_SRC/dshare/model_defn.f90 | 2 - build/FUSE_SRC/dshare/multiparam.f90 | 3 + build/FUSE_SRC/physics/smoothers.f90 | 73 +- build/FUSE_SRC/physics/update_swe_diff.f90 | 112 ++- .../{FUSE_ENGINE => prelim}/adjust_stt.f90 | 0 .../{FUSE_ENGINE => prelim}/ascii_util.f90 | 0 .../{FUSE_ENGINE => prelim}/assign_flx.f90 | 0 .../{FUSE_ENGINE => prelim}/assign_par.f90 | 0 .../{FUSE_ENGINE => prelim}/assign_stt.f90 | 0 .../{FUSE_ENGINE => prelim}/bucketsize.f90 | 0 .../{FUSE_ENGINE => prelim}/force_info.f90 | 4 +- .../{FUSE_ENGINE => prelim}/getnumerix.f90 | 0 .../{FUSE_ENGINE => prelim}/getparmeta.f90 | 0 .../{FUSE_ENGINE => prelim}/init_state.f90 | 0 .../{FUSE_ENGINE => prelim}/init_stats.f90 | 0 .../{FUSE_ENGINE => prelim}/mean_tipow.f90 | 0 .../{FUSE_ENGINE => prelim}/par_derive.f90 | 0 build/FUSE_SRC/prelim/parse_command_args.f90 | 336 ++++++++ .../{FUSE_ENGINE => prelim}/qbsaturatn.f90 | 0 .../{FUSE_ENGINE => prelim}/qtimedelay.f90 | 0 .../{FUSE_ENGINE => prelim}/uniquemodl.f90 | 0 build/Makefile | 66 +- build/generated/fuseversion.inc | 9 + 47 files changed, 2005 insertions(+), 1903 deletions(-) delete mode 100644 build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 rename build/FUSE_SRC/{FUSE_DRIVERS => FUSE_PARSENS}/.svn/all-wcprops (100%) rename build/FUSE_SRC/{FUSE_DRIVERS => FUSE_PARSENS}/.svn/entries (100%) rename build/FUSE_SRC/{FUSE_DRIVERS => FUSE_PARSENS}/.svn/text-base/qnewt_mcmc__driver.f90.svn-base (100%) rename build/FUSE_SRC/{FUSE_DRIVERS => FUSE_PARSENS}/URS_driver.f90 (100%) rename build/FUSE_SRC/{FUSE_DRIVERS => FUSE_PARSENS}/qnewt_mcmc__driver.f90 (100%) rename build/FUSE_SRC/{FUSE_DRIVERS => FUSE_PARSENS}/sobol.f90 (100%) rename build/FUSE_SRC/{FUSE_HOOK => deprecated}/fuse_stdDmdl_dmsl_mod.f90 (100%) rename build/FUSE_SRC/{FUSE_HOOK => deprecated}/make_batea_parfiles.f90 (100%) rename build/FUSE_SRC/{FUSE_SCE => deprecated}/sce_driver.f90 (100%) rename build/FUSE_SRC/{FUSE_DMSL => driver}/functn.f90 (100%) create mode 100644 build/FUSE_SRC/driver/fuse_driver.f90 rename build/FUSE_SRC/{FUSE_DMSL => driver}/fuse_rmse.f90 (95%) create mode 100644 build/FUSE_SRC/driver/get_fuse_prelim.f90 create mode 100644 build/FUSE_SRC/driver/sce_driver.f90 rename build/FUSE_SRC/{FUSE_ENGINE => prelim}/adjust_stt.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => prelim}/ascii_util.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => prelim}/assign_flx.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => prelim}/assign_par.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => prelim}/assign_stt.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => prelim}/bucketsize.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => prelim}/force_info.f90 (99%) rename build/FUSE_SRC/{FUSE_ENGINE => prelim}/getnumerix.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => prelim}/getparmeta.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => prelim}/init_state.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => prelim}/init_stats.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => prelim}/mean_tipow.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => prelim}/par_derive.f90 (100%) create mode 100644 build/FUSE_SRC/prelim/parse_command_args.f90 rename build/FUSE_SRC/{FUSE_ENGINE => prelim}/qbsaturatn.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => prelim}/qtimedelay.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => prelim}/uniquemodl.f90 (100%) create mode 100644 build/generated/fuseversion.inc diff --git a/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 b/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 deleted file mode 100644 index 8f1d81b..0000000 --- a/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 +++ /dev/null @@ -1,497 +0,0 @@ -PROGRAM DISTRIBUTED_DRIVER -! --------------------------------------------------------------------------------------- -! Creators: -! Martyn Clark, 2011 -! Modified by Brian Henn to include snow model, 6/2013 -! Modified by Nans Addor to include distributed modeling, 9/2016 -! Modified by Nans Addor to re-enable catchment-scale modeling, 4/2017 -! --------------------------------------------------------------------------------------- -! Purpose: -! Driver program to run FUSE with a snow module as either at the catchment-scale or -! at the grid-scale -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE netcdf ! NetCDF library -USE fuse_fileManager,only:fuse_SetDirsUndPhiles,& ! sets directories and filenames - SETNGS_PATH,MBANDS_INFO,MBANDS_NC, & - OUTPUT_PATH,FORCINGINFO,INPUT_PATH,& - FMODEL_ID,& - suffix_forcing,suffix_elev_bands,& - numtim_sub_str,& - KSTOP_str, MAXN_str, PCENTO_str - -! data modules -USE model_defn,nstateFUSE=>nstate ! model definition structures -USE model_defnames ! defines the integer model options -USE globaldata, ONLY: isPrint ! flag for printing progress to screen -USE globaldata, only: nFUSE_eval ! number of fuse evaluations -USE multiforce, ONLY: forcefile,vname_aprecip ! model forcing structures -USE multiforce, ONLY: AFORCE, aValid ! time series of lumped forcing/response data -USE multiforce, ONLY: nspat1, nspat2 ! grid dimensions -USE multiforce, only: GRID_FLAG ! .true. if distributed -USE multiforce, ONLY: GFORCE, GFORCE_3d ! spatial arrays of gridded forcing data -USE multiforce, only: ancilF, ancilF_3d ! ancillary forcing data -USE multiforce, ONLY: valDat ! response data -USE multiforce, only: DELTIM -USE multiforce, only: ISTART ! index for start of inference -USE multiforce, ONLY: timeUnits,time_steps,julian_day_input ! time data -USE multiforce, only: numtim_in, itim_in ! length of input time series and associated index -USE multiforce, only: numtim_sim, itim_sim ! length of simulated time series and associated index -USE multiforce, only: numtim_sub, itim_sub ! length of subperiod time series and associated index -USE multiforce, only: sim_beg,sim_end ! timestep indices -USE multiforce, only: eval_beg,eval_end ! timestep indices -USE multiforce, only: SUB_PERIODS_FLAG ! .true. if subperiods are used to run FUSE - -USE multiforce, only: ncid_forc ! NetCDF forcing file ID -USE multiforce, only: ncid_var ! NetCDF forcing variable ID -USE globaldata, only: ncid_out ! NetCDF output file ID - -USE multibands ! basin band stuctures -USE data_types, ONLY: PARATT ! data type for metadata -USE multiparam, ONLY: LPARAM, NUMPAR ! parameter metadata structures -USE multistate, only: gState ! gridded state variables -USE multistate, only: gState_3d ! gridded state variables with a time dimension -USE multiroute, ONLY: AROUTE ! model routing structures -USE multiroute, ONLY: AROUTE_3d ! model routing structures with a time dimension -USE multistats ! model statistics structures - -! informational modules -USE selectmodl_module ! reads model control file -USE getpar_str_module ! extracts parameter metadata -USE par_insert_module ! inserts model parameters -USE force_info_module,only:force_info ! get forcing info for NetCDF files -USE get_gforce_module,only:read_ginfo ! get dimension lengths from the NetCDF file -USE get_gforce_module,only:get_varid ! get netCDF ID for forcing variables -USE get_gforce_module,only:get_gforce_3d ! get forcing -USE get_mbands_module,only:GET_MBANDS_INFO ! get elevation bands for snow modeling -USE get_fparam_module ! get SCE parameters from NetCDF file -USE GET_TIME_INDICES_MODULE ! get time indices -USE time_io - -! model numerix -USE model_numerix ! defines decisions on model numerix - -! access to model simulation modules -USE fuse_rmse_module ! run model and compute the root mean squared error - -#ifdef __MPI__ -use mpi -#endif -IMPLICIT NONE - -! --------------------------------------------------------------------------------------- -! GET COMMAND-LINE ARGUMENTS... -! --------------------------------------------------------------------------------------- -CHARACTER(LEN=256) :: DatString ! file manager -CHARACTER(LEN=256) :: dom_id ! ID of the domain -CHARACTER(LEN=10) :: fuse_mode=' ' ! fuse execution mode (run_def, run_best, run_pre, calib_sce) -CHARACTER(LEN=256) :: file_param ! name of parameter file -CHARACTER(LEN=10) :: index_param ! index of desired parameter set - -! --------------------------------------------------------------------------------------- -! SETUP MODELS FOR SIMULATION -- POPULATE DATA STRUCTURES -! --------------------------------------------------------------------------------------- -! fuse_file_manager -CHARACTER(LEN=1024) :: FFMFILE ! name of fuse_file_manager file -CHARACTER(LEN=1024) :: ELEV_BANDS_NC ! name of NetCDF file for elevation bands -! get model forcing data -INTEGER(I4B) :: NTIM ! number of time steps - still needed ? -INTEGER(I4B) :: INFERN_START ! start of inference period - still needed? -! get model setup -INTEGER(I4B) :: FUSE_ID ! integer defining FUSE model -INTEGER(I4B) :: NMOD ! number of models -INTEGER(I4B) :: ERR ! error code -CHARACTER(LEN=1024) :: MESSAGE ! error message -! get spatial option -CHARACTER(LEN=6) :: SPATIAL_OPTION ! spatial option (catch or grid) -INTEGER(I4B),PARAMETER :: LUMPED=0 ! named variable for lumped simulations -INTEGER(I4B),PARAMETER :: DISTRIBUTED=1 ! named variable for distributed simulations -! define model output -LOGICAL(LGT) :: OUTPUT_FLAG ! .TRUE. = write time series output -INTEGER(I4B) :: ONEMOD=1 ! just specify one model -! timers -INTEGER(I4B) :: T_start_import_forcing ! system clock -INTEGER(I4B) :: T_end_import_forcing ! system clock -! dummies -CHARACTER(LEN=100) :: dummy_string ! used for temporary data storage -integer(i4b) :: file_pass ! used read parameter list - -! --------------------------------------------------------------------------------------- -! RUN MODEL FOR DIFFERENT PARAMETER SETS -! --------------------------------------------------------------------------------------- -INTEGER(I4B) :: ITIM ! loop thru time steps -INTEGER(I4B) :: IPAR ! loop thru model parameters -INTEGER(I4B) :: IPSET ! index of desired model parameter set -TYPE(PARATT) :: PARAM_META ! parameter metadata (model parameters) -REAL(SP), DIMENSION(:), ALLOCATABLE :: BL ! vector of lower parameter bounds -REAL(SP), DIMENSION(:), ALLOCATABLE :: BU ! vector of upper parameter bounds -REAL(SP), DIMENSION(:), ALLOCATABLE :: APAR ! model parameter set -INTEGER(KIND=4) :: ISEED ! seed for the random sequence -REAL(KIND=4),DIMENSION(:), ALLOCATABLE :: URAND ! vector of quasi-random numbers U[0,1] -REAL(SP) :: RMSE ! error from the simulation -integer(i4b) :: NUMPSET ! number of parameter sets -! --------------------------------------------------------------------------------------- -! SCE VARIABLES -! --------------------------------------------------------------------------------------- -REAL(MSP) :: AF_MSP ! objective function value -REAL(MSP), DIMENSION(:), ALLOCATABLE :: APAR_MSP ! ! lower bound of model parameters -REAL(MSP), DIMENSION(:), ALLOCATABLE :: BL_MSP ! ! lower bound of model parameters -REAL(MSP), DIMENSION(:), ALLOCATABLE :: BU_MSP ! ! upper bound of model parameters -REAL(MSP), DIMENSION(:), ALLOCATABLE :: URAND_MSP ! vector of quasi-random numbers U[0,1] -INTEGER(I4B) :: NOPT ! number of parameters to be optimized -INTEGER(I4B) :: KSTOP ! number of shuffling loops the value must change by PCENTO -INTEGER(I4B) :: MAXN ! maximum number of trials before optimization is terminated -REAL(MSP) :: PCENTO ! the percentage -CHARACTER(LEN=3) :: CSEED ! starting seed converted to a character -INTEGER(I4B) :: NGS ! # complexes in the initial population -INTEGER(I4B) :: NPG ! # points in each complex -INTEGER(I4B) :: NPS ! # points in a sub-complex -INTEGER(I4B) :: NSPL ! # evolution steps allowed for each complex before shuffling -INTEGER(I4B) :: MINGS ! minimum number of complexes required -INTEGER(I4B) :: INIFLG ! 1 = include initial point in the population -INTEGER(I4B) :: IPRINT ! 0 = supress printing -INTEGER(I4B) :: ISCE ! unit number for SCE write -REAL(MSP) :: FUNCTN ! function name for the model run - -! --------------------------------------------------------------------------------------- -! MPI variables -! --------------------------------------------------------------------------------------- -integer ( kind = 4 ) mpi_error_value -integer ( kind = 4 ) mpi_process -integer ( kind = 4 ) mpi_nprocesses - -! --------------------------------------------------------------------------------------- -! Initialize MPI -! --------------------------------------------------------------------------------------- -#ifdef __MPI__ -call MPI_Init(mpi_error_value) -call MPI_Comm_size(MPI_COMM_WORLD, mpi_nprocesses, mpi_error_value) ! determine the number of processes involved in a communicator (mpi_nproccesses) -call MPI_Comm_rank(MPI_COMM_WORLD, mpi_process, mpi_error_value) ! determine the rank of the process in the particular communicator’s group. -#else -mpi_process = 0 -mpi_nprocesses = 1 -#endif - -! --------------------------------------------------------------------------------------- -! READ COMMAND LINE ARGUMENTS -! --------------------------------------------------------------------------------------- -! read command-line arguments -CALL GETARG(1,DatString) ! string defining forcinginfo file -CALL GETARG(2,dom_id) ! ID of the domain -CALL GETARG(3,fuse_mode) ! fuse execution mode (run_def, run_best, calib_sce) -IF(TRIM(fuse_mode).EQ.'run_pre')then - CALL GETARG(4,file_param) ! name of parameter file - CALL GETARG(5,index_param) ! index of desired parameter set - IF(LEN_TRIM(index_param).EQ.0) IPSET = 1 - IF(LEN_TRIM(index_param).GT.0) read(index_param,*) IPSET -ENDIF - -! check command-line arguments -IF (LEN_TRIM(DatString).EQ.0) STOP '1st command-line argument is missing (fileManager)' -IF (LEN_TRIM(dom_id).EQ.0) STOP '2nd command-line argument is missing (dom_id)' -IF (LEN_TRIM(fuse_mode).EQ.0) STOP '3rd command-line argument is missing (fuse_mode)' -IF(TRIM(fuse_mode).EQ.'run_pre')THEN - IF(LEN_TRIM(file_param).EQ.0) STOP '4th command-line argument is missing (file_param) and is required in mode run_pre' -ENDIF - -! print command-line arguments -print*, '1st command-line argument (fileManager) = ', trim(DatString) -print*, '2nd command-line argument (dom_id) = ', trim(dom_id) -print*, '3rd command-line argument (fuse_mode) = ', fuse_mode -IF(TRIM(fuse_mode).EQ.'run_pre')THEN - print*, '4th command-line argument (file_param) = ', file_param - print*, '5th command-line argument (index_param) = ', IPSET -ENDIF - -! --------------------------------------------------------------------------------------- -! SET PATHS AND FILES NAME -! --------------------------------------------------------------------------------------- - -! set path to fuse_file_manager -FFMFILE=DatString ! must be in bin folder and you must be in bin to run FUSE - TODO read argument to FFMFILE directly - -! set directories and filenames for control files -call fuse_SetDirsUndPhiles(fuseFileManagerIn=FFMFILE,err=err,message=message) -if (err.ne.0) write(*,*) trim(message); if (err.gt.0) stop - -! define name of forcing info and elevation band file -forcefile= trim(dom_id)//suffix_forcing -ELEV_BANDS_NC=trim(dom_id)//suffix_elev_bands - -PRINT *, 'Variables defined based on domain name:' -PRINT *, 'forcefile:', TRIM(forcefile) -PRINT *, 'ELEV_BANDS_NC:', TRIM(ELEV_BANDS_NC) - -! --------------------------------------------------------------------------------------- -! GET MODEL SETUP -- MODEL NUEMERICS, GRID, AND PARAMETER AND VARIABLE INFO FOR ALL MODELS -! --------------------------------------------------------------------------------------- - -! defines method/parameters used for numerical solution based on numerix file -CALL GETNUMERIX(ERR,MESSAGE) - -! get forcing info from the txt file, ?? including NA_VALUE ?? -call force_info(fuse_mode,err,message) -if(err/=0)then; write(*,*) trim(message); stop; endif - -print *, 'Open forcing file:', trim(INPUT_PATH)//trim(forcefile) - -! open NetCDF forcing file -err = nf90_open(trim(INPUT_PATH)//trim(forcefile), nf90_nowrite, ncid_forc) -if (err.ne.0) write(*,*) trim(message); if (err.gt.0) stop -PRINT *, 'NCID_FORC is', ncid_forc - -! get the grid info (spatial and temporal dimensions) from the NetCDF file -call read_ginfo(ncid_forc,err,message) -if(err/=0)then; write(*,*) trim(message); stop; endif - -! determine period over which to run and evaluate FUSE and their associated indices -CALL GET_TIME_INDICES() - -IF((.NOT.GRID_FLAG).AND.SUB_PERIODS_FLAG)THEN; write(*,*) 'Error: in catchment mode, FUSE must run over entire time series at once, please set numtim_sub to -9999 in the filemanager (', trim(DatString),').'; stop; endif - -! allocate space for the basin/grid-average time series -allocate(aForce(numtim_sub),aRoute(numtim_sub),stat=err) -!allocate(aForce(numtim_sub),aRoute(numtim_sub),aValid(numtim_sub),stat=err) -if(err/=0)then; write(*,*) 'unable to allocate space for basin-average time series [aForce,aRoute]'; stop; endif - -! allocate space for the forcing grid and states -allocate(ancilF(nspat1,nspat2), gForce(nspat1,nspat2), gState(nspat1,nspat2), stat=err) -if(err/=0)then; write(*,*) 'unable to allocate space for forcing grid GFORCE'; stop; endif - -! allocate space for the forcing grid and states with a time dimension - only for subperiod -allocate(AROUTE_3d(nspat1,nspat2,numtim_sub), gState_3d(nspat1,nspat2,numtim_sub+1),gForce_3d(nspat1,nspat2,numtim_sub),aValid(nspat1,nspat2,numtim_sub),stat=err) -if(err/=0)then; write(*,*) 'unable to allocate space for 3d structure'; stop; endif - -! get elevation band info, in particular N_BANDS -CALL GET_MBANDS_INFO(ELEV_BANDS_NC,err,message) ! read band data from NetCDF file -if(err/=0)then; write(*,*) trim(message); stop; endif - -! allocate space for elevation bands -allocate(MBANDS_VAR_4d(nspat1,nspat2,N_BANDS,numtim_sub+1),stat=err) -if(err/=0)then; write(*,*) 'unable to allocate space for elevation bands'; stop; endif - -! get variable ID from the NetCDF file -call get_varID(ncid_forc,err,message) -if(err/=0)then; write(*,*) 'unable to get NetCDF variables ID'; stop; endif - -! Define model attributes (valid for all models) -CALL UNIQUEMODL(NMOD) ! get nmod unique models -CALL GETPARMETA(ERR,MESSAGE) ! read parameter metadata (parameter bounds etc.) - -IF (ERR.NE.0) WRITE(*,*) TRIM(MESSAGE); IF (ERR.GT.0) STOP - -! Identify a single model -CALL SELECTMODL(FMODEL_ID,ERR=ERR,MESSAGE=MESSAGE) -IF (ERR.NE.0) WRITE(*,*) TRIM(MESSAGE); IF (ERR.GT.0) STOP - -! Define list of states and parameters for the current model -CALL ASSIGN_STT() ! state definitions are stored in module model_defn -CALL ASSIGN_FLX() ! flux definitions are stored in module model_defn -CALL ASSIGN_PAR() ! parameter definitions are stored in module multiparam - -! Compute derived model parameters (bucket sizes, etc.) -CALL PAR_DERIVE(ERR,MESSAGE) -IF (ERR.NE.0) WRITE(*,*) TRIM(MESSAGE); IF (ERR.GT.0) STOP - -! Define output and parameter files -ONEMOD=1 ! one file per model (i.e., model dimension = 1) -PCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) - -IF(fuse_mode == 'run_def')THEN ! run FUSE with default parameter values - - ! files to which model run and parameter set will be saved -#ifdef __MPI__ - write(FNAME_NETCDF_RUNS, "(A,I0.5,A)") TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_runs_def_', mpi_process, ".nc" - write(FNAME_NETCDF_PARA, "(A,I0.5,A)") TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_para_def_', mpi_process, ".nc" -#else - FNAME_NETCDF_RUNS = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_runs_def.nc' - FNAME_NETCDF_PARA = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_para_def.nc' -#endif - -ELSE IF(fuse_mode == 'run_pre')THEN ! run FUSE with pre-defined parameter values - - ! files to which model run and parameter set will be saved - FNAME_NETCDF_RUNS = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_runs_pre.nc' - FNAME_NETCDF_PARA = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_para_pre_out.nc' - - NUMPSET=1 ! only the one "desired" parameter set is run - -ELSE IF(fuse_mode == 'calib_sce')THEN ! calibrate FUSE using SCE - - ! files to which model run and parameter set will be saved - FNAME_NETCDF_RUNS = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_runs_sce.nc' - FNAME_NETCDF_PARA = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_para_sce.nc' - - ! assign algorithmic control parameters for SCE - ! convert characters to interger/MSP - READ (MAXN_STR,*) MAXN ! maximum number of trials before optimization is terminated - READ (KSTOP_STR,*) KSTOP ! number of shuffling loops the value must change by PCENTO (MAX=9) - READ (PCENTO_STR,*) PCENTO ! the percentage - - PRINT *, 'SCE parameters read from file manager:' - PRINT *, 'Maximum number of trials before SCE optimization is stopped (MAXN) = ', MAXN_STR - PRINT *, 'Number of shuffling loops the value must change by PCENTO (KSTOP) = ', KSTOP_STR - PRINT *, 'PCENTO = ', PCENTO_STR - - NOPT = NUMPAR ! number of parameters to be optimized (NUMPAR in module multiparam) - NGS = 10 ! number of complexes in the initial population - NPG = 2*NOPT + 1 ! number of points in each complex - NPS = NOPT + 1 ! number of points in a sub-complex - NSPL = 2*NOPT + 1 ! number of evolution steps allowed for each complex before shuffling - MINGS = NGS ! minimum number of complexes required - INIFLG = 1 ! 1 = include initial point in the population - IPRINT = 1 ! 0 = supress printing - - NUMPSET=1.2*MAXN ! will be used to define the parameter set dimension of the NetCDF files - ! using 1.2MAXN since the final number of parameter sets produced by SCE is unknown - -ELSE IF(fuse_mode == 'run_best')THEN ! run FUSE with best (lowest RMSE) parameter set from a previous SCE calibration - - ! file from which SCE parameters will be loaded - same as FNAME_NETCDF_PARA above - FNAME_NETCDF_PARA_SCE = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_para_sce.nc' - - ! files to which "best" SCE model run and parameter set will be saved - FNAME_NETCDF_RUNS = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_runs_best.nc' - FNAME_NETCDF_PARA = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_para_best.nc' - - NUMPSET=1 ! only the one "best" parameter set is run - -ELSE - - print *, 'Unexpected fuse_mode!' - -ENDIF - -CALL DEF_PARAMS(NUMPSET) ! define model parameters (initial CREATE) -CALL DEF_SSTATS() ! define summary statistics (REDEF) -CALL DEF_OUTPUT(nSpat1,nSpat2,NUMPSET,numtim_sim) ! define model output time series (REDEF) - -! --------------------------------------------------------------------------------------- -! RUN FUSE IN DESIRED MODE -! --------------------------------------------------------------------------------------- - -! get parameter bounds and random numbers -ALLOCATE(APAR(NUMPAR),BL(NUMPAR),BU(NUMPAR),URAND(NUMPAR)) - -DO IPAR=1,NUMPAR - CALL GETPAR_STR(LPARAM(IPAR)%PARNAME,PARAM_META) - BL(IPAR) = PARAM_META%PARLOW ! lower boundary - BU(IPAR) = PARAM_META%PARUPP ! upper boundary - APAR(IPAR) = PARAM_META%PARDEF ! using default parameter values - !if(PARAM_META%PARFIT) print*, LPARAM(IPAR)%PARNAME, PARAM_META%PARDEF -END DO - -IF(fuse_mode == 'run_def')THEN ! run FUSE with default parameter values - - OUTPUT_FLAG=.TRUE. - - print *, 'Running FUSE with default parameter values' - CALL FUSE_RMSE(APAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,NUMPSET) - print *, 'Done running FUSE with default parameter values' - -ELSE IF(fuse_mode == 'run_pre')THEN ! run FUSE with pre-defined parameter values - - OUTPUT_FLAG=.TRUE. - - FNAME_NETCDF_PARA_PRE=TRIM(OUTPUT_PATH)//file_param - PRINT *, 'Loading parameter set ',IPSET,':' - - ! load specific parameter set - CALL GET_PRE_PARAM(FNAME_NETCDF_PARA_PRE,IPSET,ONEMOD,NUMPAR,APAR) - - print *, 'Running FUSE with pre-defined parameter set' - CALL FUSE_RMSE(APAR,GRID_FLAG,NCID_FORC,RMSE,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 - - ! Calibrate FUSE with SCE - OUTPUT_FLAG=.FALSE. - - FNAME_ASCII = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_sce_output.txt' - - ! printing - isPrint = .false. ! ! turn off printing to screen - nFUSE_eval = 0 ! number of fuse eevaluations - - ! convert from SP used in FUSE to MSP used in SCE - ALLOCATE(APAR_MSP(NUMPAR),BL_MSP(NUMPAR),BU_MSP(NUMPAR),URAND_MSP(NUMPAR)) - - APAR_MSP=APAR - BL_MSP=BL - BU_MSP=BU - URAND_MSP=URAND - - ! set random seed - ISEED = 1 - - ! open up ASCII output file - print *, 'Creating SCE output file:', trim(FNAME_ASCII) - ISCE = 96; OPEN(ISCE,FILE=TRIM(FNAME_ASCII)) - - ! optimize (returns A and AF) - ! note that SCE requires the kind of APAR, BL, BU to be MSP - CALL SCEUA(APAR_MSP,AF_MSP,BL_MSP,BU_MSP,NOPT,MAXN,KSTOP,PCENTO,ISEED,& - NGS,NPG,NPS,NSPL,MINGS,INIFLG,IPRINT,ISCE) - - ! close ASCII output file - CLOSE(ISCE) - - PRINT *, 'Done running SCE!' - - ! call the function again with the optimized parameter set (to ensure the last parameter set is the optimum) - !AF_MSP = FUNCTN(NOPT,AF_MSP) - - !PRINT *, 'Done calling the function again with the optimized parameter set!' - -ELSE IF(fuse_mode == 'run_best')THEN ! run FUSE with best (lowest RMSE) parameter set from a previous SCE calibration - - OUTPUT_FLAG=.TRUE. - - ! load best SCE parameter set from NetCDF file into APAR - CALL GET_SCE_PARAM(FNAME_NETCDF_PARA_SCE,ONEMOD,NUMPAR,APAR) - - print *, 'Running FUSE with best SCE parameter set' - CALL FUSE_RMSE(APAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,NUMPSET) - print *, 'Done running FUSE with best SCE parameter set' - -ELSE - -print *, 'Unexpected fuse_mode!' -stop - -ENDIF - -! deallocate space -DEALLOCATE(APAR,BL,BU,URAND) - -IF(SPATIAL_OPTION == 'CATCH')THEN - DEALLOCATE(aForce,aRoute,aValid) - !if(err/=0)then; write(*,*) 'unable to deallocate space for catchment modeling'; stop; endif - -ELSE - DEALLOCATE(gForce, gState) - !DEALLOCATE(ancilF_3d, gForce_3d, gState_3d,AROUTE_3d) - DEALLOCATE(gForce_3d, gState_3d,AROUTE_3d) - !if(err/=0)then; write(*,*) 'unable to deallocate space for grid modeling'; stop; endif - -ENDIF - -! close NetCDF files -IF(GRID_FLAG)THEN - PRINT *, 'Closing forcing file' - err = nf90_close(ncid_forc) - !if (err.ne.0) write(*,*) trim(message); if (err.gt.0) stop -ENDIF - -PRINT *, 'Closing output file' -err = nf90_close(ncid_out) -!if (err.ne.0) write(*,*) trim(message); if (err.gt.0) stop -PRINT *, 'Done' - -#ifdef __MPI__ -call MPI_Finalize(mpi_error_value) -#endif - -STOP -END PROGRAM DISTRIBUTED_DRIVER diff --git a/build/FUSE_SRC/FUSE_ENGINE/metaoutput.f90 b/build/FUSE_SRC/FUSE_ENGINE/metaoutput.f90 index 66765a1..7dd1901 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/metaoutput.f90 +++ b/build/FUSE_SRC/FUSE_ENGINE/metaoutput.f90 @@ -1,113 +1,119 @@ 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 - - print *, 'Creating variables for the snow model for ', N_BANDS ,'elevation bands' - - I=I+1; VNAME(I)='swe_tot '; LNAME(I)='total storage as snow '; VUNIT(I)='mm ' - - 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 - -ENDIF - -! 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' - -print *, 'Setting NOUTVAR (number of forcing, state and flux variables) to', I -NOUTVAR=I - -END SUBROUTINE VARDESCRIBE + + ! --------------------------------------------------------------------------------------- + ! 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 + + USE nrtype + + IMPLICIT NONE + + private + public :: VARDESCRIBE ! make subroutine public + public :: VNAME, LNAME, VUNIT, isBand ! make metadata variables public + public :: NOUTVAR ! make number of output variables public + + 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 + INTEGER(I4B) :: NOUTVAR ! number of output variables + + CONTAINS + ! --------------------------------------------------------------------------------------- + + 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. + I=I+1; VNAME(I)='pet '; LNAME(I)='potential evapotranspiration rate '; VUNIT(I)='mm day-1 '; isBand(i)=.false. + I=I+1; VNAME(I)='temp '; LNAME(I)='mean air temperature '; VUNIT(I)='deg.C '; isBand(i)=.false. + I=I+1; VNAME(I)='obsq '; LNAME(I)='observed runoff '; VUNIT(I)='mm timestep-1'; isBand(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. + I=I+1; VNAME(I)='tens_1a '; LNAME(I)='tension storage in the soil excess zone '; VUNIT(I)='mm '; isBand(i)=.false. + I=I+1; VNAME(I)='tens_1b '; LNAME(I)='tension storage in the soil recharge zone '; VUNIT(I)='mm '; isBand(i)=.false. + I=I+1; VNAME(I)='free_1 '; LNAME(I)='free storage in the upper layer '; VUNIT(I)='mm '; isBand(i)=.false. + I=I+1; VNAME(I)='watr_1 '; LNAME(I)='total storage in the upper layer '; VUNIT(I)='mm '; isBand(i)=.false. + I=I+1; VNAME(I)='tens_2 '; LNAME(I)='tension storage in the lower layer '; VUNIT(I)='mm '; isBand(i)=.false. + I=I+1; VNAME(I)='free_2 '; LNAME(I)='free storage in the lower layer '; VUNIT(I)='mm '; isBand(i)=.false. + I=I+1; VNAME(I)='free_2a '; LNAME(I)='free storage in the primary baseflow reservoir '; VUNIT(I)='mm '; isBand(i)=.false. + I=I+1; VNAME(I)='free_2b '; LNAME(I)='free storage in the secondary baseflow reservoir '; VUNIT(I)='mm '; isBand(i)=.false. + I=I+1; VNAME(I)='watr_2 '; LNAME(I)='total storage in the lower layer '; VUNIT(I)='mm '; isBand(i)=.false. + + ! snow states + I=I+1; VNAME(I)='swe_tot '; LNAME(I)='total storage as snow '; VUNIT(I)='mm '; isBand(i)=.false. + I=I+1; VNAME(I)='swe_z '; LNAME(I)='elevation band snow water equivalent '; VUNIT(I)='mm '; isBand(i)=.true. + + ! 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. + I=I+1; VNAME(I)='snwmelt_z '; LNAME(I)='band snowpack melt, in water equivalent '; VUNIT(I)='mm timestep-1'; isBand(i)=.true. + + ! model fluxes + I=I+1; VNAME(I)='eff_ppt '; LNAME(I)='effective precipitation rate '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. + I=I+1; VNAME(I)='satarea '; LNAME(I)='saturated area '; VUNIT(I)='- '; isBand(i)=.false. + I=I+1; VNAME(I)='qsurf '; LNAME(I)='surface runoff '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. + I=I+1; VNAME(I)='evap_1a '; LNAME(I)='evaporation from soil excess zone '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. + I=I+1; VNAME(I)='evap_1b '; LNAME(I)='evaporation from soil recharge zone '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. + I=I+1; VNAME(I)='evap_1 '; LNAME(I)='evaporation from the upper soil layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. + I=I+1; VNAME(I)='evap_2 '; LNAME(I)='evaporation from the lower soil layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. + I=I+1; VNAME(I)='rchr2excs '; LNAME(I)='flow from recharge zone to excess zone '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. + 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. + I=I+1; VNAME(I)='oflow_1 '; LNAME(I)='bucket overflow from upper soil layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. + 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. + I=I+1; VNAME(I)='qintf_1 '; LNAME(I)='interflow '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. + I=I+1; VNAME(I)='qperc_12 '; LNAME(I)='percolation from upper to lower soil layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. + I=I+1; VNAME(I)='qbase_2 '; LNAME(I)='baseflow '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. + I=I+1; VNAME(I)='qbase_2a '; LNAME(I)='baseflow from primary baseflow reservoir '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. + I=I+1; VNAME(I)='qbase_2b '; LNAME(I)='baseflow from secondary baseflow reservoir '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. + I=I+1; VNAME(I)='oflow_2 '; LNAME(I)='bucket overflow from lower soil layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. + I=I+1; VNAME(I)='oflow_2a '; LNAME(I)='bucket overflow from primary baseflow reservoir '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. + I=I+1; VNAME(I)='oflow_2b '; LNAME(I)='bucket overflow from secondary baseflow reservoir '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. + + ! 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. + I=I+1; VNAME(I)='err_tens_1a'; LNAME(I)='excessive extrapolation: upper excs tension storage'; VUNIT(I)='mm day-1 '; isBand(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. + I=I+1; VNAME(I)='err_free_1 '; LNAME(I)='excessive extrapolation: upper free storage '; VUNIT(I)='mm day-1 '; isBand(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. + I=I+1; VNAME(I)='err_tens_2 '; LNAME(I)='excessive extrapolation: lower tension storage '; VUNIT(I)='mm day-1 '; isBand(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. + I=I+1; VNAME(I)='err_free_2a'; LNAME(I)='excessive extrapolation: 1st baseflow reservoir '; VUNIT(I)='mm day-1 '; isBand(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. + I=I+1; VNAME(I)='err_watr_2 '; LNAME(I)='excessive extrapolation: lower total storage '; VUNIT(I)='mm day-1 '; isBand(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. + + ! model numerix + I=I+1; VNAME(I)='num_funcs '; LNAME(I)='number of function calls '; VUNIT(I)='- '; isBand(i)=.false. + I=I+1; VNAME(I)='numjacobian'; LNAME(I)='number of times the Jacobian is calculated '; VUNIT(I)='- '; isBand(i)=.false. + I=I+1; VNAME(I)='sub_accept' ; LNAME(I)='number of sub-steps accepted (taken) '; VUNIT(I)='- '; isBand(i)=.false. + I=I+1; VNAME(I)='sub_reject' ; LNAME(I)='number of sub-steps tried but rejected '; VUNIT(I)='- '; isBand(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. + I=I+1; VNAME(I)='max_iterns' ; LNAME(I)='maximum number of iterations in implicit euler '; VUNIT(I)='- '; isBand(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. + I=I+1; VNAME(I)='q_routed '; LNAME(I)='routed runoff '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. + + print *, 'Setting NOUTVAR (number of forcing, state and flux variables) to', I + NOUTVAR=I + + END SUBROUTINE VARDESCRIBE + END MODULE metaoutput diff --git a/build/FUSE_SRC/FUSE_ENGINE/metaparams.f90 b/build/FUSE_SRC/FUSE_ENGINE/metaparams.f90 index 34d313e..41cc6dd 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/metaparams.f90 +++ b/build/FUSE_SRC/FUSE_ENGINE/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/FUSE_ENGINE/parextract.f90 b/build/FUSE_SRC/FUSE_ENGINE/parextract.f90 index e9499d6..7eba011 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/parextract.f90 +++ b/build/FUSE_SRC/FUSE_ENGINE/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/FUSE_ENGINE/varextract.f90 b/build/FUSE_SRC/FUSE_ENGINE/varextract.f90 index f73f766..dbb1767 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/varextract.f90 +++ b/build/FUSE_SRC/FUSE_ENGINE/varextract.f90 @@ -1,508 +1,247 @@ 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 -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -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 ! variable types, etc. -! --------------------------------------------------------------------------------------- -! 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 -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 + private + public :: VAREXTRACT_3d + public :: VAREXTRACT + + CONTAINS + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + PURE FUNCTION VAREXTRACT_3d(VARNAME,nspat1,nspat2,numtim) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Nans Addor, based on Martyn Clark's 2007 VAREXTRACT + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Extracts variable "VARNAME" from relevant data structures + ! --------------------------------------------------------------------------------------- + USE model_numerix ! model numerix parameters + USE globaldata, only: NA_VALUE_SP ! missing value + 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 + ! input + CHARACTER(*), INTENT(IN) :: VARNAME ! variable name + INTEGER(i4b), INTENT(IN) :: nspat1,nspat2 ! number of elements in spat1, spat2 (lon, lat) + 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 + + ! --------------------------------------------------------------------------------------- + ! 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') ; 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 + + ! 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 + + ! 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 + + ! default + case default; XVAR_3d = NA_VALUE_SP + + END SELECT + + ! save the output + VAREXTRACT_3d = XVAR_3d + + ! --------------------------------------------------------------------------------------- + END FUNCTION VAREXTRACT_3d + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + ! --------------------------------------------------------------------------------------- + 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 + ! Modified by Martyn Clark to use dimension for elevation bands, 12/2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Extracts variable "VARNAME" from relevant data structures + ! --------------------------------------------------------------------------------------- + USE model_numerix ! model numerix parameters + USE globaldata, only: NA_VALUE_SP ! missing value + USE multiforce, only: MFORCE, valDat ! model forcing data + USE multistate, only: FSTATE ! model states + USE multi_flux, only: W_FLUX ! model fluxes + USE multiroute, only: MROUTE ! routed runoff + IMPLICIT NONE + ! input + CHARACTER(*), INTENT(IN) :: VARNAME ! variable name + ! internal + REAL(SP) :: XVAR ! variable + ! output + REAL(SP) :: VAREXTRACT ! FUNCTION name + ! --------------------------------------------------------------------------------------- + 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_tot') ; XVAR = FSTATE%swe_tot + + ! 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 + + ! 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 + + ! default + case default; XVAR = NA_VALUE_SP + + END SELECT + + ! and, save the output + VAREXTRACT = XVAR + ! --------------------------------------------------------------------------------------- + END FUNCTION VAREXTRACT -! save the output -VAREXTRACT_3d = XVAR_3d -! --------------------------------------------------------------------------------------- -END FUNCTION VAREXTRACT_3d END MODULE VAREXTRACT_MODULE diff --git a/build/FUSE_SRC/FUSE_NETCDF/def_output.f90 b/build/FUSE_SRC/FUSE_NETCDF/def_output.f90 index ebd3dc9..abf6450 100644 --- a/build/FUSE_SRC/FUSE_NETCDF/def_output.f90 +++ b/build/FUSE_SRC/FUSE_NETCDF/def_output.f90 @@ -1,24 +1,42 @@ -SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,NPSET,NTIM) +MODULE DEF_OUTPUT_MODULE + + USE nrtype ! variable types, etc. + + implicit none + + private + public :: DEF_OUTPUT + + contains + + SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,n_bands,NTIM) ! --------------------------------------------------------------------------------------- ! Creator: ! -------- ! Martyn Clark, 2007 + ! Modified by Martyn Clark to include elevation bands, 12/2025 ! --------------------------------------------------------------------------------------- ! Purpose: ! -------- ! Define NetCDF output files -- time-varying model output ! --------------------------------------------------------------------------------------- - USE nrtype ! variable types, etc. - USE model_defn ! 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 + ! subroutines + USE metaoutput, only: VARDESCRIBE ! define metadata for model variables + + ! data modules + USE globaldata, only: FUSE_VERSION, FUSE_BUILDTIME, FUSE_GITBRANCH, FUSE_GITHASH + USE metaoutput, only: NOUTVAR ! number of output variables + USE metaoutput, only: VNAME, LNAME, VUNIT ! metadata for all model variables + USE metaoutput, only: isBand ! logical flag to define vars with elevation dimension + USE model_defn, only: FNAME_NETCDF_RUNS ! model definition (includes filename) + 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 multiforce, only: latUnits,lonUnits ! lat/lon units string + USE multiforce, only: timeUnits ! time units string USE globaldata, only: ncid_out ! NetCDF output file ID IMPLICIT NONE @@ -26,7 +44,7 @@ SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,NPSET,NTIM) ! 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 + INTEGER(I4B), INTENT(IN) :: n_bands ! number of elevation bands ! internal REAL(MSP),DIMENSION(nspat1) :: longitude_msp ! desired variable (SINGLE PRECISION) @@ -39,62 +57,33 @@ SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,NPSET,NTIM) 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) :: band_dim ! band dimension + INTEGER(I4B), DIMENSION(3) :: TVAR ! dimension list: exclude band + INTEGER(I4B), DIMENSION(4) :: EVAR ! dimension list: include band 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 + + ! 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 + 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, 'band', n_bands, band_dim); CALL HANDLE_ERR(IERR) + 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) + + ! define dimension vector + TVAR = (/lon_dim, lat_dim, NTIM_DIM/) + EVAR = (/lon_dim, lat_dim, band_dim, NTIM_DIM/) ! define time-varying output variables DO IVAR=1,NOUTVAR @@ -103,40 +92,25 @@ SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,NPSET,NTIM) ! 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 (TRIM(VNAME(IVAR)).EQ.'q_routed') 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) + if(isBand(iVar))then + IERR = NF_DEF_VAR(ncid_out,TRIM(VNAME(IVAR)),NF_REAL,4,EVAR,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 + ! define missing value 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) + + ! write metadata + 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_PUT_ATT_REAL(ncid_out,IVAR_ID,'_FillValue',NF_FLOAT,1,NA_VALUE_OUT_MSP); CALL HANDLE_ERR(IERR) END DO ! ivar @@ -155,16 +129,20 @@ SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,NPSET,NTIM) 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 + ! define the band variable + ierr = nf_def_var(ncid_out,'band',nf_int,1,(/band_dim/),ivar_id); call handle_err(ierr) + ierr = nf_put_att_text(ncid_out,ivar_id,'units',1,'-'); call handle_err(ierr) + + ! 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 @@ -173,25 +151,12 @@ SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,NPSET,NTIM) 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 + PRINT *, 'NetCDF file for model runs defined with dimensions', n_bands, nSpat1 , nSpat2, NTIM - !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) + ! close output file IERR = NF_CLOSE(ncid_out) - deallocate(TVAR) + ! --------------------------------------------------------------------------------------- + END SUBROUTINE DEF_OUTPUT -! --------------------------------------------------------------------------------------- -END SUBROUTINE DEF_OUTPUT +END MODULE DEF_OUTPUT_MODULE diff --git a/build/FUSE_SRC/FUSE_NETCDF/def_params.f90 b/build/FUSE_SRC/FUSE_NETCDF/def_params.f90 index 0c9ea24..0e655df 100644 --- a/build/FUSE_SRC/FUSE_NETCDF/def_params.f90 +++ b/build/FUSE_SRC/FUSE_NETCDF/def_params.f90 @@ -1,67 +1,101 @@ -SUBROUTINE DEF_PARAMS(NPAR) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! Modified by Nans Addor to include snow routine -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Define NetCDF output files -- parameter variables -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition (includes filename) -USE metaparams ! metadata for all model parameters -USE multistats, ONLY: MSTATS ! model statistics structure -USE globaldata, only: ncid_out ! NetCDF output file ID -IMPLICIT NONE -! input -INTEGER(I4B), INTENT(IN) :: NPAR ! number of parameter sets -! internal -INTEGER(I4B) :: IERR ! error code -INTEGER(I4B) :: NPAR_DIM ! number of parameter sets -INTEGER(I4B) :: NMOD_DIM ! number of models -INTEGER(I4B) :: NDIF_DIM ! differences in models -INTEGER(I4B) :: NAME_DIM ! length of string defining models -INTEGER(I4B) :: ERRM_DIM ! length of string defining error message -INTEGER(I4B), DIMENSION(1) :: FVAR ! fixed dimensions -INTEGER(I4B), DIMENSION(3) :: SVAR ! model descriptor dimensions -INTEGER(I4B), DIMENSION(3) :: EVAR ! error message dimensions -INTEGER(I4B) :: IVAR ! loop through variables -INTEGER(I4B) :: IVAR_ID ! variable ID -include 'netcdf.inc' ! use netCDF libraries -! --------------------------------------------------------------------------------------- -CALL PARDESCRIBE() ! get list of parameter descriptions -! --------------------------------------------------------------------------------------- -PRINT *, 'Define NetCDF output files - parameter variables = ', TRIM(FNAME_NETCDF_PARA) -! Create file -IERR = NF_CREATE(TRIM(FNAME_NETCDF_PARA),NF_CLOBBER,ncid_out); CALL HANDLE_ERR(IERR) - ! define dimensions - ! IERR = NF_DEF_DIM(ncid_out,'mod',NMOD,NMOD_DIM); CALL HANDLE_ERR(IERR) -! IERR = NF_DEF_DIM(ncid_out,'par',NF_UNLIMITED,NPAR_DIM); CALL HANDLE_ERR(IERR) - IERR = NF_DEF_DIM(ncid_out,'par',NPAR,NPAR_DIM); CALL HANDLE_ERR(IERR) ! TODO : max number of parameter - should not be hard-coded - !IERR = NF_DEF_DIM(ncid_out,'model_differences',9,NDIF_DIM); CALL HANDLE_ERR(IERR) !TODO: this should not be hard-coded - !IERR = NF_DEF_DIM(ncid_out,'model_name_length',10,NAME_DIM); CALL HANDLE_ERR(IERR) - !IERR = NF_DEF_DIM(ncid_out,'error_message_length',LEN(MSTATS%ERR_MESSAGE),ERRM_DIM) - ! assign dimensions to indices - FVAR = (/NPAR_DIM/) ! dimensions for fixed output (parameters) - !SVAR = (/NAME_DIM,NDIF_DIM,NMOD_DIM/) ! dimensions for model names - !EVAR = (/ERRM_DIM,NMOD_DIM,NPAR_DIM/) ! dimensions for error messages - ! define fixed output variables - DO IVAR=1,NOUTPAR - IERR = NF_DEF_VAR(ncid_out,TRIM(PNAME(IVAR)),NF_REAL,1,FVAR,IVAR_ID); CALL HANDLE_ERR(IERR) - IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'long_name',LEN_TRIM(PDESC(IVAR)),TRIM(PDESC(IVAR))) - CALL HANDLE_ERR(IERR) - IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'units',LEN_TRIM(PUNIT(IVAR)),TRIM(PUNIT(IVAR))) - CALL HANDLE_ERR(IERR) - IERR = NF_PUT_ATT_REAL(ncid_out,IVAR_ID,'_FillValue',NF_REAL,1,-9999.); CALL HANDLE_ERR(IERR) - END DO ! ivar - ! define model definitions - !IERR = NF_DEF_VAR(ncid_out,'model_description',NF_CHAR,3,SVAR,IVAR_ID); CALL HANDLE_ERR(IERR) - ! define error messages - !IERR = NF_DEF_VAR(ncid_out,'error_message',NF_CHAR,3,EVAR,IVAR_ID); CALL HANDLE_ERR(IERR) -! end definitions and close file -IERR = NF_ENDDEF(ncid_out) -IERR = NF_CLOSE(ncid_out) -! --------------------------------------------------------------------------------------- -END SUBROUTINE DEF_PARAMS +MODULE DEF_PARAMS_MODULE + + USE nrtype ! variable types, etc. + + implicit none + + private + public :: DEF_PARAMS + + contains + + SUBROUTINE DEF_PARAMS(NPAR) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Nans Addor to include snow routine + ! Modified by Matyn Clark to include band dimension, 12/2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Define NetCDF output files -- parameter variables + ! --------------------------------------------------------------------------------------- + + ! subroutines + USE metaparams, only: PARDESCRIBE ! define metadata for model parameters + + ! data modules + USE metaparams, only: NOUTPAR ! number of model parameters + USE metaparams, only: PNAME, PDESC, PUNIT ! metadata for all model parameters + USE metaparams, only: isBand ! logical flag to define vars with elevation dimension + USE model_defn, only: FNAME_NETCDF_PARA ! model definition (includes filename) + USE multistats, ONLY: MSTATS ! model statistics structure + USE multibands, ONLY: N_BANDS ! number of elevation bands + USE globaldata, only: ncid_out ! NetCDF output file ID + USE globaldata, only: FUSE_VERSION, FUSE_BUILDTIME, FUSE_GITBRANCH, FUSE_GITHASH + + IMPLICIT NONE + + ! input + INTEGER(I4B), INTENT(IN) :: NPAR ! number of parameter sets + + ! internal + INTEGER(I4B) :: IERR ! error code + INTEGER(I4B) :: PAR_DIM ! parameter set dimension + INTEGER(I4B) :: BAND_DIM ! elevation band dimension + INTEGER(I4B), DIMENSION(1) :: DIMS1 ! 1-d parameter vector + INTEGER(I4B), DIMENSION(2) :: DIMS2 ! 2-d parameter-bands matrix + INTEGER(I4B) :: IVAR ! loop through variables + INTEGER(I4B) :: IVAR_ID ! variable ID + + include 'netcdf.inc' ! use netCDF libraries + + ! --------------------------------------------------------------------------------------- + CALL PARDESCRIBE() ! get list of parameter descriptions + ! --------------------------------------------------------------------------------------- + + PRINT *, 'Define NetCDF output files - parameter variables = ', TRIM(FNAME_NETCDF_PARA) + + ! Create file + IERR = NF_CREATE(TRIM(FNAME_NETCDF_PARA),NF_CLOBBER,ncid_out); CALL HANDLE_ERR(IERR) + + ! define dimensions + IERR = NF_DEF_DIM(ncid_out, 'par', NPAR, PAR_DIM); CALL HANDLE_ERR(IERR) + IERR = NF_DEF_DIM(ncid_out, 'band', N_BANDS, BAND_DIM); CALL HANDLE_ERR(IERR) + + ! assign dimensions to indices + DIMS1 = (/PAR_DIM/) ! 1-d parameter vector + DIMS2 = (/PAR_DIM, BAND_DIM/) ! 2-d parameter-bands matrix + + ! define fixed output variables + DO IVAR=1,NOUTPAR + + ! define variables + if(isBand(iVar))then + IERR = NF_DEF_VAR(ncid_out, TRIM(PNAME(IVAR)), NF_REAL, 2, DIMS2, IVAR_ID); CALL HANDLE_ERR(IERR) + else + IERR = NF_DEF_VAR(ncid_out, TRIM(PNAME(IVAR)), NF_REAL, 1, DIMS1, IVAR_ID); CALL HANDLE_ERR(IERR) + endif + + ! define metadata + IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'long_name',LEN_TRIM(PDESC(IVAR)),TRIM(PDESC(IVAR))); CALL HANDLE_ERR(IERR) + IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'units',LEN_TRIM(PUNIT(IVAR)),TRIM(PUNIT(IVAR))); CALL HANDLE_ERR(IERR) + IERR = NF_PUT_ATT_REAL(ncid_out,IVAR_ID,'_FillValue',NF_REAL,1,-9999.); CALL HANDLE_ERR(IERR) + + END DO ! ivar + + ! add global attributes + ierr = NF_PUT_ATT_TEXT(ncid_out, NF_GLOBAL, "software", len("FUSE"), "FUSE"); call HANDLE_ERR(ierr) + ierr = NF_PUT_ATT_TEXT(ncid_out, NF_GLOBAL, "fuse_version", len_trim(FUSE_VERSION), trim(FUSE_VERSION)); call HANDLE_ERR(ierr) + ierr = NF_PUT_ATT_TEXT(ncid_out, NF_GLOBAL, "fuse_build_time", len_trim(FUSE_BUILDTIME), trim(FUSE_BUILDTIME)); call HANDLE_ERR(ierr) + ierr = NF_PUT_ATT_TEXT(ncid_out, NF_GLOBAL, "fuse_git_branch", len_trim(FUSE_GITBRANCH), trim(FUSE_GITBRANCH)); call HANDLE_ERR(ierr) + ierr = NF_PUT_ATT_TEXT(ncid_out, NF_GLOBAL, "fuse_git_hash", len_trim(FUSE_GITHASH), trim(FUSE_GITHASH)); call HANDLE_ERR(ierr) + + ! end definitions and close file + IERR = NF_ENDDEF(ncid_out) + IERR = NF_CLOSE(ncid_out) + ! --------------------------------------------------------------------------------------- + END SUBROUTINE DEF_PARAMS + +END MODULE DEF_PARAMS_MODULE diff --git a/build/FUSE_SRC/FUSE_NETCDF/put_output.f90 b/build/FUSE_SRC/FUSE_NETCDF/put_output.f90 index 99d6676..7b995db 100644 --- a/build/FUSE_SRC/FUSE_NETCDF/put_output.f90 +++ b/build/FUSE_SRC/FUSE_NETCDF/put_output.f90 @@ -1,190 +1,221 @@ -SUBROUTINE PUT_OUTPUT(iSpat1,iSpat2,ITIM,IMOD,IPAR) +MODULE PUT_OUTPUT_MODULE + USE nrtype ! variable types, etc. + + implicit none + + private + public :: PUT_GOUTPUT_3D + + contains + + SUBROUTINE PUT_GOUTPUT_3D(istart_sim,istart_in,numtim) ! --------------------------------------------------------------------------------------- ! Creator: ! -------- - ! Martyn Clark, 2007 + ! Nans Addor, based on Martyn Clark's 2007 PUT_OUTPUT + ! Modified by Marytn Clark to use the elevation band dimension, 12/2025 ! --------------------------------------------------------------------------------------- ! Purpose: ! -------- - ! write NetCDF output files + ! write a 3D (or 4D) 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 data - USE globaldata, only: ncid_out ! NetCDF output file ID + + ! subroutines + USE varextract_module, only: VAREXTRACT_3d ! interface for the function to extract variables + + ! data + USE model_defn, only: FNAME_NETCDF_RUNS ! model definition (includes filename) + USE metaoutput, only: NOUTVAR ! number of output variables + USE metaoutput, only: VNAME, LNAME, VUNIT ! metadata for all model variables + USE metaoutput, only: isBand ! logical flag to define vars with elevation dimension + USE multibands, only: MBANDS_VAR_4d, N_BANDS ! variables for elevation bands + USE multiforce, only: timDat,time_steps ! time data + USE multiforce, only: nspat1,nspat2,startSpat2 ! spatial dimensions + USE multiforce, only: gForce_3d ! test only + USE multiforce, only: GRID_FLAG ! .true. if distributed + USE globaldata, only: ncid_out ! NetCDF output file ID + USE fuse_fileManager, only: Q_ONLY ! only write streamflow to output file? 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 + 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 + ! 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) + LOGICAL(LGT) :: WRITE_VAR ! used to denote if the variable is written + INTEGER(I4B) :: IERR ! error code + integer(i4b), dimension(3) :: start3 ! start indices: exclude elevation bands + integer(i4b), dimension(3) :: count3 ! count indices: exclude elevation bands + integer(i4b), dimension(4) :: start4 ! start indices: include elevation bands + integer(i4b), dimension(4) :: count4 ! count indices: include elevation bands + 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 3-d variable (SINGLE PRECISION) + REAL(MSP), DIMENSION(nspat1,nspat2,numtim) :: AVAR_3d ! desired 3-d variable (SINGLE PRECISION) + REAL(SP), DIMENSION(nspat1,nspat2,n_bands,numtim) :: XVAR_4d ! desired 4-d variable (SINGLE PRECISION) + REAL(MSP), DIMENSION(nspat1,nspat2,n_bands,numtim) :: AVAR_4d ! desired 4-d variable (SINGLE PRECISION) + REAL(MSP), DIMENSION(numtim) :: tDat ! time data + REAL(SP), DIMENSION(numtim) :: time_steps_sub ! time data + INTEGER(I4B) :: IVAR_ID ! variable ID + + INCLUDE 'netcdf.inc' ! use netCDF libraries + + + ! define dimension list (exclude elevation bands) + ! NOTE: if enabling parallel output you need 1,startSpat2 instead of 1,1 below + start3 = (/1,1,istart_sim/) + count3 = (/nspat1,nspat2,numtim/) + + ! define dimension list (exclude elevation bands) + start4 = (/1,1,1,istart_sim/) + count4 = (/nspat1,nspat2,n_bands,numtim/) - ! define indices for model output - INDX = (/iSpat1,iSpat2,ITIM/) + ! open file + IERR = NF_OPEN(TRIM(FNAME_NETCDF_RUNS),NF_WRITE,ncid_out) + CALL HANDLE_ERR(IERR) - ! loop through time-varying model output + ! loop through variables with 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 + ! 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.'q_instnt') WRITE_VAR=.TRUE. + IF (TRIM(VNAME(IVAR)).EQ.'q_routed') WRITE_VAR=.TRUE. + IF (.NOT.WRITE_VAR) CYCLE ! start new iteration of do loop, i.e. skip writting variable + 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 + ! get variable ID + IERR = NF_INQ_VARID(ncid_out,TRIM(VNAME(IVAR)),IVAR_ID) + CALL HANDLE_ERR(IERR) + + ! 3-d variables + if(.not.isBand(iVar))then + + ! write 3-d matrix + XVAR_3d = VAREXTRACT_3d(VNAME(IVAR), nspat1, nspat2, numtim); AVAR_3d = XVAR_3d ! get variable and convert format + IERR = NF_PUT_VARA_REAL(ncid_out, IVAR_ID, start3, count3, AVAR_3d) ! write data + CALL HANDLE_ERR(IERR) + + ! 4-d variables + else + + ! extract variable from 4-D elevation band matrix + select case (trim(VNAME(IVAR))) + case ('swe_z' ); XVAR_4d = MBANDS_VAR_4d(:,:,:,1:numtim)%SWE + case ('snwacml_z'); XVAR_4d = MBANDS_VAR_4d(:,:,:,1:numtim)%SNOWACCMLTN + case ('snwmelt_z'); XVAR_4d = MBANDS_VAR_4d(:,:,:,1:numtim)%SNOWMELT + case default; stop "put_output.f90: cannot identify elevation band variable: "//trim(VNAME(IVAR)) + end select + aVar_4d = xVar_4d ! use MSP to write single precision + + ! write 4-d matrix + IERR = NF_PUT_VARA_REAL(ncid_out, IVAR_ID, START4, COUNT4, AVAR_4d) + call HANDLE_ERR(IERR) + + endif ! (switch between 3-d and 4-d variables) 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 + 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) -END SUBROUTINE PUT_OUTPUT + END SUBROUTINE PUT_GOUTPUT_3D + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + SUBROUTINE PUT_OUTPUT(iSpat1, iSpat2, ITIM) -SUBROUTINE PUT_GOUTPUT_3D(istart_sim,istart_in,numtim,IPSET) ! --------------------------------------------------------------------------------------- ! Creator: ! -------- - ! Nans Addor, based on Martyn Clark's 2007 PUT_OUTPUT + ! Martyn Clark, 2007 ! --------------------------------------------------------------------------------------- ! Purpose: ! -------- - ! write a 3D data structure to the NetCDF output file + ! 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_steps ! time data - USE multiforce, ONLY: nspat1,nspat2,startSpat2 ! spatial dimensions - USE multiforce, ONLY: gForce_3d ! test only - USE multiforce, only: GRID_FLAG ! .true. if distributed - USE globaldata, only: ncid_out ! NetCDF output file ID - IMPLICIT NONE + ! subroutines + USE varextract_module, only: VAREXTRACT ! interface for the function to extract variables + + ! data + USE model_defn, only: FNAME_NETCDF_RUNS ! model definition (includes filename) + USE metaoutput, only: NOUTVAR ! number of output variables + USE metaoutput, only: VNAME, LNAME, VUNIT ! metadata for all model variables + USE metaoutput, only: isBand ! logical flag to define vars with elevation dimension + USE multibands, only: MBANDS, N_BANDS ! variables for elevation bands + USE multiforce, only: timDat,time_steps ! time data + USE multiforce, only: nspat1,nspat2,startSpat2 ! spatial dimensions + USE multiforce, only: gForce_3d ! test only + USE multiforce, only: GRID_FLAG ! .true. if distributed + USE globaldata, only: ncid_out ! NetCDF output file ID + USE fuse_fileManager, only: Q_ONLY ! only write streamflow to output file? + 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 - + 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 ! 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), 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(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 + 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 - ! 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 + 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 (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 + ! 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.'q_instnt') WRITE_VAR=.TRUE. + IF (TRIM(VNAME(IVAR)).EQ.'q_routed') WRITE_VAR=.TRUE. + IF (.NOT.WRITE_VAR) CYCLE + 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 + ! 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 - 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 + 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) - deallocate(tDat,time_steps_sub,IND_START,IND_COUNT) - -END SUBROUTINE PUT_GOUTPUT_3D + END SUBROUTINE PUT_OUTPUT + +END MODULE PUT_OUTPUT_MODULE diff --git a/build/FUSE_SRC/FUSE_NETCDF/put_params.f90 b/build/FUSE_SRC/FUSE_NETCDF/put_params.f90 index 46430b9..6173832 100644 --- a/build/FUSE_SRC/FUSE_NETCDF/put_params.f90 +++ b/build/FUSE_SRC/FUSE_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)%AF, ib=1,n_bands) ] + case ('Z_MID'); xVec(1:n_bands) = [ (MBANDS(ib)%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/FUSE_DRIVERS/.svn/all-wcprops b/build/FUSE_SRC/FUSE_PARSENS/.svn/all-wcprops similarity index 100% rename from build/FUSE_SRC/FUSE_DRIVERS/.svn/all-wcprops rename to build/FUSE_SRC/FUSE_PARSENS/.svn/all-wcprops diff --git a/build/FUSE_SRC/FUSE_DRIVERS/.svn/entries b/build/FUSE_SRC/FUSE_PARSENS/.svn/entries similarity index 100% rename from build/FUSE_SRC/FUSE_DRIVERS/.svn/entries rename to build/FUSE_SRC/FUSE_PARSENS/.svn/entries diff --git a/build/FUSE_SRC/FUSE_DRIVERS/.svn/text-base/qnewt_mcmc__driver.f90.svn-base b/build/FUSE_SRC/FUSE_PARSENS/.svn/text-base/qnewt_mcmc__driver.f90.svn-base similarity index 100% rename from build/FUSE_SRC/FUSE_DRIVERS/.svn/text-base/qnewt_mcmc__driver.f90.svn-base rename to build/FUSE_SRC/FUSE_PARSENS/.svn/text-base/qnewt_mcmc__driver.f90.svn-base diff --git a/build/FUSE_SRC/FUSE_DRIVERS/URS_driver.f90 b/build/FUSE_SRC/FUSE_PARSENS/URS_driver.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DRIVERS/URS_driver.f90 rename to build/FUSE_SRC/FUSE_PARSENS/URS_driver.f90 diff --git a/build/FUSE_SRC/FUSE_DRIVERS/qnewt_mcmc__driver.f90 b/build/FUSE_SRC/FUSE_PARSENS/qnewt_mcmc__driver.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DRIVERS/qnewt_mcmc__driver.f90 rename to build/FUSE_SRC/FUSE_PARSENS/qnewt_mcmc__driver.f90 diff --git a/build/FUSE_SRC/FUSE_DRIVERS/sobol.f90 b/build/FUSE_SRC/FUSE_PARSENS/sobol.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DRIVERS/sobol.f90 rename to build/FUSE_SRC/FUSE_PARSENS/sobol.f90 diff --git a/build/FUSE_SRC/FUSE_HOOK/fuse_stdDmdl_dmsl_mod.f90 b/build/FUSE_SRC/deprecated/fuse_stdDmdl_dmsl_mod.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_HOOK/fuse_stdDmdl_dmsl_mod.f90 rename to build/FUSE_SRC/deprecated/fuse_stdDmdl_dmsl_mod.f90 diff --git a/build/FUSE_SRC/FUSE_HOOK/make_batea_parfiles.f90 b/build/FUSE_SRC/deprecated/make_batea_parfiles.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_HOOK/make_batea_parfiles.f90 rename to build/FUSE_SRC/deprecated/make_batea_parfiles.f90 diff --git a/build/FUSE_SRC/FUSE_SCE/sce_driver.f90 b/build/FUSE_SRC/deprecated/sce_driver.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_SCE/sce_driver.f90 rename to build/FUSE_SRC/deprecated/sce_driver.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/functn.f90 b/build/FUSE_SRC/driver/functn.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DMSL/functn.f90 rename to build/FUSE_SRC/driver/functn.f90 diff --git a/build/FUSE_SRC/driver/fuse_driver.f90 b/build/FUSE_SRC/driver/fuse_driver.f90 new file mode 100644 index 0000000..dc7ae6f --- /dev/null +++ b/build/FUSE_SRC/driver/fuse_driver.f90 @@ -0,0 +1,143 @@ +PROGRAM DISTRIBUTED_DRIVER +! --------------------------------------------------------------------------------------- +! Creators: +! Martyn Clark, 2011 +! Modified by Brian Henn to include snow model, 6/2013 +! Modified by Nans Addor to include distributed modeling, 9/2016 +! Modified by Nans Addor to re-enable catchment-scale modeling, 4/2017 +! Modified by Martyn Clark to modularize and simplify CLI, 12/2025 +! --------------------------------------------------------------------------------------- +! Purpose: +! Driver program to run FUSE with a snow module as either at the catchment-scale or +! at the grid-scale +! --------------------------------------------------------------------------------------- +! data types +USE nrtype ! variable types, etc. +USE data_types, only: cli_options ! command line interface options +USE multistats, only: PCOUNT ! counter + +! data +USE globaldata, only: ncid_out +USE multiparam, only: NUMPAR +USE multiforce, only: NUMPSET +USE multiforce, only: ncid_forc, GRID_FLAG, SUB_PERIODS_FLAG +USE multiForce, only: AFORCE, gForce, gForce_3d, aValid +USE multiState, only: gState, gState_3d +USE multiRoute, only: aRoute, AROUTE_3d + +! modules +USE netcdf ! NetCDF library +USE get_fuse_prelim_MODULE, only: get_fuse_prelim ! FUSE model setup +USE parse_command_args_MODULE, only: parse_command_args ! parse command line arguments +USE get_fparam_module, only: GET_PRE_PARAM, GET_SCE_PARAM ! read parameters from netcdf file +USE sce_driver_MODULE, only: sce_driver ! SCE optimization + +! model simulation modules +USE fuse_rmse_module ! run model and compute the root mean squared error + +IMPLICIT NONE + +! error control +integer(i4b) :: err ! error code +character(len=1024) :: message ! error message + +! command line arguments +type(cli_options) :: cli_opts ! command line argument options + +! parameter set; parameter bounds +REAL(SP), DIMENSION(:), ALLOCATABLE :: BL ! vector of lower parameter bounds +REAL(SP), DIMENSION(:), ALLOCATABLE :: BU ! vector of upper parameter bounds +REAL(SP), DIMENSION(:), ALLOCATABLE :: APAR ! model parameter set + +! function evaluation +REAL(SP) :: RMSE ! sim-obs differences + +! model output +LOGICAL(LGT) :: OUTPUT_FLAG ! .TRUE. = write time series output +INTEGER(I4B) :: ONEMOD=1 ! just specify one model + +! ----- set initial counters ------------------------------------------------------------ + +! Define output and parameter files +ONEMOD=1 ! one file per model (i.e., model dimension = 1) +PCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) + +! ----- parse command line arguments ---------------------------------------------------- + +call parse_command_args(cli_opts,err,message) +if(err/=0) stop trim(message) + +! ----- get preliminary information for simulation -------------------------------------- + +call get_fuse_prelim(cli_opts, APAR, BL, BU, err, message) +if(err/=0) stop trim(message) + +print*, 'Control file = ', cli_opts%control_file +print*, 'Run mode = ', cli_opts%runmode + +! --------------------------------------------------------------------------------------- +! ----- run different FUSE modes -------------------------------------------------------- +! --------------------------------------------------------------------------------------- + +! select fuse mode +select case(cli_opts%runmode) + + ! ----- single parameter set ---------------------------------------------------------- + + case('def', 'idx', 'opt') + + OUTPUT_FLAG=.TRUE. + + ! load specific parameter set given index in vector into APAR + if (cli_opts%runmode=='idx') then + CALL GET_PRE_PARAM(cli_opts%sets_file, cli_opts%indx, ONEMOD, NUMPAR, APAR) + endif + + ! load best parameter set from NetCDF file into APAR + if (cli_opts%runmode=='opt') then + CALL GET_SCE_PARAM(cli_opts%sets_file, ONEMOD, NUMPAR, APAR) + endif + + ! run FUSE + CALL FUSE_RMSE(APAR, GRID_FLAG, NCID_FORC, RMSE, OUTPUT_FLAG, NUMPSET) + + + ! ----- SCE calibration run ----------------------------------------------------------- + + case('sce') + + call sce_driver(APAR, BL, BU) + + case default + stop "cannot identify FUSE mode" + +end select ! (FUSE mode) + +! ----- finalize ------------------------------------------------------------------------ + +! deallocate space +DEALLOCATE(APAR, BL, BU, stat=err) +if(err/=0)then; write(*,*) 'unable to deallocate space for parameter vectors'; stop; endif + +DEALLOCATE(aForce, aRoute, aValid, stat=err) +if(err/=0)then; write(*,*) 'unable to deallocate space for catchment modeling'; stop; endif + +DEALLOCATE(gForce, gState, gForce_3d, gState_3d, AROUTE_3d, stat=err) +if(err/=0)then; write(*,*) 'unable to deallocate space for grid modeling'; stop; endif + +! close NetCDF files +IF(GRID_FLAG)THEN + PRINT *, 'Closing forcing file' + err = nf90_close(ncid_forc) + if(err/=0)then; message=trim(message)//' nf90_close failed: '//trim(nf90_strerror(err)); return; endif +ENDIF + +PRINT *, 'Closing output file' +err = nf90_close(ncid_out) +if(err/=0)then; message=trim(message)//' nf90_close failed: '//trim(nf90_strerror(err)); return; endif + +PRINT *, 'Done' + + +STOP +END PROGRAM DISTRIBUTED_DRIVER diff --git a/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 b/build/FUSE_SRC/driver/fuse_rmse.f90 similarity index 95% rename from build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 rename to build/FUSE_SRC/driver/fuse_rmse.f90 index c213e2c..81833e4 100644 --- a/build/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 +++ b/build/FUSE_SRC/driver/fuse_rmse.f90 @@ -36,6 +36,7 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG 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: timdat ! time structure USE multiforce, ONLY:nspat1,nspat2 ! spatial dimensions USE multiforce, ONLY:ncid_var ! NetCDF ID for forcing variables @@ -50,8 +51,10 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! 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 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 put_params_module, ONLY: put_params ! write parameters + USE put_output_module, ONLY: put_goutput_3d ! write gridded output 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 @@ -144,6 +147,13 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG CALL PAR_DERIVE(ERR,MESSAGE) IF (ERR.NE.0) WRITE(*,*) TRIM(MESSAGE); IF (ERR.GT.0) STOP + ! get elevation bands (if catchment) + if(SMODL%iSNOWM == iopt_temp_index .and. .not.GRID_FLAG)then + Z_FORCING = Z_FORCING_grid(1,1) ! elevation of forcing data (m) + MBANDS%AF = MBANDS_INFO_3d(1,1,:)%AF ! fraction of basin area in band (-) + MBANDS%Z_MID = MBANDS_INFO_3d(1,1,:)%Z_MID ! band mid-point elevation (m) + endif + if(isPrint) PRINT *, 'Writing parameter values...' CALL PUT_PARAMS(PCOUNT) @@ -221,6 +231,7 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! get the model time CALL get_modtim(itim_in,ncid_forc,ierr,message) IF(ierr/=0)THEN; PRINT*, TRIM(cmessage); STOP; ENDIF + !print*, timdat ! compute potential ET IF(computePET) CALL getPETgrid(ierr,cmessage) @@ -316,6 +327,9 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG case default; print*, "fuse_rmse: Cannot identify diff_mode"; stop 1 end select + !print*, ITIM_IN, w_flux%eff_ppt + !if(ITIM_IN > 100) stop "check" + ! ----- end of soil physics code -------------------------------------------------------------- ! perform overland flow routing @@ -386,8 +400,8 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! write model output IF (OUTPUT_FLAG) THEN - if(isPrint) 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) + if(isPrint) PRINT *, 'Write output for ',numtim_sub_cur,' time steps starting at indices', 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) if(isPrint) PRINT *, 'Done writing output' ELSE if(isPrint) PRINT *, 'OUTPUT_FLAG is set on FALSE, no output written' diff --git a/build/FUSE_SRC/driver/get_fuse_prelim.f90 b/build/FUSE_SRC/driver/get_fuse_prelim.f90 new file mode 100644 index 0000000..f274b29 --- /dev/null +++ b/build/FUSE_SRC/driver/get_fuse_prelim.f90 @@ -0,0 +1,203 @@ +module get_fuse_prelim_MODULE + + USE nrtype + USE data_types, only: cli_options, PARATT + + implicit none + + private + public :: get_fuse_prelim + +contains + + subroutine get_fuse_prelim(opts, APAR, BL, BU, err, message) + + ! access subroutines + use netcdf, only: nf90_open, nf90_nowrite, nf90_noerr, nf90_strerror + USE fuse_fileManager, only: fuse_SetDirsUndPhiles ! sets directories and filenames + USE selectmodl_module, only: selectmodl ! reads model control file + USE force_info_module, only: force_info ! get forcing info for NetCDF files + USE get_gforce_module, only: read_ginfo ! get dimension lengths from the NetCDF file + USE get_mbands_module, only: GET_MBANDS_INFO ! get elevation bands for snow modeling + USE GET_TIME_INDICES_MODULE, only: GET_TIME_INDICES ! get time indices + USE get_gforce_module, only: get_varid ! list of var ids + USE DEF_PARAMS_MODULE, only: DEF_PARAMS ! define model parameters + USE DEF_OUTPUT_MODULE, only: DEF_OUTPUT ! define model output + USE getpar_str_module ! extracts parameter metadata + USE par_insert_module ! inserts model parameters + + ! shared data + USE fuse_fileManager, only: SETNGS_PATH,MBANDS_INFO,MBANDS_NC, & + OUTPUT_PATH,FORCINGINFO,INPUT_PATH,& + FMODEL_ID,& + suffix_forcing,suffix_elev_bands,& + numtim_sub_str,& + KSTOP_str, MAXN_str, PCENTO_str + USE model_defn, only: FNAME_TEMPRY, FNAME_NETCDF_RUNS, FNAME_NETCDF_PARA + USE multiforce, only: ncid_forc, forcefile, GRID_FLAG, SUB_PERIODS_FLAG + USE multiForce, only: AFORCE, gForce, gForce_3d, ancilF, ancilF_3d, aValid + USE multiForce, only: nSpat1, nSpat2, numtim_sub + USE multiforce, only: NUMPSET, numtim_sim + USE multiState, only: gState, gState_3d + USE multiBands, only: MBANDS_VAR_4d, N_BANDS + USE multiparam, only: LPARAM, NUMPAR + USE multiparam, only: KSTOP, MAXN, PCENTO + USE multiRoute, only: aRoute, AROUTE_3d + implicit none + ! input + type(cli_options) , intent(in) :: opts ! command line interface options + ! output + real(sp) , intent(out) , allocatable :: aPar(:) ! parameter vector + real(sp) , intent(out) , allocatable :: BL(:), BU(:) ! parameter bounds + integer(i4b) , intent(out) :: err ! error code + character(len=1024) , intent(out) :: message ! error message + ! ----- internal ----------------------------------------------------------------------- + INTEGER(I4B) :: IPAR ! parameter index + INTEGER(I4B) :: NMOD ! number of models + CHARACTER(LEN=1024) :: ELEV_BANDS_NC ! name of NetCDF file for elevation bands + TYPE(PARATT) :: PARAM_META ! parameter metadata (model parameters) + CHARACTER(LEN=64) :: TAG ! tag for output file + CHARACTER(LEN=1024) :: CMESSAGE ! error message + ! --------------------------------------------------------------------------------------- + associate(& + run_mode => opts%runmode, & ! FUSE run mode + ffm_file => opts%control_file, & ! FUSE file manager file + dom_id => opts%domain_id ) ! Domain ID + ! --------------------------------------------------------------------------------------- + err=0; message='get_fuse_prelim/' + + ! ----- set paths and file names -------------------------------------------------------- + + ! set directories and filenames for control files + call fuse_SetDirsUndPhiles(fuseFileManagerIn=ffm_file,err=err,message=cmessage) + if (err/=0)then; message=trim(message)//trim(cmessage); err=20; return; endif + + ! define name of forcing info and elevation band file + forcefile= trim(dom_id)//suffix_forcing + ELEV_BANDS_NC=trim(dom_id)//suffix_elev_bands + + ! define tag + tag = ""; if(allocated(opts%tag)) tag = trim(opts%tag) + + ! temporary file name + FNAME_TEMPRY = TRIM(OUTPUT_PATH)//TRIM(dom_id)//'_'//TRIM(FMODEL_ID)//'_'//trim(tag) + + ! files to which model run and parameter set will be saved + FNAME_NETCDF_RUNS = trim(FNAME_TEMPRY)//'_runs_'//trim(run_mode)//'.nc' + FNAME_NETCDF_PARA = trim(FNAME_TEMPRY)//'_para_'//trim(run_mode)//'.nc' + + ! convert characters to integer + READ (MAXN_STR,*) MAXN ! maximum number of trials before optimization is terminated + READ (KSTOP_STR,*) KSTOP ! number of shuffling loops the value must change by PCENTO (MAX=9) + READ (PCENTO_STR,*) PCENTO ! the percentage + + PRINT *, 'Variables defined based on domain name:' + PRINT *, 'forcefile:', TRIM(forcefile) + PRINT *, 'ELEV_BANDS_NC:', TRIM(ELEV_BANDS_NC) + + ! ----- read information on numerical decisions, forcing files, and grid info ----------- + + ! defines method/parameters used for numerical solution based on numerix file + CALL GETNUMERIX(ERR,CMESSAGE) + if (err/=0)then; message=trim(message)//trim(cmessage); err=20; return; endif + + ! get forcing info from the txt file, ?? including NA_VALUE ?? + call force_info(err,cmessage) + if (err/=0)then; message=trim(message)//trim(cmessage); err=20; return; endif + print *, 'Open forcing file:', trim(INPUT_PATH)//trim(forcefile) + + ! open NetCDF forcing file + err = nf90_open(trim(INPUT_PATH)//trim(forcefile), nf90_nowrite, ncid_forc) + if (err/=0)then; message=trim(message)//' nf90_open failed: '//trim(nf90_strerror(err)); return; endif + PRINT *, 'NCID_FORC is', ncid_forc + + ! get the grid info (spatial and temporal dimensions) from the NetCDF file + call read_ginfo(ncid_forc,err,cmessage) + if (err/=0)then; message=trim(message)//trim(cmessage); err=20; return; endif + + ! determine period over which to run and evaluate FUSE and their associated indices + CALL GET_TIME_INDICES() + + ! check time indices are OK + IF((.NOT.GRID_FLAG).AND.SUB_PERIODS_FLAG)THEN + write(*,*) 'Error: in catchment mode:' + write(*,*) 'FUSE must run over entire time series at once' + write(*,*) 'Please set numtim_sub to -9999 in the filemanager (', trim(ffm_file),').' + stop 1 + endif + + ! get elevation band info, in particular N_BANDS + CALL GET_MBANDS_INFO(ELEV_BANDS_NC,err,cmessage) ! read band data from NetCDF file + if (err/=0)then; message=trim(message)//trim(cmessage); err=20; return; endif + + ! Get NetCDF ID for each variable of the forcing file + ! NOTE: populates data structures in multiforce + call get_varID(ncid_forc, err, cmessage) + if (err/=0)then; message=trim(message)//trim(cmessage); err=20; return; endif + + ! ----- define characteristics of the current model ------------------------------------- + + ! Define model attributes (valid for all models) + CALL UNIQUEMODL(NMOD) ! get nmod unique models + CALL GETPARMETA(ERR,CMESSAGE) ! read parameter metadata (parameter bounds etc.) + if (err/=0)then; message=trim(message)//trim(cmessage); err=20; return; endif + + ! Identify a single model + CALL SELECTMODL(FMODEL_ID,ERR=ERR,MESSAGE=CMESSAGE) + if (err/=0)then; message=trim(message)//trim(cmessage); err=20; return; endif + + ! Define list of states and parameters for the current model + CALL ASSIGN_STT() ! state definitions are stored in module model_defn + CALL ASSIGN_FLX() ! flux definitions are stored in module model_defn + CALL ASSIGN_PAR() ! parameter definitions are stored in module multiparam + + ! Compute derived model parameters (bucket sizes, etc.) + CALL PAR_DERIVE(ERR,CMESSAGE) + if (err/=0)then; message=trim(message)//trim(cmessage); err=20; return; endif + + ! ----- initialize parameters, statistics, and output ----------------------------------- + + ! get number of parameter sets + ! will be used to define the parameter set dimension of the NetCDF files + select case(opts%runmode) + case('def', 'idx', 'opt'); NUMPSET=1 + case('sce'); NUMPSET=1.2*MAXN ! using 1.2MAXN since the final number of parameter sets produced by SCE is unknown + end select + + CALL DEF_PARAMS(NUMPSET) ! define model parameters (initial CREATE) + CALL DEF_SSTATS() ! define summary statistics (REDEF) + CALL DEF_OUTPUT(nSpat1,nSpat2,N_BANDS,numtim_sim) ! define model output time series (REDEF) + + ! get parameter bounds and random numbers + ALLOCATE(APAR(NUMPAR),BL(NUMPAR),BU(NUMPAR)) + + DO IPAR=1,NUMPAR + CALL GETPAR_STR(LPARAM(IPAR)%PARNAME,PARAM_META) + BL(IPAR) = PARAM_META%PARLOW ! lower boundary + BU(IPAR) = PARAM_META%PARUPP ! upper boundary + APAR(IPAR) = PARAM_META%PARDEF ! using default parameter values + END DO + + ! ----- allocate space for time series, grids, and states ------------------------------- + + ! allocate space for the basin/grid-average time series + allocate(aForce(numtim_sub),aRoute(numtim_sub),stat=err) + if(err/=0)then; message=trim(message)//'unable to allocate space for basin-average time series [aForce,aRoute]'; return; endif + + ! allocate space for the forcing grid and states + allocate(ancilF(nspat1,nspat2), gForce(nspat1,nspat2), gState(nspat1,nspat2), stat=err) + if(err/=0)then; message=trim(message)//'unable to allocate space for forcing grid GFORCE'; return; endif + + ! allocate space for the forcing grid and states with a time dimension - only for subperiod + allocate(AROUTE_3d(nspat1,nspat2,numtim_sub), gState_3d(nspat1,nspat2,numtim_sub+1),gForce_3d(nspat1,nspat2,numtim_sub),aValid(nspat1,nspat2,numtim_sub),stat=err) + if(err/=0)then; message=trim(message)//'unable to allocate space for 3d structure'; return; endif + + ! allocate space for elevation bands + allocate(MBANDS_VAR_4d(nspat1,nspat2,N_BANDS,numtim_sub+1),stat=err) + if(err/=0)then; message=trim(message)//'unable to allocate space for elevation bands'; return; endif + + end associate + + end subroutine get_fuse_prelim + +end module get_fuse_prelim_MODULE diff --git a/build/FUSE_SRC/driver/sce_driver.f90 b/build/FUSE_SRC/driver/sce_driver.f90 new file mode 100644 index 0000000..a41e0d4 --- /dev/null +++ b/build/FUSE_SRC/driver/sce_driver.f90 @@ -0,0 +1,85 @@ +module sce_driver_MODULE + + USE nrtype + + implicit none + + private + public :: sce_driver + +contains + + subroutine sce_driver(APAR, BL, BU) + USE multiparam, only: MAXN ! maximum number of trials before optimization is terminated + USE multiparam, only: KSTOP ! number of shuffling loops the value must change by PCENTO + USE multiparam, only: PCENTO ! the percentage + USE multiparam, only: NUMPAR ! # parameters + USE globaldata, only: isPrint ! used to turn of printing for calibration runs + USE globaldata, only: nFUSE_eval ! # FUSE evaluations + USE model_defn, only: FNAME_TEMPRY, FNAME_ASCII + implicit none + ! input variables + real(sp), intent(in) :: APAR(:) ! model parameter set + real(sp), intent(in) :: BL(:) ! vector of lower parameter bounds + real(sp), intent(in) :: BU(:) ! vector of upper parameter bounds + ! internal variables + REAL(MSP) :: AF_MSP ! objective function value + REAL(MSP), DIMENSION(:), ALLOCATABLE :: APAR_MSP ! ! lower bound of model parameters + REAL(MSP), DIMENSION(:), ALLOCATABLE :: BL_MSP ! ! lower bound of model parameters + REAL(MSP), DIMENSION(:), ALLOCATABLE :: BU_MSP ! ! upper bound of model parameters + REAL(MSP), DIMENSION(:), ALLOCATABLE :: URAND_MSP ! vector of quasi-random numbers U[0,1] + INTEGER(I4B) :: NOPT ! number of parameters to be optimized + INTEGER(I4B) :: NGS ! # complexes in the initial population + INTEGER(I4B) :: NPG ! # points in each complex + INTEGER(I4B) :: NPS ! # points in a sub-complex + INTEGER(I4B) :: NSPL ! # evolution steps allowed for each complex before shuffling + INTEGER(I4B) :: MINGS ! minimum number of complexes required + INTEGER(I4B) :: INIFLG ! 1 = include initial point in the population + INTEGER(I4B) :: IPRINT ! 0 = supress printing + INTEGER(I4B) :: ISCE ! unit number for SCE write + integer(i4b) :: NUMPSET ! number of parameter sets + REAL(MSP) :: FUNCTN ! function name for the model run + INTEGER(KIND=4) :: ISEED ! seed for the random sequence + + NOPT = NUMPAR ! number of parameters to be optimized (NUMPAR in module multiparam) + NGS = 10 ! number of complexes in the initial population + NPG = 2*NOPT + 1 ! number of points in each complex + NPS = NOPT + 1 ! number of points in a sub-complex + NSPL = 2*NOPT + 1 ! number of evolution steps allowed for each complex before shuffling + MINGS = NGS ! minimum number of complexes required + INIFLG = 1 ! 1 = include initial point in the population + IPRINT = 1 ! 0 = supress printing + + NUMPSET=1.2*MAXN ! will be used to define the parameter set dimension of the NetCDF files + ! using 1.2MAXN since the final number of parameter sets produced by SCE is unknown + + ! convert from SP used in FUSE to MSP used in SCE + ALLOCATE(APAR_MSP(NUMPAR), BL_MSP(NUMPAR), BU_MSP(NUMPAR)) + APAR_MSP=APAR; BL_MSP=BL; BU_MSP=BU + + ! open up ASCII output file + ISCE = 96 ! (file unit) + FNAME_ASCII = FNAME_TEMPRY//'_sce_output.txt' + print *, 'Creating SCE output file:', trim(FNAME_ASCII) + OPEN(96, FILE=TRIM(FNAME_ASCII) ) + + ! printing + isPrint = .false. ! turn off printing to screen + nFUSE_eval = 0 ! number of fuse evaluations + + ! set random seed + ISEED = 1 + + ! optimize (returns A and AF) + ! note that SCE requires the kind of APAR, BL, BU to be MSP + CALL SCEUA(APAR_MSP,AF_MSP,BL_MSP,BU_MSP,NOPT,MAXN,KSTOP,PCENTO,ISEED,& + NGS,NPG,NPS,NSPL,MINGS,INIFLG,IPRINT,ISCE) + + ! close ASCII output file + CLOSE(ISCE) + + DEALLOCATE(APAR_MSP, BL_MSP, BU_MSP) + + end subroutine sce_driver + +end module sce_driver_MODULE diff --git a/build/FUSE_SRC/dshare/data_types.f90 b/build/FUSE_SRC/dshare/data_types.f90 index d2282ee..aa42ffb 100644 --- a/build/FUSE_SRC/dshare/data_types.f90 +++ b/build/FUSE_SRC/dshare/data_types.f90 @@ -3,11 +3,27 @@ module data_types use nrtype use model_defn, only:NTDH_MAX + ! -------------------------------------------------------------------------------------- + ! 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 + character(len=:), allocatable :: progress_freq ! m/d/h/never + logical(lgt) :: show_version = .false. + logical(lgt) :: show_help = .false. + end type cli_options + ! -------------------------------------------------------------------------------------- ! model time structure ! -------------------------------------------------------------------------------------- TYPE M_TIME - REAL(SP) :: STEP ! (time interval to advance model states) + REAL(SP) :: STEP ! (time interval to advance model states) END TYPE M_TIME ! -------------------------------------------------------------------------------------- diff --git a/build/FUSE_SRC/dshare/model_defn.f90 b/build/FUSE_SRC/dshare/model_defn.f90 index 0dcd28b..8c3eb75 100644 --- a/build/FUSE_SRC/dshare/model_defn.f90 +++ b/build/FUSE_SRC/dshare/model_defn.f90 @@ -50,8 +50,6 @@ MODULE model_defn ! 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 diff --git a/build/FUSE_SRC/dshare/multiparam.f90 b/build/FUSE_SRC/dshare/multiparam.f90 index cfaa939..0bffa67 100644 --- a/build/FUSE_SRC/dshare/multiparam.f90 +++ b/build/FUSE_SRC/dshare/multiparam.f90 @@ -17,5 +17,8 @@ MODULE multiparam 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 + integer(i4b) :: MAXN ! maximum number of trials before optimization is terminated + integer(i4b) :: KSTOP ! number of shuffling loops the value must change by PCENTO + REAL(MSP) :: PCENTO ! the percentage ! -------------------------------------------------------------------------------------- END MODULE multiparam diff --git a/build/FUSE_SRC/physics/smoothers.f90 b/build/FUSE_SRC/physics/smoothers.f90 index b9da7de..7ed972d 100644 --- a/build/FUSE_SRC/physics/smoothers.f90 +++ b/build/FUSE_SRC/physics/smoothers.f90 @@ -7,7 +7,9 @@ module smoothers public:: LOGISMOOTH public:: smoother public:: smax,dsmax + public:: smin,dsmin public:: sfrac,dsfrac + public:: sclamp,dsclamp contains @@ -16,10 +18,6 @@ module smoothers PURE FUNCTION sfrac(x,xmax,ms) result(xf) ! --------------------------------------------------------------------------------------- - ! Creator: - ! -------- - ! Martyn Clark, 2025 - ! --------------------------------------------------------------------------------------- ! Purpose: ! -------- ! Use smoothed min function to compute smooth fraction @@ -40,10 +38,6 @@ end function sfrac PURE FUNCTION dsfrac(x,xmax,ms) result(dxf_dx) ! --------------------------------------------------------------------------------------- - ! Creator: - ! -------- - ! Martyn Clark, 2025 - ! --------------------------------------------------------------------------------------- ! Purpose: ! -------- ! Get derivative of the smooth fraction @@ -65,10 +59,6 @@ end function dsfrac PURE FUNCTION smax(x,xmin,ms) result(xp) ! --------------------------------------------------------------------------------------- - ! Creator: - ! -------- - ! Martyn Clark, 2025 - ! --------------------------------------------------------------------------------------- ! Purpose: ! -------- ! Compute smoothed max function following Kavetski and Kuczera (2007) @@ -93,10 +83,6 @@ end function smax PURE FUNCTION dsmax(x,xmin,ms) result(dxp) ! --------------------------------------------------------------------------------------- - ! Creator: - ! -------- - ! Martyn Clark, 2025 - ! --------------------------------------------------------------------------------------- ! Purpose: ! -------- ! Compute derivative of smoothed max function of Kavetski and Kuczera (2007) @@ -118,15 +104,54 @@ PURE FUNCTION dsmax(x,xmin,ms) result(dxp) 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) ! --------------------------------------------------------------------------------------- - ! Creator: - ! -------- - ! Martyn Clark, 2025 - ! --------------------------------------------------------------------------------------- ! Purpose: ! -------- ! A simple sigmoid smoother centered on zero @@ -151,10 +176,6 @@ end function sigmoid pure real(sp) function dsigmoid(s, beta) result(ds_dz) ! --------------------------------------------------------------------------------------- - ! Creator: - ! -------- - ! Martyn Clark, 2025 - ! --------------------------------------------------------------------------------------- ! Purpose: ! -------- ! Derivative in the sigmoid w.r.t. z given already have the sigmoid @@ -171,10 +192,6 @@ end function dsigmoid PURE FUNCTION smoother(STATE,STATE_MAX,PSMOOTH) result(w_func) ! --------------------------------------------------------------------------------------- - ! Creator: - ! -------- - ! Martyn Clark, 2025 - ! --------------------------------------------------------------------------------------- ! Purpose: ! -------- ! Provides the option of different smoothers diff --git a/build/FUSE_SRC/physics/update_swe_diff.f90 b/build/FUSE_SRC/physics/update_swe_diff.f90 index 9786387..7429ecc 100644 --- a/build/FUSE_SRC/physics/update_swe_diff.f90 +++ b/build/FUSE_SRC/physics/update_swe_diff.f90 @@ -39,6 +39,7 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) USE nrtype ! variable types, etc. (includes PI) USE data_types, only: parent ! fuse parent data 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 @@ -49,26 +50,45 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) type(parent) , intent(inout) :: fuseStruct ! parent fuse data 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 + ! ----- 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 - REAL(SP) :: DZ ! vert. distance from forcing - real(sp) :: xOPG ! scaled Orographic Precipitation Gradient (OPG) - real(sp) :: xLapse ! scaled temperature lapse rate + ! 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) - real(sp) :: xEXP ! exponential scaling factor - REAL(SP) :: PRECIP_Z ! band precipitation at timestep + ! temperature lapse (simple) + real(sp) :: xLapse ! scaled temperature lapse rate REAL(SP) :: TEMP_Z ! band temperature at timestep - INTEGER(I4B) :: ISNW ! loop through snow model bands + ! orographic precipitation multiplier (OPG) + real(sp) :: xOPG ! DZ * MPARAM%OPG/1000 -- scaled OPG (dimensionless) + real(sp), parameter :: beta_DZ=100._sp ! scaling facctor in sigmoid 1/(1+exp(-x/beta)) + real(sp) :: sDZ ! sigmoid 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: smax(1-x, eps_inv, ms_inv) + real(sp), parameter :: eps_inv=1.e-2_sp ! denominator floor + real(sp), parameter :: ms_inv=1.e-6_sp ! smax smoothing factor for inv_safe + 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.1_sp ! sigmoid width for snow/rain partition (degC) - real(sp), parameter :: ms=1.e-4_sp ! smoothing in smax function + ! snowmelt + real(sp), parameter :: ms_swe =1.e-4_sp ! smoothing in smax function (SWE) + real(sp), parameter :: ms_temp=1.e-4_sp ! smoothing in smax function (temperature) + real(sp), parameter :: ms_melt=1.e-10_sp ! smoothing in smin function (snowmelt) 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) @@ -78,11 +98,11 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) 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) :: SWE_prev ! SWE at start of band update (mm) - real(sp) :: dMF(NP), dPadj(NP), dPrecZ(NP), dTempZ(NP) ! derivative vectors - real(sp) :: dfsnow(NP), dsnow(NP), drain(NP) ! derivative vectors - real(sp) :: df_dz - real(sp) :: dposTemp(NP), dpotMelt(NP), dmeltCap(NP), dsnowmelt(NP) + real(sp) :: df_dz ! precip partitioning + real(sp) :: ds_dDZ, dfpos_dOPG, dinv_dOPG, dinvsafe_dinv, dinvsafe_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) :: dposTemp(NP), dpotMelt(NP), dmeltCap(NP), dsnowmelt(NP) ! derivative vectors real(sp) :: dSWE(NP), dSWE_new(NP) ! persist dSWE between timesteps for each band real(sp) :: w_pot, w_cap ! smooth-min weights real(sp) :: g_pos, g_cap, g_u ! dsmax factors @@ -142,7 +162,7 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) ! ----- add error to the precipiation --------------------------------------------------- SELECT CASE(SMODL%iRFERR) - CASE(iopt_additive_e); precip_adj = smax(MFORCE%PPT + MPARAM%RFERR_ADD, 0._sp, ms) ! additive error + 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 @@ -153,7 +173,7 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) ! 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) ! additive error + 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 @@ -187,16 +207,46 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) ! --- use the Orographic Precipitation Gradient (OPG) to adjust precip for elevation --- + ! dimensionless OPG DZ = MBANDS(ISNW)%var%Z_MID - Z_FORC - xOPG = MPARAM%OPG / 1000._sp ! scaled OPG - xEXP = exp(DZ * xOPG) ! exponential scaling factor - PRECIP_Z = precip_adj * xEXP ! NOTE: modified from the original branch structure + xOPG = DZ * MPARAM%OPG / 1000._sp + + ! sigmoid gate on DZ + sDZ = sigmoid(DZ, beta_DZ) + + ! positive-side formula: 1 + x + fpos = 1._sp + xOPG + + ! negative-side formula: 1/(1-x), but with safe denominator + inv = 1._sp - xOPG + inv_safe = smax(inv, eps_inv, ms_inv) ! floor inv smoothly to be >= eps + fneg = 1._sp / inv_safe + + ! blended multiplier and band precip + OPG_mult = sDZ * fpos + (1._sp - sDZ) * fneg + PRECIP_Z = precip_adj * OPG_mult ! compute derivatives if(comp_dparam)then - dPrecZ(:) = dPadj(:) * xEXP ! chain from precip_adj - dPrecZ(iOPG) = dPrecZ(iOPG) + PRECIP_Z * (DZ/1000._sp) + ! derivative in sigmoid gate on DZ + ds_dDZ = dsigmoid(sDZ, beta_DZ) + + ! derivative of fpos wrt OPG + dfpos_dOPG = DZ / 1000._sp + + ! derivative of fneg wrt OPG + dinv_dOPG = -(DZ / 1000._sp) + dinvsafe_dinv = dsmax(inv, eps_inv, ms_inv) + dinvsafe_dOPG = dinvsafe_dinv * dinv_dOPG + dfneg_dOPG = -(1._sp / (inv_safe*inv_safe)) * dinvsafe_dOPG + + ! derivative of OPGmult wrt OPG + dmult_dOPG = sDZ*dfpos_dOPG + (1._sp - sDZ)*dfneg_dOPG + + ! final derivatives + dPrecZ(:) = dPadj(:) * OPG_mult + dPrecZ(iOPG) = dPrecZ(iOPG) + precip_adj*dmult_dOPG endif ! computing derivatives @@ -233,21 +283,21 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) ! ----- calculate the (smoothed) snow melt --------------------------------------------- ! potenital melt - posTemp = smax(TEMP_Z - MPARAM%MBASE, 0._sp, ms) ! smoothed max(TEMP_Z - MPARAM%MBASE, 0) + posTemp = smax(TEMP_Z - MPARAM%MBASE, 0._sp, ms_temp) ! smoothed max(TEMP_Z - MPARAM%MBASE, 0) potMelt = MF*posTemp ! mm day-1 - + ! melt capped by availability of snow - meltCap = smax(snow + SWE_prev/DT, 0._sp, ms) + meltCap = smax(snow + SWE_prev/DT, 0._sp, ms_melt) ! smooth snowmelt - snowmelt = -smax(-potMelt, -meltCap, ms) ! smooth min(potMelt, meltCap) + snowmelt = smin(potMelt, meltCap, ms_melt) ! smooth min(potMelt, meltCap) 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) + g_pos = dsmax(TEMP_Z - MPARAM%MBASE, 0._sp, ms_temp) dposTemp(:) = g_pos * dTempZ(:) dposTemp(iMBASE) = dposTemp(iMBASE) - g_pos @@ -255,12 +305,12 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) dpotMelt(:) = dMF(:)*posTemp + MF*dposTemp(:) ! melt cap - g_cap = dsmax(snow + SWE_prev/DT, 0._sp, ms) + g_cap = dsmax(snow + SWE_prev/DT, 0._sp, ms_melt) dmeltCap(:) = g_cap * (dsnow(:) + dSWE(:)/DT) ! cap on snowmelt: smooth min weights - w_pot = dsmax(-potMelt, -meltCap, ms) ! ∂snowmelt/∂potMelt -- NOTE: minus sign cancels - w_cap = 1._sp - w_pot ! ∂snowmelt/∂meltCap + w_pot = dsmin(potMelt, meltCap, ms_melt) ! ∂snowmelt/∂potMelt + w_cap = 1._sp - w_pot ! ∂snowmelt/∂meltCap dsnowmelt(:) = w_pot*dpotMelt(:) + w_cap*dmeltCap(:) endif ! computing derivatives @@ -268,10 +318,10 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) ! ----- update SWE --------------------------------------------------------------------- u_swe = SWE_prev + DT*(snow - snowmelt) - MBANDS(ISNW)%var%SWE = smax(u_swe, 0._sp, ms) + MBANDS(ISNW)%var%SWE = smax(u_swe, 0._sp, ms_swe) if(comp_dparam)then - g_u = dsmax(u_swe, 0._sp, ms) + g_u = dsmax(u_swe, 0._sp, ms_swe) dSWE_new(:) = g_u * ( dSWE(:) + DT*(dsnow(:) - dsnowmelt(:)) ) DERIVS(ISNW)%dx%dSWE_dparam(:) = dSWE_new(:) endif @@ -279,7 +329,7 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) ! ----- calculate effective precip (rain + melt) --------------------------------------- M_FLUX%EFF_PPT = M_FLUX%EFF_PPT + MBANDS(ISNW)%var%AF * (rain + snowmelt) - + if(comp_dparam)then DERIVS(ISNW)%dx%dEffP_dParam(1:NP) = DERIVS(ISNW)%dx%dEffP_dParam(1:NP) + & MBANDS(ISNW)%var%AF * (drain(:) + dsnowmelt(:)) diff --git a/build/FUSE_SRC/FUSE_ENGINE/adjust_stt.f90 b/build/FUSE_SRC/prelim/adjust_stt.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/adjust_stt.f90 rename to build/FUSE_SRC/prelim/adjust_stt.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/ascii_util.f90 b/build/FUSE_SRC/prelim/ascii_util.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/ascii_util.f90 rename to build/FUSE_SRC/prelim/ascii_util.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/assign_flx.f90 b/build/FUSE_SRC/prelim/assign_flx.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/assign_flx.f90 rename to build/FUSE_SRC/prelim/assign_flx.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/assign_par.f90 b/build/FUSE_SRC/prelim/assign_par.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/assign_par.f90 rename to build/FUSE_SRC/prelim/assign_par.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/assign_stt.f90 b/build/FUSE_SRC/prelim/assign_stt.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/assign_stt.f90 rename to build/FUSE_SRC/prelim/assign_stt.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/bucketsize.f90 b/build/FUSE_SRC/prelim/bucketsize.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/bucketsize.f90 rename to build/FUSE_SRC/prelim/bucketsize.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/force_info.f90 b/build/FUSE_SRC/prelim/force_info.f90 similarity index 99% rename from build/FUSE_SRC/FUSE_ENGINE/force_info.f90 rename to build/FUSE_SRC/prelim/force_info.f90 index 02fcbcb..7f9b6eb 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/force_info.f90 +++ b/build/FUSE_SRC/prelim/force_info.f90 @@ -6,7 +6,7 @@ module force_info_module public::force_info contains - SUBROUTINE force_info(fuse_mode,ierr,message) + SUBROUTINE force_info(ierr,message) ! --------------------------------------------------------------------------------------- ! Creator: ! -------- @@ -41,8 +41,6 @@ SUBROUTINE force_info(fuse_mode,ierr,message) USE multiforce,only:numtim_sub ! number of time steps of subperiod (will be kept in memory) IMPLICIT NONE - ! input - CHARACTER(LEN=10) , intent(in) :: fuse_mode ! fuse execution mode (run_def, run_best, calib_sce) ! output integer(i4b), intent(out) :: ierr ! error code character(*), intent(out) :: message ! error message diff --git a/build/FUSE_SRC/FUSE_ENGINE/getnumerix.f90 b/build/FUSE_SRC/prelim/getnumerix.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/getnumerix.f90 rename to build/FUSE_SRC/prelim/getnumerix.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/getparmeta.f90 b/build/FUSE_SRC/prelim/getparmeta.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/getparmeta.f90 rename to build/FUSE_SRC/prelim/getparmeta.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/init_state.f90 b/build/FUSE_SRC/prelim/init_state.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/init_state.f90 rename to build/FUSE_SRC/prelim/init_state.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/init_stats.f90 b/build/FUSE_SRC/prelim/init_stats.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/init_stats.f90 rename to build/FUSE_SRC/prelim/init_stats.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/mean_tipow.f90 b/build/FUSE_SRC/prelim/mean_tipow.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/mean_tipow.f90 rename to build/FUSE_SRC/prelim/mean_tipow.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/par_derive.f90 b/build/FUSE_SRC/prelim/par_derive.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/par_derive.f90 rename to build/FUSE_SRC/prelim/par_derive.f90 diff --git a/build/FUSE_SRC/prelim/parse_command_args.f90 b/build/FUSE_SRC/prelim/parse_command_args.f90 new file mode 100644 index 0000000..0566ff1 --- /dev/null +++ b/build/FUSE_SRC/prelim/parse_command_args.f90 @@ -0,0 +1,336 @@ +module parse_command_args_MODULE + + USE nrtype + USE data_types, only: cli_options + + implicit none + + private + public :: parse_command_args + +contains + + subroutine parse_command_args(opts, err, message) + implicit none + ! dummies + type(cli_options) , intent(out) :: opts ! command line interface options + integer(i4b) , intent(out) :: err ! error code + character(len=1024) , intent(out) :: message ! error message + ! internal + integer(i4b) :: i ! index of command line argument + character(len=:) , allocatable :: a, v ! command line arguments + character(len=:) , allocatable :: cIndex ! character index + integer(i4b) :: nArg ! number of command line arguments + character(len=:) , allocatable :: cmessage + ! initialize error control + err=0; message='parse_command_args/' + + ! ----- parse command line arguments ------------------------------------------------------ + + ! ----------------------------------------------------------------------------------------- + ! CLI parsing for FUSE run modes + ! -c/--control (required unless --version) + ! -m/--runmode (required unless --version) + ! -d/--domid (required unless --version) + ! -s/--sets (required for idx,opt) + ! -i/--index (required for idx) + ! -r/--restart (optional) + ! -p/--progress (optional) + ! -t/--tag (optional) + ! -v/--version (prints version info and exits) + ! -h/--help (prints help and exits) + ! ----------------------------------------------------------------------------------------- + + nArg = command_argument_count() + if (nArg < 1) call printCommandHelp() + + i = 1 + do while (i <= narg) + call get_arg(i,a) + + select case (trim(a)) + + case ('-h','--help') + opts%show_help = .true. + i = i + 1 + + case ('-v','--version') + opts%show_version = .true. + i = i + 1 + + case ('-t','--tag') + call require_next(i, narg, a, v, err, cmessage) + opts%tag = trim(v) + i = i + 2 + + case ('-c','--control') + call require_next(i, narg, a, v, err, cmessage) + opts%control_file = trim(v) + i = i + 2 + + case ('-m','--runmode') + call require_next(i, narg, a, v, err, cmessage) + opts%runmode = to_lower(trim(v)) + i = i + 2 + + case ('-d','--domid') + call require_next(i, narg, a, v, err, cmessage) + opts%domain_id = trim(v) + i = i + 2 + + case ('-s','--sets','--param-sets') + call require_next(i, narg, a, v, err, cmessage) + opts%sets_file = trim(v) + i = i + 2 + + case ('-i','--index') + call require_next(i, narg, a, cIndex, err, cmessage) + i = i + 2 + + case ('-r','--restart') + call require_next(i, narg, a, v, err, cmessage) + opts%restart_freq = to_lower(trim(v)) + i = i + 2 + + case ('-p','--progress') + call require_next(i, narg, a, v, err, cmessage) + opts%progress_freq = to_lower(trim(v)) + i = i + 2 + + case default + if (len_trim(a) > 0 .and. a(1:1) == '-') then + err = 1 + cmessage = "unknown option: "//trim(a)//"; type 'fuse.exe --help' for usage" + else + err = 1 + cmessage = "unexpected positional argument: "//trim(a)//"; type 'fuse.exe --help' for usage" + end if + end select + + ! process error code + if(err/=0)then + message=trim(message)//trim(cmessage) + err=20; return + endif + + end do ! looping through arguments + + ! Early exits + if (opts%show_help) then + call printCommandHelp() + stop 0 + end if + if (opts%show_version) then + call printVersionInfo() + stop 0 + end if + + ! Parse parameter index + if(allocated(cIndex))then + call parse_int(cIndex, opts%indx, err, cmessage) + if(err/=0)then + message=trim(message)//trim(cmessage) + err=20; return + endif + endif + + ! Validate required args + if (.not. allocated(opts%control_file)) then + err = 1; message = trim(message)//"missing required --control; type 'fuse.exe --help' for usage"; return + end if + if (.not. allocated(opts%domain_id)) then + err = 1; message = trim(message)//"missing required --domid; type 'fuse.exe --help' for usage"; return + end if + if (.not. allocated(opts%runmode)) then + err = 1; message = trim(message)//"missing required --runmode; type 'fuse.exe --help' for usage"; return + end if + + if (.not. is_valid_mode(opts%runmode)) then + err = 1; message = trim(message)//"invalid --runmode: "//trim(opts%runmode)//" (expect def|idx|opt|sce)"; return + end if + + ! Mode-dependent requirements + select case (trim(opts%runmode)) + case ('idx') + if (.not. allocated(opts%sets_file)) then + err = 1; message = trim(message)//"runmode idx requires --sets "; return + end if + if (opts%indx < 0) then + err = 1; message = trim(message)//"runmode idx requires --index "; return + end if + case ('opt') + if (.not. allocated(opts%sets_file)) then + err = 1; message = trim(message)//"runmode opt requires --sets "; return + end if + case ('def','sce') + ! no extra requirements + end select + + ! Validate frequencies if provided (optional) + if (allocated(opts%restart_freq)) then + if (.not. is_valid_restart(opts%restart_freq)) then + err = 1; message = trim(message)//"invalid --restart: "//trim(opts%restart_freq)//" (expect y|m|d|e|never)"; return + end if + end if + if (allocated(opts%progress_freq)) then + if (.not. is_valid_progress(opts%progress_freq)) then + err = 1; message = trim(message)//"invalid --progress: "//trim(opts%progress_freq)//" (expect m|d|h|never)"; return + end if + end if + + end subroutine parse_command_args + + ! ----- list version ---------------------------------------------------------------------- + + subroutine printVersionInfo() + ! Assumes these are available, e.g. from: + ! include "fuseversion.inc" + ! somewhere in a used module (e.g., globaldata) OR add that include here. + use globaldata, only: FUSE_VERSION, FUSE_BUILDTIME, FUSE_GITBRANCH, FUSE_GITHASH + implicit none + print '(A)', repeat('-', 70) + print '(A)', 'FUSE' + print '(" ",A12," : ",A)', 'Version', trim(FUSE_VERSION) + print '(" ",A12," : ",A)', 'Build time', trim(FUSE_BUILDTIME) + print '(" ",A12," : ",A)', 'Git branch', trim(FUSE_GITBRANCH) + print '(" ",A12," : ",A)', 'Git hash', trim(FUSE_GITHASH) + print '(A)', repeat('-', 70) + end subroutine printVersionInfo + + ! ----- list command usage ---------------------------------------------------------------- + + subroutine printCommandHelp() + implicit none + print "(A)", "" + print "(A)", "Usage:" + print "(A)", " fuse.exe -d domain_id -c control_file -m {def|idx|opt|sce} [options]" + print "(A)", "" + + print "(A)", "Run modes:" + print "(A)", " def : run with default parameter sets" + print "(A)", " idx : run using a given index from a parameter sets file" + print "(A)", " opt : run using best simulation from a parameter sets file" + print "(A)", " sce : optimize (SCE)" + print "(A)", "" + + print "(A)", "Required:" + print "(A)", " -d, --domid Domain ID" + print "(A)", " -c, --control Control file" + print "(A)", " -m, --runmode def|idx|opt|sce" + print "(A)", "" + + print "(A)", "Conditional:" + print "(A)", " -s, --sets Parameter sets file (required for idx,opt)" + print "(A)", " -i, --index Index (required for idx)" + print "(A)", "" + + print "(A)", "Optional:" + print "(A)", " -r, --restart y|m|d|e|never" + print "(A)", " -p, --progress m|d|h|never" + print "(A)", " -t, --tag Add tag to output filename" + print "(A)", " -v, --version Print version info and exit" + print "(A)", " -h, --help Print this help and exit" + print "(A)", "" + + print "(A)", "Examples:" + print "(A)", " Default run (no parameter-set file):" + print "(A)", " fuse.exe -d camels-12345 -c ./control/FUSE_control.txt -m def" + print "(A)", "" + + print "(A)", " Default run with restart and progress output:" + print "(A)", " fuse.exe -d camels-12345 -c ./control/FUSE_control.txt -m def -r d -p h" + print "(A)", "" + + print "(A)", " Run using parameter set index 17 from a sets file:" + print "(A)", " fuse.exe -d camels-12345 -c ./control/FUSE_control.txt -m idx -s ./params/sets.nc -i 17" + print "(A)", "" + + print "(A)", " Run using the best simulation from a sets file:" + print "(A)", " fuse.exe -d camels-12345 -c ./control/FUSE_control.txt -m opt -s ./params/sets.nc" + print "(A)", "" + + print "(A)", " Optimize using SCE:" + print "(A)", " fuse.exe -d camels-12345 -c ./control/FUSE_control.txt -m sce" + print "(A)", "" + + print "(A)", " Print version information:" + print "(A)", " fuse.exe --version" + print "(A)", "" + end subroutine printCommandHelp + + ! ----------------------------------------------------------------------------------------- + ! Helpers + ! ----------------------------------------------------------------------------------------- + + subroutine get_arg(i, out) + integer, intent(in) :: i + character(len=:), allocatable, intent(out) :: out + integer :: L + call get_command_argument(i, length=L) + allocate(character(len=L) :: out) + call get_command_argument(i, out) + end subroutine get_arg + + subroutine require_next(i, narg, opt, val, err, message) + integer, intent(in) :: i, narg + character(len=*), intent(in) :: opt + character(len=:), allocatable, intent(out) :: val + integer, intent(out) :: err + character(len=:), allocatable, intent(out) :: message + err = 0 + message = "" + if (i+1 > narg) then + err = 1 + message = "missing value after "//trim(opt)//"; type 'fuse.exe --help' for usage" + return + end if + call get_arg(i+1, val) + end subroutine require_next + + subroutine parse_int(s, x, err, message) + character(len=*), intent(in) :: s + integer, intent(out) :: x + integer, intent(out) :: err + character(len=:), allocatable, intent(out) :: message + integer :: ios + err = 0 + message = "" + read(s, *, iostat=ios) x + if (ios /= 0) then + err = 1 + message = "invalid integer: "//trim(s) + end if + end subroutine parse_int + + pure function to_lower(s) result(t) + character(len=*), intent(in) :: s + character(len=len(s)) :: t + integer :: k, c + t = s + do k = 1, len(s) + c = iachar(t(k:k)) + if (c >= iachar('A') .and. c <= iachar('Z')) then + t(k:k) = achar(c + (iachar('a') - iachar('A'))) + end if + end do + end function to_lower + + pure logical function is_valid_mode(m) + character(len=*), intent(in) :: m + is_valid_mode = (trim(m) == 'def' .or. trim(m) == 'idx' .or. trim(m) == 'opt' .or. trim(m) == 'sce') + end function is_valid_mode + + pure logical function is_valid_restart(f) + character(len=*), intent(in) :: f + is_valid_restart = (trim(f) == 'y' .or. trim(f) == 'm' .or. trim(f) == 'd' .or. trim(f) == 'e' .or. trim(f) == 'never') + end function is_valid_restart + + pure logical function is_valid_progress(f) + character(len=*), intent(in) :: f + is_valid_progress = (trim(f) == 'm' .or. trim(f) == 'd' .or. trim(f) == 'h' .or. trim(f) == 'never') + end function is_valid_progress + +end module parse_command_args_MODULE + + + diff --git a/build/FUSE_SRC/FUSE_ENGINE/qbsaturatn.f90 b/build/FUSE_SRC/prelim/qbsaturatn.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/qbsaturatn.f90 rename to build/FUSE_SRC/prelim/qbsaturatn.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/qtimedelay.f90 b/build/FUSE_SRC/prelim/qtimedelay.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/qtimedelay.f90 rename to build/FUSE_SRC/prelim/qtimedelay.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/uniquemodl.f90 b/build/FUSE_SRC/prelim/uniquemodl.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/uniquemodl.f90 rename to build/FUSE_SRC/prelim/uniquemodl.f90 diff --git a/build/Makefile b/build/Makefile index 22e71fe..e1a337d 100644 --- a/build/Makefile +++ b/build/Makefile @@ -22,6 +22,8 @@ EXE_PATH = $(F_MASTER)bin/ # PART 1: Define the libraries, driver programs, and executables #======================================================================== +.DEFAULT_GOAL := all + # Define the fortran compiler. #FC = ifort FC = gfortran @@ -43,16 +45,33 @@ endif LIBRARIES = $(LIB_NETCDF) INCLUDE = $(INC_NETCDF) -# Define the driver program and associated subroutines for the fidelity test -FUSE_DRIVER = \ - sobol.f90 \ - fuse_rmse.f90 \ - functn.f90 \ - fuse_driver.f90 -DRIVER = $(patsubst %, $(DRIVER_DIR)/%, $(FUSE_DRIVER)) - -# Define the executables -DRIVER_EX = fuse.exe +GENINC := $(F_MASTER)build/generated +VERSIONFILE := $(GENINC)/fuseversion.inc + +# Use /bin/sh-compatible commands +VERSION := $(shell git describe --tags --abbrev=0 2>/dev/null || echo "no-tag") +BUILDTIME := $(shell date -u +"%Y-%m-%dT%H:%M:%SZ") +GITBRANCH := $(shell git rev-parse --abbrev-ref HEAD 2>/dev/null || echo "detached") +GITHASH := $(shell git rev-parse HEAD 2>/dev/null || echo "unknown") + +GENINC := $(F_MASTER)build/generated +VERSIONFILE := $(GENINC)/fuseversion.inc + +$(GENINC): + mkdir -p $@ + +$(VERSIONFILE): | $(GENINC) + @{ \ + echo "! Auto-generated: do not edit"; \ + echo "integer, parameter :: FUSE_VERSION_LEN = 64"; \ + echo "integer, parameter :: FUSE_BUILDTIME_LEN = 32"; \ + echo "integer, parameter :: FUSE_GITBRANCH_LEN = 64"; \ + echo "integer, parameter :: FUSE_GITHASH_LEN = 64"; \ + printf "character(len=FUSE_VERSION_LEN), parameter :: FUSE_VERSION = '%s'\n" "$(VERSION)"; \ + printf "character(len=FUSE_BUILDTIME_LEN), parameter :: FUSE_BUILDTIME = '%s'\n" "$(BUILDTIME)"; \ + printf "character(len=FUSE_GITBRANCH_LEN), parameter :: FUSE_GITBRANCH = '%s'\n" "$(GITBRANCH)"; \ + printf "character(len=FUSE_GITHASH_LEN), parameter :: FUSE_GITHASH = '%s'\n" "$(GITHASH)"; \ + } > $@ #======================================================================== # PART 2: Assemble all of the FUSE sub-routines @@ -61,14 +80,26 @@ DRIVER_EX = fuse.exe # Define directories NUMREC_DIR = $(F_KORE_DIR)FUSE_NR HOOKUP_DIR = $(F_KORE_DIR)FUSE_HOOK -DRIVER_DIR = $(F_KORE_DIR)FUSE_DMSL +DRIVER_DIR = $(F_KORE_DIR)driver NETCDF_DIR = $(F_KORE_DIR)FUSE_NETCDF DSHARE_DIR = $(F_KORE_DIR)dshare +PRELIM_DIR = $(F_KORE_DIR)prelim PHYSICS_DIR = $(F_KORE_DIR)physics ENGINE_DIR = $(F_KORE_DIR)FUSE_ENGINE SCE_DIR = $(F_KORE_DIR)FUSE_SCE TIME_DIR = $(F_KORE_DIR)FUSE_TIME +# Define the executables +DRIVER_EX = fuse.exe + +# Define the driver program and associated subroutines for the fidelity test +FUSE_DRIVER = \ + get_fuse_prelim.f90 \ + fuse_rmse.f90 functn.f90 \ + sce_driver.f90 \ + fuse_driver.f90 +DRIVER = $(patsubst %, $(DRIVER_DIR)/%, $(FUSE_DRIVER)) + # Utility modules FUSE_UTILMS= \ kinds_dmsl_kit_FUSE.f90 \ @@ -178,9 +209,11 @@ SOLVER = $(patsubst %, $(ENGINE_DIR)/%, $(FUSE_SOLVER)) # Define routines for FUSE preliminaries FUSE_PRELIM= \ + parse_command_args.f90 \ ascii_util.f90 \ uniquemodl.f90 \ getnumerix.f90 \ + force_info.f90 \ getparmeta.f90 \ assign_stt.f90 \ assign_flx.f90 \ @@ -193,11 +226,10 @@ FUSE_PRELIM= \ qtimedelay.f90 \ init_stats.f90 \ init_state.f90 -PRELIM = $(patsubst %, $(ENGINE_DIR)/%, $(FUSE_PRELIM)) +PRELIM = $(patsubst %, $(PRELIM_DIR)/%, $(FUSE_PRELIM)) FUSE_MODRUN= \ conv_funcs.f90 \ - force_info.f90 \ clrsky_rad.f90 \ getPETgrid.f90 \ get_mbands.f90 \ @@ -257,8 +289,8 @@ ifeq "$(FC)" "gfortran" endif # select a set of flags -#FLAGS = $(FLAGS_NORMA) -FLAGS = $(FLAGS_DEBUG) +#FLAGS = $(FLAGS_NORMA) -I$(GENINC) +FLAGS = $(FLAGS_DEBUG) -I$(GENINC) # MPI: FUSE with MPI has been compiled successfully with mpif90 and mpiifort. # Note: override must be specifed to enable FC passed as argument to be overridden @@ -283,7 +315,9 @@ endif all: compile install clean # compile FUSE into a static library -compile: sce_16plus.o +compile: sce_16plus.o | $(GENINC) + @rm -f $(VERSIONFILE) + @$(MAKE) $(VERSIONFILE) $(FC) $(FLAGS) $(FUSE_ALL) $(DRIVER) \ $(LIBRARIES) $(INCLUDE) $(MPI_FLAGS) -o $(DRIVER_EX) diff --git a/build/generated/fuseversion.inc b/build/generated/fuseversion.inc new file mode 100644 index 0000000..6929606 --- /dev/null +++ b/build/generated/fuseversion.inc @@ -0,0 +1,9 @@ +! Auto-generated: do not edit +integer, parameter :: FUSE_VERSION_LEN = 64 +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 = '2025-12-22T03:30:41Z' +character(len=FUSE_GITBRANCH_LEN), parameter :: FUSE_GITBRANCH = 'feature/refactor' +character(len=FUSE_GITHASH_LEN), parameter :: FUSE_GITHASH = 'b649c54b16431facc1e268fbefb10dae61faebc5' From 3869fee7bd030308f8e5a031ded1147312052d45 Mon Sep 17 00:00:00 2001 From: Martyn Clark Date: Tue, 23 Dec 2025 06:53:14 -0700 Subject: [PATCH 13/16] minor updates to snow model --- build/FUSE_SRC/FUSE_NETCDF/def_output.f90 | 10 ++- build/FUSE_SRC/physics/update_swe_diff.f90 | 85 ++++++++++------------ build/generated/fuseversion.inc | 4 +- 3 files changed, 47 insertions(+), 52 deletions(-) diff --git a/build/FUSE_SRC/FUSE_NETCDF/def_output.f90 b/build/FUSE_SRC/FUSE_NETCDF/def_output.f90 index abf6450..df726a2 100644 --- a/build/FUSE_SRC/FUSE_NETCDF/def_output.f90 +++ b/build/FUSE_SRC/FUSE_NETCDF/def_output.f90 @@ -47,8 +47,9 @@ SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,n_bands,NTIM) INTEGER(I4B), INTENT(IN) :: n_bands ! number of elevation bands ! internal - REAL(MSP),DIMENSION(nspat1) :: longitude_msp ! desired variable (SINGLE PRECISION) - REAL(MSP),DIMENSION(nspat2) :: latitude_msp ! desired variable (SINGLE PRECISION) + integer(i4b), dimension(n_bands) :: band_i ! coordinate variable + REAL(MSP),DIMENSION(nspat1) :: longitude_msp ! coordinate variable (SINGLE PRECISION) + REAL(MSP),DIMENSION(nspat2) :: latitude_msp ! coordinate 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 @@ -60,6 +61,7 @@ SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,n_bands,NTIM) INTEGER(I4B) :: band_dim ! band dimension INTEGER(I4B), DIMENSION(3) :: TVAR ! dimension list: exclude band INTEGER(I4B), DIMENSION(4) :: EVAR ! dimension list: include band + integer(i4b) :: ib ! loop through bands INTEGER(I4B) :: IVAR ! loop through variables INTEGER(I4B) :: IVAR_ID ! variable ID @@ -151,6 +153,10 @@ SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,n_bands,NTIM) 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 + band_i = [(ib, ib=1,n_bands)] ! 1..n_bands + ierr = NF_INQ_VARID(ncid_out, 'band', ivar_id); call HANDLE_ERR(ierr) + ierr = NF_PUT_VARA_INT(ncid_out, ivar_id, (/1/), (/n_bands/), band_i); call HANDLE_ERR(ierr) + PRINT *, 'NetCDF file for model runs defined with dimensions', n_bands, nSpat1 , nSpat2, NTIM ! close output file diff --git a/build/FUSE_SRC/physics/update_swe_diff.f90 b/build/FUSE_SRC/physics/update_swe_diff.f90 index 7429ecc..55857d7 100644 --- a/build/FUSE_SRC/physics/update_swe_diff.f90 +++ b/build/FUSE_SRC/physics/update_swe_diff.f90 @@ -70,43 +70,38 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) REAL(SP) :: TEMP_Z ! band temperature at timestep ! orographic precipitation multiplier (OPG) real(sp) :: xOPG ! DZ * MPARAM%OPG/1000 -- scaled OPG (dimensionless) - real(sp), parameter :: beta_DZ=100._sp ! scaling facctor in sigmoid 1/(1+exp(-x/beta)) - real(sp) :: sDZ ! sigmoid gate on DZ + 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: smax(1-x, eps_inv, ms_inv) - real(sp), parameter :: eps_inv=1.e-2_sp ! denominator floor - real(sp), parameter :: ms_inv=1.e-6_sp ! smax smoothing factor for inv_safe + 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.1_sp ! sigmoid width for snow/rain partition (degC) + real(sp), parameter :: beta_px=0.01_sp ! sigmoid width for snow/rain partition (degC) ! snowmelt - real(sp), parameter :: ms_swe =1.e-4_sp ! smoothing in smax function (SWE) real(sp), parameter :: ms_temp=1.e-4_sp ! smoothing in smax function (temperature) - real(sp), parameter :: ms_melt=1.e-10_sp ! smoothing in smin function (snowmelt) 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) :: ds_dDZ, dfpos_dOPG, dinv_dOPG, dinvsafe_dinv, dinvsafe_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) :: dposTemp(NP), dpotMelt(NP), dmeltCap(NP), dsnowmelt(NP) ! derivative vectors - real(sp) :: dSWE(NP), dSWE_new(NP) ! persist dSWE between timesteps for each band - real(sp) :: w_pot, w_cap ! smooth-min weights - real(sp) :: g_pos, g_cap, g_u ! dsmax factors - real(sp) :: u_swe ! pre-clamp SWE update + 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(& @@ -180,6 +175,12 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) 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 + ! --------------------------------------------------------------------------------------- ! --------------------------------------------------------------------------------------- @@ -199,7 +200,7 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) 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; dmeltCap(:)=0._sp; dsnowmelt(:)=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 @@ -211,38 +212,34 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) DZ = MBANDS(ISNW)%var%Z_MID - Z_FORC xOPG = DZ * MPARAM%OPG / 1000._sp - ! sigmoid gate on DZ - sDZ = sigmoid(DZ, beta_DZ) + ! 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 safe denominator + ! negative-side formula: 1/(1-x), but with hard floor on denominator inv = 1._sp - xOPG - inv_safe = smax(inv, eps_inv, ms_inv) ! floor inv smoothly to be >= eps + inv_safe = max(inv, eps_inv) ! hard floor fneg = 1._sp / inv_safe ! blended multiplier and band precip - OPG_mult = sDZ * fpos + (1._sp - sDZ) * fneg + OPG_mult = gate * fpos + (1._sp - gate) * fneg PRECIP_Z = precip_adj * OPG_mult ! compute derivatives if(comp_dparam)then - ! derivative in sigmoid gate on DZ - ds_dDZ = dsigmoid(sDZ, beta_DZ) - ! derivative of fpos wrt OPG dfpos_dOPG = DZ / 1000._sp - + ! derivative of fneg wrt OPG - dinv_dOPG = -(DZ / 1000._sp) - dinvsafe_dinv = dsmax(inv, eps_inv, ms_inv) - dinvsafe_dOPG = dinvsafe_dinv * dinv_dOPG - dfneg_dOPG = -(1._sp / (inv_safe*inv_safe)) * dinvsafe_dOPG - - ! derivative of OPGmult wrt OPG - dmult_dOPG = sDZ*dfpos_dOPG + (1._sp - sDZ)*dfneg_dOPG + 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 @@ -286,11 +283,9 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) posTemp = smax(TEMP_Z - MPARAM%MBASE, 0._sp, ms_temp) ! smoothed max(TEMP_Z - MPARAM%MBASE, 0) potMelt = MF*posTemp ! mm day-1 - ! melt capped by availability of snow - meltCap = smax(snow + SWE_prev/DT, 0._sp, ms_melt) - - ! smooth snowmelt - snowmelt = smin(potMelt, meltCap, ms_melt) ! smooth min(potMelt, meltCap) + ! 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 @@ -305,23 +300,17 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) dpotMelt(:) = dMF(:)*posTemp + MF*dposTemp(:) ! melt cap - g_cap = dsmax(snow + SWE_prev/DT, 0._sp, ms_melt) - dmeltCap(:) = g_cap * (dsnow(:) + dSWE(:)/DT) - - ! cap on snowmelt: smooth min weights - w_pot = dsmin(potMelt, meltCap, ms_melt) ! ∂snowmelt/∂potMelt - w_cap = 1._sp - w_pot ! ∂snowmelt/∂meltCap - dsnowmelt(:) = w_pot*dpotMelt(:) + w_cap*dmeltCap(:) + dsnowmelt(:) = merge(dpotMelt(:), dSWE(:)/DT, potMelt < meltcap) endif ! computing derivatives ! ----- update SWE --------------------------------------------------------------------- - + u_swe = SWE_prev + DT*(snow - snowmelt) - MBANDS(ISNW)%var%SWE = smax(u_swe, 0._sp, ms_swe) + MBANDS(ISNW)%var%SWE = max(u_swe, 0._sp) ! hard clamp just removes numerical noise if(comp_dparam)then - g_u = dsmax(u_swe, 0._sp, ms_swe) + 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(:)) ) DERIVS(ISNW)%dx%dSWE_dparam(:) = dSWE_new(:) endif diff --git a/build/generated/fuseversion.inc b/build/generated/fuseversion.inc index 6929606..bd93cac 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 = '2025-12-22T03:30:41Z' +character(len=FUSE_BUILDTIME_LEN), parameter :: FUSE_BUILDTIME = '2025-12-23T12:46:39Z' character(len=FUSE_GITBRANCH_LEN), parameter :: FUSE_GITBRANCH = 'feature/refactor' -character(len=FUSE_GITHASH_LEN), parameter :: FUSE_GITHASH = 'b649c54b16431facc1e268fbefb10dae61faebc5' +character(len=FUSE_GITHASH_LEN), parameter :: FUSE_GITHASH = 'e5093609dde9f039e889dcdbf4a5f9f1f322b135' From 931a21f36dd28801e3272fb784d3394f6dee61a2 Mon Sep 17 00:00:00 2001 From: Martyn Clark Date: Tue, 23 Dec 2025 06:57:47 -0700 Subject: [PATCH 14/16] remove all .svn files --- build/FUSE_SRC/FUSE_DMSL/.svn/all-wcprops | 95 - build/FUSE_SRC/FUSE_DMSL/.svn/entries | 538 -- .../text-base/adapt_test__driver.f90.svn-base | 154 - .../.svn/text-base/dmsl_wrapper.f90.svn-base | 347 - .../.svn/text-base/fuse_rmse.f90.svn-base | 156 - .../text-base/nfunc_test__driver.f90.svn-base | 162 - .../text-base/niter_test__driver.f90.svn-base | 169 - ...ptimiser_miniDmsl_qnewton_kit.f90.svn-base | 7047 ----------------- .../pargrid_driver-copy.f90.svn-base | 192 - .../pargrid_driver-slice.f90.svn-base | 193 - .../text-base/pargrid_driver.f90.svn-base | 209 - .../text-base/parslice_optim.f90.svn-base | 288 - .../qnewton_mcmc__driver.f90.svn-base | 366 - .../.svn/text-base/sce_merge.f90.svn-base | 108 - .../.svn/text-base/sobol.f90.svn-base | 3649 --------- .../.svn/text-base/sobol_driver.f90.svn-base | 204 - .../.svn/text-base/test_fidelity.f90.svn-base | 156 - build/FUSE_SRC/FUSE_ENGINE/.svn/all-wcprops | 443 -- build/FUSE_SRC/FUSE_ENGINE/.svn/entries | 2510 ------ .../.svn/text-base/adjust_stt.f90.svn-base | 56 - .../.svn/text-base/assign_flx.f90.svn-base | 83 - .../.svn/text-base/assign_par.f90.svn-base | 183 - .../.svn/text-base/assign_stt.f90.svn-base | 60 - .../.svn/text-base/batea_file.f90.svn-base | 184 - .../.svn/text-base/bucketsize.f90.svn-base | 31 - .../.svn/text-base/comp_stats.f90.svn-base | 32 - .../.svn/text-base/disaggflux.f90.svn-base | 132 - .../.svn/text-base/evap_lower.f90.svn-base | 60 - .../.svn/text-base/evap_upper.f90.svn-base | 66 - .../.svn/text-base/fdjac.f90.svn-base | 40 - .../.svn/text-base/fdjac_ode.f90.svn-base | 47 - .../.svn/text-base/fix_states.f90.svn-base | 283 - .../.svn/text-base/flux_deriv.f90.svn-base | 60 - .../.svn/text-base/fmin.f90.svn-base | 32 - .../.svn/text-base/frac_error.f90.svn-base | 40 - .../.svn/text-base/funcv.f90.svn-base | 63 - .../.svn/text-base/fuse_deriv.f90.svn-base | 30 - .../.svn/text-base/fuse_sieul.f90.svn-base | 62 - .../.svn/text-base/fuse_solve.f90.svn-base | 251 - .../.svn/text-base/get_limits.f90.svn-base | 76 - .../.svn/text-base/getforcing.f90.svn-base | 130 - .../.svn/text-base/getnumerix.f90.svn-base | 61 - .../.svn/text-base/getpar_str.f90.svn-base | 62 - .../.svn/text-base/getparmeta.f90.svn-base | 81 - .../.svn/text-base/init_state.f90.svn-base | 36 - .../.svn/text-base/init_stats.f90.svn-base | 30 - .../.svn/text-base/initfluxes.f90.svn-base | 50 - .../.svn/text-base/interfaceb.f90.svn-base | 69 - .../.svn/text-base/limit_xtry.f90.svn-base | 79 - .../.svn/text-base/lnsrch.f90.svn-base | 76 - .../.svn/text-base/logismooth.f90.svn-base | 22 - .../.svn/text-base/mean_stats.f90.svn-base | 105 - .../.svn/text-base/mean_tipow.f90.svn-base | 71 - .../.svn/text-base/meanfluxes.f90.svn-base | 50 - .../.svn/text-base/meta_stats.f90.svn-base | 47 - .../.svn/text-base/metaoutput.f90.svn-base | 84 - .../.svn/text-base/metaparams.f90.svn-base | 85 - .../.svn/text-base/mod_derivs.f90.svn-base | 36 - .../.svn/text-base/model_defn.f90.svn-base | 63 - .../text-base/model_defnames.f90.svn-base | 105 - .../.svn/text-base/model_numerix.f90.svn-base | 61 - .../.svn/text-base/mstate_eqn.f90.svn-base | 66 - .../.svn/text-base/multi_flux.f90.svn-base | 41 - .../.svn/text-base/multiforce.f90.svn-base | 23 - .../.svn/text-base/multiparam.f90.svn-base | 154 - .../.svn/text-base/multiroute.f90.svn-base | 12 - .../.svn/text-base/multistate.f90.svn-base | 46 - .../.svn/text-base/multistats.f90.svn-base | 35 - .../.svn/text-base/newtoniter.f90.svn-base | 199 - .../.svn/text-base/ode_int.f90.svn-base | 360 - .../.svn/text-base/par_derive.f90.svn-base | 35 - .../.svn/text-base/par_insert.f90.svn-base | 100 - .../.svn/text-base/parextract.f90.svn-base | 126 - .../.svn/text-base/putpar_str.f90.svn-base | 59 - .../.svn/text-base/q_baseflow.f90.svn-base | 51 - .../.svn/text-base/q_misscell.f90.svn-base | 171 - .../.svn/text-base/q_overland.f90.svn-base | 53 - .../.svn/text-base/qbsaturatn.f90.svn-base | 54 - .../.svn/text-base/qinterflow.f90.svn-base | 33 - .../.svn/text-base/qpercolate.f90.svn-base | 40 - .../.svn/text-base/qrainerror.f90.svn-base | 33 - .../.svn/text-base/qsatexcess.f90.svn-base | 69 - .../.svn/text-base/qtimedelay.f90.svn-base | 69 - .../.svn/text-base/selectmodl.f90.svn-base | 225 - .../.svn/text-base/str_2_xtry.f90.svn-base | 41 - .../.svn/text-base/sumextract.f90.svn-base | 54 - .../.svn/text-base/uniquemodl.f90.svn-base | 132 - .../.svn/text-base/updatstate.f90.svn-base | 81 - .../.svn/text-base/varextract.f90.svn-base | 97 - .../.svn/text-base/viol_state.f90.svn-base | 82 - .../.svn/text-base/wgt_fluxes.f90.svn-base | 57 - .../.svn/text-base/xtry_2_str.f90.svn-base | 84 - build/FUSE_SRC/FUSE_HOOK/.svn/all-wcprops | 29 - build/FUSE_SRC/FUSE_HOOK/.svn/entries | 164 - .../text-base/fuse_fileManager.f90.svn-base | 125 - .../fuse_stdDmdl_dmsl_mod.f90.svn-base | 432 - .../kinds_dmsl_kit_FUSE.f90.svn-base | 120 - .../make_batea_parfiles.f90.svn-base | 23 - build/FUSE_SRC/FUSE_MAIN/.svn/all-wcprops | 41 - build/FUSE_SRC/FUSE_MAIN/.svn/entries | 232 - .../.svn/text-base/batea_test.f90.svn-base | 183 - .../.svn/text-base/driver_ascii.f90.svn-base | 124 - .../.svn/text-base/driver_netcdf.f90.svn-base | 124 - .../text-base/fmodel_run_ascii.f90.svn-base | 53 - .../text-base/fmodel_run_netcdf.f90.svn-base | 56 - .../.svn/text-base/sobol.f90.svn-base | 3649 --------- .../FUSE_NETCDF__DUMMY/.svn/all-wcprops | 89 - .../FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/entries | 504 -- .../.svn/text-base/caldatss.f90.svn-base | 52 - .../.svn/text-base/def_output.f90.svn-base | 28 - .../.svn/text-base/def_params.f90.svn-base | 33 - .../.svn/text-base/def_sstats.f90.svn-base | 29 - .../.svn/text-base/extractor.f90.svn-base | 47 - .../.svn/text-base/get_fparam.f90.svn-base | 55 - .../.svn/text-base/get_objfnc.f90.svn-base | 40 - .../.svn/text-base/get_smodel.f90.svn-base | 37 - .../.svn/text-base/getmahudat.f90.svn-base | 158 - .../.svn/text-base/handle_err.f90.svn-base | 8 - .../.svn/text-base/juldayss.f90.svn-base | 46 - .../.svn/text-base/put_output.f90.svn-base | 30 - .../.svn/text-base/put_params.f90.svn-base | 35 - .../.svn/text-base/put_sstats.f90.svn-base | 31 - build/FUSE_SRC/FUSE_NR/.svn/all-wcprops | 77 - build/FUSE_SRC/FUSE_NR/.svn/entries | 436 - .../.svn/text-base/gammln.f90.svn-base | 45 - .../FUSE_NR/.svn/text-base/gammp.f90.svn-base | 29 - .../FUSE_NR/.svn/text-base/gcf.f90.svn-base | 89 - .../FUSE_NR/.svn/text-base/gser.f90.svn-base | 72 - .../.svn/text-base/lubksb.f90.svn-base | 25 - .../.svn/text-base/ludcmp.f90.svn-base | 27 - .../FUSE_NR/.svn/text-base/nr.f90.svn-base | 3168 -------- .../.svn/text-base/nrtype.f90.svn-base | 31 - .../.svn/text-base/nrutil.f90.svn-base | 1086 --- .../.svn/text-base/pythag.f90.svn-base | 18 - .../.svn/text-base/svbksb.f90.svn-base | 17 - .../.svn/text-base/svdcmp.f90.svn-base | 163 - build/FUSE_SRC/FUSE_NUMERIX/.svn/all-wcprops | 23 - build/FUSE_SRC/FUSE_NUMERIX/.svn/entries | 130 - .../.svn/text-base/nmodel_run.f90.svn-base | 67 - .../text-base/numerix_driver.f90.svn-base | 401 - .../.svn/text-base/sobol.f90.svn-base | 3649 --------- build/FUSE_SRC/FUSE_PARSENS/.svn/all-wcprops | 11 - build/FUSE_SRC/FUSE_PARSENS/.svn/entries | 62 - .../text-base/qnewt_mcmc__driver.f90.svn-base | 406 - build/FUSE_SRC/FUSE_SCE/.svn/all-wcprops | 29 - build/FUSE_SRC/FUSE_SCE/.svn/entries | 164 - .../.svn/text-base/functn.f90.svn-base | 36 - .../.svn/text-base/fuse_rmse.f90.svn-base | 152 - .../FUSE_SCE/.svn/text-base/sce.f.svn-base | 850 -- .../.svn/text-base/sce_driver.f90.svn-base | 155 - build/FUSE_SRC/FUSE_TESTFUNC/.svn/all-wcprops | 65 - build/FUSE_SRC/FUSE_TESTFUNC/.svn/entries | 368 - .../text-base/driver_testfunc.f90.svn-base | 90 - .../.svn/text-base/impl_error.f90.svn-base | 37 - .../.svn/text-base/interfaceb.f90.svn-base | 67 - .../.svn/text-base/model_numerix.f90.svn-base | 64 - .../.svn/text-base/ode_int.f90.svn-base | 318 - .../.svn/text-base/rtnewt_sub.f90.svn-base | 35 - .../.svn/text-base/substepper.f90.svn-base | 409 - .../.svn/text-base/test_deriv.f90.svn-base | 26 - .../.svn/text-base/test_modvar.f90.svn-base | 32 - .../.svn/text-base/test_solve.f90.svn-base | 193 - 162 files changed, 42641 deletions(-) delete mode 100644 build/FUSE_SRC/FUSE_DMSL/.svn/all-wcprops delete mode 100644 build/FUSE_SRC/FUSE_DMSL/.svn/entries delete mode 100644 build/FUSE_SRC/FUSE_DMSL/.svn/text-base/adapt_test__driver.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_DMSL/.svn/text-base/dmsl_wrapper.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_DMSL/.svn/text-base/fuse_rmse.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_DMSL/.svn/text-base/nfunc_test__driver.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_DMSL/.svn/text-base/niter_test__driver.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_DMSL/.svn/text-base/optimiser_miniDmsl_qnewton_kit.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_DMSL/.svn/text-base/pargrid_driver-copy.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_DMSL/.svn/text-base/pargrid_driver-slice.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_DMSL/.svn/text-base/pargrid_driver.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_DMSL/.svn/text-base/parslice_optim.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_DMSL/.svn/text-base/qnewton_mcmc__driver.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_DMSL/.svn/text-base/sce_merge.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_DMSL/.svn/text-base/sobol.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_DMSL/.svn/text-base/sobol_driver.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_DMSL/.svn/text-base/test_fidelity.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/all-wcprops delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/entries delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/adjust_stt.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/assign_flx.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/assign_par.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/assign_stt.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/batea_file.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/bucketsize.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/comp_stats.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/disaggflux.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/evap_lower.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/evap_upper.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fdjac.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fdjac_ode.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fix_states.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/flux_deriv.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fmin.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/frac_error.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/funcv.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fuse_deriv.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fuse_sieul.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fuse_solve.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/get_limits.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/getforcing.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/getnumerix.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/getpar_str.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/getparmeta.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/init_state.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/init_stats.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/initfluxes.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/interfaceb.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/limit_xtry.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/lnsrch.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/logismooth.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/mean_stats.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/mean_tipow.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/meanfluxes.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/meta_stats.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/metaoutput.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/metaparams.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/mod_derivs.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/model_defn.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/model_defnames.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/model_numerix.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/mstate_eqn.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multi_flux.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multiforce.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multiparam.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multiroute.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multistate.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multistats.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/newtoniter.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/ode_int.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/par_derive.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/par_insert.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/parextract.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/putpar_str.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/q_baseflow.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/q_misscell.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/q_overland.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qbsaturatn.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qinterflow.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qpercolate.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qrainerror.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qsatexcess.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qtimedelay.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/selectmodl.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/str_2_xtry.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/sumextract.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/uniquemodl.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/updatstate.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/varextract.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/viol_state.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/wgt_fluxes.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/xtry_2_str.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_HOOK/.svn/all-wcprops delete mode 100644 build/FUSE_SRC/FUSE_HOOK/.svn/entries delete mode 100644 build/FUSE_SRC/FUSE_HOOK/.svn/text-base/fuse_fileManager.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_HOOK/.svn/text-base/fuse_stdDmdl_dmsl_mod.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_HOOK/.svn/text-base/kinds_dmsl_kit_FUSE.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_HOOK/.svn/text-base/make_batea_parfiles.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_MAIN/.svn/all-wcprops delete mode 100644 build/FUSE_SRC/FUSE_MAIN/.svn/entries delete mode 100644 build/FUSE_SRC/FUSE_MAIN/.svn/text-base/batea_test.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_MAIN/.svn/text-base/driver_ascii.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_MAIN/.svn/text-base/driver_netcdf.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_MAIN/.svn/text-base/fmodel_run_ascii.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_MAIN/.svn/text-base/fmodel_run_netcdf.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_MAIN/.svn/text-base/sobol.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/all-wcprops delete mode 100644 build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/entries delete mode 100644 build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/caldatss.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/def_output.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/def_params.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/def_sstats.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/extractor.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/get_fparam.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/get_objfnc.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/get_smodel.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/getmahudat.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/handle_err.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/juldayss.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/put_output.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/put_params.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/put_sstats.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NR/.svn/all-wcprops delete mode 100644 build/FUSE_SRC/FUSE_NR/.svn/entries delete mode 100644 build/FUSE_SRC/FUSE_NR/.svn/text-base/gammln.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NR/.svn/text-base/gammp.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NR/.svn/text-base/gcf.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NR/.svn/text-base/gser.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NR/.svn/text-base/lubksb.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NR/.svn/text-base/ludcmp.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NR/.svn/text-base/nr.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NR/.svn/text-base/nrtype.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NR/.svn/text-base/nrutil.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NR/.svn/text-base/pythag.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NR/.svn/text-base/svbksb.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NR/.svn/text-base/svdcmp.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/.svn/all-wcprops delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/.svn/entries delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/.svn/text-base/nmodel_run.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/.svn/text-base/numerix_driver.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/.svn/text-base/sobol.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_PARSENS/.svn/all-wcprops delete mode 100644 build/FUSE_SRC/FUSE_PARSENS/.svn/entries delete mode 100644 build/FUSE_SRC/FUSE_PARSENS/.svn/text-base/qnewt_mcmc__driver.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_SCE/.svn/all-wcprops delete mode 100644 build/FUSE_SRC/FUSE_SCE/.svn/entries delete mode 100644 build/FUSE_SRC/FUSE_SCE/.svn/text-base/functn.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_SCE/.svn/text-base/fuse_rmse.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_SCE/.svn/text-base/sce.f.svn-base delete mode 100644 build/FUSE_SRC/FUSE_SCE/.svn/text-base/sce_driver.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_TESTFUNC/.svn/all-wcprops delete mode 100644 build/FUSE_SRC/FUSE_TESTFUNC/.svn/entries delete mode 100644 build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/driver_testfunc.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/impl_error.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/interfaceb.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/model_numerix.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/ode_int.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/rtnewt_sub.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/substepper.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/test_deriv.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/test_modvar.f90.svn-base delete mode 100644 build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/test_solve.f90.svn-base diff --git a/build/FUSE_SRC/FUSE_DMSL/.svn/all-wcprops b/build/FUSE_SRC/FUSE_DMSL/.svn/all-wcprops deleted file mode 100644 index e714525..0000000 --- a/build/FUSE_SRC/FUSE_DMSL/.svn/all-wcprops +++ /dev/null @@ -1,95 +0,0 @@ -K 25 -svn:wc:ra_dav:version-url -V 61 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/41/trunk/FUSE_SRC/FUSE_DMSL -END -nfunc_test__driver.f90 -K 25 -svn:wc:ra_dav:version-url -V 83 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_DMSL/nfunc_test__driver.f90 -END -fuse_rmse.f90 -K 25 -svn:wc:ra_dav:version-url -V 75 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/32/trunk/FUSE_SRC/FUSE_DMSL/fuse_rmse.f90 -END -sobol_driver.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/10/trunk/FUSE_SRC/FUSE_DMSL/sobol_driver.f90 -END -sce_merge.f90 -K 25 -svn:wc:ra_dav:version-url -V 74 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_DMSL/sce_merge.f90 -END -optimiser_miniDmsl_qnewton_kit.f90 -K 25 -svn:wc:ra_dav:version-url -V 95 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_DMSL/optimiser_miniDmsl_qnewton_kit.f90 -END -niter_test__driver.f90 -K 25 -svn:wc:ra_dav:version-url -V 83 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_DMSL/niter_test__driver.f90 -END -dmsl_wrapper.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/41/trunk/FUSE_SRC/FUSE_DMSL/dmsl_wrapper.f90 -END -pargrid_driver-slice.f90 -K 25 -svn:wc:ra_dav:version-url -V 85 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_DMSL/pargrid_driver-slice.f90 -END -adapt_test__driver.f90 -K 25 -svn:wc:ra_dav:version-url -V 83 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_DMSL/adapt_test__driver.f90 -END -pargrid_driver.f90 -K 25 -svn:wc:ra_dav:version-url -V 80 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/10/trunk/FUSE_SRC/FUSE_DMSL/pargrid_driver.f90 -END -qnewton_mcmc__driver.f90 -K 25 -svn:wc:ra_dav:version-url -V 86 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/10/trunk/FUSE_SRC/FUSE_DMSL/qnewton_mcmc__driver.f90 -END -test_fidelity.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_DMSL/test_fidelity.f90 -END -parslice_optim.f90 -K 25 -svn:wc:ra_dav:version-url -V 80 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/10/trunk/FUSE_SRC/FUSE_DMSL/parslice_optim.f90 -END -pargrid_driver-copy.f90 -K 25 -svn:wc:ra_dav:version-url -V 84 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_DMSL/pargrid_driver-copy.f90 -END -sobol.f90 -K 25 -svn:wc:ra_dav:version-url -V 70 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_DMSL/sobol.f90 -END diff --git a/build/FUSE_SRC/FUSE_DMSL/.svn/entries b/build/FUSE_SRC/FUSE_DMSL/.svn/entries deleted file mode 100644 index 01a8cb2..0000000 --- a/build/FUSE_SRC/FUSE_DMSL/.svn/entries +++ /dev/null @@ -1,538 +0,0 @@ -10 - -dir -63 -https://venture1.projectlocker.com/UoNEnvEngGroup/FUSE/svn/trunk/FUSE_SRC/FUSE_DMSL -https://venture1.projectlocker.com/UoNEnvEngGroup/FUSE/svn - - - -2012-03-31T03:00:04.873654Z -41 -kavetski - - - - - - - - - - - - - - -7fd0be38-6417-4f01-9cbe-fd474d0c6e94 - -nfunc_test__driver.f90 -file - - - - -2013-06-12T18:10:48.423574Z -d6cbc25db9a8f23ec818a5255c14bc30 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -10429 - -fuse_rmse.f90 -file - - - - -2013-06-12T18:10:48.423574Z -23ebc1bf6ccc4e811dff448b78e8e51a -2011-06-23T02:23:09.739958Z -32 -kavetski - - - - - - - - - - - - - - - - - - - - - -7782 - -sobol_driver.f90 -file - - - - -2013-06-12T18:10:48.423574Z -46c0c460e9a73aa082ace4c41dd8a0de -2009-11-20T05:52:33.882819Z -10 -kavetski - - - - - - - - - - - - - - - - - - - - - -12028 - -sce_merge.f90 -file - - - - -2013-06-12T18:10:48.423574Z -9ec1bf96f66f07b8af421c67e0327408 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -6297 - -optimiser_miniDmsl_qnewton_kit.f90 -file - - - - -2013-06-12T18:10:48.423574Z -0dcb99f16bd9915d3e1423ce91d50281 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -338198 - -niter_test__driver.f90 -file - - - - -2013-06-12T18:10:48.423574Z -41070266f3d2a7744f0bc2633ad0cfb1 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -10388 - -dmsl_wrapper.f90 -file - - - - -2013-06-12T18:10:48.427574Z -b2fe5a50d109c2137b51c17fa6537c92 -2012-03-31T03:00:04.873654Z -41 -kavetski - - - - - - - - - - - - - - - - - - - - - -21383 - -pargrid_driver-slice.f90 -file - - - - -2013-06-12T18:10:48.427574Z -afa52a5c73663e7a200cd03bd6481892 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -12015 - -adapt_test__driver.f90 -file - - - - -2013-06-12T18:10:48.423574Z -7c8b380b24f84cf0564a118888b4aa1f -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -9601 - -pargrid_driver.f90 -file - - - - -2013-06-12T18:10:48.423574Z -6ee5209eaf67eb9384cc3406cca0adad -2009-11-20T05:52:33.882819Z -10 -kavetski - - - - - - - - - - - - - - - - - - - - - -12929 - -qnewton_mcmc__driver.f90 -file - - - - -2013-06-12T18:10:48.423574Z -f239af3c685eac489e920344e619de01 -2009-11-20T05:52:33.882819Z -10 -kavetski - - - - - - - - - - - - - - - - - - - - - -20903 - -test_fidelity.f90 -file - - - - -2013-06-12T18:10:48.423574Z -ab8ea1e21cef26e31db2ca734ac5197f -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -9735 - -parslice_optim.f90 -file - - - - -2013-06-12T18:10:48.423574Z -442b2408d1f9d4e5b67a4ce326b95e4b -2009-11-20T05:52:33.882819Z -10 -kavetski - - - - - - - - - - - - - - - - - - - - - -18458 - -pargrid_driver-copy.f90 -file - - - - -2013-06-12T18:10:48.423574Z -76b8e9248e4005f09ecef945779a29bd -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -12014 - -sobol.f90 -file - - - - -2013-06-12T18:10:48.427574Z -0be2419af7c817a5ec0c7e618616af44 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -159630 - diff --git a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/adapt_test__driver.f90.svn-base b/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/adapt_test__driver.f90.svn-base deleted file mode 100644 index 1d7b22e..0000000 --- a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/adapt_test__driver.f90.svn-base +++ /dev/null @@ -1,154 +0,0 @@ -PROGRAM ADAPT_TEST__DRIVER -! --------------------------------------------------------------------------------------- -! Creator: -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! Driver program to evaluate the accuracy and efficiency of adaptive sub-stepping routines -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE ddirectory ! directory for data files -! data modules -USE model_defn,nstateFUSE=>nstate ! model definition structures -USE multiforce, ONLY: AFORCE, DELTIM, NUMTIM ! data interval = maximum model time step -USE multiparam, ONLY: LPARAM, PARATT, NUMPAR ! parameter metadata structures -USE multiroute, ONLY: AROUTE ! model routing structures -USE multistats ! model statistics structures -! informational modules -USE selectmodl_module ! reads model control file -USE getpar_str_module ! extracts parameter metadata -USE par_insert_module ! inserts model parameters -! model numerix -USE model_numerix ! defines decisions on model numerix -! access to model simulation modules -USE fuse_rmse_module ! run model and compute the root mean squared error -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -! (0) GET COMMAND-LINE ARGUMENTS... -! --------------------------------------------------------------------------------------- -CHARACTER(LEN=6) :: FMODEL_ID=' ' ! integer defining FUSE model -CHARACTER(LEN=6) :: NSOLUTION=' ' ! numerical solution (0=implicit, 1=explicit) -CHARACTER(LEN=6) :: PAR_IDX =' ' ! index of parameter set -! --------------------------------------------------------------------------------------- -! (1) SETUP MODELS FOR SIMULATION -- POPULATE DATA STRUCTURES -! --------------------------------------------------------------------------------------- -! get model forcing data -INTEGER(I4B) :: NTIM ! number of time steps -INTEGER(I4B) :: INFERN_START ! start of inference period -! get model setup -INTEGER(I4B) :: FUSE_ID ! integer defining FUSE model -INTEGER(I4B) :: NMOD ! number of models -INTEGER(I4B) :: ERR ! error code -CHARACTER(LEN=256) :: MESSAGE ! error message -! define model output -LOGICAL(LGT) :: OUTPUT_FLAG ! .TRUE. = write time series output -INTEGER(I4B) :: ONEMOD=1 ! just specify one model -! --------------------------------------------------------------------------------------- -! (2) RUN MODEL FOR GIVEN PARAMETER SET AND DIFFERENT NUMERIX CONFIGURATIONS -! --------------------------------------------------------------------------------------- -INTEGER(I4B) :: IPAR ! looping variable -TYPE(PARATT) :: PARAM_META ! parameter metadata (model parameters) -REAL(SP), DIMENSION(:), ALLOCATABLE :: BL ! vector of lower parameter bounds -REAL(SP), DIMENSION(:), ALLOCATABLE :: BU ! vector of upper parameter bounds -REAL(SP), DIMENSION(:), ALLOCATABLE :: APAR ! model parameter set -INTEGER(KIND=4) :: ISEED ! seed for the random sequence -REAL(KIND=4),DIMENSION(:), ALLOCATABLE :: URAND ! vector of quasi-random numbers U[0,1] -INTEGER(I4B) :: ITRY ! (looping) -INTEGER(I4B) :: JTRY ! (looping) -REAL(SP) :: RMSE ! error from the simulation -! --------------------------------------------------------------------------------------- -! (0) READ COMMAND LINE ARGUMENTS -! --------------------------------------------------------------------------------------- -! read command-line arguments -CALL GETARG(1,FMODEL_ID) ! integer defining FUSE model -CALL GETARG(2,NSOLUTION) ! numerical solution -CALL GETARG(3,PAR_IDX) ! index in the Sobol sequence -! check command-line arguments -IF (LEN_TRIM(NSOLUTION).EQ.0) STOP '1st command-line argument is missing (FMODEL_ID)' -IF (LEN_TRIM(NSOLUTION).EQ.0) STOP '2nd command-line argument is missing (NSOLUTION)' -IF (LEN_TRIM(PAR_IDX) .EQ.0) STOP '3rd command-line argument is missing (PAR_IDX)' -! convert command-line arguments to integer flags and real numbers -CALL GETNUMERIX() ! defines method/parameters used for numerical solution -READ(FMODEL_ID,*) FUSE_ID ! integer definining FUSE model -READ(NSOLUTION,*) SOLUTION_METHOD ! numerical solution (0=EE, 1=EH, 2=IE, 3=IH, 4=SI) -READ(PAR_IDX,*) ISEED ! convert index to an integer -! check solution method -SELECT CASE(SOLUTION_METHOD); CASE(EXPLICIT_EULER,EXPLICIT_HEUN,IMPLICIT_EULER,IMPLICIT_HEUN,SEMI_IMPLICIT) -CASE DEFAULT; - PRINT *, 'solution method (2nd command line argument) must equal 0 (explicit_euler), 1 (explicit heun),'//& - ' 2 (implicit_euler), 3 (implicit_heun), or 4 (semi_implicit)' - STOP -END SELECT -! --------------------------------------------------------------------------------------- -! (1) GET MODEL SETUP -- MODEL DEFINITION, AND PARAMETER AND VARIABLE INFO FOR ALL MODELS -! --------------------------------------------------------------------------------------- -! Read data from the "BATEA-compliant" ASCII files -CALL GETFORCING(INFERN_START,NTIM) -! Define model attributes (valid for all models) -CALL UNIQUEMODL(NMOD) ! get nmod unique models -CALL GETPARMETA() ! read parameter metadata (parameter bounds etc.) -! Identify a single model (read control file ../DataFiles/m_decisions.txt) -CALL SELECTMODL(FUSE_ID,ISTATUS=ERR,MESSAGE=MESSAGE) -IF (ERR.NE.0) THEN - PRINT *, TRIM(MESSAGE); STOP -ENDIF -! Define list of states and parameters for the current model -CALL ASSIGN_STT() ! state definitions are stored in module model_defn -CALL ASSIGN_FLX() ! flux definitions are stored in module model_defn -CALL ASSIGN_PAR() ! parameter defintions are stored in module multiparam -! compute derived model parameters (bucket sizes, etc.) -CALL PAR_DERIVE() -! Define output file names (shared in MODULE model_defn) -FNAME_NETCDF = TRIM(OUTPUT_PATH)//TRIM(SMODL%MNAME)//'_adapt-steps_'//& - TRIM(PAR_IDX)//'_'//TRIM(NSOLUTION)//'.nc' -! Define NetCDF output files (only write parameters and summary statistics) -ONEMOD=1 ! one file per model (i.e., model dimension = 1) -PCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) -OUTPUT_FLAG = .FALSE. ! .TRUE. if desire time series output -CALL DEF_PARAMS(ONEMOD) ! define model parameters (initial CREATE) -CALL DEF_SSTATS() ! define summary statistics (REDEF) -IF (OUTPUT_FLAG) CALL DEF_OUTPUT(NTIM) ! define model time series (REDEF) -! --------------------------------------------------------------------------------------- -! (2) RUN MODEL FOR THE CURRENT PARAMETER SET WITH DIFFERENT NUMERIX OPTIONS -! --------------------------------------------------------------------------------------- -! get parameter bounds and random numbers -ALLOCATE(APAR(NUMPAR),BL(NUMPAR),BU(NUMPAR),URAND(NUMPAR)) -DO IPAR=1,NUMPAR - CALL GETPAR_STR(LPARAM(IPAR)%PARNAME,PARAM_META) - BL(IPAR) = PARAM_META%PARLOW - BU(IPAR) = PARAM_META%PARUPP -END DO -! get new parameter sets -CALL I4_SOBOL(NUMPAR,ISEED,URAND) -WRITE(*,'(I4,1X,12(E10.2,1X))') ISEED-1, URAND -APAR = BL + URAND*(BU-BL) -!DO IPAR=1,NUMPAR; WRITE(*,'(A11,1X,F9.3)') LPARAM(IPAR)%PARNAME, APAR(IPAR); END DO -! create the exact solution -TEMPORAL_ERROR_CONTROL = TS_ADAPT ! adaptive time steps -ERR_TRUNC_ABS = 1.e-9 ! absolute temporal truncation error tolerance -ERR_TRUNC_REL = 1.e-9 ! relative temporal truncation error tolerance -MIN_TSTEP = 0.01_sp/60._sp/24._sp ! minimum time step length (minutes --> days) -MAX_TSTEP = 10.0_sp/60._sp/24._sp ! maximum time step length (minutes --> days) -! run model (parameters and statistics are written in FUSE_RMSE) -CALL FUSE_RMSE(APAR,RMSE,OUTPUT_FLAG) -! save solution for subsequent testing -AROUTE(:)%Q_ACCURATE = AROUTE(:)%Q_ROUTED -! modify numerix parameters -MAX_TSTEP = DELTIM ! max step length = data interval -! evaluate different parameters for step-size control -DO ITRY=3,9,3 ! play with different ERR_TRUNC_ABS parameters - ERR_TRUNC_ABS = 1. * 10.**-REAL(ITRY, KIND(SP)) - DO JTRY=1,9 ! play with different ERR_TRUNC_REL parameters - ERR_TRUNC_REL = 1. * 10.**-REAL(JTRY, KIND(SP)) - ! run zee model - write(*,'(2(E15.7,1X))') ERR_TRUNC_ABS, ERR_TRUNC_REL - CALL FUSE_RMSE(APAR,RMSE,OUTPUT_FLAG) - END DO ! (loop through different numerix parameter combinations) -END DO ! (loop through different numerix parameter combinations) -! for reference, include the fixed-step method -TEMPORAL_ERROR_CONTROL = TS_FIXED ! fixed time steps -CALL FUSE_RMSE(APAR,RMSE,OUTPUT_FLAG) ! run zee model -! and, deallocate space -DEALLOCATE(APAR,BL,BU,URAND) -STOP -END PROGRAM ADAPT_TEST__DRIVER diff --git a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/dmsl_wrapper.f90.svn-base b/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/dmsl_wrapper.f90.svn-base deleted file mode 100644 index 855f359..0000000 --- a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/dmsl_wrapper.f90.svn-base +++ /dev/null @@ -1,347 +0,0 @@ -MODULE DMSL_WRAPPER_MODULE -USE kinds_dmsl_kit -IMPLICIT NONE -PRIVATE -PUBLIC::QNEWTON_WRAPPER,MCMC_WRAPPER,OBJFUNC_WRAPPER_OPTI,OBJFUNC_WRAPPER_MCMC -CONTAINS -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! (A) QUASI-NEWTON OPTIMIZATION -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -SUBROUTINE QNEWTON_WRAPPER(X0I,XLO,XHI,XSCALE,FDIGITS,UOUT, & ! input - XOPT,FOPT,ITER,FCALLS,GCALLS,HCALLS, & ! output - IERR,MESSAGE) ! error handling -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Wrapper for the DMSL quasi-Newton optimization -! --------------------------------------------------------------------------------------- -USE nrtype ! data types -USE multistats, ONLY:MSTATS ! provide access to error message -USE optimiser_dmsl_kit, ONLY:QNEWTON ! provide access to qnewton -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -! (1) DUMMIES -! --------------------------------------------------------------------------------------- -! input -REAL(SP),DIMENSION(:),INTENT(IN) :: X0I ! initial estimate of solution -REAL(SP),DIMENSION(:),INTENT(IN) :: XLO ! lower bound on solution, either none or both bounds must be present -REAL(SP),DIMENSION(:),INTENT(IN) :: XHI ! upper bound on solution, either none or both bounds must be present -REAL(SP),DIMENSION(:),INTENT(IN) :: XSCALE ! typical scale of parameters -INTEGER(I4B),INTENT(IN) :: FDIGITS ! number of reliable digits in function evaluation -! ! (-2=estimate,-1=full machine precision) -INTEGER(I4B),INTENT(IN) :: UOUT ! output unit for run-time information -! output -REAL(SP),DIMENSION(:),INTENT(OUT) :: XOPT ! optimum value of "x", for which f(x) takes its minimum value -REAL(SP),INTENT(OUT) :: FOPT ! function value at optimum -INTEGER(I4B),INTENT(OUT) :: ITER ! number of steps (iterations) -INTEGER(I4B),INTENT(OUT) :: FCALLS ! number of function calls -INTEGER(I4B),INTENT(OUT) :: GCALLS ! number of gradient calls -INTEGER(I4B),INTENT(OUT) :: HCALLS ! number of Hessian calls -! error handling -INTEGER(I4B),INTENT(OUT) :: IERR ! error code -CHARACTER(*),INTENT(OUT) :: MESSAGE ! error message -! --------------------------------------------------------------------------------------- -! (2) LOCALS -! --------------------------------------------------------------------------------------- -! Active set (to identify parameters on bounds) -INTEGER(I4B),DIMENSION(SIZE(X0I)) :: ACTIVESET ! active set (-1=lo,0=free,+1=hi), must be present if using xLo and xHi -! Define termination tolerances -REAL(SP) :: EPSF ! desired precision -REAL(SP) :: GTOL ! scaled gradient tolerance -REAL(SP) :: STOL ! scaled step tolerance -REAL(SP) :: FTOL ! scaled function tolerance -! Define scaling settings -REAL(SP),PARAMETER :: FSCALE=1._SP ! scale of function -REAL(SP) :: STPMAX ! maximum scaled stepsize/trust radius (set<0 for default) -! Define computational algorithms used in qnewton -INTEGER(I4B),PARAMETER :: IMETH=5 ! iteration globalisation method; 5=Near-exact trust method ("hookstep") -INTEGER(I4B),PARAMETER :: GMETH=1 ! gradient evaluation method; 1=Forward difference gradient -INTEGER(I4B),PARAMETER :: HMETH=6 ! Hessian evaluation method; 6=BFGS update of unfactored Hessian -! Define initialization settings -INTEGER(I4B),PARAMETER :: HIMETH=5 ! Diagonal of estimated d2f/dx2 -REAL(SP) :: TRUSTRAD ! initial scaled trust region radius (set<0 for internal default) -! Define maximum effort expended before termination -INTEGER(I4B),PARAMETER :: MAXITER=5000 ! Maximum number of iterations -INTEGER(I4B),PARAMETER :: MAXFEV=500 ! Maximum number of function calls -! Useful diagnostics and information -REAL(SP),DIMENSION(SIZE(X0I)) :: GRADOPT ! gradient at the optimum -REAL(SP),DIMENSION(SIZE(X0I),SIZE(X0I)) :: HESSOPT ! Hessian at optimum -! Memory footprint -REAL(SP) :: MEMHESS2 ! additional memory necessary for allocating internal Hessian storage -! Return codes and runtime messages -INTEGER(I4B) :: ERR_QN ! error diagnostic, err=0->ok,<0=warning,>0=error -CHARACTER(LEN=256) :: MESSAGE_QN ! status description -INTEGER(I4B) :: ILEN ! length of error message -INTEGER(I4B) :: I ! looping variable -! --------------------------------------------------------------------------------------- -! initialize variables -ACTIVESET(:) = 0 ! define active set (-1=lo,0=free,+1=hi) -TRUSTRAD = -1._SP ! use internal default for trust region radius -STPMAX = -1._SP ! use internal default for maximum scaled stepsize/trust radius -MSTATS%ERR_MESSAGE(1:31)='searching for the local optimum' -FORALL(I=32:LEN(MSTATS%ERR_MESSAGE)) MSTATS%ERR_MESSAGE(I:I)=' ' -! define termination tolerances -EPSF = 10._SP**(-FDIGITS) ! desired precision -GTOL = SQRT(EPSF) ! scaled gradient tolerance -STOL = EPSF ! scaled step tolerance -FTOL = EPSF ! scaled function tolerance -! find local optimum in the vicinity of the starting point -CALL QNEWTON(OBJFUNC_WRAPPER_OPTI, & ! Objective function to be minimised - x0=x0i, & ! Initial estimate of optimum - xLo=xlo,xHi=xhi,activeSet=activeSet, & ! Upper and lower bounds on solution, active set - gtol=gtol,stol=stol,ftol=ftol, & ! Termination tolerances - xscale=xscale,fscale=fscale,fdigits=fdigits,stpmax=stpmax, & ! Scaling settings - imeth=imeth,gmeth=gmeth,hmeth=hmeth, & ! Computational algorithms - himeth=himeth,trustRad=trustRad, & ! Initialisation settings - maxIter=maxIter,maxFev=maxFev, & ! Termination due to excessive effort - uout=uout, & ! Output unit for runtime information - xopt=xopt,fopt=fopt, & ! Approximated optimal solution - gradOpt=gradOpt,hessOpt=hessOpt, & ! Useful diagnostics and information - iter=iter,fcalls=fcalls,gcalls=gcalls,hcalls=hcalls, & ! Computational cost report - memHess2=memHess2, & ! Memory footprint - err=err_qn,message=message_qn) ! Return codes and runtime messages -! save errors -MSTATS%ERR_MESSAGE = MESSAGE_QN -IERR=ERR_QN; MESSAGE=MESSAGE_QN -!WRITE(*,'(4(I6,1X),20(F9.3,1X))') ITER,FCALLS,GCALLS,HCALLS,FOPT,XOPT -END SUBROUTINE QNEWTON_WRAPPER -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -SUBROUTINE MCMC_WRAPPER(sample0,sdevDiag0,ierr,message) ! initial values for samples -! --------------------------------------------------------------------------------------- -! Creators: -! --------- -! Martyn Clark and Dmitri Kavetski, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Wrapper for the DMSL MCMC routines -! --------------------------------------------------------------------------------------- -USE mcmc_dmsl_kit,ONLY:mbrSettings_type,mbrOut_type,metropolis_RK ! MCMC data types -USE model_defn, ONLY:FNAME_PREFIX,FNAME_TEMPRY ! prefix for filenames -USE multiparam, ONLY:LPARAM,NUMPAR ! list of model parameters -IMPLICIT NONE -! input -REAL(mrk),DIMENSION(:),INTENT(IN) :: sample0 ! initial sample -REAL(mrk),DIMENSION(:),INTENT(IN) :: sdevDiag0 ! initial diagonal of the covariance matrix -! output -integer(mik) :: ierr ! error code -character(*) :: message ! error message -! local -integer(mik), parameter :: text_len=256 ! string length -integer(mik) :: ipar ! loop through model parameters -character(len=text_len),dimension(:),allocatable :: parNames ! parameter names -type(mbrSettings_type) :: mbrSettings ! Algorithmic control parameters -type(mbrOut_type) :: mbrOut ! Performance diagnostix -character(len=text_len) :: lineFmtIn ! user-specified formatting for output -character(len=text_len) :: lineFmtOut ! actual format used -! --------------------------------------------------------------------------------------- -! initialize errors -ierr=0; message='start of mcmc_wrapper, everything is a-ok' -! populate parameter names -allocate(parNames(0:NUMPAR), stat=ierr) -if (ierr.ne.0) then; message='mcmc_wrapper: problem allocating parNames'; stop; endif -parNames(0) = 'Variance' -DO IPAR=1,NUMPAR - parNames(ipar) = LPARAM(IPAR)%PARNAME -END DO -! set filenames in mbrSettings -mbrSettings%samfiles = TRIM(FNAME_PREFIX)//'__'//mbrSettings%samfiles -! open up run time diagnostix -open(mbrSettings%uInfo,file=TRIM(FNAME_PREFIX)//'__'//'mcmc_info.txt',status='unknown') -CALL metropolis_RK(OBJFUNC_WRAPPER_MCMC, & ! Objective function to be minimised - title="FUSE MCMC", & - varNames=parnames, & ! Parameter names - mbrSettings=mbrSettings, & ! Algorithmic control parameters - sample0=sample0,sdevDiag0=sdevDiag0, & ! Initial values for samples - mbrOut=mbrOut, & ! Performance diagnostix -! lineFmtIn=lineFmtIn,&!lineFmtOut,& & ! Formatting for the sample - err=ierr,message=message) ! Return codes and runtime messages -! Phase 1 - OnerPerTime - Use one-variable-per-time Metropolis -! Phase 2 - Scaling - Compute covariance and adjust its scale using single-block Metropolis -! Phase 3 - Burnin - Sample using fixed covariance matrix -! Phase 4 - Production - Production samples - -if (ierr.ne.0) message='mcmc_wrapper: '//trim(message) - -! deallocate parNames -deallocate(parNames, stat=ierr) -if (ierr.ne.0) message='mcmc_wrapper: problem deallocating parNames' - - -END SUBROUTINE MCMC_WRAPPER -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! (B) OBJECTIVE FUNCTION WRAPPaz -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -SUBROUTINE OBJFUNC_WRAPPER_OPTI(dataIN,dataOUT,argInf,& - feas,objFuncM,gradObjFuncM,hessObjFuncM,err,message) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Wrapper for the objective function used in DMSL optimization routines, based on the -! bateauDK_objFunc_opt wrapper coded by Dmitri Kavetski -! Calls the SUBROUTINE fuse_rmse.f90 to calculate the RMSE for a given -! FUSE model and parameter set -! --------------------------------------------------------------------------------------- -use kinds_dmsl_kit ! numeric kind definitions -use types_dmsl_kit,only:data_ricz_type ! data types (dataIN,dataOUT; not actually used) -use fuse_rmse_module,only:fuse_rmse ! provide access to fuse_rmse (run model) -use multiparam,only:lparam,paratt,numpar ! provide access to the FUSE model parameter structures -use multistats,only:fcount ! provide access to the number of function evaluations -use getpar_str_module ! provide access to getpar_str (get parameter metadata) -implicit none -! dummies -type(data_ricz_type),intent(in),optional::dataIN -type(data_ricz_type),intent(inout),optional::dataOUT -real(mrk),intent(in)::argInf(:) -logical(mlk),intent(out)::feas -real(mrk),intent(out),optional::objFuncM,gradObjFuncM(:),hessObjFuncM(:,:) -integer(mik),intent(out)::err -character(*),intent(out)::message -! locals -integer(mik)::ipar ! loop through model parameters -type(paratt)::param_meta ! parameter metadata -logical(mlk)::output_flag ! switch to write model output -logical(mlk)::mparam_flag ! switch to turn off writing of parameters and statistics -! default error code and message -err=0; message='no error checking' -! define flags to write model output and compute summary statistics -output_flag = .false. -mparam_flag = .false. -! check for the feasability of the parameters -feas=.true. ! initialize feasability flag -do ipar=1,numpar - call getpar_str(lparam(ipar)%parname,param_meta) ! get parameter metadata structure - if (argInf(ipar).lt.param_meta%parlow) feas=.false. ! check above lower limit - if (argInf(ipar).gt.param_meta%parupp) feas=.false. ! check below upper limit - !write(*,'(a11,1x,3(f12.6,1x),l1)') & - ! lparam(ipar)%parname,argInf(ipar), param_meta%parlow, param_meta%parupp, feas -end do ! looping through parameters -! calculate objective function and increment counter -if (present(objFuncM) .and. feas) then - call fuse_rmse(argInf,objFuncM,output_flag,mparam_flag) -endif -if (present(objFuncM)) fcount = fcount+1 -!if (present(objFuncM)) write(*,'(i8,1x,20(f9.3,1x))') fcount,objFuncM,argInf -! populate un-used output with missing values -if(present(gradObjFuncM))gradObjFuncM=undefRN -if(present(hessObjFuncM))hessObjFuncM=undefRN -END SUBROUTINE OBJFUNC_WRAPPER_OPTI -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -SUBROUTINE OBJFUNC_WRAPPER_MCMC(dataIN,dataOUT,x,& - feas,logp,faux,gradLogP,hessLogP,err,message) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Wrapper for the objective function used in DMSL MCMC routines, based on the -! bateauDK_objFunc_opt wrapper coded by Dmitri Kavetski -! Calls the SUBROUTINE fuse_rmse.f90 to calculate the RMSE for a given -! FUSE model and parameter set -! --------------------------------------------------------------------------------------- -! FUSE modules -use fuse_rmse_module,only:fuse_rmse ! provide access to fuse_rmse (run model) -use multiforce,only:istart,numtim,aforce ! start+count of the calibration period; forcing data -use multiparam,only:lparam,paratt,numpar ! provide access to the FUSE model parameter structures -use multiroute,only:aroute ! provide access to the FUSE simulated runoff -use multistats,only:fcount ! provide access to the number of function evaluations -use getpar_str_module ! provide access to getpar_str (get parameter metadata) -! DMSL modules -use kinds_dmsl_kit ! numeric kind definitions -use types_dmsl_kit,only:data_ricz_type ! data types (dataIN,dataOUT; not actually used) -USE numerix_dmsl_kit,only:normal_logp ! log-density of a normal deviate -implicit none -! dummies -type(data_ricz_type),intent(in),optional::dataIN -type(data_ricz_type),intent(inout),optional::dataOUT -real(mrk),intent(in)::x(0:) -logical(mlk),intent(out)::feas -real(mrk),intent(out),optional::logp,faux(:),gradLogP(:),hessLogP(:,:) -integer(mik),intent(out)::err -character(*),intent(out)::message -! locals -integer(mik)::ipar ! loop through model parameters -integer(mik)::itim ! loop through calibration period -type(paratt)::param_meta ! parameter metadata -logical(mlk)::output_flag ! switch to write model output -logical(mlk)::mparam_flag ! switch to turn off writing of parameters and statistics -real(mrk) ::rmse ! root mean squared error -real(mrk),dimension(:),allocatable :: resd ! individual residuals -real(mrk),dimension(:),allocatable :: dens ! log-density of individual residuals -real(mrk)::VAR -! default error code and message -err=0; message='start of fuse wrapper' -! define flags to write model output and compute summary statistics -output_flag = .false. -mparam_flag = .false. -! check for the feasability of the parameters -feas=.true. ! initialize feasability flag -do ipar=1,numpar - call getpar_str(lparam(ipar)%parname,param_meta) ! get parameter metadata structure - if (x(ipar).lt.param_meta%parlow) feas=.false. ! check above lower limit - if (x(ipar).gt.param_meta%parupp) feas=.false. ! check below upper limit - !write(*,'(a11,1x,3(f12.6,1x),l1)') & - ! lparam(ipar)%parname,x(ipar), param_meta%parlow, param_meta%parupp, feas -end do ! looping through parameters -! add error checking -if (.not.feas) then - message='parameter set is infeasible' - return -endif -! calculate objective function and increment counter -if (present(logp) .and. feas) then - VAR=10._mrk**x(0) - call fuse_rmse(x(1:),rmse,output_flag,mparam_flag) - ! allocate space for log-density of individual residuals - allocate(resd(istart:numtim),dens(istart:numtim), stat=err) - if (err.ne.0) then; err=-20; message='problem allocating space for dens'; return; endif - ! loop thru time steps to get log-density of individual residuals - do itim=istart,numtim - resd(itim) = AROUTE(itim)%Q_ROUTED - AFORCE(itim)%OBSQ - dens(itim) = normal_logp(x=resd(itim),mean=0._mrk,var=VAR) - end do - logp = sum(dens) ! log density of the simulation - ! deallocate space for log-density of individual residuals - deallocate(resd,dens, stat=err) - if (err.ne.0) then; err=-30; message='problem deallocating space for dens'; return; endif -endif -if (present(logp)) fcount = fcount+1 -!if (present(logp)) write(*,'(i8,1x,20(f9.3,1x))') fcount,logp,x -! populate un-used output with missing values -if(present(gradLogP))gradLogP=undefRN -if(present(hessLogP))hessLogP=undefRN -END SUBROUTINE OBJFUNC_WRAPPER_MCMC -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -END MODULE DMSL_WRAPPER_MODULE diff --git a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/fuse_rmse.f90.svn-base b/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/fuse_rmse.f90.svn-base deleted file mode 100644 index 538a0e5..0000000 --- a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/fuse_rmse.f90.svn-base +++ /dev/null @@ -1,156 +0,0 @@ -MODULE FUSE_RMSE_MODULE ! have as a module because of dynamic arrays -IMPLICIT NONE -CONTAINS -SUBROUTINE FUSE_RMSE(XPAR,RMSE,OUTPUT_FLAG,MPARAM_FLAG) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Calculate the RMSE for single FUSE model and single parameter set -! input: model parameter set -! output: root mean squared error -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -! data modules -USE model_defn, ONLY:NSTATE,SMODL ! number of state variables -USE multiparam, ONLY:LPARAM,NUMPAR,MPARAM ! list of model parameters -USE multiforce, ONLY:MFORCE,AFORCE,DELTIM,ISTART,& ! model forcing data - NUMTIM ! model forcing data (continued) -USE multistate, ONLY:fracstate0,TSTATE,MSTATE,FSTATE,& ! model states - HSTATE ! model states (continued) -USE multiroute, ONLY:MROUTE,AROUTE ! routed runoff -USE multistats, ONLY:MSTATS,PCOUNT,MOD_IX ! access model statistics; counter for param set -! informational modules -USE par_insert_module ! insert parameters into data structures -USE str_2_xtry_module ! provide access to the routine str_2_xtry -! 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) :: OUTPUT_FLAG ! .TRUE. if desire time series output -LOGICAL(LGT), INTENT(IN), OPTIONAL :: MPARAM_FLAG ! .FALSE. (used to turn off writing statistics) -! output -REAL(SP),INTENT(OUT) :: RMSE ! root mean squared error -! internal -REAL(SP) :: T1,T2 ! CPU time -INTEGER(I4B) :: ITIM ! loop through time series -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 -CHARACTER(LEN=CLEN) :: MESSAGE ! error message -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_rmse ' -! increment parameter counter for model output (shared in module MULTISTATS) -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) -!DO IPAR=1,NUMPAR; WRITE(*,'(A11,1X,F9.3)') LPARAM(IPAR), XPAR(IPAR); END DO -! compute derived model parameters (bucket sizes, etc.) -CALL PAR_DERIVE(IERR,message) -IF (IERR.NE.0) then - message= ' problem allocating space for state vectors in fuse_rmse ' - PRINT *, TRIM(MESSAGE); STOP -endif -! initialize model states and model time step -CALL INIT_STATE(fracState0) ! fracState0 is shared in MODULE multistate -CALL STR_2_XTRY(FSTATE,STATE0) ! get the vector of states from the FSTATE structure -DT_SUB = DELTIM ! init stepsize to full step (DELTIM shared in module multiforce) -DT_FULL = DELTIM ! init stepsize to full step (DELTIM shared in module multiforce) -! initialize summary statistics -CALL INIT_STATS() -CALL CPU_TIME(T1) -! loop through time -DO ITIM=1,NUMTIM ! (NUMTIM is shared in MODULE multiforce) - ! run model for one time step - MFORCE = AFORCE(ITIM) ! assign model forcing data - MSTATE = FSTATE ! refresh model states - CALL INITFLUXES() ! set weighted sum of fluxes to zero - ! testing - !if (itim.eq.392) then - !allocate(j(2,2),dsdt(2)) - !do itest=695000,696000 - ! do jtest=544000,545000 - !do itest=5500,7500,5 - ! do jtest=4500,6500,5 - !test_a = real(itest,kind(sp))/10000._dp; test_b=real(jtest,kind(sp))/10000._dp - !test_a = real(itest,kind(sp))/100._dp; test_b=real(jtest,kind(sp))/100._dp - !state1 = (/test_a,test_b/) - !dsdt = fuse_deriv(state1) - !call fdjac_ode(state1,dsdt,j) - !state1 = (/test_a,test_b/) ! (modified in fdjac_ode) - !write(*,'(10(f14.10,1x))') state0, state1, dsdt, state1 - (state0 + dsdt), j(1,1), j(2,2) - !end do - !end do - !deallocate(j,dsdt) - !stop - !endif - ! 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() - ! save state - STATE0=STATE1 - ! save instantaneous and routed runoff - AROUTE(ITIM)%Q_INSTNT = MROUTE%Q_INSTNT ! save instantaneous runoff - AROUTE(ITIM)%Q_ROUTED = MROUTE%Q_ROUTED ! save routed runoff - !if (itim.ge.300) & - !WRITE(*,'(I10,1X,I4,1X,4(I2,1X),F9.3,1X,F20.1,1X,4(F11.3,1X),I7)') & - ! ITIM, AFORCE(ITIM), AROUTE(ITIM)%Q_ROUTED, NUM_FUNCS - !if (itim.gt.400) stop - !WRITE(*,'(I10,1X,4(F15.8,1X))') ITIM, FSTATE%WATR_1, FSTATE%WATR_2, MPARAM%MAXWATR_1, MPARAM%MAXWATR_2 - IF (AROUTE(ITIM)%Q_ROUTED.LT.0._sp) STOP ' Q_ROUTED is less than zero ' - IF (AROUTE(ITIM)%Q_ROUTED.GT.1000._sp) STOP ' Q_ROUTED is enormous ' - ! compute summary statistics - CALL COMP_STATS() - ! write model output - IF (OUTPUT_FLAG) THEN - CALL PUT_OUTPUT(PCOUNT,MOD_IX,ITIM) - !WRITE(*,'(I10,1X,2(F15.8,1X))') ITIM, FSTATE%WATR_1, FSTATE%WATR_2 - !WRITE(*,'(I10,1X,I4,1X,4(I2,1X),F9.3,1X,F20.1,1X,4(F11.3,1X))') ITIM, AFORCE(ITIM), AROUTE(ITIM)%Q_ROUTED - ENDIF -END DO ! (itim) -CALL CPU_TIME(T2) -!print *, t2-t1 -! calculate mean summary statistics -CALL MEAN_STATS() -RMSE = MSTATS%RAW_RMSE -! WRITE(unt,'(2(I6,1X),3(F20.15,1X))') MOD_IX, PCOUNT, MSTATS%RAW_RMSE, MSTATS%NASH_SUTT, MSTATS%NUM_FUNCS -! write model parameters and summary statistics -IF (.NOT.PRESENT(MPARAM_FLAG)) THEN - CALL PUT_PARAMS(PCOUNT,MOD_IX) ! PCOUNT = index for parameter set; ONEMOD=1 (just one model structure) - CALL PUT_SSTATS(PCOUNT,MOD_IX) -ELSE - IF (MPARAM_FLAG) THEN - CALL PUT_PARAMS(PCOUNT,MOD_IX) ! PCOUNT = index for parameter set; ONEMOD=1 (just one model structure) - CALL PUT_SSTATS(PCOUNT,MOD_IX) - ENDIF -ENDIF -! deallocate state vectors -DEALLOCATE(STATE0,STATE1,STAT=IERR); IF (IERR.NE.0) STOP ' problem deallocating state vectors in fuse_rmse ' -! --------------------------------------------------------------------------------------- -END SUBROUTINE FUSE_RMSE -END MODULE FUSE_RMSE_MODULE diff --git a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/nfunc_test__driver.f90.svn-base b/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/nfunc_test__driver.f90.svn-base deleted file mode 100644 index e7744bb..0000000 --- a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/nfunc_test__driver.f90.svn-base +++ /dev/null @@ -1,162 +0,0 @@ -PROGRAM NFUNC_TEST__DRIVER -! --------------------------------------------------------------------------------------- -! Creator: -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! Driver program to evaluate the accuracy and efficiency of adaptive sub-stepping routines -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE ddirectory ! directory for data files -! data modules -USE model_defn,nstateFUSE=>nstate ! model definition structures -USE multiforce, ONLY: AFORCE, DELTIM, NUMTIM ! data interval = maximum model time step -USE multiparam, ONLY: LPARAM, PARATT, NUMPAR ! parameter metadata structures -USE multiroute, ONLY: AROUTE ! model routing structures -USE multistats ! model statistics structures -! informational modules -USE selectmodl_module ! reads model control file -USE getpar_str_module ! extracts parameter metadata -USE par_insert_module ! inserts model parameters -! model numerix -USE model_numerix ! defines decisions on model numerix -! access to model simulation modules -USE fuse_rmse_module ! run model and compute the root mean squared error -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -! (0) GET COMMAND-LINE ARGUMENTS... -! --------------------------------------------------------------------------------------- -CHARACTER(LEN=12) :: MBASIN_ID=' ' ! MOPEX basin ID -CHARACTER(LEN=6) :: FMODEL_ID=' ' ! integer defining FUSE model -CHARACTER(LEN=6) :: NSOLUTION=' ' ! numerical solution (0=implicit, 1=explicit) -CHARACTER(LEN=6) :: FADAPTIVE=' ' ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -CHARACTER(LEN=6) :: TRUNC_ABS=' ' ! absolute temporal truncation error tolerance -CHARACTER(LEN=6) :: TRUNC_REL=' ' ! relative temporal truncation error tolerance -CHARACTER(LEN=12) :: TSTEP_LEN=' ' ! maximum length of the time step (days) -CHARACTER(LEN=6) :: NUMPARSET=' ' ! number of parameter sets -! --------------------------------------------------------------------------------------- -! (1) SETUP MODELS FOR SIMULATION -- POPULATE DATA STRUCTURES -! --------------------------------------------------------------------------------------- -! get model forcing data -INTEGER(I4B) :: NTIM ! number of time steps -INTEGER(I4B) :: INFERN_START ! start of inference period -! get model setup -INTEGER(I4B) :: FUSE_ID ! integer defining FUSE model -INTEGER(I4B) :: NMOD ! number of models -INTEGER(I4B) :: ERR ! error code -CHARACTER(LEN=256) :: MESSAGE ! error message -! define model output -LOGICAL(LGT) :: OUTPUT_FLAG ! .TRUE. = write time series output -INTEGER(I4B) :: ONEMOD=1 ! just specify one model -! --------------------------------------------------------------------------------------- -! (2) RUN MODEL FOR DIFFERENT PARAMETER SETS -! --------------------------------------------------------------------------------------- -INTEGER(I4B) :: IPAR ! loop thru model parameters -INTEGER(I4B) :: IPSET ! loop thru model parameter sets -INTEGER(I4B) :: NUMPSET ! number of parameter sets -TYPE(PARATT) :: PARAM_META ! parameter metadata (model parameters) -REAL(SP), DIMENSION(:), ALLOCATABLE :: BL ! vector of lower parameter bounds -REAL(SP), DIMENSION(:), ALLOCATABLE :: BU ! vector of upper parameter bounds -REAL(SP), DIMENSION(:), ALLOCATABLE :: APAR ! model parameter set -INTEGER(KIND=4) :: ISEED ! seed for the random sequence -REAL(KIND=4),DIMENSION(:), ALLOCATABLE :: URAND ! vector of quasi-random numbers U[0,1] -REAL(SP) :: RMSE ! error from the simulation -! --------------------------------------------------------------------------------------- -! (0) READ COMMAND LINE ARGUMENTS -! --------------------------------------------------------------------------------------- -! read command-line arguments -CALL GETARG(1,MBASIN_ID) ! MOPEX basin ID -CALL GETARG(2,FMODEL_ID) ! integer defining FUSE model -CALL GETARG(3,NSOLUTION) ! numerical solution (0=explicit, 1=implicit) -CALL GETARG(4,FADAPTIVE) ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -CALL GETARG(5,TRUNC_ABS) ! absolute temporal truncation error tolerance -CALL GETARG(6,TRUNC_REL) ! relative temporal truncation error tolerance -CALL GETARG(7,TSTEP_LEN) ! maximum length of the time step (days) -CALL GETARG(8,NUMPARSET) ! number of parameter sets -! check command-line arguments -IF (LEN_TRIM(MBASIN_ID).EQ.0) STOP '1st command-line argument is missing (MBASIN_ID)' -IF (LEN_TRIM(FMODEL_ID).EQ.0) STOP '2nd command-line argument is missing (FMODEL_ID)' -IF (LEN_TRIM(NSOLUTION).EQ.0) STOP '3rd command-line argument is missing (NSOLUTION)' -IF (LEN_TRIM(FADAPTIVE).EQ.0) STOP '4th command-line argument is missing (FADAPTIVE)' -IF (LEN_TRIM(TRUNC_ABS).EQ.0) STOP '5th command-line argument is missing (TRUNC_ABS)' -IF (LEN_TRIM(TRUNC_REL).EQ.0) STOP '6th command-line argument is missing (TRUNC_REL)' -IF (LEN_TRIM(TSTEP_LEN).EQ.0) STOP '7th command-line argument is missing (TSTEP_LEN)' -IF (LEN_TRIM(NUMPARSET).EQ.0) STOP '8th command-line argument is missing (NUMPARSET)' -! define basin desired -FORCINGINFO = 'forcinginfo.'//TRIM(MBASIN_ID)//'.txt' -! convert command-line arguments to integer flags and real numbers -CALL GETNUMERIX() ! defines method/parameters used for numerical solution -READ(FMODEL_ID,*) FUSE_ID ! integer definining FUSE model -READ(NSOLUTION,*) SOLUTION_METHOD ! numerical solution (0=implicit, 1=explicit) -READ(FADAPTIVE,*) TEMPORAL_ERROR_CONTROL ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -READ(TRUNC_ABS,*) ERR_TRUNC_ABS ! absolute temporal truncation error tolerance -READ(TRUNC_REL,*) ERR_TRUNC_REL ! relative temporal truncation error tolerance -READ(TSTEP_LEN,*) MAX_TSTEP ! maximum length of the time step (days) -READ(NUMPARSET,*) NUMPSET ! number of parameter sets -! additional checks -SELECT CASE(SOLUTION_METHOD); CASE(EXPLICIT_EULER,EXPLICIT_HEUN,IMPLICIT_EULER,IMPLICIT_HEUN,SEMI_IMPLICIT) -CASE DEFAULT - PRINT *, 'solution method (1st command line argument) must equal 0 (explicit_euler), 1 (explicit heun), '//& - '2 (implicit_euler), 3 (implicit_heun), or 4 (semi_implicit)' - STOP -END SELECT -SELECT CASE(TEMPORAL_ERROR_CONTROL); CASE(TS_FIXED,TS_ADAPT); CASE DEFAULT; - STOP 'temporal error control (2nd command line argument) must equal 0 (fixed steps) or 1 (adaptive steps)' -END SELECT -write(*,'(A5,1X,2(I1,1X),2(E12.5,1X),I6,1X,A11,1X,I6)') 'FUSE ', & -SOLUTION_METHOD, TEMPORAL_ERROR_CONTROL, ERR_TRUNC_ABS, ERR_TRUNC_REL -! --------------------------------------------------------------------------------------- -! (1) GET MODEL SETUP -- MODEL DEFINITION, AND PARAMETER AND VARIABLE INFO FOR ALL MODELS -! --------------------------------------------------------------------------------------- -! Read data from the "BATEA-compliant" ASCII files -CALL GETFORCING(INFERN_START,NTIM) -! Define model attributes (valid for all models) -CALL UNIQUEMODL(NMOD) ! get nmod unique models -CALL GETPARMETA() ! read parameter metadata (parameter bounds etc.) -! Identify a single model (read control file ../DataFiles/m_decisions.txt) -CALL SELECTMODL(FUSE_ID,ISTATUS=ERR,MESSAGE=MESSAGE) -IF (ERR.NE.0) THEN - PRINT *, TRIM(MESSAGE); STOP -ENDIF -! Define list of states and parameters for the current model -CALL ASSIGN_STT() ! state definitions are stored in module model_defn -CALL ASSIGN_FLX() ! flux definitions are stored in module model_defn -CALL ASSIGN_PAR() ! parameter defintions are stored in module multiparam -! compute derived model parameters (bucket sizes, etc.) -CALL PAR_DERIVE() -! Define output file names (shared in MODULE model_defn) -FNAME_NETCDF = TRIM(OUTPUT_PATH)//TRIM(MBASIN_ID)//'__'//TRIM(SMODL%MNAME)//'__'//& - TRIM(NSOLUTION)//'-'//TRIM(FADAPTIVE)//'__'//& - TRIM(TRUNC_ABS)//'-'//TRIM(TRUNC_REL)//'__'//& - TRIM(TSTEP_LEN)//'__numfuncs.nc' -write(*,'(a)') trim(fname_netcdf) -! Define NetCDF output files (only write parameters and summary statistics) -ONEMOD=1 ! one file per model (i.e., model dimension = 1) -PCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) -OUTPUT_FLAG = .FALSE. ! .TRUE. if desire time series output -CALL DEF_PARAMS(ONEMOD) ! define model parameters (initial CREATE) -CALL DEF_SSTATS() ! define summary statistics (REDEF) -IF (OUTPUT_FLAG) CALL DEF_OUTPUT(NTIM) ! define model time series (REDEF) -! --------------------------------------------------------------------------------------- -! (2) RUN MODEL FOR THE CURRENT PARAMETER SET WITH DIFFERENT NUMERIX OPTIONS -! --------------------------------------------------------------------------------------- -! get parameter bounds and random numbers -ALLOCATE(APAR(NUMPAR),BL(NUMPAR),BU(NUMPAR),URAND(NUMPAR)) -DO IPAR=1,NUMPAR - CALL GETPAR_STR(LPARAM(IPAR)%PARNAME,PARAM_META) - BL(IPAR) = PARAM_META%PARLOW - BU(IPAR) = PARAM_META%PARUPP -END DO -! loop through parameter sets -DO IPSET=1,NUMPSET - ! get new parameter sets - ISEED=IPSET; CALL I4_SOBOL(NUMPAR,ISEED,URAND) - !WRITE(*,'(I4,1X,12(E10.2,1X))') ISEED-1, URAND - APAR = BL + URAND*(BU-BL) - ! run zee model - CALL FUSE_RMSE(APAR,RMSE,OUTPUT_FLAG) -END DO -! and, deallocate space -DEALLOCATE(APAR,BL,BU,URAND) -STOP -END PROGRAM NFUNC_TEST__DRIVER diff --git a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/niter_test__driver.f90.svn-base b/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/niter_test__driver.f90.svn-base deleted file mode 100644 index e3e3ce6..0000000 --- a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/niter_test__driver.f90.svn-base +++ /dev/null @@ -1,169 +0,0 @@ -PROGRAM NITER_TEST__DRIVER -! --------------------------------------------------------------------------------------- -! Creator: -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! Driver program to assess the number of function evaluations taken in four different -! configurations of the Newton scheme: -! 1) Newton's method with line searches (fixed Jacobian) -! 2) Newton's method without line searches (fixed Jacobian) -! 3) Newton's method with line searches (variable Jacobian) -! 4) Newton's method without line searches (variable Jacobian) -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE ddirectory ! directory for data files -! data modules -USE model_defn,nstateFUSE=>nstate ! model definition structures -USE multiforce, ONLY: AFORCE, DELTIM, NUMTIM ! data interval = maximum model time step -USE multiparam, ONLY: LPARAM, PARATT, NUMPAR ! parameter metadata structures -USE multiroute, ONLY: AROUTE ! model routing structures -USE multistats ! model statistics structures -! informational modules -USE selectmodl_module ! reads model control file -USE getpar_str_module ! extracts parameter metadata -USE par_insert_module ! inserts model parameters -! model numerix -USE model_numerix ! defines decisions on model numerix -! access to model simulation modules -USE fuse_rmse_module ! run model and compute the root mean squared error -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -! (0) GET COMMAND-LINE ARGUMENTS... -! --------------------------------------------------------------------------------------- -CHARACTER(LEN=6) :: FMODEL_ID=' ' ! integer defining FUSE model -CHARACTER(LEN=6) :: NUMPARSET=' ' ! number of model parameter sets -INTEGER(I4B) :: FUSE_ID ! integer definining FUSE model -INTEGER(I4B) :: NUMPSET ! number of model parameter sets -! --------------------------------------------------------------------------------------- -! (1) SETUP MODELS FOR SIMULATION -- POPULATE DATA STRUCTURES -! --------------------------------------------------------------------------------------- -! get model forcing data -INTEGER(I4B) :: NTIM ! number of time steps -INTEGER(I4B) :: INFERN_START ! start of inference period -! get model setup -INTEGER(I4B) :: NMOD ! number of models -INTEGER(I4B) :: ERR ! error code -CHARACTER(LEN=256) :: MESSAGE ! error message -! define model output -LOGICAL(LGT) :: OUTPUT_FLAG ! .TRUE. = write time series output -INTEGER(I4B) :: ONEMOD=1 ! just specify one model -! --------------------------------------------------------------------------------------- -! (2) RUN MODEL FOR GIVEN PARAMETER SET AND DIFFERENT NUMERIX CONFIGURATIONS -! --------------------------------------------------------------------------------------- -INTEGER(I4B) :: IPAR ! looping variable -TYPE(PARATT) :: PARAM_META ! parameter metadata (model parameters) -REAL(SP), DIMENSION(:), ALLOCATABLE :: BL ! vector of lower parameter bounds -REAL(SP), DIMENSION(:), ALLOCATABLE :: BU ! vector of upper parameter bounds -REAL(SP), DIMENSION(:), ALLOCATABLE :: APAR ! model parameter set -INTEGER(KIND=4) :: ISEED ! seed for the random sequence -REAL(KIND=4),DIMENSION(:), ALLOCATABLE :: URAND ! vector of quasi-random numbers U[0,1] -INTEGER(I4B) :: IPSET ! (looping) -INTEGER(I4B) :: IJAC ! (looping) -INTEGER(I4B) :: ISCH ! (looping) -REAL(SP) :: RMSE ! error from the simulation -! --------------------------------------------------------------------------------------- -! (0) READ COMMAND LINE ARGUMENTS -! --------------------------------------------------------------------------------------- -! read command-line arguments -CALL GETARG(1,FMODEL_ID) ! integer defining FUSE model -CALL GETARG(2,NUMPARSET) ! number of model parameter sets -! check command-line arguments -IF (LEN_TRIM(FMODEL_ID).EQ.0) STOP '1st command-line argument is missing (FMODEL_ID)' -IF (LEN_TRIM(NUMPARSET).EQ.0) STOP '2nd command-line argument is missing (NUMPARSET)' -! process command-line arguments -CALL GETNUMERIX() ! defines method/parameters used for numerical solution -READ(FMODEL_ID,*) FUSE_ID ! integer definining FUSE model -READ(NUMPARSET,*) NUMPSET ! number of model parameter sets -! --------------------------------------------------------------------------------------- -! (1) GET MODEL SETUP -- MODEL DEFINITION, AND PARAMETER AND VARIABLE INFO FOR ALL MODELS -! --------------------------------------------------------------------------------------- -! Read data from the "BATEA-compliant" ASCII files -CALL GETFORCING(INFERN_START,NTIM) -! Define model attributes (valid for all models) -CALL UNIQUEMODL(NMOD) ! get nmod unique models -CALL GETPARMETA() ! read parameter metadata (parameter bounds etc.) -! Identify a single model -CALL SELECTMODL(FUSE_ID,ISTATUS=ERR,MESSAGE=MESSAGE) -IF (ERR.NE.0) THEN - PRINT *, TRIM(MESSAGE); STOP -ENDIF -! Define list of states and parameters for the current model -CALL ASSIGN_STT() ! state definitions are stored in module model_defn -CALL ASSIGN_FLX() ! flux definitions are stored in module model_defn -CALL ASSIGN_PAR() ! parameter defintions are stored in module multiparam -! Allocate space for the constant Jacobians -ALLOCATE(fjacCOPY(nstateFUSE,nstateFUSE),fjacDCMP(nstateFUSE,nstateFUSE),fjacINDX(nstateFUSE)) -! compute derived model parameters (bucket sizes, etc.) -CALL PAR_DERIVE() -! Define output file names (shared in MODULE model_defn) -FNAME_NETCDF = TRIM(OUTPUT_PATH)//TRIM(SMODL%MNAME)//'_niter-test.nc' -! Define NetCDF output files (only write parameters and summary statistics) -ONEMOD=1 ! one file per model (i.e., model dimension = 1) -PCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) -OUTPUT_FLAG = .TRUE. ! .TRUE. if desire time series output -CALL DEF_PARAMS(ONEMOD) ! define model parameters (initial CREATE) -CALL DEF_SSTATS() ! define summary statistics (REDEF) -IF (OUTPUT_FLAG) CALL DEF_OUTPUT(NTIM) ! define model time series (REDEF) -! --------------------------------------------------------------------------------------- -! (2) RUN MODEL FOR THE CURRENT PARAMETER SET WITH DIFFERENT NUMERIX OPTIONS -! --------------------------------------------------------------------------------------- -! get default numerix parameters -CALL DEFAULT_NUMERIX() -! get parameter bounds and random numbers -ALLOCATE(APAR(NUMPAR),BL(NUMPAR),BU(NUMPAR),URAND(NUMPAR)) -DO IPAR=1,NUMPAR - CALL GETPAR_STR(LPARAM(IPAR)%PARNAME,PARAM_META) - BL(IPAR) = PARAM_META%PARLOW - BU(IPAR) = PARAM_META%PARUPP -END DO -! loop through parameter sets -DO IPSET=963,963+NUMPSET-1 - ! get new parameter sets - ISEED=IPSET; CALL I4_SOBOL(NUMPAR,ISEED,URAND) - WRITE(*,'(I4,1X,12(E10.2,1X))') ISEED-1, URAND - APAR = BL + URAND*(BU-BL) - ! base run with fully-variable Jacobian - JAC_RECOMPUTE = FULLYVARIABLE - CALL FUSE_RMSE(APAR,RMSE,OUTPUT_FLAG) - ! try freezing the Jacobian once we get "sufficiently close" to the solution - JAC_RECOMPUTE = PERIOD_FREEZE - DO IJAC=0,10,2 - THRESH_FRZE = 1. * 10.**-REAL(IJAC, KIND(SP)) - !CALL FUSE_RMSE(APAR,RMSE,OUTPUT_FLAG) - END DO ! (loop through different numerix parameter combinations) - print *, '**********' - ! try only re-computing Jacobian if don't get sufficiently large decrease - ! in the norm of the residual vector - JAC_RECOMPUTE = SMALL_F_RATIO - DO IJAC=10,10,2 - THRESH_FRZE = REAL(IJAC, KIND(SP))/10._sp - print *, THRESH_FRZE - CALL FUSE_RMSE(APAR,RMSE,OUTPUT_FLAG) - END DO ! (loop through different numerix parameter combinations) -END DO ! (loop through different parameter sets) -! and, deallocate space -DEALLOCATE(APAR,BL,BU,URAND) -STOP -END PROGRAM NITER_TEST__DRIVER -! -------------------------------------------------------------------------------------------------------------- -SUBROUTINE DEFAULT_NUMERIX() -USE model_numerix -SOLUTION_METHOD = IMPLICIT_EULER ! implicit euler solution -TEMPORAL_ERROR_CONTROL = TS_FIXED ! fixed time steps -INITIAL_NEWTON = STATE_OLD ! initial conditions for Newton -JAC_RECOMPUTE = FULLYVARIABLE ! fully variable Jacobian -CHECK_OVERSHOOT = LINE_SEARCH ! use line search to trap/fix overshoot problems -ERR_TRUNC_ABS = 1.e-9 ! absolute temporal truncation error tolerance -ERR_TRUNC_REL = 1.e-9 ! relative temporal truncation error tolerance -ERR_ITER_FUNC = 1.e-9 ! iteration convergence tolerance for function values -ERR_ITER_DX = 1.e-9 ! iteration convergence tolerance for dx -THRESH_FRZE = 1.e-9 ! Threshold for freezing the Jacobian -FRACSTATE_MIN = 1.e-9 ! fractional minimum value of state (for non-zero derivatives) -SAFETY = 0.9_sp ! safety factor in step-size equation -RMIN = 0.1_sp ! minimum step size multiplier -RMAX = 4.0_sp ! maximum step size multiplier -NITER_TOTAL = 100 ! total number of iterations used in the implicit scheme -MIN_TSTEP = 0.01_sp/60._sp/24._sp ! minimum time step length (minutes --> days) -MAX_TSTEP = 1440.0_sp/60._sp/24._sp ! maximum time step length (minutes --> days) -END SUBROUTINE DEFAULT_NUMERIX diff --git a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/optimiser_miniDmsl_qnewton_kit.f90.svn-base b/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/optimiser_miniDmsl_qnewton_kit.f90.svn-base deleted file mode 100644 index 8a1eb19..0000000 --- a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/optimiser_miniDmsl_qnewton_kit.f90.svn-base +++ /dev/null @@ -1,7047 +0,0 @@ -!****************************************************************** -! (C) Copyright 2000-2008 --- Dmitri Kavetski --- All rights reserved -!****************************************************************** -module optimiser_dmsl_kit -! Purpose: Contains advanced numerical optimisation methods in Fortran-95. -! Programmer: Dmitri Kavetski, Created September 2003. -! Last modified 17 January 2005. -! This code is part of the DMSL library and is subject to use restrictions -! (see DMSL readme file for details). -! --- -! Primary References: -! * NW2000: Nocedal,J. and Wright,S.J.(2000) Numerical Optimization, Springer. -! * F1996: Fletcher,R.(1996) Practical Methods of Optimization,2nd Ed,Wiley. -! * DS1996: Dennis Jr,J.E. and Schnabel,R.B.(1996) Numerical Methods for -! Unconstrained Optimization and Nonlinear Equations, SIAM reprint. -! * GMW1981: Gill,P.E.,Murray,W. and Wright,M.H.(1981) Practical Optimization, -! Academic Press. -! * GW1976: Gill,P.E. and Murray,W.(1976) Minimization subject to bounds on -! variables, NPL report NAC72. -! * P1992: Press et al.(1992) Numerical Recipes in F-77, 2nd ed, Cambridge Press. -! --- -! Notes: -! * The module follows fairly closely the classical modular system presented by -! Dennis and Schnabel (DS1996) also utilising material from more recent references -! (NW2000). However, exploiting Fortran-95, the code is much more compact, at the -! expense of some possible memory and efficiency losses (array operations). -! These 'deficiencies' are (i) usually negligible, assuming the function -! being optimised is expensive to evaluate, but (ii) greatly simplify developing, -! debugging and modifying the code. -! * In addition to the 'proper' Newton-type methods (classic Newton, quasi-Newton), -! this code also includes limited-memory quasi-Newton and conjugate-gradient methods. -! This makes the code suitable for superdimensional problems. -! * If you function is very cheap to evaluate (i.e., cheaper than the linear algebra -! in Newton-type equations), this code may become inefficient relative to carefull -! micro-optimized codes, particularly for high-dimensional bounded problems. -! --- -use kinds_dmsl_kit ! kind definitions -implicit none -private -!public::multiStart -public::qnewton,qnewtonUnwise_type -!public::LBFGS -!----------------------------- -public::QN_DMSL_mometh,LBFGS_mometh -!----------------------------- -! * Parameterised external settings -! Generic indicator: user supplied evaluator -integer(mik),parameter::user_meth= 0 ! user-provided (Hessian,gradient,etc.) -! Method selection for multistart optimisation -integer(mik),parameter::none_mometh= 1,& ! random search - QN_DMSL_mometh= 2,& ! native DMSL quasi-Newton (best for middle-D problems) - QN_IMSL_mometh= 3,& ! IMSL-based quasi-Newton - LBFGS_mometh= 4,& ! LBFGS scheme (best for huge-D problems) - SCE_mometh= 5 ! SCE search (multistart version probably redundant) -! Iteration globalisation methods -integer(mik),parameter::null_imeth= 0,& ! No globalisation (usually 4 testing only) - armijo_imeth= 1,& ! Armijo backtracking linesearch - wolfe_imeth= 2,& ! Wolfe condition linesearch - stwolfe_imeth= 3,& ! Strong Wolfe condition linesearch - brentmin_imeth= 4,& ! Brent line minimisation - trustEx_imeth= 5,& ! Near-exact trust method ("hookstep") - dogLeg_imeth= 6 ! Generalized dogleg trust method -! Gradient computation method -integer(mik),parameter::fd_gmeth= 1,& ! Forward difference gradient - cd_gmeth= 2 ! Central difference gradient -! Hessian computation methods -integer(mik),parameter::fdg_hmeth= 1,& ! Newton, Hessian by fwd differencing gradient - cdg_hmeth= 2,& ! Newton, Hessian by cntrl differencing gradient - fdf_hmeth= 3,& ! Newton, Hessian by fwd differencing function - cdf_hmeth= 4,& ! Newton, Hessian by cntrl differencing function - bfgsInv_hmeth= 5,& ! Quasi-Newton, BFGS update of inverse Hessian - bfgsUnfac_hmeth=6,& ! Quasi-Newton, BFGS update of unfactored Hessian - bfgsFac_hmeth= 7,& ! Quasi-Newton, BFGS update of factored Hessian - SR1unFac_hmeth= 8,& ! Quasi-Newton, SR1 update of unfactored Hessian - NCG_FR_hmeth= 9,& ! Conjugate-gradient method, Fletcher-Reeves - NCG_PR_hmeth= 10,& ! Conjugate-gradient method, Polak-Ribiere - NCG_PPR_hmeth= 11 ! Conjugate-gradient method, Positive Polak-Ribiere -! quasi-Hessian initialisation method (ignored for non-quasi-Newton methods) -integer(mik),parameter::unt_himeth= 1,& ! Unit matrix - untcnd1_himeth= 2,& ! Unit matrix with conditioning on 1st step - scld_himeth= 3,& ! Scaled matrix - scldcnd1_himeth=4,& ! Scaled matrix with conditioning on 1st step - d2fdx2_himeth= 5,& ! Diagonal of estimated d2f/dx2 - hessX0_himeth= 6 ! Hessian at initial point (approx) -!----------------------------- -! * Parameterised internal settings -! Termination test values -integer(mik),parameter::no_con= 0,& ! No convergence yet - grad_con= 1,& ! Gradient criterion satisfied - search_con= 2,& ! Search tolerance satisfied - fred_con= 3,& ! Function reduction criterion satisfied - switchCD_con= 4,& ! Switch to central difference gradient - srchBadGrad_con=5,& ! Search convergent but grad still large - fredBadGrad_con=6 ! Function convergent but grad still large -! Globalisation return codes -integer(mik),parameter::badFunc_glob= -3,& ! Function evaluation returned error - unfeas_glob= -2,& ! Unfeasible points along search direction - badDir_glob= -1,& ! Bad direction provided (eg, not descent) - failed_glob= 1,& ! Failed to achieve globalisation objective - success_glob= 0,& ! Globalisation objective achieved - fconv_glob= 2 ! Globalisation converges to function precision -! Trust region iteration return codes -integer(mik),parameter::unfeas_tr= -2,& ! unfeasible region inside trust region - failed_tr= -1,& ! trust region did not achieve required f(x) reduction - suceed_tr= 0,& ! trust region successful - collapsed_tr= 1,& ! trust region collapsed to stol - blown_tr= 2,& ! trust region blown up to stepmax - dxTiny_tr= 3,& ! restricted step negligible - fconExpObs_tr= 4,& ! expected reduction within machine precision - goBig_tr= 5,& ! step to be retaken with larger trust radius - expRedNonP_tr= 6 ! expected function reduction nonpositive -! Trust region subproblem outcomes -integer(mik),parameter::onTrustBound= 0,& ! trust region step constrained by bound - insideTrust= 1,& ! trust region step well inside trust radius - hardCase= 2,& ! trust region encountered More's "hard case" - failed2Solve= -1 ! failed to solve the trust subproblem -! Status codes for finite difference gradient estimation -integer(mik),parameter::fresh_hx= 0,& ! freshly estimated stepsize - old_hx= 1 ! stepsize estimated at different point -! Active set values -integer(mik),parameter::freeVar_as= 0,& ! free variable inside search bounds - loVar_as= -1,& ! variable fixed at lower bound - hiVar_as= +1,& ! variable fixed at upper bound - freeLoVar_as= -2,& ! variable on lower bound, Lgrng mult < 0 - freeHiVar_as= +2 ! variable on upper bound, Lgrng mult < 0 -! Miscellaneous return codes -integer(mik),parameter::okAlg= 0,& ! algorithmic sucess - failAlg= 1,& ! algorithmic failure (not bug) - bugFail= +100 ! failure due to apparent bug -! Iteration info summary -integer(mik),parameter::iterNfo_no= 0,& ! no iter info - iterNfo_summ= 1,& ! iteration summary - iterNfo_var= 2 ! summary and variables after each iteration -! Gradient check strategy -integer(mik),parameter::chkG_neva= -1,& ! never check gradient - chkG_fail= 0,& ! fast check when failed to globalise - chkG_f2g= 1,& ! full check when failed to globalise - chkG_dxstp= 2,& ! fast check every step with dx - chkG_hxstp= 3,& ! fast check every step with hx - chkG_full= 4 ! full check every step -! Hessian checking strategy -integer(mik),parameter::chkHess_no= 0,& ! no Hessian checking - chkHess_f2g= 1,& ! full check when failed to globalise - chkHess_full= 2 ! full check every step -! Finite difference 'reliable' gradient estimation method -integer(mik),parameter::gradFD_gill= 1,& ! Gill et al. method - gradFD_sw1= 2,& ! Stepleman and Winarsky method,O(h) - gradFD_sw2= 3 ! Stepleman and Winarsky method,O(h2) -! Implementation of Strong Wolfe linesearch -integer(mik),parameter::strongwolfe_more= 1,& ! Fairly sophisticated Strong Wolfe linesearch - strongwolfe_fletcher=2 ! Brute force "bisection"-style beast -! Elliptical scaling of Hessian -integer(mik),parameter::xscaleH_sphere= 0,& ! Spherical Hessian - xscaleH_user= 1,& ! User-supplied ellipticity (xscale) - xscaleH_hdiag= 2 ! Adaptive ellipticity based on Hessian diagonal -! Modified Hessian factorization -integer(mik),parameter::schnab_facmeth= 0,& ! revised modified Cholesky-Gershgorin of Schnabel/Eskew - dennis_facmeth= 1 ! perturbed Cholesky-Gershgorin of Dennis/Schnabel -! Hybrid FD<->CD gradient (hybridFDCD) -integer(mik),parameter::useFDCDhybrid= -12 ! allows use of hybrid FD<->CD gradient -! fd_gmeth(1) and cd_gmeth(2) force strict O(1) and O(2) methods -! Types of Cauchy steps -integer(mik),parameter::cauchyInside= 0,& ! Cauchy step inside trust region - cauchyOnBound= 1,& ! Cauchy step constrained by trust - cauchyInfin= 2,& ! Cauchy step wants infinity - cauchyZeroGrad= 3 ! Cauchy collapses because grad~0 -! Active set diagonal fixing option -integer(mik),parameter::setUnit_fixDiag= 0,& ! Set fixed diagonals to unity - keepDiag_fixDiag=1 ! Keep fixed diagonals as is -! Types of bounds for L-BFGS [DK: defined in LBFGS engine] -integer(mik),parameter::no_btype= 0,& ! No bounds - lo_btype= 1,& ! lower bound only - lh_btype= 2,& ! low & high bounds - hi_btype= 3 ! high bound only -!----------------------------- -! Global constants -character(*),parameter::unknownMethodChar="UNKNOWN METHOD (USER INPUT ERROR)" ! text of error message -logical(mlk),parameter::bfgsInvNR=.true.,bfgsInvUt=bfgsInvNR ! NR-based method for inverse quasi-Hessian update -!----------------------------- -! * External bundle -! The type below parameterises esoteric settings which are preset to default values. -! Only those users with some idea of the method (and the code!) should mess with them... -type qnewtonUnwise_type -! Initial point analysis - real(mrk)::gtol0fac=1.e-3_mrk ! reduction in gtol for initial point analysis -! Linesearch settings - real(mrk)::alpha_ls=1.e-4_mrk ! Wolfe criterion - real(mrk)::beta_ls=0.9_mrk ! Wolfe criterion (linesearch for Newton methods) - real(mrk)::beta_ls_CG=1.e-3_mrk ! Wolfe criterion (line minimisation for CG) - integer(mik)::LNSstrongwolfe=strongwolfe_more ! strong Wolfe linesearch algorithm - logical(mlk)::useDirDer=.false. ! allows cheap directional derivatives (Wolfe) - integer(mik)::linmin_ometh=2 ! line minimisation method (0=golden,1=Brent,2=dBrent) - real(mrk)::linmin_tol=1.e-8_mrk ! tolerance in line minimisation - integer(mik)::linmin_itmax=1000 ! max number of iterations in line minimisation -! Trust region settings - real(mrk)::acceptRatio_tr=1.e-4_mrk ! acceptable fred ratio (obs/pred) - real(mrk)::roDown_tr=0.10_mrk ! below this fred ratio trust is decreased - real(mrk)::radDown_tr=0.25_mrk ! trust reduction factor - real(mrk)::roUp_tr=0.7_mrk ! above this fred ratio trust can be increased - real(mrk)::stepOtrustUp_tr=0.5_mrk ! if stepLen/trustRad>stepOtrust increase trust - real(mrk)::radUp_tr=2.00_mrk ! trust increase factor - real(mrk)::trustOstepMax_tr=1.e2_mrk ! if trustRad/stepLen>trustOstepMax truncate trust - real(mrk)::roUpNow_tr=0.8_mrk ! "increase trust now!" fred threshold - integer(mik)::niter_tr=20 ! max outer iterations of trust region - integer(mik)::ncholMax_tr=200 ! max Cholesky decomposition per trust solution - real(mrk)::SR1forceUpdt=-1.e1_mrk ! if SR1 perform below this ratio, force update - logical(mlk)::pivotCholTrust=.true. ! true for pivoted Cholesky in trust region (can be over-ruled) - real(mrk)::dogNewtBias=0.8_mrk ! Dogleg bias towards Newton (0=single dogleg) - real(mrk)::boundFrac=1.0_mrk ! prevents small trust expansions constrained by bounds -! Quasi-Hessian update settings - logical(mlk)::skipQNupdtClassic=.false. ! forces "classic" update-skip condition in QN methods - logical(mlk)::allowQHreset=.false. ! reset quasi-Hessian to identity when failing - logical(mlk)::maxSR1update=.false. ! force frequent SR1 updates - logical(mlk)::facBFGS_useR2=.false. ! requests rank-2 BFGS updates (QR method) - logical(mlk)::facBFGS_getLLt=.false. ! DEBUG: requests backup unfactored BFGS Hessian - logical(mlk)::dampedBFGS=.true. ! requests damped BFGS updating (better than classic skips) - real(mrk)::dampFac=0.2_mrk ! BFGS damping factor -! Hessian scaling method - integer(mik)::xscaleHmeth=xscaleH_user ! ellipticity of Hessian -! Function roundoff estimation - real(mrk)::Hscale=1._mrk ! scale for roundoff estimation in f(x) - real(mrk)::hammPow=1._mrk/3._mrk ! power of epsRe in "h" for Hammings analysis -! Performance output - integer(mik)::iterNfo=iterNfo_var ! iteration info option -! Active set bound constraints handling - real(mrk)::tolGfree_bnd=1.e-1_mrk ! tolerance on gradient (Lgrng mult) for fast release (>1.0=>ignore) - real(mrk)::tolOptSlack_bnd=1.e3_mrk ! slack factor on "stol&ftol" to release vars (<1.0=>ignore) - real(mrk)::tolGfree2_bnd=1.e-1_mrk ! tolerance for standard release (>1.0=>4 1 @ a time del) - integer(mik)::fixDiagOption=keepDiag_fixDiag ! what to do with diagonals of fixed variables -! False convergence analysis - real(mrk)::tolFalseDx=1.e3_mrk*epsRe ! false convergence tolerance on dx - integer(mik)::nFalseDxMax=100 ! max consecutive steps satisfying false tol - integer(mik)::nFalseRfrshDxMax=20 ! max consecutive steps satisfying false tol for refresh -! Gradient checking - integer(mik)::chkGrd=chkG_fail ! gradient checking option - integer(mik)::chkGrd_gmeth=fd_gmeth ! gradient checking method - real(mrk)::chkGrd_tG=1.e-2_mrk ! gradient check tolerance on g(x) agreement - real(mrk)::chkGrd_tGdf=1.e-4_mrk ! gradient check tolerance on df - real(mrk)::chkGrd_tF=1.e-2_mrk ! gradient check tolerance on f(x) vals - real(mrk)::chkGrd_h=1.e0_mrk ! h-value (scale) in gradient check -! Hessian checking - integer(mik)::chkHess=chkHess_no ! Hessian checking option - integer(mik)::chkHess_hmeth=fdg_hmeth ! Hessian checking method - logical(mlk)::ignoreBadHess=.true. ! no action taken on bad Hessians -! Finite difference gradient approximation - real(mrk)::FDscale=1._mrk ! scale for finite difference gradient (GMW,p345) - logical(mlk)::useHxDef=.true. ! forces default finite difference stepsize - logical(mlk)::hybridFDCD=.false. ! mixed FD/CD componentwise gradient approximation - integer(mik)::dfdx0meth=gradFD_gill ! initial dfdx estimator method - logical(mlk)::allowFDCD=.false. ! allows enhanced switches FD<->CD gradient - real(mrk)::tolFDCD=1.e-2_mrk ! truncation error tolerance for FD->CD (enhanced) - real(mrk)::fracFDCD=0.3_mrk ! critical fraction for FD->CD switch (enhanced) - real(mrk)::tolCDFD=1.e+1_mrk ! truncation error tolerance for CD->FD (enhanced) - real(mrk)::fracCDFD=0.5_mrk ! critical fraction for CD->FD switch (enhanced) - real(mrk)::tolGradFDCD=1.e-1_mrk ! gradient tolerance for FD->CD switch - real(mrk)::tolGradCDFD=1.e+1_mrk ! gradient tolerance for CD->FD switch - real(mrk)::tolDxFDCD=0.e-6_mrk ! step tolerance for FD->CD switch - logical(mlk)::adaptFDhX=.false. ! adapt FD hx using Hessian diagonal - logical(mlk)::adaptCDhX=.false. ! adapt CD hx using Hessian diagonal -! Modified Hessian factorization settings - integer(mik)::facmeth=schnab_facmeth ! modified factorization method - real(mrk)::tau=undefRN ! (schnab) these values indicate default initial e^1/3 - real(mrk)::tauBar=undefRN ! (schnab) e^2/3. but F-95 precludes initialisation here - real(mrk)::mu=0.1_mrk ! (schnab) - real(mrk)::maxHessCond=undefRN ! (dennis) bound on condition of modified Hessian - logical(mlk)::controlHessCond=.false. ! Hessian condition control -endtype qnewtonUnwise_type -!----------------------------- -! * Internal data bundles -!--- -type gmethBundle_type ! - Gradient evaluation bundle - integer(mik),pointer::gmeth_now - logical(mlk)::useHxDef - real(mrk)::FDscale - real(mrk),pointer::hx(:)=>null() - logical(mlk)::hybridFDCD - real(mrk)::tolGradFDCD - logical(mlk)::useDirDer -endtype gmethBundle_type -!--- -type trustBundle_type ! - Trust region bundle - real(mrk)::acceptRatio_tr - real(mrk)::roDown_tr - real(mrk)::radDown_tr - real(mrk)::roUp_tr - real(mrk)::stepOtrustUp_tr - real(mrk)::radUp_tr - real(mrk)::roUpNow_tr - real(mrk)::trustOstepMax_tr - integer(mik)::niter_tr - integer(mik)::ncholMax_tr - real(mrk)::trustMax - real(mrk)::trustMin - real(mrk)::SR1skipTol - real(mrk)::SR1forceUpdt - logical(mlk)::pivotCholTrust - real(mrk)::dogNewtBias - real(mrk)::boundFrac -endtype trustBundle_type -!--- -type objFuncBundle_type ! - Function properties bundle - real(mrk)::epsF - real(mrk)::Hscale -endtype objFuncBundle_type -!--- -type hessFacBundle_type ! - Hessian factorization bundle - integer(mik)::facmeth - real(mrk)::tau - real(mrk)::tauBar - real(mrk)::mu - real(mrk)::maxHessCond -endtype hessFacBundle_type -!----------------------------- -contains -!---------------------------------------------------- -subroutine qnewton( & - evalFunc,dataIN,dataOUT, & ! Objective function to be minimised - x0, & ! Initial estimate of optimum - xLo,xHi,activeSet, & ! Upper and lower bounds on solution, active set - gtol,stol,ftol, & ! Termination tolerances - xscale,fscale,fdigits,stpmax, & ! Scaling settings - imeth,gmeth,hmeth, & ! Computational algorithms - himeth,trustRad, & ! Initialisation settings - maxIter,maxFev, & ! Termination due to excessive effort - uout, & ! Output unit for runtime information - xopt,fopt, & ! Approximated optimal solution - gradOpt,hessOpt, & ! Useful diagnostics and information - iter,fcalls,gcalls,hcalls, & ! Computational cost report - memHess2, & ! Memory footprint - qnewtonUnwise, & ! Esoteric settings that shouldnt be touched - err,message) ! Return codes and runtime messages -!--------------- -! Purpose: Implements Newton-type and conjugate-gradient methods for optimisation -! (minimisation) of differentiable (C2 class) functions f(x) evaluated by subroutine -! "evalFunc". Analytical derivatives (gradient and Hessian) need not be known, but -! can be approximated internally or externally. -! But if the objective function is genuinely non-differentiable, the -! Newton-type methods in this code will have (major, fatal) difficulties. -! Methods may still work on C1 functions (eg, singular Hessian), but with loss of -! computational efficiency. For C2 functions with reasonably accurate gradient estimates -! the methods generally converge at least superlinearly in the vicinity of the solution. -! Non-differentiable functions should be handled using simplex-type or Monte Carlo methods. -! --- -! Programmer: Dmitri Kavetski -! 17 January 2005. -! --- -! * For difficult problems there may be large variations in efficiency depending on -! algorithmic settings (factors of 10-1000 not too unusual even for simple test -! functions such as Rosenbrock with poor initial guesses/scaling). Hence, if a -! problem is taking too long to solve, experimenting with different methods may prove -! beneficial (may also boost confidence in results). -! * When solution bounds xLo and xHi not provided solves unconstrained problems. -! Unconstrained algorithm may still work on "softly" constrained problems, ie, -! when the optimum of a (possibly nonlinearly) constrained problem is "well" away -! from the constrains. Method "should" also work on box-constrained problems -! where the descent direction at the boundary points inwards (the box can be of -! arbitrary shape). For truly contrained problems, supplying the optional arguments -! "xLo,xHi,activeSet" invokes the active set strategy, which is the correct way -! to solve bound-constrained problems. The conjugate-gradient method here also uses -! the active set scheme, but is probably less suited to it than Newton-type methods. -! NB: either none or both bounds (xLo and xHi) need to be supplied. If bounds are -! supplied, then activeSet must also be supplied. -! * When solution bounds "xLo" and xHi" provided, solves bound-constrained problems -! using the classic active set strategy. If a variable hits a bound, it is fixed -! and its quadratic information discarded. The variable is then released only when -! special conditions are met (based largely on its Lagrange multiplier). These -! settings can be tuned to minimise zigzagging. -! * The Fortran-95 code here is designed for balanced clarity/efficiency. However, -! no huge effort is taken to minimise storage (eg, 1D array storage of matrices), -! since this negatively impacts on code readability/maintenance. In this code, -! reduction of computations takes precedence over reduction of memory, with the -! rationale that modern computing operates in memory-rich environment. -! * It is assumed that the primary computational cost of the optimisation is the -! evaluation of functions. Hence no huge effort directed to optimise "small-scale" -! arithmetic. In addition, note that the near-exact (hookstep) trust region method -! may require several Cholesky decompositions per step. If your function is -! considerably cheaper than a Cholesky decomposition then a dogleg-type trust region -! (or linesearch) algorithm may be more efficient in computing time. Conjugate-gradient -! methods are particularly fast per-step, but may be somewhat less robust. -! * Code testing and QA: The code was written from scratch by DK, and tested -! "moderately" both internally (checking intermediate results) and externally -! (checking performance on known test problems and also on fairly difficult problems -! in water engineering where solutions have already been obtained using alternative -! methods). -! The current version has been tested using the following functions, -! with satisfactory results in both constrained and unconstrained conditions -! - Quadratic functions (n=2) -! - Rosenbrock function (n=2...10,000) -! - Powell Singular function (n=4...20) (which has singular Hessian at optimum) -! - Trigonometric function (which has multiple 'global' optima) -! - Helical valley function (n=3) -! - Wood function (n=4) -! - Water engineering objective functions, mixture of strong and mild -! nonlinearities (n=20-80) -! In all cases the DMSL code performed comparatively the same as equivalent IMSL -! code (both have the same basic pseudocode, DS96). In general, it is always -! recommended to verify numerical approximations using independent methods and codes. -! Having a version of IMSL is often quite handy psychologically if another -! code is having difficulties and one suspects its computer implementation. -! * Algorithm selection (Exact=exact Hessian) -! - Typically superior options -! . Trust region Exact/BFGS/SR1 method (imeth=5 & hmeth=0,6,8) -! . Strong-Wolfe linesearch Exact/BFGS method (imeth=3 & hmeth=0,6-7) -! . Strong-Wolfe linesearch with PR method (large N) (imeth=3 & hmeth=10,11) -! . Brent line minimisation with PR method (large N) (imeth=4 & hmeth=10,11) -! - Intrinsically incompatible options -! . Inverse BFGS Hessian and hookstep trust region (imeth=5 & hmeth=5) -! . Factored BFGS Hessian and hookstep trust region (imeth=5 & hmeth=7) -! . Conjugate gradient method and trust regions (imeth=5-6 & hmeth=9,10,11) -! - Currently incompatible options -! . Inverse BFGS Hessian and active set method (hmeth=5 & xLo/xHi) -! . Brent line minimisation and active set method (imeth=4 & xLo/xHi) -! - Poor combined performance likely -! . SR1 Hessian and linesearch methods (imeth=1-4 & hmeth=8) -! . Conjugate gradient method and crude linesearches (imeth=0-2 & hmeth=9,10,11) -! * For problems poorly solved (or not solved at all) by the default algorithms, -! changing the method often helps, sometimes dramatically. E.g., the trust region -! method is generally solid, but in some cases linesearches are more efficient. -! In very rare cases, the finite difference gradient can perform better than -! analytical gradients (eg, on a narrow plateau analytical gradient can be -! small, but the finite difference stepsize may indicate nearby regions of -! larger gradient). However, the more derivative information is used, the better -! performance is to be expected. In DK's experience, the best option is -! exact gradient/exact Hessian with trust region. If exact gradient available, -! estimating the Hessian from the gradient is typically the next reliable option, -! since quasi-Newton method can be fooled by rapid changes in curvature. -! * For quasi-Newton methods, a good initial Hessian is often very beneficial, -! and often has more influence on the final results than other settings. -! * For difficult problems the default esoteric settings can be inefficient and even -! prevent success. The optional 'qnewtonUnwise' argument gives the user access -! to virtually all algorithmic parameters of this code. But use them with care! -! * Whenever the exact gradient is supplied, the algorithm performance will typically -! improve, sometimes dramatically. Note that finite difference gradients inevitably -! become inaccurate near optima, which limits the accuracy to which the solution -! can be approximated. If some elements of the gradient can be calculated analytically -! but others cannot, it may be worthwhile to use gmeth=0 option and approximate -! the remaining elements numerically inside the user-supplied routine "evalFunc". -! * Whenever the exact Hessian is supplied, the algorithm performance will improve, -! but often not as dramatically as when approximate gradients are replaced -! by exact gradients. This is because the gradient determines the entirety of -! descent directions, whereas the Hessian merely selects the optimal member of this -! set of directions. When the gradient is approximate, the set of descent directions -! will also be inaccurate, which more fundamentally degrades the algorithm. -! * Whenever supplying any derivatives analytically, it is strongly recommended to -! check them as thoroughly as possible. It has been claimed (and the author -! fully believes this) that the majority of failures when using optimisation -! methods is due to inaccurate calculation of derivatives by the user. The code has -! options to check the supplied gradients and Hessians. Since such checking usually -! finds any errors very quickly, but is often expensive in terms of function calls, -! it is usually sufficient to run the check for a few iterations only. -! The most informative gradient checking option is "chkG_full", which checks every -! gradient component at every step. This is very expensive and not recommended -! except in initial stages of a project where code verification is necessary. -! It is more efficient (but less reliable) to use the directional derivative to -! check the gradient. Option "chkG_hxstp" check the gradient at every step using -! a much cheaper method (2 function calls per check). By default, however, the -! gradient is checked only when failing to globalise. -! * The code can be (and has been) used as a 'black-box' for special optimisation, -! e.g., nonlinear least squares (NLS). However, NLS problems not only possess -! extra structure that can be exploited for efficiency, but are also often subject -! to strong ill-conditioning. In these cases supplying the analytical SS Hessian -! has the negative effect of squaring the condition number of the problem. -! For tough NLS problems a dedicated solver is often essential, based on QR or SVD -! decomposition of Gauss-Newton Hessian equations. -! * For superdimensional problems Newton-type methods will fail due to O(N2) memory -! growth and the O(N2)-O(N3) linear algebra on the Hessians. Instead, the -! conjugate gradient methods should be used, which are only O(N) in both memory -! (no Hessian stored) and cost-per-step (no linear alegbra). But there is some -! reduction in robustness of the code, so accurate initial estimates and good -! scaling become particularly important. -!--------------- -! * Available selection of algorithms: -! 1. Iteration schemes: -! Newton methods: Classical and Discrete -! Quasi-Newton methods: BFGS (factored/unfactored) and SR1 -! Conjugate gradient methods: Fletcher-Reeves, Polak-Ribiere and PR+ -! 2. Globalisation methods: -! Linesearch methods -! - Armijo, Wolfe and Strong Wolfe search conditions -! - Brent line minimisation with/without derivatives -! Trust region methods -! - Near-exact (hookstep) solutions -! - Generalized dogleg (2D subspace minimization) solutions -! 3. Active set method for bounded optimisation -! 4. Optional "smart" semi-adaptive finite difference gradient approximations: -! Forward differences (adaptive dynamic/static stepsize) -! Central differences (adaptive static stepsize) -! 5. Optional default-stepsize finite-difference Hessian approximations: -! Forward differences of gradient -! Forward differences of function -! Central differences of function -! 6. Static/adaptive step scaling -! Static scaling based on user xscale (Dennis and Schnabel) -! Dynamic scaling based on Hessian ellipticity (Nocedal) -! 10.Auxiliary tools: -! Hamming's empirical determination of function evaluation precision -! Fast/full gradient checking -! Full Hessian checking -!--------------- -! * Code peculiarities -! 1. The statement "goto 1000 !return" is effectively a return statement - -! it directs the code to the cleanupMem routine to free the heap space ("hessScaled"). -!--------------- -! **** Troubleshooting Newton optimisation **** -! 1. Do not expect to solve a hard problem with a default algorithm. Many problems -! have some specific structure that makes them difficult to some methods. -! Special insight and experimentation is often required for such problems. -! This code offers many algorithm selections and, provided the problem has -! a reasonably well-posed solution, it is likely one of the methods will succeed -! and be efficient. In particular, having the analytical gradient puts at our -! disposal far more reliable algorithms than when finite difference gradients -! are used. Hence a day's effort in programming reliable derivatives is often -! repaid by more consistent and efficient performance (and allows higher final accuracy). -! 2. Algorithm returns with a warning (err<0), with the solution NOT satisfying the -! prescribed tolerances. This typically occurs if the tolerances are too stringent and -! iterations are stopped due to lack of progress. This warning is often innocuous and -! in some codes is actually a sucessful return condition (suggesting convergence). -! This code is more cautious in reporting sucess, so looking at the log file is useful -! to establish whether a satisfactory solution is obtained. More generally, realistic -! tolerances depend on whether analytical or approximate gradients are used. Exceedingly -! stringent tolerances hamper efficiency. E.g., the algorithm can start thrashing around -! at the end, since FD gradients (and often even analytical) are highly inaccurate -! near stationary points. Even analytical gradients can be inaccurate for such points, -! due to scaling constraints in floating point computation. Finally, Taylor series -! analysis shows its generally impossible to zero the gradient to full machine precision. -! See recommened ('default') tolerances below, but be prepared to modify (relax) them! -! 3. Recommended values for primary tolerances: -! With exact grads: gtol=epsRe**1/2; stol=aE*epsRe; ftol=bE*epsRe -! With approx grads: gtol=epsRe**1/3 or epsRe**1/4; stol=aA*epsRe; ftol=bA*epsRe -! where aE=aA=bE=bA ~ 10-100. Alternatively try something like stol=ftol ~ epsRe**2/3 -! See good discussions in GMW1981 and DS1996. -! NB: for small-residual least-squares problems ftol can be set to epsRe**2 due -! to special properties of these problems (see GMW1981 & DS1996). -! 4. Finite difference gradient poorly approximating actual gradient. -! - This algorithm can use default stepsize ("useHxDef=.true.") which assumes that -! the function being optimised is well-scaled. This is fast and typically -! satisfactory (at least good enough for IMSL). -! - Poorly scaled functions may require the adaptive stepsize. "useHxDef=.false." -! deploys stepsize adaption at the initial point and whenever slow progress -! is taking place. This option is usually more robust, but can also be rather costly -! in terms of function calls, particularly the SW (Stepleman/Winarsky) option. -! A potential weakness of the "useHxDef=.false." option is that the gradient is -! optimised for the selected points only. If the optimal stepsize varies -! significantly, the mechanism does not always recognise that slow progress is -! being made and hence perseveres with potentially poor gradients, slowing -! the whole thing down. In these cases, the slow-progress diagnostics 'tolDxFDCD', -! and 'tolFalseDx' may help. -! - Often the Quasi-Newton Hessian gives useful order-of-magnitude estimates -! of d2f/dx2 that can be used to cheaply optimise the gradient stepsize at each -! Newton step ("adaptFDhX=.true."). -! - Since forward differences become progressively inaccurate as the iterations -! converge to an optimum, a timely switch to central differences can boost -! efficiency by preventing many iterations at the limiting accuracy of the -! gradient approximation, where very little progress is made at each step. This -! algorithm will never terminate on a forward difference gradient alone, but -! setting "allowFDCD=.true." enables additional switches to central differences, -! which is often beneficial but sometimes wasteful if premature switches occur. -! - The tolerance "tolGradFDCD" allows forcing central differences whenever -! the scaled gradient is below this tolerance. "tolGradCDFD" regulates the switch -! back to central differences, which is often beneficial when the function has -! plateaus that must be negotiated using central differences before the area -! of faster function variation is reached. -! This switch is standard and is attempted regardless of allowFDCD (enhanced switches) -! - "tolFDCD/CDFD" and "fracFDCD/CDFD" allow switches FD<->CD governed by truncation -! error analysis based on the Hessian diagonal. This switch is non-standard and -! seems rarely needed (a similar/more reliable effect given "tolGradFDCD/tolGradCDFD". -! Set allowFDCD=.false. to ignore this option. -! - "tolDxFDCD" requests a switch to central differences if the scaled step is small. -! - "dfdx0meth" selects between the Gill et al. and Stepleman/Winarsky finite -! differencing. The former is usually cheaper, the latter usually more robust. -! - In general, use of finite differences gradients can degrade the convergence -! and final accuracy of the solution. Hence it is often beneficial to take care -! to provide the best accurate derivatives possible, preferably analytically. -! Sometimes the user may have a better idea of stepsize selection, which can -! certainly be very helpful. In this case, set "gmeth=user" and implement the -! optimal finite differencing yourself. -! 5. Zigzagging on/off bounds (this can be diagnosed from the iteration info file) -! - For functions with many active constraints, undesirable zigzagging may occur -! where a variable is repeatedly fixed/released, causing small steps to be taken -! at each iteration. -! - setting "tolOptSlack_bnd" to a low value will increase the tolerance to which -! the function is optimised before changes in the active set are allowed. -! Set "tolOptSlack_bnd<1" to optimise the function to full extent before releasing -! any variables (NB: gtol is not affected by tolOptSlack_bnd, only stol&ftol). -! - "tolGfree_bnd" specifies the critical gradient for fast active set release. -! if a fixed variable has a positive scaled gradient in excess of the max gradient -! times "tolGfree_bnd" then the variable is released immediately. To possibly limit -! zigzagging, set "tolGfree_bnd>1" to disable fast release. -! - "tolGfree2_bnd" allows to release more than 1 variable at a time when the -! active set is forced to change. Set "tolGfree2_bnd>1" to ensure vars are released -! one at a time. In some cases it is best to release several variables at a time. -! - Even with optimal settings, zigzagging is still possible whenever the -! unconstrained optimum is close to a bound. Sometimes a change of variables -! can be beneficial to eliminate the bound or 'move' it away (eg, in log-space). -! 6. Crazy/Small steps followed by failure/overflow/underflow -! - Usually indicative of serious user error, eg, incorrect gradient/Hessian. -! - It is not unheard of peoples trying to maximise instead of minimise: -! incorrect implementation of the subroutine "evalFunc" is something to look -! out for. If you want to maximise f(x), minimise fm=-f(x), with grad[fm]=-grad[f] -! and hessian[fm]=-hessian[f]. -! - Small steps followed by failure are sometimes indicative of the function -! being non-smooth, in which case the gradient may not be defined or be fairly -! useless. Functions with higher numerical noise can sometimes be treated by -! setting "fdigits" to less than machine precision. For truly rough functions use -! simplex (polytope) optimisation, such as Nelder-Mead or (if fearing multimodality) SCE. -! 7. Long cyclical iterations -! - If very stringent accuracy is requested, the iterations may end up cycling -! endlessly around the optimum, governed more by roundoff than by the genuine -! function behaviour. In general set ftol~epsRe,stol~epsRe, but gtol~sqrt(epsRe) -! and even lower whenever inexact derivatives are used. -! - Endless cycling used to occur near bounds in older code versions. -! This is possibly a bug in the code, so inform the author for fixing. -! 8. Very slow progress of quasi-Newton method on unconstrained problems -! - If no bounds present, zigzagging cannot be blamed. However, this code can -! handle bounds 'implicitly' (do not provide xLo and xHi but use 'feas' argument -! in evalfunc). This option should only be used if the bounds are purely safeguards -! and the optimum is certainly to be expected well in the interior of the feasible -! domain. Generally if you use 'feas' then it is best to supply xLo and xHi. -! - The Newton method works best when the Hessian is reasonably-conditioned along -! the Newton trajectory. If Hessian is ill-conditioned, two thing can occur: -! i) The underlying model is divergent, so that large steps are suggested and then -! curbed by the linesearch and trust region globalisation. Although in principle -! convergence will still occur in the limit as iter->infinity, this can become -! impractical. -! ii) The underlying model suggests small steps that are accepted by the -! globalisation methods, but overall very small progress is made towards the solution. -! Numerical evidence (Rosenbrock, 2D, x0=f*{-1.2,1},f>1000) suggests the optimisers -! can be particularly affected by such problems when quasi-Newton Hessians are used. -! One would expect a quasi-Newton Hessian such as BFGS or (more preferably, SR1) to -! become progressively unreliable as the true Hessian becomes ill-conditioned. -! Linesearches based on strong Wolfe conditions sometimes alleviate the problem, -! since the search is allowed to expand the step length. -! - The spherical/elliptical trust region is hard to orient in directions -! un-aligned with coordinate axis (unless eigen-decompositions are used). Therefore -! for rapidly curving high-dimensional valleys trust region methods may not work -! as reliably as expected. These cases are often best handled by transforming the -! solution space by the user so that the scaling of the variables is consistent. -! Trying a linesearch algorithm is sometimes helpful, since it is more robust -! wrt (affine) rescaling. Conversely, trust regions can be sensitive to poor scaling. -! 9. Each iteration is painfully slow, even though the function is cheap to compute -! - For very high-dimensional functions, the cost of Newton iterations can become -! dominated by the linear algebra of Cholesky decompositions (trust region and -! unfactored Hessians). Use of factored quasi-Hessians can then be highly beneficial -! since it reduces the cost of each iteration from O(N3) to O(N2). Note that exact -! trust regions cannot then be used, only linesearches (which is usually A-OK). -! - For extremely high-dimensional functions even the O(N2) memory requirement -! for the Hessian can be burdensome. These cases are best handled using -! conjugate-gradient methods, which require only O(N) storage, but are typically -! inferior to Newton methods in terms of function evaluations. Truncated Newton -! and limited memory quasi-Newton methods are another alternatives. This code -! implements a family of conjugate gradient methods. -! 10. Poor function scaling -! The characteristic scale of the function, including its independent variables, -! is critical in optimization. The scaling vector "xscale" and "fscale" should -! be used whenever the variables are not uniformly scaled. -! For example, if x1~1.e-10->5.e-10 but x2~1.e4->5.e4, then it is best to reflect -! this a priori scaling information in xscale. Otherwise "mis-scaling" may occur, -! which will be manifested in badly-conditioned Hessians and very slow progress of -! the algorithms, especially conjugate gradient and maybe also quasi-Newton schemes. -! Vector xscale affects the following components of all algorithms: -! - Termination tests. -! - Conditioning perturbation of the Hessian matrix in linesearch globalisation. -! (except inverse BFGS updating, which is not monitored for conditioning) -! - Trust region steps will be progressively affected by scaling, since the -! trust region is always spherical in the scaled coordinates. -! - Accuracy to which the Newton equations can be solved (since bad scaling -! leads to poor conditining). -! In addition, quasi-Newton (secant) methods are further affected as follows -! - Initial quasi-Hessian estimate. -! - Skipping conditions in quasi-Hessian updates. -! In addition, finite difference versions of the algorithms are affected as follows -! - Default stepsize estimation becomes progressively wrong. -! Moderate mis-scaling is tolerable, but in general it is best to scale the problem -! so that the variables are approximately of order unity in the optimal regions. -! If variables range over many orders of magnitude nonlinear (eg, exponential) -! transformations may be necessary. -! By default, the Hessian 'ellipticity' scaling coincides with the user-provided -! xscale, so that xscaleHmeth=xscaleH_user. -! In some cases, a spherical trust region may be appropriate even though variables -! are disparate in scale. This occurs for curving ellipsoidal objective functions -! where the long axis is curving and an elliptical trust region is thus detrimental. -! Then set xscaleHmeth=xscaleH_sphere. Note that this will affect Hessian scaling -! only - all other algorithm components will still use xscale. -! In other cases, it is possible to determine a "dimensionless" Hessian by -! scaling by the square root of diagonal elements. This type of scaling is attractive -! due to its invariance properties and works well for near-Gaussian objective functions, -! where it is equivalent to converting a covariance matrix into a correlation matrix. -! Set xscaleHmeth=xscaleH_hdiag to request this type of Hessian scaling. Again, -! all other algorithm components will use xscale. Note that if this option is used -! in a quasi-Newton method, default initial Hessians will not be scaled consistently, -! which may degrade efficiency or even result in failure. -! 11. Stack/Heap/Memory overflow inside the qnewton code when using Hessian-based methods -! This code does not exploit any sparsity of the objective function Hessian, and hence will -! become memory-bound for huge problems . Generally, the quasi-Newton storage constraints are -! ndim^2, due to the storage of the Hessian matrix. -! By design, the memory footprint of qnewton is 2*(ndim,ndim)+O(ndim). Whereas most other -! quasi-Newton algorithms use 1*(ndim,ndim)+O(ndim), doing so significantly (IMO) increases -! the code complexity (particularly if direction-scaling is implemented) and requires increased -! arithmetic (since intermediate storage is unavailable). -! This code therefore requires the storage of an additional [ndim,ndim] scaled Hessian matrix -! ("hessScaled"), effectively halving the maximum problem memory size that could be solved if -! all the arithmetic was rolled into the single user-provided array. -! Note that halving the problem memory size reduces the maximum number of variables only -! by sqrt(2) ~ 1.3, so that the actual penalty is quite small. If you really have a -! huge problem its likely you may need to use conjugate-gradient-type algorithms. -! Note that the [ndim,ndim] matrix is now allocated on the heap, rather than (automatically) -! on the stack. Therefore any stack overflows are likely due to [ndim] vectors, all -! of which are automatically allocated to the stack. Setting the stack to ~80% of available -! RAM (~1-1.5GB on WinXP-based machines, but potentially higher for linux machines) should -! avoid stack overflows. Of course if [ndim] vectors are too big (billions of variables!), then -! forget about using any quasi-Newton code, and even conjugate gradients are likely -! unfeasible. Therefore your problem would appear unsolvable using current computing -! resources. Note that heap storage is no larger than stack storage provided the -! later is set large enough using compiler switches. -! 12. Newton-type schemes becoming extremely inefficient for cheap super-dimensional functions. -! Conjugate-gradient methods are ideal for very large problems since the memory footprint is -! O(N) and computational cost per step is also O(N) - very favourable compared to Newton-type -! methods which are O(N^2) and O(N^2)-O(N^3). Therefore, only tera-dimensional problems are -! too big for CG methods. However CG methods can be sensitive to scaling (they are -! related to the steepest descent scheme) and thus are not as robust for strongly nonlinear -! problems. They work best when the Hessian eigenvalues are clustered into a few groups. -!--------------- -use types_dmsl_kit,only:data_ricz_type -use utilities_dmsl_kit,only:& - zero,half,one,& - assertEq,assertEqLog,checkBounds,checkOnBounds,putDiag,& - fmatmul_mv,& - iFirstTrueLoc,getdiag,norm2,& - getRelHxFromHx,getHxFromRelHx,& - epsF_to_epsA,& - getFDCDgrad,getCDgrad,& - getHessDiagFromFunc,getHessFromGrad,getHessFromFunc -use linalg_dmsl_kit,only:choles_fwbw -implicit none -! dummies -type(data_ricz_type),intent(in),optional::dataIN -type(data_ricz_type),intent(inout),optional::dataOUT -real(mrk),intent(in)::x0(:) ! initial estimate of solution -real(mrk),optional,intent(in)::xLo(:) ! lower bound on solution, either none or both bounds must be present -real(mrk),optional,intent(in)::xHi(:) ! upper bound on solution, either none or both bounds must be present -integer(mik),optional,intent(inout)::activeSet(:) ! active set (-1=lo,0=free,+1=hi), must be present if using xLo and xHi -real(mrk),intent(in)::gtol ! scaled gradient tolerance -real(mrk),intent(in)::stol ! scaled step tolerance -real(mrk),intent(in)::ftol ! scaled function tolerance -real(mrk),intent(in)::xscale(:) ! scale of independent variables -real(mrk),intent(in)::fscale ! scale of function -integer(mik),intent(in)::fdigits ! number of reliable digits in function evaluation (-2=estimate,-1=full machine precision) -real(mrk),intent(in)::stpmax ! maximum scaled stepsize/trust radius (set<0 for default) -! recommended: stpmax=stmax*max(norm2(x0/xscale),norm2(one/xscale)),stmax=1.e2_mrk -integer(mik),intent(in)::maxIter ! maximum number of iterations -integer(mik),intent(in)::maxFev ! maximum number of function calls -integer(mik),intent(in)::imeth ! iteration globalisation method -integer(mik),intent(in)::gmeth ! gradient evaluation method -integer(mik),intent(in)::hmeth ! Hessian evaluation method -integer(mik),optional,intent(in)::himeth ! Hessian initialisation method -real(mrk),optional,intent(inout)::trustRad ! initial scaled trust region radius (set<0 for internal default) -real(mrk),intent(out)::xopt(:) ! optimum value of "x", for which f(x) takes its minimum value. -real(mrk),intent(out)::fopt ! function value at optimum -integer(mik),intent(out)::iter ! number of steps (iterations) -integer(mik),intent(out)::fcalls ! number of function calls -integer(mik),intent(out)::gcalls ! number of gradient calls -integer(mik),intent(out)::hcalls ! number of Hessian calls -real(mrk),intent(inout)::gradOpt(:) ! gradient at the optimum -real(mrk),intent(inout),optional::hessOpt(:,:) ! Hessian at optimum -integer(mik),intent(in)::uout ! output unit for runtime info -real(mrk),intent(out),optional::memHess2 ! additional memory necessary for allocating internal Hessian storage -type(qnewtonUnwise_type),intent(in),optional::qnewtonUnwise ! esoteric settings (use with care) -integer(mik),intent(out)::err ! error diagnostic, err=0->ok,<0=warning,>0=error -character(*),intent(out)::message ! status description -! * user-provided function to be minimised ("objective function") -interface - subroutine evalFunc(dataIN,dataOUT,x,feas,fx,gradFx,hessFx,err,message) - use kinds_dmsl_kit - use types_dmsl_kit,only:data_ricz_type - implicit none - type(data_ricz_type),intent(in),optional::dataIN - type(data_ricz_type),intent(inout),optional::dataOUT - real(mrk),intent(in)::x(:) - logical(mlk),intent(out)::feas - real(mrk),intent(out),optional::fx,gradFx(:),hessFx(:,:) - integer(mik),intent(out)::err - character(*),intent(out)::message - endsubroutine evalfunc -endinterface -! locals -integer(mik)::ndim ! dimensionality of objective function -real(mrk)::epsF ! relative function accuracy -! locals for Newton iterations -real(mrk)::stepmax ! generic maximum step -real(mrk)::stepToBound ! maximum step to nearest bound -real(mrk)::stepmaxL ! "local" maximum step -real(mrk)::dx(size(x0)) ! search / shift vector -real(mrk),allocatable::hessScaled(:,:) ! scratch Hessian workspace: heap -real(mrk)::xold(size(x0)),gradold(size(x0)),fold ! previous iteration data -real(mrk)::fredExp,fredAct ! expected and actual reduction in function values -! locals for modified Hessian factorization methods -real(mrk)::logdet,condEst,Einf ! Hessian properties -integer(mik)::nfacstats(2) ! Hessian factorization cost during step -! locals for linesearch -real(mrk)::lambda ! steplength in linesearch -! locals for trust region -real(mrk)::trustRadTemp ! temp copy of trust radius -logical(mlk)::trustDidGradHess ! -! locals for factored BFGS updating -real(mrk)::Ld(size(x0)) ! diagonal of lower Cholesky factor in factored BFGS -! locals for FD gradient -real(mrk),target::hx(size(x0)) ! stepsize for finite difference gradient -real(mrk)::d2fdx2(size(x0)) ! d2f/dx2 estimates -integer(mik),target::gmeth_now ! current gradient evaluation method -integer(mik)::gradHx ! FD stepsize status -real(mrk)::gOh_fdcd ! fraction of FD gradient affected by truncation error -integer(mik)::errj(size(x0)) -character(100)::messagej(size(x0)) -! locals for cost reporting -integer(mik)::addFcalls,addGcalls -! locals for initial Hessian -logical(mlk)::sclHess1it -! locals for gradient checking -integer(mik)::gradCheckAnalysis -! locals for bounded search -logical(mlk)::boundedSearch ! true if bounds supplied -logical(mlk)::hitBound ! indicates that step truncated due to hitting bound -integer(mik)::nfree,nfree0,nfix,nthawn ! number of variables in different status -logical(mlk)::skipDxDfCheck ! skip convergence check (when releasing variable) -logical(mlk)::delCon ! indicates that a constraint is to be deleted -! locals for false convergence detection -integer(mik)::nFalseDx ! consecutive steps satisfying false convergence tolerance -! other locals -logical(mlk)::ok ! general purpose logical -integer(mik)::retcode,globcode ! algorithm status indicator -logical(mlk)::freshHess ! indicates quasi-Hessian reset -! conjugate gradient variables -real(mrk)::dgg,gam,gg -! algorithm indicators -logical(mlk)::useConjGrad ! true if conjugate gradient method in use -logical(mlk)::useQuasiHessian ! true if quasi-Newton method in use -logical(mlk)::useTrust ! true if trust region method in use -!---------- -! 'Esoteric' parameters (can be user-defined via qnewtonUnwise_type) -! Initial point analysis -real(mrk)::gtol0fac ! reduction in gtol for initial point analysis -! Linesearch settings -real(mrk)::alpha_ls ! Wolfe criterion -real(mrk)::beta_ls ! Wolfe criterion -integer(mik)::LNSstrongwolfe ! Implementatation of Strong-Wolfe linesearch -logical(mlk)::useDirDer ! allows use of cheap directional derivatives (Wolfe) -integer(mik)::linmin_ometh ! line minimisation method (0=golden,1=Brent,2=dBrent) -real(mrk)::linmin_tol ! tolerance in line minimisation -integer(mik)::linmin_itmax ! max number of iterations in line minimisation -! Trust region settings -real(mrk)::acceptRatio_tr ! trust region settings -real(mrk)::roDown_tr ! below this fred ratio trust is decreased -real(mrk)::radDown_tr ! trust reduction factor -real(mrk)::roUp_tr ! above this fred ratio trust can be increased -real(mrk)::stepOtrustUp_tr ! if stepLen/trustRad>stepOtrust increase trust -real(mrk)::radUp_tr ! trust increase factor -real(mrk)::trustOstepMax_tr ! if trustRad/stepLen>trustOstepMax truncate trust -real(mrk)::roUpNow_tr ! "increase trust now!" threshold -integer(mik)::niter_tr ! trust region max iterations -integer(mik)::ncholMax_tr ! max Cholesky decomposition per trust solver -real(mrk)::SR1forceUpdt ! if SR1 perform below this ratio, force update -logical(mlk)::pivotCholTrust ! true for pivoted Cholesky in trust region -real(mrk)::dogNewtBias ! Dogleg bias towards Newton (0=single dogleg) -real(mrk)::boundFrac ! prevents small trust expansions constrained by bounds -! Quasi-Hessian update settings -logical(mlk)::skipQNupdtClassic ! update skip condition in QN methods -logical(mlk)::allowQHreset ! reset quasi-Hessian to identity when failing -logical(mlk)::maxSR1update ! force frequent SR1 updates -logical(mlk)::facBFGS_useR2 ! requests rank-2 BFGS updates -logical(mlk)::facBFGS_getLLt ! DEBUG: requests backup unfactored BFGS Hessian -logical(mlk)::dampedBFGS ! requests damped BFGS updating -real(mrk)::dampFac ! BFGS damping factor -! Hessian scaling method -integer(mik)::xscaleHmeth ! ellipticity of Hessian -! Function roundoff estimation -real(mrk)::Hscale ! scale for roundoff estimation in f(x) -real(mrk)::hammPow ! power of epsRe in "h" for Hammings analysis -! Performance output -integer(mik)::iterNfo ! iteration info option -! Active set bound constraints handling -real(mrk)::tolGfree_bnd ! tolerance on gradient (Lgrng mult) for fast release -real(mrk)::tolOptSlack_bnd ! slack factor on main "tol" to release vars -real(mrk)::tolGfree2_bnd ! tolerance for standard release -integer(mik)::fixDiagOption ! what to do with diagonals of fixed variables -! False convergence analysis -real(mrk)::tolFalseDx ! false convergence tolerance on dx -integer(mik)::nFalseDxMax ! max consecutive steps with false tol -integer(mik)::nFalseRfrshDxMax ! max consecutive steps with false tol for refresh -! Gradient checking -integer(mik)::chkGrd ! gradient checking option -integer(mik)::chkGrd_gmeth ! gradient checking method -real(mrk)::chkGrd_tG ! gradient check tolerance on g(x) agreement -real(mrk)::chkGrd_tGdf ! gradient check tolerance on df -real(mrk)::chkGrd_tF ! gradient check tolerance on f(x) vals -real(mrk)::chkGrd_h ! h-value (scale) in gradient check -! Hessian checking -integer(mik)::chkHess ! Hessian checking option -integer(mik)::chkHess_hmeth ! Hessian checking method -logical(mlk)::ignoreBadHess ! no action taken on bad Hessians -! Finite difference gradient approximation -real(mrk)::FDscale ! scale for finite difference gradient (p345,GMW) -logical(mlk)::useHxDef ! forces use of default finite difference stepsize -logical(mlk)::hybridFDCD ! mixed hybrid FDCD componentwise gradient evaluation -integer(mik)::dfdx0meth ! initial dfdx estimator -logical(mlk)::allowFDCD ! allows enhanced switch FD->CD gradient -real(mrk)::tolFDCD ! truncation error tolerance for FD->CD (enhanced) -real(mrk)::fracFDCD ! critical fraction for FD->CD switch (enhanced) -real(mrk)::tolCDFD ! truncation error tolerance for CD->FD (enhanced) -real(mrk)::fracCDFD ! critical fraction for CD->FD switch (enhanced) -real(mrk)::tolGradFDCD ! gradient tolerance for FD->CD switch -real(mrk)::tolGradCDFD ! gradient tolerance for CD->FD switch -real(mrk)::tolDxFDCD ! step tolerance for FD->CD switch -logical(mlk)::adaptFDhX ! adapt FD hx using Hessian diagonal -logical(mlk)::adaptCDhX ! adapt CD hx using Hessian diagonal -! Modified Hessian factorization settings -integer(mik)::facmeth ! modified factorization method -real(mrk)::tau ! (schnab) these values indicate default initial e^1/3 -real(mrk)::tauBar ! (schnab) e^2/3. but F-95 precludes initialisation here -real(mrk)::mu ! (schnab) -real(mrk)::maxHessCond ! (dennis) bound on condition of modified Hessian -logical(mlk)::controlHessCond ! Hessian condition control -!---------- -! Bundles -type(gmethBundle_type):: gmethBundle -type(trustBundle_type):: trustBundle -type(objFuncBundle_type)::objFuncBundle -type(hessFacBundle_type)::hessFacBundle -! Default parameters hardly worth changing -real(mrk),parameter::stmax=1.e2_mrk ! used in default stepmax computation, DS96,IMSL -character(*),parameter::epsFtitle="Quasi-Newton-associated epsF estimation" -logical(mlk),parameter::useHxDefIni=.true. ! sets stepsize in finite difference Hessians -! Debugging parameters -character(3)::facBFGS_typeH ! factored BFGS Hessian matrix storage scheme -! General purpose locals -!---------- -! Start procedure here -err=0; message="qnewton/justStarted" -useConjGrad=useConjGrad_inq(hmeth) ! method categories -useQuasiHessian=useQuasiHessian_inq(hmeth); useTrust=useTrust_inq(imeth) -! * Initialise and check input, dimensioning, etc. -if(useConjGrad)then - call assertEq(size(x0),size(xopt),size(xscale),size(gradopt),ok,ndim) -else - call assertEq(size(x0),size(xopt),size(xscale),size(gradopt),& - size(hessopt,1),size(hessopt,2),ok,ndim) -endif -if(.not.ok)then ! dimension error - err=10;message="f-qnewton/dimError[mainVars]" - call write_exitInfo(skipDetailedExitInfo=.true.) - goto 1000 !return -endif -call checkBounds(xLo=zero,x=xscale,chkLeq=.true.,err=err,message=message) -if(err/=0)then ! check xscale is positive - err=20;message="f-qnewton/inError/illegal[xscale<=0]/&"//message - call write_exitInfo(skipDetailedExitInfo=.true.) - goto 1000 !return -endif -if(fscale<=zero)then ! fscale must be positive - err=21;message="f-qnewton/inError/illegal[fscale<=0]" - call write_exitInfo(skipDetailedExitInfo=.true.) - goto 1000 !return -elseif(gtolstepmax)then - trustRad=stepmax ! limit radius by stepmax - endif - endif ! else ! - user-supplied (positive) value - else - err=+10;message="f-qnewton/missing[trust]" - call write_exitInfo(skipDetailedExitInfo=.true.) - goto 1000 !return - endif -endif -! * All algorithmic constant initialization should be finished -! - prepare bundles -call makeGmethBundle() ! bundle for gradient evaluation -if(useTrust)call makeTrustBundle() ! bundle for trust evaluation -call makeObjFuncBundle() ! bundle for function properties -if(.not.useConjGrad)call makeHessFacBundle() ! bundle of Hessian factorization settings -iter=0 ! define 'iter' for output of routines below -! check gradient? -selectcase(chkGrd) -case(chkG_hxstp,chkG_full) - call checkGrad_macro() - if(err>0)then - call write_exitInfo(skipDetailedExitInfo=.true.) - goto 1000 !return - endif -endselect -! check Hessian? -selectcase(chkHess) -case(chkHess_full) - call checkHess_macro() - if(err>0)then - call write_exitInfo(skipDetailedExitInfo=.true.) - goto 1000 !return - endif -endselect -! check whether initial point is on any bound -nfree=ndim;nfree0=ndim;nfix=0;nthawn=0 -if(boundedSearch)then - call checkActiveSet(xopt,xscale,activeSet,fixDiagOption,hmeth,gradOpt,hessOpt,& - Ld,xLo,xHi,hitBound,nfree,nfix,nthawn) - if(nfix==ndim)then ! all variables fixed - err=0;message="qnewton/problem/onBound&fixed[x0]" - call write_exitInfo(skipDetailedExitInfo=.true.) - goto 1000 !return - else ! check for constraints to be deleted - call checkReleaseActiveSet(xopt,xscale,activeSet,gradopt,hessopt,Ld,& - tolGfree_bnd,nfree==0,tolGfree2_bnd,nfree,nfix,nthawn) - endif -endif -iter=0;dx=zero;fredAct=zero;fredExp=zero;freshHess=.true. -retcode=0;globcode=0;nFalseDx=0;delCon=.false. -call write_iterationInfo() ! write initial info to output file as required -! check initial point using stringent convergence -call checkConvergence0(xopt,fopt,gradOpt,activeSet,xscale,fscale,gtol0fac*gtol,retcode) -selectcase(retcode) -case(no_con) -case(grad_con) - err=0;message="qnewton/grad[x0]~0" - call write_exitInfo(skipDetailedExitInfo=.true.) - goto 1000 !return -endselect -! *** Part II. Iteration loop -do iter=1, maxiter -! * Get optimal local descent direction using quasi-newton eqn - do ! allow several attempts when using finite difference gradient - selectcase(imeth) - case(null_imeth,armijo_imeth,wolfe_imeth,stwolfe_imeth,brentmin_imeth) - selectcase(hmeth) ! * linesearch methods - case(user_meth,& ! construct and solve modified Newton equations - fdg_hmeth,cdg_hmeth,fdf_hmeth,cdf_hmeth,& - bfgsUnfac_hmeth,SR1unFac_hmeth) - call solveModNewtHess(hess=hessopt,hessScaled=hessScaled,Ld=Ld,grad=gradopt,& - hessFacBundle=hessFacBundle,xscaleHmeth=xscaleHmeth,xscale=xscale,fscale=fscale,& - activeset=activeset,dx=dx,ncholstats=nfacstats,& - logdet=logdet,condest=condest,Einf=Einf,err=err,message=message) - if(err/=okAlg)then - message="f-qnewton/&"//message - call write_exitInfo() - goto 1000 !return - endif - case(bfgsFac_hmeth) ! positive definite Cholesky decomposition already in-place - call choles_fwbw(a=HessOpt,Ld=Ld,b=gradOpt,usePivot=.false.,x=dx,err=retcode,message=message) - if(retcode/=okAlg)then - err=-30;message="f-qnewton/&"//message - call write_exitInfo() - goto 1000 !return - endif - dx=-dx - case(bfgsInv_hmeth) ! inverse Hessian available directly - if(bfgsInvUt)then ! work with upper triangle only - dx=-fmatmul_mv(m=HessOpt,v=gradOpt,typeMV="SUV") - else ! full matmul - dx=-matmul(HessOpt,gradOpt) - endif - case(NCG_FR_hmeth,NCG_PR_hmeth,NCG_PPR_hmeth) ! * conjugate gradient methods - dx=Ld - endselect - case(trustEx_imeth,dogLeg_imeth) ! * trust methods (implemented in dedicated sub) - case default - err=10;message="f-qnewton/unknownIMETH" - call write_exitInfo() - goto 1000 !return - endselect -! * Standard ("full") Newton step determined. - xold=xopt; fold=fopt; gradold=gradopt ! save old location (nb: conjugate gradient uses this info) - selectcase(imeth) ! - linesearch methods: check dx for bounds... - case(null_imeth,armijo_imeth,wolfe_imeth,stwolfe_imeth,brentmin_imeth) - if(boundedSearch)then ! ... and truncate if violating 'em. - call checkStepBounds(xopt,xLo,xHi,activeSet,dx,stepToBound) - stepmaxL=getStepLen2(dx*stepToBound,xscale) - stepmaxL=min(stepmax,stepmaxL) - endif - case(trustEx_imeth,dogLeg_imeth) ! - trust region checks for bounds internally - endselect -! * Globalisation strategy (largely independent of Hessian method) - selectcase(imeth) - case(null_imeth) ! * Testing only: no globalisation - xopt=xopt+dx; globcode=success_glob - call getfredExp() ! expected function reduction based on step dx - call evalFunc(dataIN,dataOUT,xopt,ok,fopt,err=err,message=message) - fcalls=fcalls+1 - if(err/=0)then - write(message,'(a,i0,a)')"f-qnewton/userErr[iter=",iter,"]/&"//trim(message) - globcode=badFunc_glob - elseif(.not.ok)then - write(message,'(a,i0,a)')"f-qnewton/userUnfeas[iter=",iter,"]/&"//trim(message) - globcode=unfeas_glob - endif - fredAct=fold-fopt ! actual reduction in function value - case(armijo_imeth) ! * Armijo backtracking - lambda=one ! always start with natural Newton step - call getfredExp() ! expected function reduction based on step dx - call linesearch_armijo(evalFunc,dataIN,dataOUT,xold,fold,gradopt,dx,xscale,& - stol,alpha_ls,stepmaxL,xopt,fopt,fredAct,lambda,addFcalls,globcode,message) - fcalls=fcalls+addFcalls - case(wolfe_imeth) ! * Wolfe linesearch - lambda=one ! always start with natural Newton step - call getfredExp() ! expected function reduction based on step dx - call linesearch_wolfe(evalFunc,dataIN,dataOUT,xold,fold,gradold,gmethBundle,objFuncBundle,& - dx,xscale,fscale,stol,alpha_ls,beta_ls,stepmaxL,xopt,fopt,gradopt,fredAct,& - lambda,addFcalls,addGcalls,globcode,message) - fcalls=fcalls+addFcalls; gcalls=gcalls+addGcalls - case(stwolfe_imeth) ! * Strong Wolfe linesearch - lambda=one ! always start with natural Newton step - call getfredExp() ! expected function reduction based on step dx - call linesearch_strongwolfe(evalFunc,dataIN,dataOUT,xold,fold,gradold,gmethBundle,objFuncBundle,& - dx,xscale,fscale,stol,alpha_ls,beta_ls,stepmaxL,LNSstrongwolfe,& - xopt,fopt,gradopt,fredAct,lambda,addFcalls,addGcalls,globcode,message) - fcalls=fcalls+addFcalls; gcalls=gcalls+addGcalls - case(brentmin_imeth) ! * Brent line minimisation - xopt=xold; lambda=one - call getfredExp() ! expected function reduction based on step dx - call brentmin(evalFunc,dataIN,dataOUT,linmin_ometh,xopt,fold,dx,stepmaxL,stol,& - linmin_tol,linmin_itmax,xscale,fopt,lambda,addFcalls,addGcalls,globcode,message) - fcalls=fcalls+addFcalls; gcalls=gcalls+addGcalls; fredAct=fold-fopt - case(trustEx_imeth,dogLeg_imeth) ! * Trust region globalization - trustRadTemp=trustRad ! save trust in case step needs retaken with better grad - call trustDriver(evalFunc,dataIN,dataOUT,x0=xold,fx0=fold,grad0=gradold,& - hess0=hessopt,Ld0=Ld,hessScaled=hessScaled,& - boundedSearch=boundedSearch,xLo=xLo,xHi=xHi,activeSet=activeSet,& - imeth=imeth,hmeth=hmeth,& - quadTypeH=facBFGS_typeH,maxSR1update=maxSR1update,gmethBundle=gmethBundle,& - xscaleHmeth=xscaleHmeth,xscale=xscale,fscale=fscale,& - trustBundle=trustBundle,objFuncBundle=objFuncBundle,& - hessFacBundle=hessFacBundle,didGradNewHess=trustDidGradHess,& - x=xopt,fx=fopt,gradx=gradopt,dx=dx,trustRad=trustRad,& - fredExp=fredExp,fredAct=fredAct,& - fcalls=addFcalls,gcalls=addGcalls,ncholstats=nfacstats,& - logdet=logdet,condest=condest,Einf=Einf,err=globcode,message=message) - fcalls=fcalls+addFcalls; gcalls=gcalls+addGcalls - case default - err=+10;write(message,'(a,i0,a)')"f-qnewton/unknown[imeth=",imeth,"]" - call write_exitInfo() - goto 1000 !return - endselect -! call write_iterationInfo() - if(fredAct0)write(uout,'(a,i7,a)')"iter=",iter," Globalization FAILED ..."//trim(message) - call checkGrad_macro() ! check gradient accuracy - if(err>0)then - call write_exitInfo() - goto 1000 !return - endif - call checkHess_macro() ! check gradient accuracy - if(err>0)then - call write_exitInfo() - goto 1000 !return - endif - selectcase(gmeth_now) ! * forward difference gradient - case(fd_gmeth) ! try refreshing stepsize - if(useHxDef)gradHx=fresh_hx ! botch to switch to CD immediately - selectcase(gradHx) - case(old_hx) - hx=getHxFromRelHx(hx,xopt,xscale,FDscale) - call getHx_macro() ! re-optimise stepsize - if(err/=0)goto 1000 !return - hx=getRelHxFromHx(hx,xopt,xscale,FDscale) - if(any(errj/=0))then ! perceived errors not unusual when grad[fx] is small - call write_FDCDswitchInfo(fd_to_cd=.true.) - gmeth_now=cd_gmeth ! switch to central differences immediately - endif - gradHx=fresh_hx - trustRad=trustRadTemp ! restore trust region - case(fresh_hx) ! switch to central differences - gmeth_now=cd_gmeth - hx=getHxFromRelHx(hx,xopt,xscale,FDscale) - call getHx_macro() ! re-optimise stepsize - if(err/=0)goto 1000 !return - hx=getRelHxFromHx(hx,xopt,xscale,FDscale) - call write_FDCDswitchInfo(fd_to_cd=.true.) - gradHx=fresh_hx - trustRad=trustRadTemp ! restore trust region - case default - exit - endselect ! refreshed gradient may alter the active set - if(boundedSearch)then - call checkActiveSet(xopt,xscale,activeSet,fixDiagOption,hmeth,& - gradopt,hessopt,Ld,xLo,xHi,& - hitBound,nfree,nfix,nthawn) - if(nfix==ndim)then ! all dimensions fixed - exit - else ! check for constraints to be deleted - call checkReleaseActiveSet(xopt,xscale,activeSet,gradopt,hessopt,Ld,& - tolGfree_bnd,nfree==0,tolGfree2_bnd,nfree,nfix,nthawn) - endif - endif - if(useQuasiHessian.and.allowQHreset)call setUnitQhess_macro() - case(cd_gmeth) ! * central difference gradient - if(useHxDef)gradHx=fresh_hx ! botch to exit immediately - selectcase(gradHx) - case(old_hx) - hx=getHxFromRelHx(hx,xopt,xscale,FDscale) - call getHx_macro() ! re-optimise stepsize - if(err/=0)goto 1000 !return - hx=getRelHxFromHx(hx,xopt,xscale,FDscale) - gradHx=fresh_hx - trustRad=trustRadTemp ! restore trust region - case(fresh_hx) ! already tried refreshing central differences - exit ! not much else can be done... - case default - exit - endselect ! refreshed gradient may alter the active set - if(boundedSearch)then - call checkActiveSet(xopt,xscale,activeSet,fixDiagOption,hmeth,& - gradopt,hessopt,Ld,xLo,xHi,& - hitBound,nfree,nfix,nthawn) - if(nfix==ndim)then ! all dimensions fixed - exit - else ! check for constraints to be deleted - call checkReleaseActiveSet(xopt,xscale,activeSet,gradopt,hessopt,Ld,& - tolGfree_bnd,nfree==0,tolGfree2_bnd,nfree,nfix,nthawn) - endif - endif - if(useQuasiHessian.and.allowQHreset)call setUnitQhess_macro() - case(user_meth) ! * analytical gradient was used... cant do much else - if(freshHess)then - exit - elseif(useQuasiHessian.and.allowQHreset)then ! ..except try resetting quasi-Hessian - call setUnitQhess_macro() - trustRad=trustRadTemp ! restore trust region - freshHess=.true. - else - exit - endif - endselect - case(success_glob) ! - succeeded in globalisation strategy -! gradHx=old_hx; freshHess=.false. ! these now set after convergence test - exit - case default - err=10;message="f-qnewton/unknown/BUG?/&"//message - call write_exitInfo() - goto 1000 !return - endselect - enddo -! * Evaluate required derivatives (gradient/Hessian) at "globalised" point - selectcase(hmeth) - case(user_meth) ! ** user-supplied Hessian - selectcase(imeth) - case(null_imeth,armijo_imeth,brentmin_imeth,trustEx_imeth,dogLeg_imeth) ! need gradient/Hessian - selectcase(gmeth_now) - case(user_meth) ! - analytical gradient - call evalFuncMacro(xx=xopt,gg=gradopt,hh=hessopt,xxIsX0=.false.) - if(err/=0)goto 1000 !return - case(fd_gmeth) ! - FD gradient - call evalFuncMacro(xx=xopt,hh=hessopt,xxIsX0=.false.) - if(err/=0)goto 1000 !return - if(adaptFDhX)then - call adaptFDgradHx(hx,xopt,xscale,FDscale,& - epsF_to_epsA(epsF,fopt,fscale,Hscale),hessopt) - endif - call getFDCDmacro() - case(cd_gmeth) ! - CD gradient - call evalFuncMacro(xx=xopt,hh=hessopt,xxIsX0=.false.) - if(err/=0)goto 1000 !return - call getCDmacro() - endselect - case(wolfe_imeth,stwolfe_imeth) ! just need Hessian - call evalFuncMacro(xx=xopt,hh=hessopt,xxIsX0=.false.) - if(err/=0)goto 1000 !return - endselect - case(fdg_hmeth,cdg_hmeth) ! ** finite difference Hessian from gradient - selectcase(imeth) - case(null_imeth,armijo_imeth,brentmin_imeth,trustEx_imeth,dogLeg_imeth) ! need gradient - selectcase(gmeth_now) - case(user_meth) ! - analytical gradient - call evalFuncMacro(xx=xopt,gg=gradopt,xxIsX0=.false.) - if(err/=0)goto 1000 !return - case default - err=200;message="f-qnewton/BUG/shouldntBeHere:hmeth=fdg&gmeth/=user" - goto 1000 !return - endselect - case(wolfe_imeth,stwolfe_imeth) ! gradient already available - endselect - call getHessFromGrad(evalFunc,dataIN,dataOUT,xopt,gradopt,xscale,epsF,useHxDef=useHxDefIni,& - hmeth=hmeth,hessfd=hessopt,gcalls=addGcalls,err=retcode,message=message) - gcalls=gcalls+addGcalls - if(retcode/=okAlg)then - err=+10;message="f-qnewton/&"//message - call write_exitInfo() - goto 1000 !return - endif - case(fdf_hmeth,cdf_hmeth) ! ** finite difference Hessian from function - selectcase(imeth) - case(null_imeth,armijo_imeth,brentmin_imeth,trustEx_imeth,dogLeg_imeth) ! need gradient - selectcase(gmeth_now) - case(user_meth) ! - analytical gradient - call evalFuncMacro(xx=xopt,gg=gradopt,xxIsX0=.false.) - if(err/=0)goto 1000 !return - case(fd_gmeth) ! - FD gradient - if(adaptFDhX)then - call adaptFDgradHx(hx,xopt,xscale,FDscale,& - epsF_to_epsA(epsF,fopt,fscale,Hscale),hessopt) - endif - call getFDCDmacro() - case(cd_gmeth) ! - CD gradient - call getCDmacro() - endselect - case(wolfe_imeth,stwolfe_imeth) ! gradient already available - endselect - call getHessFromFunc(evalFunc,dataIN,dataOUT,xopt,fopt,xscale,epsF,useHxDef=useHxDefIni,& - hmeth=hmeth-2,hessfd=hessopt,fcalls=addFcalls,err=retcode,message=message) - fcalls=fcalls+addFcalls - if(retcode/=okAlg)then - err=+10;message="f-qnewton/&"//message - call write_exitInfo() - goto 1000 !return - endif - case(bfgsInv_hmeth) ! ** BFGS Hessian (inverse) - selectcase(imeth) - case(null_imeth,armijo_imeth,brentmin_imeth,trustEx_imeth,dogLeg_imeth) ! need gradient - selectcase(gmeth_now) - case(user_meth) ! - analytical gradient - call evalFuncMacro(xx=xopt,gg=gradopt,xxIsX0=.false.) - if(err/=0)goto 1000 !return - case(fd_gmeth) ! - FD gradient - if(adaptFDhX)then - call adaptFDgradHx(hx,xopt,xscale,FDscale,& - epsF_to_epsA(epsF,fopt,fscale,Hscale),hessopt) - endif - call getFDCDmacro() - case(cd_gmeth) ! - CD gradient - call getCDmacro() - endselect - case(wolfe_imeth,stwolfe_imeth) ! gradient already available - endselect - if(bfgsInvNR)then ! NR-based approach (efficient) - call bfgsInv_update1(dx,xscale,activeSet,gradopt,gradold,hessopt,& - rescale=(iter==1.and.sclHess1it)) - else ! Nocedal-based inverse quasi-Hessian (v inefficient) - call bfgsInv_update2(dx,xscale,activeSet,gradopt,gradold,hessopt,hessScaled,& - rescale=(iter==1.and.sclHess1it)) - endif - case(bfgsUnfac_hmeth) ! ** BFGS Hessian (unfactored) - selectcase(imeth) - case(null_imeth,armijo_imeth,brentmin_imeth,trustEx_imeth,dogLeg_imeth) ! need gradient - selectcase(gmeth_now) - case(user_meth) ! - analytical gradient - call evalFuncMacro(xx=xopt,gg=gradopt,xxIsX0=.false.) - if(err/=0)goto 1000 !return - case(fd_gmeth) ! - FD gradient - if(adaptFDhX)then - call adaptFDgradHx(hx,xopt,xscale,FDscale,& - epsF_to_epsA(epsF,fopt,fscale,Hscale),hessopt) - endif - call getFDCDmacro() - case(cd_gmeth) ! - CD gradient - call getCDmacro() - endselect - case(wolfe_imeth,stwolfe_imeth) ! gradient already available - endselect - call bfgsUnfac_update(dx,xscale,activeSet,gradopt,gradold,hessopt,& - merge(epsF,sqrt(epsF),gmeth==user_meth),& - skipQNupdtClassic,dampedBFGS=dampedBFGS,dampFac=dampFac,& - rescale=(iter==1.and.sclHess1it),err=err,message=message) - case(bfgsFac_hmeth) ! ** BFGS Hessian (factored) - selectcase(imeth) - case(null_imeth,armijo_imeth,brentmin_imeth,trustEx_imeth,dogLeg_imeth) ! need gradient - selectcase(gmeth_now) - case(user_meth) ! - analytical gradient - call evalFuncMacro(xx=xopt,gg=gradopt,xxIsX0=.false.) - if(err/=0)goto 1000 !return - case(fd_gmeth) ! - FD gradient - if(adaptFDhX)then - call adaptFDgradHx(hx,xopt,xscale,FDscale,& - epsF_to_epsA(epsF,fopt,fscale,Hscale),hessopt) - endif - call getFDCDmacro() - case(cd_gmeth) ! - CD gradient - call getCDmacro() - endselect - case(wolfe_imeth,stwolfe_imeth) ! gradient already available - endselect - call bfgsFac_update(dx,xscale,activeSet,gradopt,gradold,hessopt,Ld,& - tol=merge(epsF,sqrt(epsF),gmeth==user_meth),& - controlHessCond=controlHessCond,maxHessCond=hessFacBundle%maxHessCond,& - logDet=logdet,condest=condest,& - facBFGS_useR2=facBFGS_useR2,facBFGS_getLLt=facBFGS_getLLt,& - skipClassic=skipQNupdtClassic,dampedBFGS=dampedBFGS,dampFac=dampFac,& - rescale=(iter==1.and.sclHess1it),err=err,message=message) - if(err/=0)then ! probably a bug - call write_exitInfo() - goto 1000 !return - endif - case(SR1unfac_hmeth) ! ** SR1 Hessian (unfactored) - selectcase(imeth) - case(null_imeth,armijo_imeth,brentmin_imeth,trustEx_imeth,dogLeg_imeth) ! need gradient - selectcase(gmeth_now) - case(user_meth) ! - analytical gradient - if(trustDidGradHess)then ! already computed - else - call evalFuncMacro(xx=xopt,gg=gradopt,xxIsX0=.false.) - if(err/=0)goto 1000 !return - endif - case(fd_gmeth) ! - FD gradient - if(trustDidGradHess)then ! - already done (note that this precludes adaption) - else - if(adaptFDhX)then - call adaptFDgradHx(hx,xopt,xscale,FDscale,& - epsF_to_epsA(epsF,fopt,fscale,Hscale),hessopt) - endif - call getFDCDmacro() - endif - case(cd_gmeth) ! - CD gradient - if(trustDidGradHess)then ! - already done (note that this precludes adaption) - else - call getCDmacro() - endif - endselect - case(wolfe_imeth,stwolfe_imeth) ! gradient already available - endselect - if(err/=0)then - message="f-qnewton/unknown/&"//message - call write_exitInfo() - goto 1000 !return - endif - if(.not.trustDidGradHess)then ! avoid updating twice - call SR1unFac_update(dx,xscale,activeSet,gradopt,gradold,& - trustBundle%SR1skipTol,hessopt,rescale=(iter==1.and.sclHess1it),& - err=err,message=message) - endif - case(NCG_FR_hmeth,NCG_PR_hmeth,NCG_PPR_hmeth) ! ** Conjugate gradient methods - selectcase(imeth) - case(null_imeth,armijo_imeth,brentmin_imeth) ! need gradient - selectcase(gmeth_now) - case(user_meth) ! - analytical gradient - call evalFuncMacro(xx=xopt,gg=gradopt,xxIsX0=.false.) - if(err/=0)goto 1000 !return - case(fd_gmeth) ! - FD gradient - if(adaptFDhX)then - call adaptFDgradHx(hx,xopt,xscale,FDscale,& - epsF_to_epsA(epsF,fopt,fscale,Hscale),hessopt) - endif - call getFDCDmacro() - case(cd_gmeth) ! - CD gradient - call getCDmacro() - endselect - case(wolfe_imeth,stwolfe_imeth) ! gradient already available - endselect - gg=dot_product(gradOld,gradOld) - selectcase(hmeth) - case(NCG_FR_hmeth) ! - Fletcher-Reeves algorithm - dgg=dot_product(gradOpt,gradOpt) - case(NCG_PR_hmeth) ! - Polak-Ribiere (somewhat more graceful - NR-77) - dgg=dot_product(gradOpt-gradOld,gradOpt) - case(NCG_PPR_hmeth) ! - PR+ (Nocedal and Wright) - dgg=dot_product(gradOpt-gradOld,gradOpt) ! more resistant to inexact linesearches than PR - if(dgg0)then - call write_exitInfo() - goto 1000 !return - endif - endselect - selectcase(chkHess) ! * check Hessian at every step? - case(chkHess_full) - call checkHess_macro() - if(err>0)then - call write_exitInfo() - goto 1000 !return - endif - endselect -! * Check active set after each iteration. - skipDxDfCheck=.false. - if(boundedSearch.and.globcode/=failed_glob)then -! if(boundedSearch)then -! - Safeguard rare case when failing to globalise in bounded optimisation creates -! an infinite loop with skipping convergence test. Failure to globalise is final!!! - call checkActiveSet(xopt,xscale,activeSet,fixDiagOption,hmeth,gradopt,hessopt,& - Ld,xLo,xHi,hitBound,nfree0,nfix,nthawn) -! - check whether bound-deletion convergence satisfied - call checkConvergence(xopt,dx,fopt,gradOpt,& ! this checks loose convergence - merge(freeVar_as,loVar_as,activeSet==freeVar_as),& - user_meth,fredExp,fredAct,xscale,fscale,& - gtol,tolOptSlack_bnd*stol,tolOptSlack_bnd*ftol,& ! gtol not relaxed by tolOptSlack_bnd -! tolOptSlack_bnd*gtol,tolOptSlack_bnd*stol,tolOptSlack_bnd*ftol,& - hitBound,retcode) - selectcase(retcode) ! establish whether to force constraint deletion - case(grad_con,search_con,fred_con) - delCon=.true. - case default - delCon=.false. - endselect - call checkReleaseActiveSet(xopt,xscale,activeSet,gradopt,hessopt,Ld,& - tolGfree_bnd,nfree==0.or.delCon,tolGfree2_bnd,nfree,nfix,nthawn) - if(nFree>nfree0)then - skipDxDfCheck=.true. ! skip convergence check if variable released - retcode=no_con - endif - elseif(delCon)then ! do no skip convergence test after releasing constraint - hitBound=.false. ! (otherwise infinite loop can occur release/fix) - elseif(globcode==failed_glob)then ! failed to globalize - skipDxDfCheck=.true. - endif - call write_iterationInfo() -! * Check convergence criteria (gradient/search/function tolerance) - call checkConvergence(xopt,dx,fopt,gradOpt,activeSet,gmeth_now,fredExp,fredAct,& - xscale,fscale,gtol,stol,ftol,hitBound.or.skipDxDfCheck,retcode) - selectcase(gmeth) ! some extra logic when gradient is approximated - case(fd_gmeth,cd_gmeth) - if(useHxDef.and.hybridFDCD)then -! - if using default FD gradient stepsize with hybrid component adaption, -! do not bother switching, since gradient would have already been estimated -! using CD (provided tolGradFDCD ~ 0.1 or so, as it should be) - selectcase(retcode) - case(-grad_con,-search_con,-fred_con) - retcode=abs(retcode) - endselect - elseif(.not.useHxDef.and.gradHx/=fresh_hx)then ! insist on refreshing stepsize - selectcase(retcode) ! before termination - case(grad_con,search_con,fred_con) - retcode=switchCD_con - endselect - endif - endselect - selectcase(retcode) - case(no_con) ! no convergence yet - gradHx=old_hx; freshHess=.false. ! indicate that gradient stepsize unrefreshed - case(grad_con) ! gradient converged - err=0;message="qnewton/ok/grad[x]~0" - call write_exitInfo() - goto 1000 !return - case(search_con) ! search converged - err=0;message="w-qnewton/prob.ok/||dx||~0" - call write_exitInfo() - goto 1000 !return - case(fred_con) ! function converged - err=0;message="w-qnewton/prob.ok/df~0" - call write_exitInfo() - goto 1000 !return - case(srchBadGrad_con) ! search converged but grad still large - err=-10;message="w-qnewton/sus/||dx||~0,grad[x]>>0" - call write_exitInfo() - goto 1000 !return - case(fredBadGrad_con) ! function converged but grad still large - err=-20;message="w-qnewton/sus/df~0,grad[x]>>0" - call write_exitInfo() - goto 1000 !return - case(switchCD_con,& - -grad_con,-search_con,-fred_con,& - -srchBadGrad_con,-fredBadGrad_con) -! need to switch to central differences to continue progress - retcode=switchCD_con - call write_FDCDswitchInfo(fd_to_cd=.true.) - gmeth_now=cd_gmeth - hx=getHxFromRelHx(hx,xopt,xscale,FDscale) - call getHx_macro() ! re-optimise stepsize - if(err/=0)goto 1000 !return - hx=getRelHxFromHx(hx,xopt,xscale,FDscale) - gradHx=fresh_hx - endselect - if(fcalls>maxFev)then - err=-100;message="f-qnewton/maxFevalExceeded" - call write_exitInfo() - goto 1000 !return - endif - selectcase(globcode) ! check global convergence - case(success_glob) ! ... keep going - case default ! ... failed to globalize but convergence not verified - err=-50;message="f-qnewton/warning/lastStepFailedNoTermination/checkResults..." - call write_exitInfo() - goto 1000 !return - endselect -!----- -! Check conditions for switch between forward <-> central differences - if(gradHx/=fresh_hx)then - if(.not.(hybridFDCD.and.useHxDef))then - call checkFDCDswitch_macro() - if(err/=0)goto 1000 !return -! elseif(gmeth_now==cd_gmeth)then ! encourage switches CD->FD -! call checkFDCDswitch_macro() -! if(err/=0)goto 1000 !return - endif - endif -! check for false convergence (succesive scaled step lengths too small) - if(scaledStepLen(dx,xopt,xscale)<=tolFalseDx)then - nFalseDx=nFalseDx+1 - else ! reset false convergence counter - nFalseDx=0 - endif - if(nFalseDx>nFalseDxMax)then - err=30; message="f-qnewton/falseConvergence(nonCriticalPoint)/slowProgress" - call write_exitInfo() - goto 1000 !return - elseif(mod(nFalseDx+1,nFalseRfrshDxMax)==0)then ! refresh stepsize? - if(gmeth_now/=user_meth.and..not.useHxDef)then - if(uout>0)write(uout,'(a)')"False convergence / slow progress detected" - hx=getHxFromRelHx(hx,xopt,xscale,FDscale) - call getHx_macro() ! re-optimise stepsize - if(err/=0)goto 1000 !return - hx=getRelHxFromHx(hx,xopt,xscale,FDscale) - gradHx=fresh_hx - endif - if(useQuasiHessian.and.allowQHreset)call setUnitQhess_macro() - endif -enddo ! ... proceed to next Newton iteration -err=20; message="f-qnewton/maxIterExceeded" -call write_exitInfo() -! just before return: clean up heap memory -1000 call cleanupMem() -! End main procedure here -contains -!----- -subroutine startupMem() ! macro to allocate heap memory -use utilities_dmsl_kit,only:BperMB -implicit none -integer(mik)::memHess2temp -if(useConjGrad)then ! no Hessian storge needed - memHess2temp=0 ! (big advantage of conjugate-gradient methods for large problems) -else - memHess2temp=ndim**2*mrkBy/BperMB ! extra MB's needed for Hessian allocation on the heap - allocate(hessScaled(ndim,ndim),stat=err) - if(err/=0)then ! no need to preserve err values: its always err=0 when this routine is called - err=101 - write(message,'(a,i0,a)')"f-startupMem/allocError:hessScaled[",size(x0),"]/tryConjugateGradientMethods" - endif -endif -if(present(memHess2))memHess2=memHess2temp -endsubroutine startupMem -!----- -subroutine cleanupMem() ! macro to clean up the memory space and avoid memory leaks -implicit none ! cannot rely on the compiler to do so -integer(mik)::jerr ! local var to avoid obliterating the "err" return status -if(allocated(hessScaled))then - deallocate(hessScaled,stat=jerr) -else - jerr=0 -endif -if(jerr/=0)then - jerr=102;if(err==0)err=jerr ! but if this happened on a normal return then flag a problem - write(message,'(a,i0,a)')"f-cleanupMem/deAllocError:hessScaled[",size(x0),"]/strange(bug?)" -endif -endsubroutine cleanupMem -!----- -subroutine processUnwiseSettings() ! macro to handle unwise parameters -use utilities_dmsl_kit,only:oneThird,twoThirds -implicit none -! locals -type(qnewtonUnwise_type)::qnewtonUnwiseLoc ! default settings held here -! Start procedure here -if(present(qnewtonUnwise))then ! overwrite default settings - qnewtonUnwiseLoc=qnewtonUnwise - if(uout>0)write(uout,'(a)')"Warning:qnewtonUnwise prescribed" -endif -! Initial point analysis -gtol0fac =qnewtonUnwiseLoc%gtol0fac -! Linesearch settings -alpha_ls =qnewtonUnwiseLoc%alpha_ls -beta_ls =merge(qnewtonUnwiseLoc%beta_ls_CG,qnewtonUnwiseLoc%beta_ls,useConjGrad) -LNSstrongwolfe =qnewtonUnwiseLoc%LNSstrongwolfe -useDirDer =qnewtonUnwiseLoc%useDirDer -linmin_ometh =qnewtonUnwiseLoc%linmin_ometh -linmin_tol =qnewtonUnwiseLoc%linmin_tol -linmin_itmax =qnewtonUnwiseLoc%linmin_itmax -! Trust region settings -acceptRatio_tr =qnewtonUnwiseLoc%acceptRatio_tr -roDown_tr =qnewtonUnwiseLoc%roDown_tr -radDown_tr =qnewtonUnwiseLoc%radDown_tr -roUp_tr =qnewtonUnwiseLoc%roUp_tr -stepOtrustUp_tr =qnewtonUnwiseLoc%stepOtrustUp_tr -radUp_tr =qnewtonUnwiseLoc%radUp_tr -roUpNow_tr =qnewtonUnwiseLoc%roUpNow_tr -trustOstepMax_tr=qnewtonUnwiseLoc%trustOstepMax_tr -niter_tr =qnewtonUnwiseLoc%niter_tr -ncholMax_tr =qnewtonUnwiseLoc%ncholMax_tr -SR1forceUpdt =qnewtonUnwiseLoc%SR1forceUpdt -pivotCholTrust =qnewtonUnwiseLoc%pivotCholTrust -! - do not use pivoting with factored BFGS quasi-Newton -if(imeth==dogLeg_imeth.and.hmeth==bfgsFac_hmeth)pivotCholTrust=.false. -dogNewtBias =qnewtonUnwiseLoc%dogNewtBias -boundFrac =qnewtonUnwiseLoc%boundFrac -! Quasi-Hessian update settings -skipQNupdtClassic=qnewtonUnwiseLoc%skipQNupdtClassic -allowQHreset =qnewtonUnwiseLoc%allowQHreset -maxSR1update =qnewtonUnwiseLoc%maxSR1update -facBFGS_useR2 =qnewtonUnwiseLoc%facBFGS_useR2 -facBFGS_getLLt =qnewtonUnwiseLoc%facBFGS_getLLt -facBFGS_typeH =merge("SCL","SU ",hmeth==bfgsFac_hmeth.and..not.facBFGS_getLLt) -dampedBFGS =qnewtonUnwiseLoc%dampedBFGS -dampFac =qnewtonUnwiseLoc%dampFac -! Hessian scaling method -xscaleHmeth =qnewtonUnwiseLoc%xscaleHmeth -! Function roundoff estimation -Hscale =qnewtonUnwiseLoc%Hscale -hammPow =qnewtonUnwiseLoc%hammPow -! Performance output -iterNfo =qnewtonUnwiseLoc%iterNfo -! Active set bound constraints handling -tolGfree_bnd =qnewtonUnwiseLoc%tolGfree_bnd -tolOptSlack_bnd =qnewtonUnwiseLoc%tolOptSlack_bnd -tolGfree2_bnd =qnewtonUnwiseLoc%tolGfree2_bnd -fixDiagOption =qnewtonUnwiseLoc%fixDiagOption -! False convergence analysis -tolFalseDx =qnewtonUnwiseLoc%tolFalseDx -nFalseDxMax =qnewtonUnwiseLoc%nFalseDxMax -nFalseRfrshDxMax=qnewtonUnwiseLoc%nFalseRfrshDxMax -! Gradient checking -chkGrd =qnewtonUnwiseLoc%chkGrd -chkGrd_gmeth =qnewtonUnwiseLoc%chkGrd_gmeth -chkGrd_tG =qnewtonUnwiseLoc%chkGrd_tG -chkGrd_tGdf =qnewtonUnwiseLoc%chkGrd_tGdf -chkGrd_tF =qnewtonUnwiseLoc%chkGrd_tF -chkGrd_h =qnewtonUnwiseLoc%chkGrd_h -! Hessian checking -chkHess =qnewtonUnwiseLoc%chkHess -chkHess_hmeth =qnewtonUnwiseLoc%chkHess_hmeth -ignoreBadHess =qnewtonUnwiseLoc%ignoreBadHess -! Finite difference gradient approximation -FDscale =qnewtonUnwiseLoc%FDscale -useHxDef =qnewtonUnwiseLoc%useHxDef -hybridFDCD =qnewtonUnwiseLoc%hybridFDCD -dfdx0meth =qnewtonUnwiseLoc%dfdx0meth -allowFDCD =qnewtonUnwiseLoc%allowFDCD -tolFDCD =qnewtonUnwiseLoc%tolFDCD -fracFDCD =qnewtonUnwiseLoc%fracFDCD -tolCDFD =qnewtonUnwiseLoc%tolCDFD -fracCDFD =qnewtonUnwiseLoc%fracCDFD -tolGradFDCD =qnewtonUnwiseLoc%tolGradFDCD -tolGradCDFD =qnewtonUnwiseLoc%tolGradCDFD -tolDxFDCD =qnewtonUnwiseLoc%tolDxFDCD -adaptFDhX =qnewtonUnwiseLoc%adaptFDhX -adaptCDhX =qnewtonUnwiseLoc%adaptCDhX -! Modified Hessian factorization settings -facmeth =qnewtonUnwiseLoc%facmeth -! - no pivoting with Cholesky-Gershgorin factorization -if(facmeth==dennis_facmeth)pivotCholTrust=.false. -tau =qnewtonUnwiseLoc%tau -tau =merge(epsRe**oneThird,tau,taugmeth_now -gmethBundle%useHxDef = useHxDef -gmethBundle%FDscale = FDscale -gmethBundle%hx =>hx -gmethBundle%hybridFDCD = hybridFDCD -gmethBundle%tolGradFDCD = tolGradFDCD -gmethBundle%useDirDer = useDirDer -! End procedure here -endsubroutine makeGmethBundle -!----- -subroutine makeTrustBundle() ! macro to collect trust-evaluation bundle -use utilities_dmsl_kit,only:oneThird -implicit none -! Start procedure here -trustBundle%acceptRatio_tr = acceptRatio_tr -trustBundle%roDown_tr = roDown_tr -trustBundle%radDown_tr = radDown_tr -trustBundle%roUp_tr = roUp_tr -trustBundle%stepOtrustUp_tr = stepOtrustUp_tr -trustBundle%radUp_tr = radUp_tr -trustBundle%roUpNow_tr = roUpNow_tr -trustBundle%trustOstepMax_tr = trustOstepMax_tr -trustBundle%niter_tr = niter_tr -trustBundle%ncholMax_tr = ncholMax_tr -trustBundle%trustMax = stepmax -trustBundle%trustMin = stol -!trustBundle%SR1skipTol = merge(sqrt(epsF),sqrt(sqrt(epsF)),gmeth==user_meth) -trustBundle%SR1skipTol = merge(sqrt(epsF),epsF**oneThird,gmeth==user_meth) -trustBundle%SR1forceUpdt = SR1forceUpdt -trustBundle%pivotCholTrust = pivotCholTrust -trustBundle%dogNewtBias = dogNewtBias -trustBundle%boundFrac = boundFrac -! End procedure here -endsubroutine makeTrustBundle -!----- -subroutine makeObjFuncBundle() ! macro to collect function-evaluation bundle -implicit none -! Start procedure here -objFuncBundle%epsF = epsF -objFuncBundle%Hscale = Hscale -! End procedure here -endsubroutine makeObjFuncBundle -!----- -subroutine makeHessFacBundle() ! macro to collect Hessian factorization bundle -implicit none -! Start procedure here -hessFacBundle%facmeth = facmeth -hessFacBundle%tau = tau -hessFacBundle%tauBar = tauBar -hessFacBundle%mu = mu -hessFacBundle%maxHessCond = maxHessCond -! End procedure here -endsubroutine makeHessFacBundle -!----- -elemental function useConjGrad_inq(hmeth) ! returns true if conjugate gradient used -implicit none -! dummies -integer(mik),intent(in)::hmeth -logical(mlk)::useConjGrad_inq -! Start procedure here -selectcase(hmeth) -case(NCG_FR_hmeth,NCG_PR_hmeth,NCG_PPR_hmeth) - useConjGrad_inq=.true. -case default - useConjGrad_inq=.false. -endselect -! End procedure here -endfunction useConjGrad_inq -!----- -elemental function useQuasiHessian_inq(hmeth) ! returns true if quasi-Newton method used -implicit none -! dummies -integer(mik),intent(in)::hmeth -logical(mlk)::useQuasiHessian_inq -! Start procedure here -selectcase(hmeth) -case(bfgsInv_hmeth,bfgsUnfac_hmeth,bfgsFac_hmeth,SR1unFac_hmeth) - useQuasiHessian_inq=.true. -case default - useQuasiHessian_inq=.false. -endselect -! End procedure here -endfunction useQuasiHessian_inq -!----- -elemental function useTrust_inq(imeth) ! returns true if trust region method used -implicit none -! dummies -integer(mik),intent(in)::imeth -logical(mlk)::useTrust_inq -! Start procedure here -selectcase(imeth) -case(trustEx_imeth,dogLeg_imeth) - useTrust_inq=.true. -case default - useTrust_inq=.false. -endselect -! End procedure here -endfunction useTrust_inq -!----- -subroutine getFDCDmacro() ! macro to evaluate FDCD gradient -use utilities_dmsl_kit,only:getFDCDgrad -implicit none -! Start procedure here -call getFDCDgrad(evalFunc,dataIN,dataOUT,xopt,fopt,xscale,fscale,epsF,& - getHxFromRelHx(hx,xopt,xscale,FDscale),useHxDef,& - merge(useFDCDhybrid,fd_gmeth,hybridFDCD),tolGradFDCD,& - gradopt,addFcalls,err,message) -fcalls=fcalls+addFcalls -! End procedure here -endsubroutine getFDCDmacro -!----- -subroutine getCDmacro() ! macro to evaluate CD gradient -use utilities_dmsl_kit,only:getCDgrad -implicit none -! Start procedure here -call getCDgrad(evalFunc,dataIN,dataOUT,xopt,fopt,xscale,epsF,& - getHxFromRelHx(hx,xopt,xscale,FDscale),useHxDef,& - gradopt,addFcalls,err,message) -fcalls=fcalls+addFcalls -! End procedure here -endsubroutine getCDmacro -!----- -subroutine evalFuncMacro(xx,ff,gg,hh,xxIsX0) ! macro to evaluate function -implicit none -! dummies -real(mrk),intent(in)::xx(:) -real(mrk),intent(out),optional::ff,gg(:),hh(:,:) -logical(mlk),intent(in)::xxIsX0 -! locals -logical(mlk)::ok -! Start procedure here -call evalFunc(dataIN,dataOUT,xx,ok,ff,gg,hh,err=err,message=message) -if(err/=0)then - err=100; write(message,'(a,i0,a)')"f-qnewton/userErr[iter=",iter,"]/&"//trim(message) -elseif(.not.ok)then - if(xxIsX0)then - err=10;message="f-qnewton/x0unfeas" - else - err=20;write(message,'(a,i0,a)')"f-qnewton/bug/x(accepted)Unfeas[iter=",iter,"]" - endif - call write_exitInfo() -else - err=0 - if(present(ff))fcalls=fcalls+1 - if(present(gg))gcalls=gcalls+1 - if(present(hh))hcalls=hcalls+1 -endif -! End procedure here -endsubroutine evalFuncMacro -!----- -subroutine checkStepmax_macro() ! macro to set stepmax -implicit none -! Start procedure here -stepmax=stpmax -if(stepmax<=zero)then ! default value for stepmax (DS96,IMSL) - stepmax=stmax*max(norm2(x0/xscale),norm2(one/xscale)) -endif -stepmaxL=stepmax -! End procedure here -endsubroutine checkStepmax_macro -!----- -subroutine checkFDCDswitch_macro() ! macro to switch FD<->CD -implicit none -! Start procedure here -selectcase(gmeth_now) -case(fd_gmeth) - if(allowFDCD.and.fracFDCD<=one)then -! Designed by DK: compare FD gradient dfdx_fd with curvature d2f/dx2. -! Since as df/dx(true)->0, dfdx_fd->0.5*h*d2f/dx2 -! the quasi-Hessian diagonal gives possibly useful order-of-magnitude -! estimate of d2f/dx2 and hence can be used to construct a switch condition. - selectcase(hmeth) ! unfactored quasi-Hessian approximations - case(user_meth,fdg_hmeth,cdg_hmeth,fdf_hmeth,cdf_hmeth,& - bfgsUnfac_hmeth,SR1unFac_hmeth) - d2fdx2=abs(getdiag(hessopt)) - case(bfgsFac_hmeth) - d2fdx2=abs(getdiag(hessopt)) - case(bfgsInv_hmeth) - d2fdx2=one/abs(getdiag(hessopt)) ! this is wrong but probably still works... - endselect ! ...otherwise use recursion to get d2f/dx2 from inverse Hessian -! fraction of variables where gradient is "small" relative to curvature. - gOh_fdcd=get_gOh_fdcd(gradopt,d2fdx2,& - getHxFromRelHx(hx,xopt,xscale,FDscale),activeset,tolFDCD) - if(gOh_fdcd>=fracFDCD)gmeth_now=cd_gmeth ! switch to central diffs - gOh_fdcd=-1._mrk ! indicate on potential later switches that value not fresh - endif - if(scaledGrad(gradopt,xopt,fopt,xscale,fscale,activeSet)=one-fracCDFD)gmeth_now=fd_gmeth ! switch back to forward differences - gOh_fdcd=-1._mrk ! indicate on potential later switches that value not fresh - endif - if(scaledGrad(gradopt,xopt,fopt,xscale,fscale,activeSet)>tolGradCDFD)then - gmeth_now=fd_gmeth - endif - selectcase(gmeth_now) - case(fd_gmeth) ! switch from FD -> CD but do not re-optimize stepsize - call write_FDCDswitchInfo(fd_to_cd=.false.) - endselect - endselect -endselect -! End procedure here -endsubroutine checkFDCDswitch_macro -!----- -subroutine setUnitQhess_macro() ! macro to reset quasi-Hessian to unit matrix -implicit none -! Start procedure here -selectcase(hmeth) ! reset quasi-Hessian to identity -case(bfgsInv_hmeth) - call initQHess_inv(fopt,fscale,xscale,unt_himeth,hessopt) -case(bfgsUnfac_hmeth) - call initQHess_unfac(fopt,fscale,xscale,unt_himeth,hessopt) -case(bfgsFac_hmeth) - call initQHess_fac(fopt,fscale,xscale,unt_himeth,hessopt,Ld,facBFGS_getLLt) -case(SR1unFac_hmeth) - call initQHess_unfac(fopt,fscale,xscale,unt_himeth,hessopt) -endselect -! End procedure here -endsubroutine setUnitQhess_macro -!----- -subroutine getfredExp() ! macro to evaluate predicted function reduction -use utilities_dmsl_kit,only:quadDf -implicit none -! Start procedure here -selectcase(hmeth) -case(NCG_FR_hmeth,NCG_PR_hmeth,NCG_PPR_hmeth) ! * Conjugate gradient methods - fredExp=-dot_product(gradOpt,dx) ! ignore Hessian portion -case(bfgsInv_hmeth) ! * Inverse BFGS Hessian - fredExp=-dot_product(gradOpt,dx) ! ignore Hessian portion -case default ! * All other Hessians can be used in full quadratic form - fredExp=-quadDf(dx=dx,dfdx=gradOpt,d2fdx2=hessOpt,typeH=facBFGS_typeH) -endselect -! End procedure here -endsubroutine getfredExp -!----- -subroutine writeSettings() ! macro to write algorithm settings -implicit none -! locals -character(200)::infoString !,infoStringB -character(*),parameter::fmtIS='(3x,a,a)',fmtSN='(3x,a,es7.1)' -! Start procedure here -if(uout<=0)return -write(uout,'(a)')"*********************************************************************" -write(uout,'(a)')"------- ALGORITHMIC SETTINGS: DMSL NEWTON OPTIMIZATION MODULE -------" -write(uout,'(a)')"List of major settings and some (not all) 'esoteric' settings..." -! * Some problems specs -write(uout,'(a)')"0. PRIMARY PROBLEM CHARACTERISTIX" -write(uout,'(3x,a,i0)')"Number of variables (ndim) is ",ndim -write(uout,'(a)')"1. PRIMARY ALGORITHM SELECTION" -! * Globalization method -selectcase(imeth) -case(null_imeth) - infoString="Null: pure Newton iterations (debugging only)" -case(armijo_imeth) - infoString="Armijo backtracking linesearch" -case(wolfe_imeth) - infoString="Wolfe linesearch" -case(stwolfe_imeth) - infoString="Strong Wolfe linesearch" -case(brentmin_imeth) - infoString="Brent line minimisation" -case(trustEx_imeth) - infoString="Hookstep (near-exact) trust region" -case(dogLeg_imeth) - infoString="Dogleg trust region" -case default - infoString=unknownMethodChar -endselect -write(uout,fmtIS)"Globalization method: ",trim(infoString) -! * Gradient method -selectcase(gmeth) -case(user_meth) - infoString="User-supplied" -case(fd_gmeth) - infoString="Forward difference approximation ("//& - trim(merge("default ","adaptive",useHxDef))//" stepsize)" -case(cd_gmeth) - infoString="Central difference approximation ("//& - trim(merge("default ","adaptive",useHxDef))//" stepsize)" -case default - infoString=unknownMethodChar -endselect -write(uout,fmtIS)"Gradient method: ",trim(infoString) -! * Hessian method -selectcase(hmeth) -case(user_meth) - infoString="User-supplied" -case(fdg_hmeth) - infoString="Forward difference from gradient" -case(cdg_hmeth) - infoString="Central difference from gradient" -case(fdf_hmeth) - infoString="Forward difference from function" -case(cdf_hmeth) - infoString="Central difference from function" -case(bfgsInv_hmeth) - infoString="BFGS Quasi-Newton: inverse Hessian" -case(bfgsUnfac_hmeth) - infoString="BFGS Quasi-Newton: unfactored Hessian" -case(bfgsFac_hmeth) - infoString="BFGS Quasi-Newton: factored Hessian" -case(SR1unFac_hmeth) - infoString="SR1 Quasi-Newton: unfactored Hessian" -case(NCG_FR_hmeth) - infoString="Conjugate-gradient method, Fletcher-Reeves" -case(NCG_PR_hmeth) - infoString="Conjugate-gradient method, Polak-Ribiere" -case(NCG_PPR_hmeth) - infoString="Conjugate-gradient method, Positive Polak-Ribiere" -case default - infoString=unknownMethodChar -endselect -write(uout,fmtIS)"Hessian method: ",trim(infoString) -! * Initial Hessian if appropriate -if(useQuasiHessian)then - selectcase(himeth) - case(user_meth) - infoString="User-supplied" - case(unt_himeth) - infoString="Unit matrix" - case(untcnd1_himeth) - infoString="Conditioned unit matrix" - case(scld_himeth) - infoString="Scaled unit matrix" - case(scldcnd1_himeth) - infoString="Conditioned scaled unit matrix" - case(d2fdx2_himeth) - infoString="Approximate Hessian diagonal (can be expensive)" - case(hessX0_himeth) - infoString="Full Hessian (very expensive)" - case default - infoString=unknownMethodChar - endselect -else - infoString="Non-quasi-Newton method: 'himeth' ignored" -endif -write(uout,fmtIS)"Initial quasi-Hessian: ",trim(infoString) -! - Quasi-Hessian update -if(useQuasiHessian)then - selectcase(hmeth) - case(bfgsInv_hmeth,bfgsUnfac_hmeth,bfgsFac_hmeth) - if(skipQNupdtClassic)then - infoString="Classic BFGS update skipping" - elseif(dampedBFGS)then - infoString="Damped BFGS update skipping" - else - infoString="DK-modified BFGS update (maybe not positive-definite)" - endif - write(uout,fmtIS)"BFGS updating: ",trim(infoString) - endselect - if(allowQHreset)then - infoString="Reset Quasi-Hessian to unit matrix when failing" - else - infoString="Do not reset Quasi-Hessian to unit matrix when failing" - endif - write(uout,fmtIS)"Hessian resetting: ",trim(infoString) -endif -! * Convergence tolerance information -write(uout,'(a)')"2. TERMINATION CRITERIA" -write(uout,fmtSN)"Scaled gradient tolerance (gtol): ", gtol -write(uout,fmtSN)"Scaled step tolerance (stol): ", stol -write(uout,fmtSN)"Scaled function tolerance (ftol): ", ftol -write(uout,fmtSN)"False convergence tolerance (tolFalseDx): ",tolFalseDx -! * Active set (bound) information -write(uout,'(a)')"3. ACTIVE-SET INFORMATION" -if(boundedSearch)then - write(uout,fmtIS)"Bounds supplied by user: bound-constrained minimization","" - write(uout,fmtSN)"Gradient tolerance for fast release (>1.0=ignore): ",tolGfree_bnd - write(uout,fmtSN)"Slack factor for variable release (<1.0=ignore): ",tolOptSlack_bnd - write(uout,fmtSN)"Gradient tolerance for standard release (>1.0=one-at-time): ",tolGfree2_bnd -else - write(uout,fmtIS)"No bounds supplied by user: unconstrained minimization","" -endif -! * Additional information -if(useConjGrad)then ! method -else - write(uout,'(a)')"4. SECONDARY ALGORITHM SELECTION" -! - Hessian inversion method - selectcase(facmeth) - case(schnab_facmeth) - infoString="Revised modified Cholesky of Schnabel and Eskew" - case(dennis_facmeth) - infoString="Robust Cholesky-Gershgorin of Dennis and Schnabel (Gill et al)" - case default - infoString=unknownMethodChar - endselect - write(uout,fmtIS)"Hessian Cholesky method: ",trim(infoString) -! - Cholesky pivoting information - selectcase(imeth) - case(armijo_imeth,wolfe_imeth,stwolfe_imeth,brentmin_imeth) - selectcase(facmeth) - case(schnab_facmeth) - infoString="Pivoting enabled (recommended)" - case(dennis_facmeth) - infoString="Pivotion disabled (not recommended)" - endselect - case(trustEx_imeth) - if(pivotCholTrust)then - infoString="Pivoting enabled (probably un-necessarily)" - else - infoString="Pivotion disabled" - endif - case(dogLeg_imeth) - if(pivotCholTrust)then - infoString="Pivoting enabled" - else - infoString="Pivotion disabled (not recommended)" - endif - endselect - write(uout,fmtIS)"Cholesky pivoting: ",trim(infoString) -! - Hessian ellipticity scaling - selectcase(xscaleHmeth) - case(xscaleH_sphere) - infoString="Non-scaled Hessian" - case(xscaleH_user) - infoString="Scaled Hessian (user scale: xscale)" - case(xscaleH_hdiag) - infoString="Scaled Hessian (based on Hessian diagonal)" - case default - infoString=unknownMethodChar - endselect - write(uout,fmtIS)"Hessian 'ellipticity' scaling: ",trim(infoString) -endif -! - Finite difference gradient -if(gmeth/=user_meth)then - write(uout,'(a)')"5. FINITE DIFFERENCE GRADIENT" - write(uout,fmtIS)"Hybrid FD/CD gradient: ",merge("enabled ","disabled",hybridFDCD) - selectcase(imeth) - case(wolfe_imeth,stwolfe_imeth) - if(useDirDer)then - infoString="Fast (1 func eval) method" - else - infoString="Slow (n func eval) method" - endif - write(uout,fmtIS)"Directional derivative: ",trim(infoString) - endselect - write(uout,fmtIS)"Enhanced FD<->CD switches: ",merge("enabled ","disabled",allowFDCD) -endif -! - -write(uout,'(a)')"----- END ALGORITHMIC SETTINGS: DMSL NEWTON OPTIMIZATION MODULE -----" -write(uout,'(a)')"*********************************************************************" -! End main procedure here -endsubroutine writeSettings -!----- -subroutine write_iterationInfo(exitInfo,skipDetailedExitInfo) ! macro to write iteration info -use utilities_dmsl_kit,only:quickif -implicit none -! dummies -logical(mlk),intent(in),optional::exitInfo,skipDetailedExitInfo -! locals -character(200)::infoString -logical(mlk),parameter::exitInfoDef=.false.,skipDetailedExitInfoDef=.false. -character(*),parameter::& - fmtM ="(a,i7, & - &2x,a,es22.14e3, & - &4(2x,a,es12.4e3),& - &2x,a,es11.4, & - &2x,a,i2, & - &2x,a,i2, & - &2x,a,i3,a,i2,a,f4.1,a,& - &3(2x,a,es11.3e3))", & ! main format - fmtR ="(a,es22.14e3)", & - fmtI ="(a,i0)", & - fmtC ="(a)" -! Start procedure here -if(uout<=0)return -if(quickif(exitInfo,exitInfoDef))then ! exit information - write(uout,fmtC) "---------------------------" - selectcase(err) - case(0) ! succesful exit - write(uout,fmtC) "ALGORITHM EXIT SUCCESSFUL" - case(:-1) ! warning - write(uout,fmtC) "ALGORITHM EXIT WITH WARNING (SOLUTION MAY STILL BE ACCURATE)" - case(1:) ! error - write(uout,fmtC) "ALGORITHM EXIT WITH ERROR" - endselect - write(uout,fmtI) "Error code: ",err - write(uout,fmtC) "Message: "//trim(message) - if(quickif(skipDetailedExitInfo,skipDetailedExitInfoDef))then - write(uout,fmtC) "---------------------------" - write(uout,fmtC) "Algorithm did not fully initialise: no further exit details available" - else - write(uout,fmtC) "---------------------------" - write(uout,fmtC) "I. Termination information at the minimum" - write(uout,fmtR) "Function value at minimum: fopt= ",fopt - write(uout,fmtR) "Scaled gradient at minimum: grad[f]= ",scaledGrad(gradopt,xopt,fopt,xscale,fscale,activeSet,.true.) - selectcase(gmeth_now) - case(user_meth) - infoString="User-supplied" - case(fd_gmeth) - infoString="Forward difference approximation ("//& - trim(merge("default ","adaptive",useHxDef))//" stepsize)" - case(cd_gmeth) - infoString="Central difference approximation ("//& - trim(merge("default ","adaptive",useHxDef))//" stepsize)" - case default - infoString=unknownMethodChar - endselect - write(uout,fmtC) "Gradient method at termination: "//trim(infoString) - write(uout,fmtR) "Final scaled step: dx= ",scaledStepLen(dx,xopt,xscale) - write(uout,fmtR) "Final observed scaled function reduction: dfObs= ",scaledFred(fredAct,fopt,fscale) - write(uout,fmtR) "Final expected scaled function reduction: dfExp= ",scaledFred(fredExp,fopt,fscale) - write(uout,fmtI) "Total number of function calls: fcalls= ",fcalls - write(uout,fmtC) "---------------------------" - write(uout,fmtC) "II. Hessian information at the minimum (estimated)" - write(uout,fmtR) "Condition number of Hessian: condH= ",condEst - write(uout,fmtR) "Log(e)-determinant of Hessian: logDetH= ",logDet - write(uout,fmtR) "Bound on the magnitude of the most negative Hessian eigenvalue: |Einf|= ",Einf - write(uout,fmtC) "---------------------------" - write(uout,fmtC) "III. Constraint information at the minimum" - if(boundedSearch)then - write(uout,fmtC) "Hit bound on last step: "//merge("yes","no ",hitBound) - write(uout,fmtI) "Number of free variables: nfree= ",nfree - write(uout,fmtI) "Number of fixed variables: nfix= ",nfix - write(uout,fmtI) "Number of thawed variables (Lagrange<0): nthawn= ",nthawn - else - write(uout,fmtC) "Unconstrained optimisation (No constraints were specified)" - endif - write(uout,fmtC) "---------------------------" - write(uout,fmtC) "IV. Function information at the minimum" - write(uout,fmtR) "Function minimum: fopt= ",fopt - call write_iterationInfo_aux1(uout=uout,vecLabel="xOpt:",vecLabel_i="x",& - vecA1=xOpt, prec=8,boundedSearch=boundedSearch,activeSet=activeSet) - call write_iterationInfo_aux1(uout=uout,vecLabel="gOpt:",vecLabel_i="g",& - vecA1=gradOpt,prec=8,boundedSearch=boundedSearch,activeSet=activeSet) - call write_iterationInfo_aux1(uout=uout,vecLabel="hOpt:",vecLabel_i="h",& - vecA2=hessOpt,prec=8,boundedSearch=boundedSearch,activeSet=activeSet) - endif - write(uout,fmtC) "---------------------------" - write(uout,fmtC) "Thnx 4 uzing d'z q-nutn, ketch u L8er ..." - write(uout,fmtC) "---------------------------" -else - selectcase(iterNfo) - case(iterNfo_no) ! no iteration info - case(iterNfo_summ,iterNfo_var) ! iteration summary w/wo variables -! standard summary - write(uout,fmtM,advance="no")& - "iter"//"["//merge("U","C",nfree==ndim)//"]=",iter,& ! iteration number -! (U=unconstrained iteration (inside domain) vs C=constrained iteration (sliding/hitting bounds) - "fx=", fopt, & ! function value - "grad[f]=", scaledGrad(gradopt,xopt,fopt,xscale,fscale,activeSet,.true.),& ! scaled gradient - "dx=", scaledStepLen(dx,xopt,xscale), & ! scaled step - "dfObs=", scaledFred(fredAct,fopt,fscale), & ! observed scaled function reduction - "dfExp=", scaledFred(fredExp,fopt,fscale), & ! expected scaled function reduction - "fcalls=", real(fcalls,4), & ! function calls - "glob_code=", globcode, & ! globalisation return code - "gmeth_now=", gmeth_now, & ! gradient method - "nfac=",nfacstats(1),"(",nfacstats(2)," x", & ! number of Hessian factorizations - real(nfacstats(1))/real(max(nfacstats(2),1)),")",& - "condH=", condEst, & ! condition number of Hessian (estimated) - "logdetH=", logDet, & ! log-det[Hessian], estimated - "EinfH=", Einf ! |Einf| (magnitude of most negative Hessian eigenvalue), estimated -! trust region info - selectcase(imeth) - case(trustEx_imeth,dogLeg_imeth) - write(uout,'(2x,a,es11.3e3)',advance="no") & - "trustRad=", trustRad ! trust radius - endselect -! active set info - if(boundedSearch)then - write(uout,'(2x,a,3(2x,a,i6))',advance="no") & - "hitBound= "//merge("yes","no ",hitBound), & ! indicates whether step hit bound - "nfree=", nfree, & ! free variables - "nfix=", nfix, & ! fixed variables - "nthaw=", nthawn ! thawed variables (Lagrange<0) - endif -! prepare for possible dump of variable's info - write(uout,'(a)',advance=merge("yes","no ",iterNfo==iterNfo_summ)) " " - selectcase(iterNfo) - case(iterNfo_var) ! append current optimum to line - call write_iterationInfo_aux1(uout=uout,vecLabel=" xOpt: ",vecLabel_i="x",& - vecA1=xopt,prec=4,boundedSearch=boundedSearch,activeSet=activeSet) - endselect - endselect -endif -! End procedure here -endsubroutine write_iterationInfo -!----- -subroutine write_iterationInfo_aux1(uout,vecLabel,vecLabel_i,vecA1,vecA2,prec,boundedSearch,activeSet) -! Purpose: writes a standard inline vector (eg, optimum, gradient, Hessian diagonal) -use utilities_dmsl_kit,only:quickif -implicit none -! dummies -integer(mik),intent(in)::uout,activeSet(:) -character(*),intent(in),optional::vecLabel -character(*),intent(in)::vecLabel_i -real(mrk),intent(in),optional::vecA1(:) -real(mrk),intent(in),optional::vecA2(:,:) -integer(mik),intent(in)::prec ! output precision: 4 (single) -> 8 (double) -logical(mlk),intent(in)::boundedSearch -! locals -integer(mik)::i -integer(mik),parameter::var_len=100 -character(var_len)::fmtSS,fmtSP,fmtU,fmtV,vecLabel0 -character(*),parameter::& - fmtSS4="(a,i0,a,ss,i2,s,a,es14.6e3, 2x)", & ! single-precision format for activeSet with no "+" - fmtSS8="(a,i0,a,ss,i2,s,a,es22.14e3,2x)", & ! double-precision format for activeSet with no "+" - fmtSP4="(a,i0,a,sp,i2,s,a,es14.6e3, 2x)", & ! single-precision format for activeSet with "+" - fmtSP8="(a,i0,a,sp,i2,s,a,es22.14e3,2x)", & ! double-precision format for activeSet with "+" - fmtU4= "(a,i0, a,es14.6e3, 2x)", & ! single-precision format for variable (no active set) - fmtU8= "(a,i0, a,es22.14e3,2x)", & ! double-precision format for variable (no active set) - fmtLA='a,2x',fmtLA1='('//fmtLA//')',fmtLA2='('//fmtLA//',', & ! format for vecLabel_i - fmtLB='a', fmtLB1='('//fmtLB//')',fmtLB2='('//fmtLB//',' ! format for vecLabel_i -integer(mik)::vecType -integer(mik),parameter::vectType_arr1=1,vectType_arr2=2 -logical(mlk)::pres1,pres2 -! Start procedure here -selectcase(prec) -case(4) - fmtSS=fmtSS4;fmtSP=fmtSP4;fmtU=fmtU4 -case(8) - fmtSS=fmtSS8;fmtSP=fmtSP8;fmtU=fmtU8 -case(16) -!case default - write(uout,'(a)')"BUGERRO:f-write_iterationInfo_aux1/badIN:prec/={4,8}" -endselect -vecLabel0=quickif(vecLabel," ",var_len) -pres1=present(vecA1); pres2=present(vecA2) -if(pres1.and.pres2)then - write(uout,'(a)')"BUGERRO:f-write_iterationInfo_aux1/badIN:pres1.and.pres2" -elseif(pres1)then - vecType=vectType_arr1 -elseif(pres2)then - vecType=vectType_arr2 -else - return -endif -if(boundedSearch)then ! include active set info using pretty notation - if(len_trim(vecLabel0)>0)then ! acrobatics to get right spacing before 1st entry - write(uout,fmtLA1,advance="no")trim(vecLabel0) - else - write(uout,fmtLB1,advance="no")trim(vecLabel0) - endif - do i=1,ndim - fmtV=merge(fmtSS,fmtSP,activeSet(i)==0) - selectcase(vecType) - case(vectType_arr1) - write(uout,fmtV,advance="no")vecLabel_i,i,"(",activeSet(i),")=",vecA1(i) - case(vectType_arr2) - write(uout,fmtV,advance="no")vecLabel_i,i,"(",activeSet(i),")=",vecA2(i,i) - endselect - enddo - write(uout,'(a)',advance="yes")" " ! terminate line -else - if(len_trim(vecLabel0)>0)then ! acrobatics to get right spacing before 1st entry - write(fmtV,'(a,i0,a,a)')fmtLA2,ndim,trim(fmtU),')' - else - write(fmtV,'(a,i0,a,a)')fmtLB2,ndim,trim(fmtU),')' - endif - selectcase(vecType) - case(vectType_arr1) - write(uout,fmtV)trim(vecLabel0),(vecLabel_i,i,"=",vecA1(i),i=1,ndim) - case(vectType_arr2) - write(uout,fmtV)trim(vecLabel0),(vecLabel_i,i,"=",vecA2(i,i),i=1,ndim) - endselect -endif -! End procedure here -endsubroutine write_iterationInfo_aux1 -!----- -subroutine write_exitInfo(skipDetailedExitInfo) ! macro to write exit info -implicit none -! dummies -logical(mlk),intent(in),optional::skipDetailedExitInfo -! locals -logical(mlk),parameter::exitInfo=.true. -! Start procedure here -call write_iterationInfo(exitInfo,skipDetailedExitInfo) -! End procedure here -endsubroutine write_exitInfo -!----- -subroutine getHx_macro() ! macro to compact hx-estimation code -implicit none -! Start procedure here -! optimise finite difference interval and compute derivatives at initial point -if(useHxDef)then - selectcase(gmeth_now) - case(fd_gmeth) - call getFDCDgrad(evalFunc,dataIN,dataOUT,xopt,fopt,xscale,fscale,epsF,& - hx,useHxDef,& - merge(useFDCDhybrid,fd_gmeth,hybridFDCD),tolGradFDCD,& - gradopt,addFcalls,err,message) - case(cd_gmeth) - call getCDgrad(evalFunc,dataIN,dataOUT,xopt,fopt,xscale,epsF,& - hx,useHxDef,gradopt,addFcalls,err,message) - endselect - fcalls=fcalls+addFcalls - selectcase(himeth) - case(d2fdx2_himeth) ! independent evaluation of d2f/dx2 - call getHessDiagFromFunc(evalFunc,dataIN,dataOUT,xopt,fopt,xscale,epsF,useHxDef=useHxDefIni,& - hmeth=1,hessDiag=d2fdx2,fcalls=addFcalls,err=err,message=message) - fcalls=fcalls+addFcalls - endselect - if(uout>0)write(uout,'(a)',advance="no")"automatic stepsize in getHx_macro..." - if(err/=0)then - err=+20;message="f-getHx_macro/&"//message - if(uout>0)then - write(uout,'(a)')"NOT.OK" - write(uout,'(a)')"Message: "//trim(message) - endif - else - if(uout>0)write(uout,'(a)')"OK" - endif -else - if(uout>0)write(uout,'(a)',advance="no")"Estimating FD stepsize... " - call getFDgradHx(evalFunc,dataIN,dataOUT,xopt,fopt,xscale,fscale,activeSet,epsF,Hscale,& - merge(dfdx0meth,gradFD_sw2,gmeth_now==fd_gmeth),& - hx,xLo,xHi,gradopt,d2fdx2,addFcalls,err,errj,messagej) - fcalls=fcalls+addFcalls - if(err/=0)then ! some kind of error - message="f-getHx_macro/BUG?/&"//messagej(1) - call write_exitInfo() - return - elseif(any(errj/=0))then - if(uout>0)write(uout,'(a)')"NOT.OK" - err=merge(+30,0,any(errj>0)) - message="f-getHx_macro/&"//messagej(iFirstTrueLoc(errj/=0)) - call write_getFDgradHx_error() - where(errj/=0)d2fdx2=one ! go for safety: if df/dx poor then d2f/dx2 also - else ! likely to be poor - if(uout>0)write(uout,'(a)')"OK" - endif -endif -! End procedure here -endsubroutine getHx_macro -!----- -subroutine write_getFDgradHx_error() ! macro to write error from getFDgradHx -implicit none -integer(mik)::j -! Start procedure here -if(uout>0)then ! write warning to output file - write(uout,'(a)')"WARNING IN GETFDGRADHX" - do j=1,size(errj) ! report troublesome components - if(errj(j)/=0)then - write(uout,'(a,i6,a,i4,a,2(a,es19.12))')& - "Var",j,"; err=",errj(j),"; message="//trim(messagej(j)),& - "; df/dx=",gradopt(j),"; d2f/dx2=",d2fdx2(j) - endif - enddo -endif -! End procedure here -endsubroutine write_getFDgradHx_error -!----- -subroutine write_FDCDswitchInfo(fd_to_cd) ! macro to write switch info -implicit none -logical(mlk),intent(in)::fd_to_cd -character(21)::string -! Start procedure here -if(uout>0)then - string=merge("SWITCH:FD->CD (ratio=","SWITCH:CD->FD (ratio=",fd_to_cd) - write(uout,'(a,f5.2,a,i7,a)')string,gOh_fdcd,") (iter=",iter,")" -endif -! End procedure here -endsubroutine write_FDCDswitchInfo -!----- -subroutine checkGrad_macro() ! macro to check gradient accuracy -use numerix_dmsl_kit,only:checkGradFast,checkGradFast0,checkGrad -implicit none -! locals -real(mrk)::dfObs,dfObsB,dfPred -integer(mik)::afcalls,nfigOK(ndim),i,nfigOKmax -real(mrk)::hh(ndim) -logical(mlk)::gradOK -character(100)::status -! local pars -integer(mik),parameter::checkgrad_meth_old=0,checkgrad_meth_new=1 -integer(mik),parameter::checkgrad_meth=checkgrad_meth_new -character(*),parameter::fmtNfig="es12.3e3" ! "es23.14e3" ! "es17.8e3" ! -! Start procedure here -selectcase(chkGrd) -case(chkG_dxstp,chkG_hxstp,chkG_fail) - selectcase(chkGrd) - case(chkG_dxstp) ! * in direction of last step (this becomes rather - hh=dx ! un-informative when sliding along boundaries - case(chkG_hxstp,chkG_fail) ! * in default direction - selectcase(gmeth) - case(user_meth) ! analytical gradient (default estimate of "hx" for checking) - hh=sqrt(epsF)*max(abs(xopt),xscale) - case default ! use existing finite difference perturbations - hh=getHxFromRelHx(hx,xopt,xscale,FDscale) - endselect - if(boundedSearch)then - where(xopt+hhxHi)hh=-hh - endif - endselect - selectcase(checkgrad_meth) - case(checkgrad_meth_old) ! old fast method - call checkGradFast0(evalFunc,dataIN,dataOUT,x=xopt,fx=fopt,grad=gradopt,& - xdir=hh,h=chkGrd_h,fscale=fscale,scalingAnalysis=.true.,& - tolG=chkGrd_tG,tolGdf=chkGrd_tGdf,tolF=chkGrd_tF,& - gradAnalysis=gradCheckAnalysis,& - dfObs=dfObs,dfObsB=dfObsB,dfPred=dfPred,fcalls=afcalls,& - err=err,message=message) - case(checkgrad_meth_new) ! new fast method (recommended) - call checkGradFast(evalFunc,dataIN,dataOUT,x=xopt,fx=fopt,grad=gradopt,& - xdir=hh,h=chkGrd_h,fscale=fscale,& - tolG=chkGrd_tG,tolGdf=chkGrd_tGdf,tolF=chkGrd_tF,& - gradAnalysis=gradCheckAnalysis,& - dfA=dfObs,dfB=dfObsB,dfPred=dfPred,fcalls=afcalls,& - err=err,message=message) - endselect - fcalls=fcalls+afcalls - if(uout>0)then - if(err/=0)then;write(status,'(a,i0)')"err:",err - else; status="OK";endif - write(uout,'(a,i7,a,a,i3,3(a,1x,es10.3),a)')& - "iter=",iter,& - " chk Grad... "//trim(status),& - "; result:",gradCheckAnalysis,& - "; dfPred=",dfPred,"; dfObs=",dfObs,"; dfObsB=",dfObsB,& - "; message="//trim(message) - endif -case(chkG_full,chkG_f2g) ! full gradient check - call checkGrad(evalFunc,dataIN,dataOUT,xopt,fopt,gradopt,hx,chkGrd_gmeth,& - xscale,epsF,chkGrd_tG,hh,nfigOK,gradOK,afcalls,err,message) - fcalls=fcalls+afcalls - if(uout>0)then - if(err/=0)then;write(status,'(a,i0)')"err:",err - else; status="OK";endif - write(uout,'(a,i7,a,a,i4,2(a,1x,i4),a)')& - "iter=",iter,& - " chk Grad... "//trim(status),& - "; bestAgree:",maxval(nfigOK),& - "; worstAgree:",minval(nfigOK),& - "; message="//trim(message) - selectcase(iterNfo) ! possibly print entire gradient analysis - case(iterNfo_var) - write(uout,'(a)') "-----" - write(uout,'(a)') "Gradient analysis using "& - //merge("Forward O(1) Diffs",& - "Central O(2) Diffs",chkGrd_gmeth==fd_gmeth)& - //" method" - do i=1,ndim - write(uout,'(a,i6,a,2(a,'//fmtNfig//'),a,i4)')& - "var",i,": ",& ! variable - "gradOpt=", gradopt(i),& ! supplied gradient - "; gradFD=",hh(i),& ! estimated gradient - "; nFigOK=",nfigOK(i) ! decimal figures agreement - enddo - write(uout,'(a)') "-----" - endselect - endif -case default ! no gradient check - nfigOK=10 -endselect -if(err/=0)then - message="f-checkGrad_macro/&"//message; return -endif -nfigOKmax=maxval(nfigOK) -if(nfigOKmax<1)then - err=-10 - write(message,'(a,i0,a)')"f-checkGrad_macro/veryBadGradAccuracy[nfigOKmax=",nfigOKmax,"]" -else - err=0 -endif -! Start procedure here -endsubroutine checkGrad_macro -!----- -subroutine checkHess_macro() ! macro to check Hessian accuracy -use utilities_dmsl_kit,only:ns=>number_string,write_matrix,arthsi,trimv=>trim,flip_UtoL -use numerix_dmsl_kit,only:checkHess -implicit none -! locals -integer(mik)::afcalls,agcalls,nfigOK(ndim,ndim),nfigOKmax -real(mrk)::hfd(ndim,ndim) -logical(mlk)::hessOK -character(100)::hmethChar,status -! local pars -! Start procedure here -selectcase(chkHess) -case(chkHess_full,chkHess_f2g) - selectcase(hmeth) - case(bfgsFac_hmeth) ! currently cannot check Cholesky decomposition of Hessian -! (need to compute full Hessian, or, if using cheap method, projected Hessian) - err=100;message="f-checkHess_macro/CholeskyHessian:checkNotSupported" - return - endselect - call flip_UtoL(hessopt) ! make Hessian symmetric - call checkHess(evalFunc,dataIN,dataOUT,xopt,fopt,gradopt,hessopt,chkHess_hmeth,& - xscale,epsF,chkGrd_tG,hfd,nfigOK,hessOK,afcalls,agcalls,err,message) - fcalls=fcalls+afcalls; gcalls=gcalls+agcalls - if(uout>0)then - if(err/=0)then;write(status,'(a,i0)')"err:",err - else; status="OK";endif - write(uout,'(a,i7,a,a,i3,2(a,1x,i4),a)')& - "iter=",iter,& - " chk Hess... "//trim(status),& - "; bestAgree:",maxval(nfigOK),& - "; worstAgree:",minval(nfigOK),& - "; message="//trim(message) - selectcase(iterNfo) ! possibly print entire Hessian analysis - case(iterNfo_var) - selectcase(chkHess_hmeth) - case(fdg_hmeth) - hmethChar="'Gradient differencing, one-sided, O(1)'" - case(cdg_hmeth) - hmethChar="'Gradient differencing, central, O(2)'" - case(fdf_hmeth) - hmethChar="'Function differencing, one-sided, O(1)'" - case(cdf_hmeth) - hmethChar="'Function differencing, central, O(2)'" - case default - hmethChar="'chkHess_hmeth=Unknown' option, probably user input error" - endselect - write(uout,'(a)') "-----" - write(uout,'(a)') "Hessian analysis using "//trim(hmethChar)//" method" - call write_matrix(unt=uout,header="Supplied Hessian",& - m=hessopt,nfig=4,display=-1,vLabel="var"//trimv(ns(arthsi(ndim)),3),& - err=err,message=message) - write(uout,'(a)') " " - call write_matrix(unt=uout,header="Approxim Hessian",& - m=hfd,nfig=4,display=-1,vLabel="var"//trimv(ns(arthsi(ndim)),3),& - err=err,message=message) - write(uout,'(a)') " " - call write_matrix(unt=uout,header="Decimal digits of agreement",& - m=nfigOK,display=-1,vLabel="var"//trimv(ns(arthsi(ndim)),3),& - err=err,message=message) - write(uout,'(a)') "-----" - endselect - endif -case default ! no Hessian check - err=0;message="w-checkHess_macro/hessCheckNotCarriedOut" - nfigOK=10 -endselect -if(err/=0)then - message="f-checkHess_macro/&"//message; return -endif -nfigOKmax=maxval(nfigOK) -if(nfigOKmax<1)then - err=merge(0,-10,ignoreBadHess) - write(message,'(a,i0,a)')"f-checkHess_macro/veryBadHessAccuracy[nfigOKmax=",nfigOKmax,"]" -else - err=0 -endif -! Start procedure here -endsubroutine checkHess_macro -!----- -endsubroutine qnewton -!---------------------------------------------------- -pure subroutine checkStepBounds(x,xLo,xHi,activeSet,dx,stepToBound,hitBound) -! When carrying out box-constrained optimisation, the natural suggested Newton -! step may be too long and must be truncated. However, it is too early to freeze -! any variables since the final step may be even shorter. -! Optionally returns largest step to nearest bound (stepToBound) -! Comments -! - Method may fail (overflow) on numerical condition if x~xBound~0~dx. -! Need scale to handle this safely. -use utilities_dmsl_kit,only:zero,one -implicit none -! dummies -real(mrk),intent(in)::x(:),xLo(:),xHi(:) -integer(mik),intent(in)::activeSet(:) -real(mrk),intent(inout)::dx(:) -real(mrk),intent(out),optional::stepToBound -logical(mlk),optional,intent(out)::hitBound -! locals -real(mrk)::boundLmax,boundLj,dxx -integer(mik)::j,jMax -! Start procedure here -boundLmax=hugeRe;jMax=0 -do j=1,size(dx) - selectcase(activeSet(j)) - case(freeVar_as) ! * free variable - if(dx(j)>zero)then ! - check upper bound - dxx=max(epsRe*max(abs(xHi(j)),abs(x(j))),abs(dx(j))) - boundLj=(xHi(j)-x(j))/dxx - if(boundLjxHi(j))then ! - check upper bound - dx(j)=max(zero,xHi(j)-x(j)) ! (guarding against roundoff) - if(present(newActiveSet))newActiveSet(j)=hiVar_as - elseif(x(j)+dx(j)zero) - actv(j)=.false. - elseif(x(j)>=xHi(j)-safeEps*max(abs(xHi(j)),xscale(j)))then ! freeze variable - onBound=.true. ! now at upper bound, zero Hessian entries - selectcase(hmeth) ! update Cholesky factors - case(bfgsFac_hmeth) - call choles_update(L=hess,Ld=Ld,useLDL=.false.,actvrc=actv,& - irc=j,err=jerr,message=jmsg) - call putDiag(hess,Ld) ! See comment B/C - endselect - selectcase(fixDiagOption) - case(setUnit_fixDiag) - call replaceRowColMat(hess,j,newDiag=one/xscale(j)**2) - selectcase(hmeth) - case(bfgsFac_hmeth) - Ld(j)=one/xscale(j); hess(j,j)=Ld(j) ! See comment B/C - endselect - case(keepDiag_fixDiag) - call replaceRowColMat(hess,j) - endselect - activeSet(j)=merge(hiVar_as,freeHiVar_as,grad(j)zero)& - activeSet(j)=loVar_as ! ... fix variable and - selectcase(fixDiagOption) ! ... ensure Hessian entries remained zeroed - case(setUnit_fixDiag) - call replaceRowColMat(hess,j,newDiag=one/xscale(j)**2) - selectcase(hmeth) - case(bfgsFac_hmeth) - Ld(j)=one/xscale(j); hess(j,j)=Ld(j) ! See comment B/C - endselect - case(keepDiag_fixDiag) - call replaceRowColMat(hess,j) - endselect - case(hiVar_as) ! * variable at higher bound - if(grad(j)>=zero)& - activeSet(j)=freeHiVar_as ! ... thaw variable and - selectcase(fixDiagOption) ! ... ensure Hessian entries remained zeroed - case(setUnit_fixDiag) - call replaceRowColMat(hess,j,newDiag=one/xscale(j)**2) - selectcase(hmeth) - case(bfgsFac_hmeth) - Ld(j)=one/xscale(j); hess(j,j)=Ld(j) ! See comment B/C - endselect - case(keepDiag_fixDiag) - call replaceRowColMat(hess,j) - endselect - case(freeHiVar_as) ! * semi-free variable at higher bound - if(grad(j)= tolFast * ||grad(free)|| -! * If forceRel=.true. (ie, must release at least one var), release var(i) where -! grad(i) >= tolForce * ||grad(thawn)|| -! Actions: -! * Sets the status of variable -! * Could perhaps adjust Hessian components corresponding to the fixed variables -! (currently retains Hessian as is). The questions is really of scaling. -! See also usage of "fixDiagOption", which controls whether to overwrite fixed -! diagonals with unity. -use utilities_dmsl_kit,only:imaxloc -implicit none -! dummies -real(mrk),intent(in)::x(:),xscale(:),grad(:) -logical(mlk),intent(in)::forceRel -real(mrk),intent(in)::tolFast,tolForce -real(mrk),intent(inout)::hess(:,:),Ld(:) -integer(mik),intent(inout)::activeSet(:) -integer(mik),intent(out)::nfree,nfix,nthawn -! locals -logical(mlk)::thawn(size(x)) -integer(mik)::imax -real(mrk)::gradMaxFree,gradMaxThawn -! Start procedure here -thawn=activeset==freeLoVar_as.or.activeset==freeHiVar_as -if(count(thawn)>0)then ! something can be released -! * Immediate release of variables - if(any(activeset==freeVar_as))then - gradMaxFree=maxval(abs(grad)*max(abs(x),xscale),mask=activeset==freeVar_as) - where(thawn.and.abs(grad)*max(abs(x),xscale)>=tolFast*gradMaxFree)& - activeSet=freeVar_as - endif - if(forceRel)then -! * Time to release at least one variable - imax=imaxloc(abs(grad)*max(abs(x),xscale),mask=thawn) - activeSet(imax)=freeVar_as - gradMaxThawn=abs(grad(imax))*max(abs(x(imax)),xscale(imax)) - where(thawn.and.abs(grad)*max(abs(x),xscale)>=tolForce*gradMaxThawn)& - activeSet=freeVar_as ! allow more than one variable to the released - endif -endif -nfree= count(activeset==freeVar_as) -nfix= count(activeset==loVar_as.or.activeset==hiVar_as) -nthawn=count(activeset==freeLoVar_as.or.activeset==freeHiVar_as) -! End procedure here -endsubroutine checkReleaseActiveSet -!---------------------------------------------------- -subroutine fdigits2epsF(fdigits,evalFunc,dataIN,dataOUT,x,xLo,xHi,xscale,fscale,Hscale,hammPow,& - uout,uoutTitle,epsF,fcalls,err,message) -! Purpose: Converts number of reliable digits to function evaluation precision. -use types_dmsl_kit,only:data_ricz_type -use utilities_dmsl_kit,only:estimateEpsF -implicit none -! dummies -type(data_ricz_type),intent(in),optional::dataIN -type(data_ricz_type),intent(inout),optional::dataOUT -integer(mik),intent(in)::fdigits -real(mrk),intent(in)::x(:),xscale(:),fscale,Hscale,hammPow -real(mrk),optional,intent(in)::xLo(:),xHi(:) -integer(mik),intent(in)::uout -character(*),intent(in),optional::uoutTitle -real(mrk),intent(out)::epsF -integer(mik),intent(out)::fcalls -integer(mik),intent(out)::err -character(*),intent(out)::message -interface - subroutine evalFunc(dataIN,dataOUT,x,feas,fx,gradFx,hessFx,err,message) - use kinds_dmsl_kit - use types_dmsl_kit,only:data_ricz_type - implicit none - type(data_ricz_type),intent(in),optional::dataIN - type(data_ricz_type),intent(inout),optional::dataOUT - real(mrk),intent(in)::x(:) - logical(mlk),intent(out)::feas - real(mrk),intent(out),optional::fx,gradFx(:),hessFx(:,:) - integer(mik),intent(out)::err - character(*),intent(out)::message - endsubroutine evalfunc -endinterface -! locals -logical(mlk)::ok -real(mrk)::eA,eAfast,epsFfast -logical(mlk),parameter::fastOnly=.false.,useFast=.false. -! Start procedure here -fcalls=0;err=0 -selectcase(fdigits) -case(-2) ! use method of Hamming to estimate fdigits (function accuracy) - call estimateEpsF(evalFunc,dataIN,dataOUT,x,xLo,xHi,xscale,fscale,Hscale,hammPow,fastOnly,& - uout,uoutTitle,eA=eA,epsF=epsF,eAfast=eAfast,epsFfast=epsFfast,& - feas=ok,fcalls=fcalls,err=err,message=message) - if(.not.ok.or.err/=0)then - err=20; message="f-fdigits2epsF/&"//message - else - err=0; message="fdigits2epsF/ok" - endif - if(useFast)epsF=epsFfast -case(-1) ! full precision - epsF=epsRe; message="fdigits2epsF/fullPrecision" -case(0:2) ! virtually unworkable precision for optimisation methods - err=30; message="f-fdigits2epsF/fdigitsTooLow" -case(3:) ! user-supplied relative precision - epsF=10._mrk**(-fdigits); message="fdigits2epsF/ok(base10)" -case default ! unknown specification - err=-100; message="f-fdigits2epsF/fdigits:unknown" -endselect -! End procedure here -endsubroutine fdigits2epsF -!---------------------------------------------------- -pure function get_gOh_fdcd(gradFD,d2fdx2,h,activeset,tol) -! Purpose: calculates fraction where the estimated truncation error -! of a forward difference derivative exceeds the threshold -use utilities_dmsl_kit,only:half,zero -implicit none -! dummies -real(mrk),intent(in)::gradFD(:),d2fdx2(:),h(:),tol -integer(mik),optional,intent(in)::activeset(:) -real(mrk)::get_gOh_fdcd -! locals -integer(mik)::ndim -logical(mlk)::active(size(gradFD)) -! Start procedure here -if(present(activeSet))then - active=(activeSet==freeVar_as) - ndim=count(active) - if(ndim>0)then ! * at least one active variable - get_gOh_fdcd=& - real(count(half*abs(h)*abs(d2fdx2)>tol*abs(gradFD).and.active),mrk)/& - real(ndim,mrk) - else ! * all variables fixed - get_gOh_fdcd=zero - endif -else ! * all variables active - ndim=size(gradFD) - get_gOh_fdcd=& - real(count(half*abs(h)*abs(d2fdx2)>tol*abs(gradFD)),mrk)/real(ndim,mrk) -endif -! End procedure here -endfunction get_gOh_fdcd -!---------------------------------------------------- -pure function getStepLen2(dx,xscale) -! Purpose: Computes scaled norm-2 steplength. Used in assessing stepmax -use utilities_dmsl_kit,only:norm2 -implicit none -! dummies -real(mrk),intent(in)::dx(:),xscale(:) -real(mrk)::getStepLen2 -! Start procedure here -getStepLen2=norm2(dx/xscale) -! End procedure here -endfunction getStepLen2 -!---------------------------------------------------- -pure function scaledGrad(grad,x,fx,xscale,fscale,activeSet,incAllFree) -! Purpose: Computes scaled gradient at point "x". -! Optional activeSet and incAllFree allows to regulate which variables -! included in analysis. -use utilities_dmsl_kit,only:zero -implicit none -! dummies -real(mrk),intent(in)::grad(:),x(:),fx,xscale(:),fscale -integer(mik),intent(in),optional::activeSet(:) -logical(mlk),intent(in),optional::incAllFree -real(mrk)::scaledGrad -! locals -logical(mlk)::active(size(grad)) -! Start procedure here -if(present(activeSet))then - if(present(incAllFree))then - if(incAllFree)then - active= activeSet==freeVar_as .or.& - activeSet==freeLoVar_as .or.& - activeSet==freeHiVar_as - else - active= activeSet==freeVar_as - endif - else - active= activeSet==freeVar_as - endif - if(any(active))then ! * at least one active variable - scaledGrad=& - maxval(abs(grad)*max(abs(x),xscale)/max(abs(fx),fscale),& - mask=active) - else ! * all variables fixed - scaledGrad=zero - endif -else ! * all variables active - scaledGrad=& - maxval(abs(grad)*max(abs(x),xscale)/max(abs(fx),fscale)) -endif -! End procedure here -endfunction scaledGrad -!---------------------------------------------------- -pure function scaledStepLen(dx,x,xscale) -! Purpose: Computes scaled steplength -implicit none -! dummies -real(mrk),intent(in)::dx(:),x(:),xscale(:) -real(mrk)::scaledStepLen -! Start procedure here -scaledStepLen=maxval(abs(dx)/max(abs(x),xscale)) -! End procedure here -endfunction scaledStepLen -!---------------------------------------------------- -pure function scaledFred(fred,fx,fscale) -! Purpose: Computes scaled function reduction -implicit none -! dummies -real(mrk),intent(in)::fred,fx,fscale -real(mrk)::scaledFred -! Start procedure here -scaledFred=fred/max(abs(fx),fscale) -! End procedure here -endfunction scaledFred -!---------------------------------------------------- -pure subroutine checkConvergence0(x,fx,gradFx,activeSet,xscale,fscale,gtol,termcode) -! Purpose: check convergence of optimisation algorithm at initial point using -! (a) max-norm of scaled gradient; -! Comments: -! * The gradient tolerance gtol supplied to this procedure should be very stringent -! to avoid spurious termination on the startinhg point. -! * Note this procedure does not request CD gradient approximations. This can -! be requested by the calling program -use utilities_dmsl_kit,only:one -implicit none -! dummies -real(mrk),intent(in)::x(:),fx,gradFx(:),xscale(:),fscale,gtol -integer(mik),intent(in),optional::activeSet(:) ! current active set -integer(mik),intent(out)::termcode -! Start procedure here -termcode=no_con -if(scaledGrad(gradFx,x,fx,xscale,fscale,activeSet,.true.)<=gtol)then - termcode=grad_con -endif -! End procedure here -endsubroutine checkConvergence0 -!---------------------------------------------------- -pure subroutine checkConvergence(x,dx,fx,gradFx,activeSet,gmeth,fredExp,fredAct,& - xscale,fscale,gtol,stol,ftol,skipDxDfCheck,termcode) -! Purpose: check convergence of optimisation algorithm using -! (a) max-norm of scaled gradient; -! (b) scaled step tolerance -! (c) expected and predicted function reduction -! Will not terminate happily unless gradient is no larger than gtolMin -! (i) user-provided; or -! (ii) approximated using central differences; -use utilities_dmsl_kit,only:one -implicit none -! dummies -real(mrk),intent(in)::x(:),dx(:),fx,gradFx(:) ! current point properties -integer(mik),intent(in),optional::activeSet(:)! current active set -integer(mik),intent(in)::gmeth ! method of gradient evaluation -real(mrk),intent(in)::fredExp,fredAct ! expected actual and reduction -real(mrk),intent(in)::xscale(:),fscale ! scale modifiers -real(mrk),intent(in)::gtol,stol,ftol ! convergence tolerances -logical(mlk),intent(in)::skipDxDfCheck ! requests skipping dx and df checks -integer(mik),intent(out)::termcode ! termination code -! locals -real(mrk)::scaledG,scaledS,scaledFobs,scaledFexp -real(mrk),parameter::gtolMin=0.1_mrk ! minimal gradient for succesful termination -! Start procedure here -termcode=no_con -scaledG=scaledGrad(gradFx,x,fx,xscale,fscale,activeSet,.true.) -if(scaledG<=gtol)then -! * check gradient convergence - selectcase(gmeth) - case(fd_gmeth) -! termcode=switchCD_con - termcode=-grad_con - case default - termcode=grad_con ! gradient criterion satisfied - endselect -elseif(.not.skipDxDfCheck)then -! check steplength tolerance and function convergence tolerance. -! these should be skipped if a bound has been hit (since steplength can be very small) -! or if releasing variables from the freezing set (in which case the only reliable -! measure of convergence is the gradient. - scaledS=scaledStepLen(dx,x,xscale) - scaledFobs=scaledFred(abs(fredAct),fx,fscale) - scaledFexp=scaledFred(abs(fredExp),fx,fscale) - if(scaledS<=stol.and.scaledG<=gtolMin)then -! * check step convergence - selectcase(gmeth) - case(fd_gmeth) -! termcode=switchCD_con - termcode=-search_con - case default - termcode=search_con - endselect - elseif(scaledFobs<=ftol.and.scaledFexp<=ftol.and.scaledG<=gtolMin)then -! * check function convergence (expected and actual) - selectcase(gmeth) - case(fd_gmeth) -! termcode=switchCD_con - termcode=-fred_con - case default - termcode=fred_con - endselect - elseif(scaledS<=stol)then ! iterates converged but gradient too large - selectcase(gmeth) - case(fd_gmeth) -! termcode=switchCD_con - termcode=-srchBadGrad_con - case default - termcode=srchBadGrad_con - endselect - elseif(scaledFobs<=ftol.and.scaledFexp<=ftol)then ! function converged -! elseif(scaledFobs<=ftol)then ! function converged but gradient large - selectcase(gmeth) - case(fd_gmeth) -! termcode=switchCD_con - termcode=-fredBadGrad_con - case default - termcode=fredBadGrad_con - endselect - endif -endif -! End procedure here -endsubroutine checkConvergence -!---------------------------------------------------- -pure subroutine makeGoodHessDiag(hdiag,controlHessCond,maxHessCond) -! Purpose: Makes a good Hessian diagonal suitable for use in the quasi-Newton -! method. Must be positive non-singular with moderate conditioning -use utilities_dmsl_kit,only:zero,one -implicit none -! dummies -real(mrk),intent(inout)::hdiag(:) -logical(mlk),intent(in)::controlHessCond -real(mrk),intent(in)::maxHessCond -! locals -real(mrk)::dMax -! Start procedure here -hdiag=abs(hdiag); dMax=maxval(hdiag) -if(dMax==zero)then ! handle zero case - hdiag=one -elseif(controlHessCond)then ! control conditioning - where(hdiag=i)hessScaled(i,j)=hess(i,j)*xscale(i)*xscale(j) -gradScaled=grad*xscale; steepStepLen=norm2(gradScaled) -! if(steepStepLenzero) - endwhere - hmax=hmaxSafe*hmax ! and safeguard just in case - else - hmax=hmaxFac*max(abs(x),xscale) - endif - call dfdx_sw(evalFunc,dataIN,dataOUT,x,whatdfdx,fxin=fx,epsF=epsFa,fcallsmax=fcmax_sw,h0in=h0,& - betain=spread(beta_sw,1,size(x)),xscale=xscale,fscale=fscale,hmax=hmax,& - dfdx=dfdx,Edfdx=Edfdx,hopt=hx,& - fcalls=addFcalls,err=err,message=message) - fcalls=fcalls+sum(addFcalls) - if(any(err/=0))then - ibad=ifirstTrueLoc(err/=0); err(1)=err(ibad) - retcode=bugFail; message(1)="f-getFDgradHx/&"//message(ibad); return - endif - if(present(d2fdx2))then - call getHessDiagFromFunc(evalFunc,dataIN,dataOUT,x,fx,xscale,epsF,useHxDef=useHxDef_d2fdx2,& - hmeth=1,hessDiag=d2fdx2,fcalls=addFcalls(1),err=lerr,message=lmessage) - fcalls=fcalls+addFcalls(1) - if(lerr/=0)then - retcode=bugFail; err(1)=10; message(1)=trim(lmessage) !//message(1) - endif - endif -case(gradFD_sw2) -! * Stepleman and Winarsky method,O(h2) analysis - where(varStatus==freeVar_as) ! internal - whatdfdx=dfdxC2 ! central approximation - elsewhere(varStatus==loVar_as.or.varStatus==freeLoVar_as) ! lower bound - whatdfdx=dfdxF2 ! forward app. - elsewhere(varStatus==hiVar_as.or.varStatus==freeHiVar_as) ! upper bound - whatdfdx=dfdxB2 ! backward app. - endwhere - if(present(xLo).and.present(xHi))then - where (whatdfdx==dfdxB2) ! backward at upper bound - hmax=half*(xLo-x) - elsewhere(whatdfdx==dfdxF2) ! forward at lower bound - hmax=half*(xHi-x) - elsewhere(whatdfdx==dfdxC2) ! internal: check either side - hmax=min(x-xLo,xhi-x) - endwhere - where(whatdfdx==dfdxC2.and.abs(hmax)zero) ! switch to forward/backward method - hmax=hmaxSafe*hmax ! and safeguard just in case - endwhere - else - hmax=hmaxFac*max(abs(x),xscale) - endif - call dfdx_sw(evalFunc,dataIN,dataOUT,x,whatdfdx,fxin=fx,epsF=epsFa,fcallsmax=fcmax_sw,h0in=h0,& - betain=spread(beta_sw,1,size(x)),xscale=xscale,fscale=fscale,hmax=hmax,& - dfdx=dfdx,Edfdx=Edfdx,dfdxFree=d2fdx2loc,hopt=hx,& - fcalls=addFcalls,err=err,message=message) - fcalls=fcalls+sum(addFcalls) - if(any(err/=0))then - ibad=ifirstTrueLoc(err/=0); err(1)=err(ibad) - retcode=bugFail; message(1)="f-getFDgradHx/&"//message(ibad); return - endif - if(present(d2fdx2))d2fdx2=d2fdx2loc -case default ! bug: unknown method - retcode=bugFail; err=bugFail; message="f-getFDgradHx/unknownMethod" -endselect -! End procedure here -endsubroutine getFDgradHx -!---------------------------------------------------- -pure subroutine bfgsInv_update1(dx,xscale,activeSet,grad,gradold,qhessinv,rescale) -! Purpose: BFGS update of inverse quasi-Hessian (NR-based method). -! * Update is skipped if "fac" is not sufficiently positive. -! * Skipping condition 2 (when change in dx expected to be below noise) -! is not implemented, since quasi-Hessian itself is unavailable. -! * Classic skipping condition requires 'fac>0' to ensure +ve definite q-Hessian. -! Modified conditions (BFGS damping) not implemented for the inverse-updating. -! * The implementation below requires far fewer matrix multiplies than -! "bfgsInv_update2" and takes advantage of symmetry. -! * Option available to rescale the initial diagonal Hessian after first -! iteration but before first update using eqn (8.20) in Nocedal. -! This can improve the scaling of Hessian for subsequent updates. -! * Routine can work with upper Hessian only. However, for some compilers, -! the matmul is so fast that it could be preferred over DMSL's symmetric mamtul... -use utilities_dmsl_kit,only:zero,one,norm2,rank1updt,fmatmul_mv,flip_UtoL -implicit none -! dummies -real(mrk),intent(in)::dx(:),xscale(:),grad(:),gradold(:) -integer(mik),intent(in),optional::activeSet(:) -real(mrk),intent(inout)::qhessinv(:,:) -!logical(mlk),intent(in)::skipClassic -logical(mlk),intent(in)::rescale -! locals -real(mrk)::dg(size(dx)),hdg(size(dx)),fac,fad,fae -! Start procedure here -dg=grad-gradold -if(present(activeSet))then ! need to zero dg for fixed variables - where(activeSet/=freeVar_as)dg=zero -endif -fac=dot_product(dg,dx) -if(rescale)then ! rescale Hessian during first iteration - call qhessRescale(qhess=qhessinv,invrs=.true.,dg=dg,fac=fac) -endif -!if(skipClassic)then ! skip update (condition 1), classic, ensures +ve def update - if(fac<=sqrt(epsRe)*norm2(dx/xscale)*norm2(dg*xscale))return -!else ! skip update (condition 1), new, can yield indefinite updates -! if(abs(fac)<=sqrt(epsRe)*norm2(dx/xscale)*norm2(dg*xscale))return -!endif -if(bfgsInvUt)then ! avoid accessing lower triangle - hdg=fmatmul_mv(m=qhessinv,v=dg,typeMV="SUV") -else ! full matmul - hdg=matmul(qhessinv,dg) -endif -fae=dot_product(dg,hdg) -fac=one/fac; fad=one/fae; dg=fac*dx-fad*hdg ! vector that makes BFGS different from DFP -call rank1updt(a=qhessinv,facX=fac,x=dx,facY=-fad,y=hdg,facZ=fae,z=dg,symm="U") -if(.not.bfgsInvUt)call flip_UtoL(qhessinv) ! make symmetric if requested -! End procedure here -endsubroutine bfgsInv_update1 -!---------------------------------------------------- -pure subroutine bfgsInv_update2(dx,xscale,activeSet,grad,gradold,qhessinv,mtemp,rescale) -! Purpose: BFGS update of inverse quasi-Hessian (eqn 8.16 in Nocedal). -! * Update is skipped if "fac" is not sufficiently positive. -! * Skipping condition 2 (when change in dx expected to be below noise) -! is not implemented, since quasi-Hessian itself is unavailable. -! * Classic skipping condition requires 'fac>0' to ensure +ve definite q-Hessian. -! Modified conditions (BFGS damping) not implemented for the inverse-updating. -! * Option available to rescale the initial diagonal Hessian after first -! iteration but before first update using eqn (8.20) in Nocedal. -! This can improve the scaling of Hessian for subsequent updates. -! * This routine should be used as backup only - it implements the BFGS -! equations in a rather cumbersome inefficient manner. -! * Routine works with entire matrix. This makes it not quite compatible -! with "bfgsInv_update1", which works solely with upper triangle. -use utilities_dmsl_kit,only:zero,one,norm2,rank1updt,addDiag,outerprod -implicit none -! dummies -real(mrk),intent(in)::dx(:),xscale(:),grad(:),gradold(:) -integer(mik),intent(in),optional::activeSet(:) -real(mrk),intent(inout)::qhessinv(:,:),mtemp(:,:) -!logical(mlk),intent(in)::skipClassic -logical(mlk),intent(in)::rescale -! locals -real(mrk)::dg(size(dx)),fac -! Start procedure here -dg=grad-gradold -if(present(activeSet))then ! need to zero dg for fixed variables - where(activeSet/=freeVar_as)dg=zero -endif -fac=dot_product(dg,dx) -if(rescale)then ! rescale Hessian during first iteration - call qhessRescale(qhess=qhessinv,invrs=.true.,dg=dg,fac=fac) -endif -!if(skipClassic)then ! skip update (condition 1), classic, ensures +ve def update - if(fac<=sqrt(epsRe)*norm2(dx/xscale)*norm2(dg*xscale))return -!else ! skip update (condition 1), new, can yield indefinite updates -! if(abs(fac)<=sqrt(epsRe)*norm2(dx/xscale)*norm2(dg*xscale))return -!endif -fac=one/fac ! this construction is far less efficient than "bfgsInv_update1" -mtemp=-fac*outerprod(dx,dg); call addDiag(mtemp,one) ! cos it needs several full matmul's -qhessinv=matmul(mtemp,qhessinv); qhessinv=matmul(qhessinv,transpose(mtemp)) -call rank1updt(a=qhessinv,fac=fac,x=dx,symm="N") -! End procedure here -endsubroutine bfgsInv_update2 -!---------------------------------------------------- -pure subroutine bfgsUnfac_update(dx,xscale,activeSet,grad,gradold,qhess,tol,& - skipClassic,dampedBFGS,dampFac,rescale,err,message) -! Purpose: BFGS update of unfactored quasi-Hessian. This allows monitoring the -! condition number of Hessian and ensuring "sufficient" positive definiteness. -! This naive implementation in this procedure leads to O(N3) cost since the -! Cholesky decomposition of the quasi-Hessian needs to be performed at each iteration. -! Comments: -! * Skipping conditions 1 and 2 implemented, to ensure positive definiteness -! and prevent numerical noise from degrading the quasi-Hessian -! * Allows BFGS damping as described by Nocedal and Wright 1999,p.201&540, -! to improve the performance in difficult regions where Hessian not +ve definite. -! * Classic skipping condition ensures BFGS Hessian remains positive -! definite by skipping updates when 'fac~0'. Nocedal and Wright experience -! (as well as DK's!) suggests that in some cases this forces excessive -! skipping and inhibits the methods to the point of failure. -! Damped BFGS handles 'fac~0' in a different way, still ensuring +ve -! definite Hessians. A more drastic DK change is merely guard overflow and -! accept indefinite Hessians. Indeed,when using trust-region methods, -! indefinite q-Hessians can be OK, indeed, desirable. In this case use -! skipClassic=.false. and dampedBFGS=.false. -! * Option available to rescale the initial diagonal Hessian after first -! iteration but before first update using eqn (8.20) in Nocedal. -! This can improve the scaling of Hessian for subsequent updates. -! * Routine works with upper triangle of Hessian only. -use utilities_dmsl_kit,only:zero,one,norm2,fmatmul_mv,rank1updt -implicit none -! dummies -real(mrk),intent(in)::dx(:),xscale(:),grad(:),gradold(:),tol -integer(mik),intent(in),optional::activeSet(:) -real(mrk),intent(inout)::qhess(:,:) -logical(mlk),intent(in)::skipClassic -logical(mlk),intent(in)::dampedBFGS -real(mrk),intent(in)::dampFac -logical(mlk),intent(in)::rescale -integer(mik),intent(out)::err -character(*),intent(out)::message -! locals -real(mrk)::dg(size(dx)),hdx(size(dx)),fac,fad -! BFGS damping -real(mrk)::dampTheta -! Start procedure here -err=0;message="bfgsUnFac_update/ok"; dg=grad-gradold -if(present(activeSet))then ! need to zero dg for fixed variables - where(activeSet/=freeVar_as)dg=zero -endif -fac=dot_product(dg,dx) -if(rescale)then ! rescale Hessian during first iteration - call qhessRescale(qhess=qhess,dg=dg,invrs=.false.,fac=fac) -endif -!hdx=matmul(qhess,dx) -hdx=fmatmul_mv(m=qhess,v=dx,typeMV="SUV") ! avoid accessing lower triangle -fad=dot_product(dx,hdx) -if(all(abs(dg-Hdx)<=tol*max(abs(grad),abs(gradold))))then ! prevents noisy updates - err=0;message="bfgsUnFac_update/skipCond2(noisyUpdate)" - return -endif -if(skipClassic)then ! - classical (Dennis and Schnabel) skipping conditions - if(fac<=sqrt(epsRe)*norm2(dx/xscale)*norm2(dg*xscale))then ! prevents indefinite updates - err=0;message="bfgsFac_update/skipCond1(posDefUpdate)(classic)" - return - endif -elseif(dampedBFGS.and.faczero)then ! (crudely) maintain reasonable conditioning - Ldmin=triang_minEig(Ld=Ld,condMax=maxHessCond,cholLd=.true.) - where(Ldj)LS(i,j)=L0(i,j)*xscale(i) -elseif(present(LS))then - forall(i=1:n,j=1:n,i>j)LS(i,j)=LS(i,j)*xscale(i) -endif -if(present(LdS).and.present(Ld0))then ! diagonal of L-factor - LdS=Ld0*xscale -elseif(present(LdS))then - LdS=LdS*xscale -endif -if(present(gradS).and.present(grad0))then ! gradient - gradS=grad0*xscale -elseif(present(gradS))then - gradS=gradS*xscale -endif -if(present(pS).and.present(p0))then ! step - pS=p0/xscale -elseif(present(pS))then - pS=pS/xscale -endif -! End procedure here -endsubroutine xscaleNewt -!---------------------------------------------------- -pure subroutine unXscaleNewt(xscale,hess0,hessS,L0,LS,Ld0,LdS,grad0,gradS,p0,pS) -! Purpose: unscales Hessian, L-factors, gradient and step -! using a diagonal scaling matrix xscale. -! NB: note step scaling is inverse! -implicit none -! dummies -real(mrk),intent(in)::xscale(:) -real(mrk),intent(inout),optional::hess0(:,:),L0(:,:),Ld0(:),grad0(:),p0(:) -real(mrk),intent(in), optional::hessS(:,:),LS(:,:),LdS(:),gradS(:),pS(:) -! locals -integer(mik)::i,j,n -! Start procedure here -n=size(xscale) -if(present(hess0).and.present(hessS))then ! upper triangle of Hessian - forall(i=1:n,j=1:n,i<=j)hess0(i,j)=hessS(i,j)/xscale(i)/xscale(j) -elseif(present(hess0))then - forall(i=1:n,j=1:n,i<=j)hess0(i,j)=hess0(i,j)/xscale(i)/xscale(j) -endif -if(present(L0).and.present(LS))then ! lower triangular factor L of Hessian - forall(i=1:n,j=1:n,i>j)L0(i,j)=LS(i,j)/xscale(i) -elseif(present(L0))then - forall(i=1:n,j=1:n,i>j)L0(i,j)=L0(i,j)/xscale(i) -endif -if(present(Ld0).and.present(LdS))then ! diagonal of L-factor - Ld0=LdS/xscale -elseif(present(Ld0))then - Ld0=Ld0/xscale -endif -if(present(grad0).and.present(gradS))then ! gradient - grad0=gradS/xscale -elseif(present(grad0))then - grad0=grad0/xscale -endif -if(present(p0).and.present(pS))then ! step - p0=pS*xscale -elseif(present(p0))then - p0=p0*xscale -endif -! End procedure here -endsubroutine unXscaleNewt -!---------------------------------------------------- -subroutine solveModNewtHess(hess,hessScaled,Ld,grad,hessFacBundle,& - xscaleHmeth,xscale,fscale,activeset,dx,ncholstats,logdet,condest,Einf,err,message) -! Purpose: Processes the model Hessian equations for Newton-type optimisation -! using a modified factorization guaranteed to produce a positive definite -! matrix and hence descent direction. -! INPUT: -! hess = full raw (unscaled) Hessian (may be indefinite, singular, etc.) -! hessScaled = work array for Hessian decomposition -! grad = full raw (unscaled) gradient -! hessFacBundle = modified factorization bundle (settings etc.) -! xscaleHmeth = Hessian scaling method -! xscale = user-provided xscale -! activeSet = active set -! OUTPUT -! dx = full solution of modified Hessian equations (Newton step) -! logdet = log-determinant of modified Hessian -! condest = condition estimate of modified Hessian -! Einf = estimated most negative eigenvalue of input Hessian -! err = error status -! message = description of problems. -! Currently implemented factorization methods -! - modified Cholesky-Gershgorin w/wo pivoting, which perturb the Hessian diagonal -! to achieve +ve definiteness and improve conditioning. -!--------- -! Algorithm flowchart: -! Input: Raw Hessian and gradient for Newton step -! Output: Full modified Newton solution -! -! Raw Hessian (may be indefinite) -> -! Active Hessian (excludes constrained variables) -> -! Scaled active Hessian (accounting for diagonal scaling of vars) -> -! Pivoted modified scaled active Hessian for Cholesky solution -> -! Pivoted scaled active solution (to the modified problem) -> -! Scaled active solution -> -! Active solution -> -! Full solution -!--------- -! Comments -! * The work array hessScaled greatly simplifies memory management and reduces -! arithmetic load in constructing the active Hessian, scaling and permuting it. -! If this extra array is memory-busting, you should not be using dense Newton -! in the first place - try conjugate gradient or truncated / limited memory Newton. -! * If the Cholesky algebra here is too much (but memory OK), can use factored -! BFGS approximations which do not require explicit factorizations. -use utilities_dmsl_kit,only:zero,one,arthsi,terminateRowColMat -use linalg_dmsl_kit,only:choles_dcmp,choles_fwbw -implicit none -! dummies -real(mrk),intent(in)::hess(:,:),grad(:),xscale(:),fscale -real(mrk),intent(inout)::hessScaled(:,:) ! scratch Hessian -real(mrk),intent(out)::Ld(:) -type(hessFacBundle_type),intent(in)::hessFacBundle -integer(mik),intent(in)::xscaleHmeth -integer(mik),intent(in),optional::activeset(:) -real(mrk),intent(out)::dx(:) -integer(mik),intent(out)::ncholstats(:) -real(mrk),intent(out)::logdet,condest,Einf -integer(mik),intent(out)::err -character(*),intent(out)::message -! locals for cholesky -integer(mik)::ndim,nchol -logical(mlk)::ok -!--locals for bounds -integer(mik)::lerr,nact -logical(mlk)::active(size(dx)) -real(mrk)::xscaleH(size(dx)) -integer(mik)::avar(size(dx)) -character(100)::lmessage -! Cholesky pivoting -logical(mlk),parameter::doPivot=.true. -integer(mik)::indx(size(dx)) -real(mrk)::gradScaled(size(dx)) -! Start procedure here -ndim=size(dx);ncholstats=0 -err=0;message="solveModNewtHess/ok" -if(present(activeset))then ! * bound-contrained optimisation - active=(activeSet==freeVar_as) - nact=count(active) -else - nact=ndim -endif -call getXscaleH(xscaleHmeth,hess,xscale,fscale,xscaleH) -if(nact==0)then ! * all variables on bounds - dx=zero; ok=.true.; logdet=zero; condest=zero; Einf=zero - err=okAlg; message="w-solveModNewtHess/allVarsFixed" -else - if(nact==ndim)then ! * effectively unconstrained - avar=arthsi(ndim) - call xscaleNewt(xscaleH,hess0=hess,hessS=hessScaled) - else ! * active constraints present: need to muck around - avar=pack(arthsi(ndim),active) ! index of active variables -! pack active hessian, removing rows/columns corresponding to fixed variables - call terminateRowColMat(hess,hessScaled(1:nact,1:nact),active,lerr,lmessage) - call xscaleNewt(xscaleH(avar(1:nact)),hessS=hessScaled(1:nact,1:nact)) - endif ! also scale gradient - call xscaleNewt(xscaleH(avar(1:nact)),grad0=grad(avar(1:nact)),gradS=gradScaled(1:nact)) - selectcase(hessFacBundle%facmeth) ! select modified Hessian factorization method - case(schnab_facmeth) ! - revised modified Cholesky-Gershgorin of Schnabel and Eskew - indx=-1 ! (indicate no pre-scrambling) - call choles_dcmp(A=hessScaled(1:nact,1:nact),Ld=Ld(1:nact),& - tau=hessFacBundle%tau,tauBar=hessFacBundle%tauBar,mu=hessFacBundle%mu,& - doPivot=doPivot,indx=indx(1:nact),& - posDefinite=ok,logDet=logdet,condest=condEst,Einf=Einf,err=err,message=lmessage) - nchol=1 ! note if pivoting used then everything will be scrambled (and scaled) - case(dennis_facmeth) ! - perturbed Cholesky-Gershgorin of Dennis and Schnabel - call choles_dcmp(A=hessScaled(1:nact,1:nact),Ld=Ld(1:nact),& - maxCond=hessFacBundle%maxHessCond,& - posDefinite=ok,nchol=nchol,logDet=logdet,condest=condEst,& - Einf=Einf,err=err,message=lmessage) - endselect - ncholstats(1)=ncholstats(1)+nchol ! number of O(3) Cholesky factorizations - ncholstats(2)=ncholstats(2)+1 ! number of internal iterations - if(err/=okAlg)then ! (usually 1 for linesearch, >1 for trusts) - err=-20;message="f-solveModNewtHess/&"//lmessage - return - endif ! solve the scaled permuted Newton equations. the solution is unscrambled ... - call choles_fwbw(a=hessScaled(1:nact,1:nact),Ld=Ld(1:nact),indx=indx(1:nact),& - usePivot=hessFacBundle%facmeth==schnab_facmeth.and.doPivot,& - b=gradScaled(1:nact),x=dx(1:nact),err=err,message=lmessage) - call unXscaleNewt(xscaleH(avar(1:nact)),p0=dx(1:nact)) ! ... and now unscaled - if(err/=okAlg)then - err=-30;message="f-solveModNewtHess/&"//lmessage - return - endif - if(nactstepmax)then ! scale down large steps - sdir=sdir*stepmax/stepLen; stepLen=stepmax -endif -slope0=dot_product(grad0,sdir) ! initial slope -if(slope0>zero)then ! search direction is uphill - x=x0; fx=fx0; retcode=badDir_glob; return -elseif(slope0==zero)then ! no perceived slope in search direction - x=x0; fx=fx0; fredAct=zero; retcode=failed_glob; return -endif -relLen=scaledStepLen(sdir,x0,xscale) ! scaled step length (used in termination test) -lambdaMin=stol/relLen ! minimum allowable steplength, lambda must be above noise -lambdaMin=max(minval(epsRe*max(abs(x0),xscale)/max(abs(sdir),xscale)),lambdaMin) -firstRed=.true.; retcode=failed_glob -do ! loop to compute lambda that satisfies Armijo condition - x=x0+lambda*sdir - call evalFunc(dataIN,dataOUT,x,feas,fx,err=err,message=message) - fcalls=fcalls+1 - if(err/=0)then - retcode=badFunc_glob; message="f-linesearch_armijo/userErr/&"//message; return - elseif(.not.feas)then ! reduce lambda and try again - lambda=lambda*lambdaRedMax - if(lambdafx0)then ! return original point if it was the best found - x=x0; fx=fx0 - endif - exit - endif - if(firstRed)then ! * quadratic interpolation on backtrack - firstRed=.false.; lambdaTemp=-slope0*half/(fx-fx0-slope0) - else ! * cubic interpolation on subsequent backtrack - c(1:2)= (/ fx- fx0-lambda *slope0,& ! enjoy some Fortran side-tracks - fprev-fx0-lambdaPrev*slope0 /) - m(1,1:2)=(/ one/lambda**2, -one/lambdaPrev**2 /) - m(2,1:2)=(/ -lambdaPrev/lambda**2, lambda/lambdaPrev**2 /) - c=matmul(m,c)/(lambda-lambdaPrev) ! c1*L^3+c2*L^2+slope0*L+fx0 - if(c(1)==zero)then ! cubic is quadratic - lambdaTemp=-slope0*half/c(2) - else ! legitimate cubic - disc=c(2)**2-three*c(1)*slope0 ! discriminant of cubic - if(disclambdaRedMin*lambda)then ! ensure lambda is sufficiently decreased - lambdaTemp=lambda*lambdaRedMin ! to avoid stagnation - elseif(lambdaTempstepmax)then ! scale down large steps - sdir=sdir*stepmax/stepLen; stepLen=stepmax -endif -slope0=dot_product(grad0,sdir) ! initial slope -if(slope0>=zero)then - retcode=badDir_glob - x=x0;fx=fx0;gradFx=grad0 - return -endif -relLen=scaledStepLen(sdir,x0,xscale) ! scaled step length (used in termination test) -lambdaMin=stol/relLen ! minimum allowable steplength, lambda must be above noise -lambdaMin=max(minval(epsRe*max(abs(x0),xscale)/max(abs(sdir),xscale)),lambdaMin) -lambdaMax=stepMax/stepLen -firstRed=.true.; fcalls=0; gcalls=0; firstSearch=.true.; retcode=failed_glob -finalGrad=.false. -outer_loop: do ! loop to compute lambda that satisfies Wolfe conditions - x=x0+lambda*sdir - call evalFunc(dataIN,dataOUT,x,feas,fx,err=err,message=message) - fcalls=fcalls+1 - if(err/=0)then - retcode=badFunc_glob; message="f-linesearch_wolfe/userErr1/&"//message; return - elseif(.not.feas)then ! reduce lambda and try again - lambda=lambda*lambdaRedMax - if(lambda=fx0+alpha*lambda*slope0.or. & ! cond A now violated - slopeX>=beta*slope0.or. & ! cond B now satisfied - lambda>=lambdaMax) & ! ran out of lambda's - exit ! time to pop-out 10.3a.4.1.2U - enddo - endif if41 - if42: if(lambdaone.and.fx>=fx0+alpha*lambda*slope0))then - Llo=min(lambda,lambdaPrev) - Ldiff=abs(LambdaPrev-Lambda) - if(lambda=fx0+alpha*lambda*slope0)then ! 10.3a.4.2.4.6 - Ldiff=Lincr; fhi=fx - else - call getGradSlopeX() - if(err/=0)return - if(slopeX=beta*slope0.or.Ldifffx0)then ! return original point if it was the best found - x=x0; fx=fx0; gradFx=grad0 - endif - exit outer_loop - endif - if(firstRed)then ! * quadratic interpolation on backtrack - firstRed=.false. - lambdaTemp=-slope0*half/(fx-fx0-slope0) - else ! * cubic interpolation on subsequent backtrack - c(1:2)= (/ fx- fx0-lambda *slope0,& ! enjoy some Fortran side-tracks - fprev-fx0-lambdaPrev*slope0 /) - m(1,1:2)=(/ one/lambda**2, -one/lambdaPrev**2 /) - m(2,1:2)=(/ -lambdaPrev/lambda**2, lambda/lambdaPrev**2 /) - c=matmul(m,c)/(lambda-lambdaPrev) ! c1*L^3+c2*L^2+slope0*L+fx0 - if(c(1)==zero)then ! cubic is quadratic - lambdaTemp=-slope0*half/c(2) - else ! legitimate cubic - disc=c(2)**2-three*c(1)*slope0 ! discriminant of cubic - if(disclambdaRedMin*lambda)& ! ensure lambda is sufficiently decreased - lambdaTemp=lambdaRedMin*lambda ! to avoid stagnation - endif - lambdaPrev=lambda; fprev=fx ! safeguards to avoid spurious changes in lambda - if(lambdaTempstepmax)then ! scale down large steps - sdir=sdir*stepmax/stepLen; stepLen=stepmax -endif -slope0=dot_product(grad0,sdir) ! initial slope -if(slope0>=zero)then - retcode=badDir_glob;message="f-linesearch_more/badDir" - x=x0;fx=fx0;gradFx=grad0 - return -endif -relLen=scaledStepLen(sdir,x0,xscale) ! relative steplength (used in termination test) -lambdaMin=stol/relLen ! minimum allowable steplength, lambda must be above noise -lambdaMin=max(minval(epsRe*max(abs(x0),xscale)/max(abs(sdir),xscale)),lambdaMin) -lambdaMax=stepMax/stepLen ! maximum allowable steplength -Llo=zero; Flo=fx0; Glo=slope0 -Flo=Flo-fx0-alpha*slope0*Llo; Glo=Glo-alpha*slope0 -Lhi=lambdaMax; haveHi=.false.; finalGrad=.false. -fcalls=0; gcalls=0; retcode=failed_glob; useMod=.false. -finalGrad=.false. -do itsearch=1, itsearchmax -! * evaluate trial lambda - x=x0+lambda*sdir - call getGradSlopeX() ! evaluate function and directional derivative - if(err/=0)then - return - elseif(.not.feas)then ! reduce lambda and try again - Lhi=half*lambda; haveHi=.false.; lambdaMax=Lhi - lambda=max(lambda*lambdaRedMax,Llo*(one-lambdaRedUnfeas)+lambdaRedUnfeas*Lhi) - if(lambda<=lambdaMin)then ! nothing feasible in requested direction - if((useMod.and.fx>fx0).or.& - (.not.useMod.and.fx+fx0+alpha*slope0*lambda>fx0))then - x=x0;fx=fx0;gradFx=grad0 - endif - retcode=unfeas_glob; exit - endif - cycle - endif -! * check Wolfe conditions - if(fx=zero)then - useMod=.true. ! use modified algorithm from now on - Flo=Flo+fx0+alpha*slope0*Llo; Glo=Glo+alpha*slope0 ! recover lower bracket - else - fx=temp; slopeX=slopeX-alpha*slope0 - endif - endif -! * generate safeguarded trial value -! write(*,*)"fx=",fx,"flo=",flo,"glo=",glo,"slopeX=",slopeX - if(fx>Flo)then ! ** case 1 (interpolation) - call quadFitStation(xa=Llo,xb=lambda,fA=Flo,fB=fx,dfA=Glo,& - xs=Lquad,ts=typeQ1,err=err,message=message) - if(err/=0)then - typeQ1=10;err=0 -! retcode=bugFail;message="f-linesearch_more/bug?/A/&"//message -! return - endif - call cubiqFitStation(xa=Llo,xb=lambda,fA=Flo,fB=fx,dfA=Glo,dfB=slopeX,& - xs1=Lcube,xs2=LcubeMax,ts1=typeC1,ts2=typeC2,& - err=err,message=message) - if(err/=0)then - typeC1=10;err=0 -! retcode=bugFail;message="f-linesearch_more/bug?/B/&"//message -! return - endif - if((typeQ1==-1.and.typeC1==-1.and.abs(Lcube-Llo)=abs(Lquad2-lambda)).or.& - (typeQ2/=-1.and.typeC1==-1))then - LambdaTemp=Lcube - elseif(typeQ2==-1)then - LambdaTemp=Lquad2 - else - LambdaTemp=average(n1=Llo,n2=Lhi) - endif - elseif(fx<=Flo.and.slopeX*Glo>=zero.and.abs(slopeX)<=abs(Glo))then - ! ** case 3 (extrapolation) - call quadFitStation(xa=Llo,xb=lambda,fA=Flo,dfB=slopeX,dfA=Glo,& - xs=Lquad2,ts=typeQ2,err=err,message=message) - if(err/=0)then - typeQ2=10;err=0 -! retcode=bugFail;message="f-linesearch_more/bug?/E/&"//message -! return - endif - call cubiqFitStation(xa=Llo,xb=lambda,fA=Flo,fB=fx,dfA=Glo,dfB=slopeX,& - xs1=Lcube,xs2=LcubeMax,ts1=typeC1,ts2=typeC2,& - err=err,message=message) -! - in this case err/=0 often indicates convergence and roundoff error - if(err/=0)then - typeC1=10;err=0 -! retcode=bugFail;message="f-linesearch_more/bug?/F/&"//message -! return - endif - if(typeC1==-1.and.Lcube>lambda)then - if(abs(Lcube-lambda)=lambda.and.Lambda>=lambdaMax)then ! maximum step taken - if(.not.useMod)then ! recover function value - fx=fx+fx0+alpha*slope0*Llo - endif - retcode=success_glob - exit - elseif(LambdaTemp>lambdaMax.and.LambdaLlo)then ! employ safeguards - LambdaTemp=min(lambda+delSafe*(Lhi-lambda),lambdaTemp) - else - LambdaTemp=max(lambda+delSafe*(Lhi-lambda),lambdaTemp) - endif - else ! ** case 4 (interpolation) - if(haveHi)then - call cubiqFitStation(xa=Lhi,xb=lambda,fA=Fhi,fB=fx,dfA=Ghi,dfB=slopeX,& - xs1=Lcube,xs2=LcubeMax,ts1=typeC1,ts2=typeC2,& - err=err,message=message) - if(err/=0)then - typeC1=10;err=0 -! retcode=bugFail;message="f-linesearch_more/bug?/G/&"//message -! return - endif - if(typeC1==-1)then ! cubic minimum "safely" computed - LambdaTemp=Lcube - else - LambdaTemp=average(n1=Llo,n2=Lhi) ! safeguard degeneration - endif - else - LambdaTemp=min(lambda*lambdaUpFac,max(Lhi,Llo)) ! Lhi and Llo may not be ordered - endif - endif -! * update brackets using "modified updating algorithm", page 297 - if(fx>Flo)then - Lhi=lambda; Fhi=fx; Ghi=slopeX; haveHi=.true. - else - if(slopeX*(Llo-lambda)Lhi)then ! safeguard against bugs just in case. -! retcode=bugFail;message="f-linesearch_more/bug?/lambdaOutOfBrackets" -! return -! Lambda=average(n1=Llo,n2=Lhi) -! endif -enddo -if(itsearch>=itsearchmax+1)then - x=x0; fx=fx0; gradFx=grad0; sdir=zero; fredAct=zero - retcode=failed_glob -else ! * some additional postcalculations - sdir=x-x0 ! get shift vector (must equal sdir*lambda) - fredAct=fx0-fx ! actual reduction in function value - if(gmethBundle%useDirDer)then ! final call to get full gradient - finalGrad=.true.; call getGradSlopeX() - endif -endif -! End procedure here -contains -!-- -subroutine getGradSlopeX() ! macro to get directional derivative -use utilities_dmsl_kit,only:getFDCDgrad,getCDgrad,getHxFromRelHx,getFDdirDer -implicit none -! dummies -! locals -! local registered settings -integer(mik),parameter::scal_smeth=0,imax_smeth=1,ave_smeth=2,wei_smeth=3 -! Start procedure here -selectcase(gmethBundle%gmeth_now) -case(user_meth) ! analytical derivatives available - call evalFunc(dataIN,dataOUT,x,feas,fx,gradFx,err=err,message=message);fcalls=fcalls+1;gcalls=gcalls+1 - if(err/=0)then - message="f-linesearch_wolfe/getGradSlopeX/userErrA/&"//message - retcode=badFunc_glob; return - elseif(.not.feas)then - message="f-linesearch_wolfe/getGradSlopeX/userUnfeasA/&"//message; return - endif - slopeX=dot_product(gradFx,sdir) ! new slope -case(fd_gmeth) ! forward difference gradient - if(.not.finalGrad)then - call evalFunc(dataIN,dataOUT,x,feas,fx,err=err,message=message); fcalls=fcalls+1 - if(err/=0)then - retcode=badFunc_glob; message="f-linesearch_more/getGradSlopeX/userErrFD/&"//message; return - elseif(.not.feas)then ! do not bother with gradient if unfeasible - message="f-linesearch_wolfe/getGradSlopeX/userUnfeasFD/&"//message; return - endif - endif - if(.not.finalGrad.and.gmethBundle%useDirDer)then ! use cheap directional derivative - call getFDdirDer(evalFunc,dataIN,dataOUT,x=x,p=sdir,fx=fx,xscale=xscale,fscale=fscale,& - epsF=objFuncBundle%epsF,& - hx=getHxFromRelHx(gmethBundle%hx,x,xscale,gmethBundle%FDscale),& - useHxDef=gmethBundle%useHxDef,& - dmeth=merge(useFDCDhybrid,fd_gmeth,gmethBundle%hybridFDCD),& - dFDCD=gmethBundle%tolGradFDCD,& - smeth=scal_smeth,normalize=.false.,& - fdDirDer=slopeX,fcalls=addFcalls,err=err,message=message) - else - call getFDCDgrad(evalFunc,dataIN,dataOUT,x,fx,xscale,fscale,objFuncBundle%epsF,& - getHxFromRelHx(gmethBundle%hx,x,xscale,gmethBundle%FDscale),& - gmethBundle%useHxDef,& - merge(useFDCDhybrid,fd_gmeth,gmethBundle%hybridFDCD),gmethBundle%tolGradFDCD,& - gradFx,addFcalls,err,message) - slopeX=dot_product(gradFx,sdir) - endif - fcalls=fcalls+addFcalls -case(cd_gmeth) ! central difference gradient - if(.not.finalGrad)then - call evalFunc(dataIN,dataOUT,x,feas,fx,err=err,message=message); fcalls=fcalls+1 - if(err/=0)then - retcode=badFunc_glob; message="f-linesearch_more/getGradSlopeX/userErrCD/&"//message; return - elseif(.not.feas)then ! do not bother with gradient if unfeasible - message="f-linesearch_wolfe/getGradSlopeX/userUnfeasCD/&"//message; return - endif - endif - if(.not.finalGrad.and.gmethBundle%useDirDer)then ! use cheap directional derivative - call getFDdirDer(evalFunc,dataIN,dataOUT,x=x,p=sdir,fx=fx,xscale=xscale,fscale=fscale,& - epsF=objFuncBundle%epsF,& - hx=getHxFromRelHx(gmethBundle%hx,x,xscale,gmethBundle%FDscale),& - useHxDef=gmethBundle%useHxDef,& - dmeth=merge(useFDCDhybrid,fd_gmeth,gmethBundle%hybridFDCD),& - dFDCD=gmethBundle%tolGradFDCD,& - smeth=scal_smeth,normalize=.false.,& - fdDirDer=slopeX,fcalls=addFcalls,err=err,message=message) - else - call getCDgrad(evalFunc,dataIN,dataOUT,x,fx,xscale,objFuncBundle%epsF,& - getHxFromRelHx(gmethBundle%hx,x,xscale,gmethBundle%FDscale),& - gmethBundle%useHxDef,gradFx,addFcalls,err,message) - slopeX=dot_product(gradFx,sdir) - endif - fcalls=fcalls+addFcalls -endselect -if(err/=0)then - retcode=unfeas_glob; message="f-linesearch_more/getGradSlopeX/&"//message -endif -! End procedure here -endsubroutine getGradSlopeX -!-- -endsubroutine linesearch_more -!---------------------------------------------------- -subroutine linesearch_fletcher(evalFunc,dataIN,dataOUT,x0,fx0,grad0,gmethBundle,objFuncBundle,& - sdir,xscale,fscale,stol,alpha,beta,stepmax,x,fx,gradFx,& - fredAct,lambda,fcalls,gcalls,retcode,message) -! Purpose: Linesearch using the strong Wolfe conditions A (alpha) and B (beta). -! Condition A (sufficient decrease condition) -! Condition B (absolute gradient condition) -! sdir is local search direction (typically Newton-derived). -! Programmer: Dmitri Kavetski -! Ref: * Fletcher,R.(1996) Practical Methods of Optimization,2nd Ed,Wiley. -! * Nocedal,J. and Wright,S.J.(2000) Numerical Optimization, Springer. -! * More, J.J. and Thuente, D.J. (1994) Line search algorithms with -! guaranteed sufficient decrease, ACM Transactions on Mathematical -! software, vol. 20(3), p.286-307. -use types_dmsl_kit,only:data_ricz_type -use utilities_dmsl_kit,only:zero,one,two,half -implicit none -! dummies -type(data_ricz_type),intent(in),optional::dataIN -type(data_ricz_type),intent(inout),optional::dataOUT -real(mrk),intent(in)::x0(:),fx0,grad0(:),xscale(:),fscale,stepmax -real(mrk),intent(in)::stol,alpha,beta -type(gmethBundle_type),intent(in)::gmethBundle -type(objFuncBundle_type),intent(in)::objFuncBundle -real(mrk),intent(inout)::lambda,sdir(:) -real(mrk),intent(out)::x(:),fx,gradFx(:),fredAct -integer(mik),intent(out)::fcalls,gcalls,retcode -character(*),intent(out)::message -! user-provided function -interface - subroutine evalFunc(dataIN,dataOUT,x,feas,fx,gradFx,hessFx,err,message) - use kinds_dmsl_kit - use types_dmsl_kit,only:data_ricz_type - implicit none - type(data_ricz_type),intent(in),optional::dataIN - type(data_ricz_type),intent(inout),optional::dataOUT - real(mrk),intent(in)::x(:) - logical(mlk),intent(out)::feas - real(mrk),intent(out),optional::fx,gradFx(:),hessFx(:,:) - integer(mik),intent(out)::err - character(*),intent(out)::message - endsubroutine evalfunc -endinterface -! local parameters -real(mrk),parameter::lambdaRedMax=0.1_mrk,lambdaRedUnfeas=0.2_mrk -real(mrk),parameter::tau1=9._mrk,tau2def=0.1_mrk,tau3=half -real(mrk),parameter::lambdaUpCoarse=2._mrk,closeToMax=0.99 -real(mrk),parameter::safeEps=10._mrk -integer(mik)::status -integer(mik),parameter::keepgoing=0,dontbother=1 -! locals -real(mrk)::slope0,stepLen,relLen,lambdaMin,lambdaMax,tau2 -real(mrk)::slopeX,lambdaTemp,lambdaPrev,fprev,Gprev -real(mrk)::Llo,Lhi,flo,fhi,Glo,Ghi -integer(mik)::err,addFcalls -logical(mlk)::feas,ipp,finalGrad -! Start procedure here -err=0; message="linesearch_fletcher/ok"; stepLen=getStepLen2(sdir,xscale) -if(stepLen>stepmax)then ! scale down large steps - sdir=sdir*stepmax/stepLen - stepLen=stepmax -endif -slope0=dot_product(grad0,sdir) ! initial slope -if(slope0>=zero)then - retcode=badDir_glob - x=x0;fx=fx0;gradFx=grad0 - return -endif -relLen=scaledStepLen(sdir,x0,xscale) ! relative steplength (used in termination test) -lambdaMin=stol/relLen ! minimum allowable steplength, lambda must be above noise -lambdaMin=max(minval(epsRe*max(abs(x0),xscale)/max(abs(sdir),xscale)),lambdaMin) -lambdaMax=stepMax/stepLen ! maximum allowable steplength -lambdaPrev=zero; fprev=fx0; Gprev=slope0; Llo=zero; Flo=fx0; Glo=slope0; Lhi=lambdaMax -fcalls=0;gcalls=0; retcode=failed_glob; status=keepgoing; ipp=.false. -finalGrad=.false. -! ** bracket lambda that satisfies the strong Wolfe conditions -do - x=x0+lambda*sdir - call getGradSlopeX() - if(err/=0)then - return - elseif(.not.feas)then ! reduce lambda and try again - Lhi=half*lambda - lambda=max(lambda*lambdaRedMax,& - lambdaPrev*(one-lambdaRedUnfeas)+lambdaRedUnfeas*Lhi) - if(lambda=fx0+alpha*lambda*slope0.or.(fx>=fprev.and.ipp))then ! function increasing - Llo=lambdaPrev; flo=fprev; Glo=Gprev; Lhi=lambda; fhi=fx; Ghi=slopeX - exit - endif - if(.not.ipp)ipp=.true. - if(abs(slopeX)<=-beta*slope0)then ! strong Wolfe conditions satisfied - status=dontbother; retcode=success_glob; exit - elseif(slopeX>=zero)then ! positive slope (function increasing) - Llo=lambda; flo=fx; Glo=slopeX; Lhi=lambdaPrev; fhi=fprev; Ghi=Gprev - exit - elseif(lambda>=lambdaMax)then ! maximum step not big enough, it seems - status=dontbother; retcode=success_glob; exit - endif - lambdaTemp=lambda*lambdaUpCoarse ! function still decreasing: increase step ... - lambdaTemp=max(lambdaTemp,two*lambda-lambdaPrev) ! ... using safeguards - lambdaTemp=min(lambdaTemp,lambda+tau1*(lambda-lambdaPrev)) - if(lambdaTemp>=closeToMax*Lhi)then ! very close to max step - status=dontbother; retcode=success_glob; exit - endif - lambdaprev=lambda; fprev=fx ! keep previous evaluation - lambda=lambdatemp ! and update steplength - if(lambdafx0)then ! return original point if it was the best found - x=x0; fx=fx0; gradFx=grad0 - endif - exit - elseif(lambda>lambdaMax)then ! flag large steps - lambda=lambdaMax; Lhi=lambdaMax - endif -enddo -! "zoom", or bracket contraction -tau2=min(tau2def,beta) -do - if(status==dontbother)exit - lambdaprev=lambda; fprev=fx; Gprev=slopeX - lambdaTemp=half*(Llo+Lhi) ! bisection - lambdaTemp=max(lambdaTemp,Llo+tau2*(Lhi-Llo)) ! use safeguards - lambda=min(lambdaTemp,Lhi-tau3*(Lhi-Llo)) -! evaluate function - x=x0+lambda*sdir - call getGradSlopeX() - if(err/=0)then - return - elseif(.not.feas)then ! unfeasible inside bracket: too hard basket - retcode=unfeas_glob - x=x0; fx=fx0; gradFx=grad0 - exit - endif - if(fx>=fx0+alpha*lambda*slope0.or.fx>=Flo)then ! function increasing - Lhi=lambda; fhi=fx - else - if(abs(slopeX)<=-beta*slope0)then ! satisfaction of strong gradient condition - retcode=success_glob; exit - elseif(slopeX*(Llo-lambda)fx0)then ! restore original point if all trials worse... - x=x0;fx=fx0;gradFx=grad0 - endif - retcode=failed_glob; exit ! bracket collapsed to initial point ... - endif -enddo -sdir=x-x0 ! get shift vector (must equal sdir*lambda) -fredAct=fx0-fx ! actual reduction in function value -if(gmethBundle%useDirDer)then ! final call to get full gradient - finalGrad=.true.; call getGradSlopeX() -endif -! End procedure here -contains -!-- -subroutine getGradSlopeX() ! macro to get directional derivative -use utilities_dmsl_kit,only:getFDCDgrad,getCDgrad,getHxFromRelHx,getFDdirDer -implicit none -! dummies -! locals -! local registered settings -integer(mik),parameter::scal_smeth=0,imax_smeth=1,ave_smeth=2,wei_smeth=3 -! Start procedure here -selectcase(gmethBundle%gmeth_now) -case(user_meth) ! analytical derivatives available - call evalFunc(dataIN,dataOUT,x,feas,fx,gradFx,err=err,message=message);fcalls=fcalls+1;gcalls=gcalls+1 - if(err/=0)then - message="f-linesearch_fletcher/getGradSlopeX/userErrA/&"//message - retcode=badFunc_glob; return - elseif(.not.feas)then - message="f-linesearch_fletcher/getGradSlopeX/userUnfeas/&"//message; return - endif - slopeX=dot_product(gradFx,sdir) ! new slope -case(fd_gmeth) ! forward difference gradient - if(.not.finalGrad)then - call evalFunc(dataIN,dataOUT,x,feas,fx,err=err,message=message); fcalls=fcalls+1 - if(err/=0)then - message="f-linesearch_fletcher/getGradSlopeX/userErrFD/&"//message - retcode=badFunc_glob; return - elseif(.not.feas)then - message="f-linesearch_fletcher/getGradSlopeX/userUnfeasFD/&"//message; return - endif - endif - if(.not.finalGrad.and.gmethBundle%useDirDer)then ! use cheap directional derivative - call getFDdirDer(evalFunc,dataIN,dataOUT,x=x,p=sdir,fx=fx,xscale=xscale,fscale=fscale,& - epsF=objFuncBundle%epsF,& - hx=getHxFromRelHx(gmethBundle%hx,x,xscale,gmethBundle%FDscale),& - useHxDef=gmethBundle%useHxDef,& - dmeth=merge(useFDCDhybrid,fd_gmeth,gmethBundle%hybridFDCD),& - dFDCD=gmethBundle%tolGradFDCD,& - smeth=scal_smeth,normalize=.false.,& - fdDirDer=slopeX,fcalls=addFcalls,err=err,message=message) - else - call getFDCDgrad(evalFunc,dataIN,dataOUT,x,fx,xscale,fscale,objFuncBundle%epsF,& - getHxFromRelHx(gmethBundle%hx,x,xscale,gmethBundle%FDscale),& - gmethBundle%useHxDef,& - merge(useFDCDhybrid,fd_gmeth,gmethBundle%hybridFDCD),gmethBundle%tolGradFDCD,& - gradFx,addFcalls,err,message) - slopeX=dot_product(gradFx,sdir) - endif - fcalls=fcalls+addFcalls -case(cd_gmeth) ! central difference gradient - if(.not.finalGrad)then - call evalFunc(dataIN,dataOUT,x,feas,fx,err=err,message=message); fcalls=fcalls+1 - if(err/=0)then - message="f-linesearch_fletcher/getGradSlopeX/userErrCD/&"//message - retcode=badFunc_glob; return - elseif(.not.feas)then - message="f-linesearch_fletcher/getGradSlopeX/userUnfeasCD/&"//message; return - endif - endif - if(.not.finalGrad.and.gmethBundle%useDirDer)then ! use cheap directional derivative - call getFDdirDer(evalFunc,dataIN,dataOUT,x=x,p=sdir,fx=fx,xscale=xscale,fscale=fscale,& - epsF=objFuncBundle%epsF,& - hx=getHxFromRelHx(gmethBundle%hx,x,xscale,gmethBundle%FDscale),& - useHxDef=gmethBundle%useHxDef,& - dmeth=merge(useFDCDhybrid,fd_gmeth,gmethBundle%hybridFDCD),& - dFDCD=gmethBundle%tolGradFDCD,& - smeth=scal_smeth,normalize=.false.,& - fdDirDer=slopeX,fcalls=addFcalls,err=err,message=message) - else - call getCDgrad(evalFunc,dataIN,dataOUT,x,fx,xscale,objFuncBundle%epsF,& - getHxFromRelHx(gmethBundle%hx,x,xscale,gmethBundle%FDscale),& - gmethBundle%useHxDef,gradFx,addFcalls,err,message) - slopeX=dot_product(gradFx,sdir) - endif - fcalls=fcalls+addFcalls -endselect -if(err/=0)then - retcode=unfeas_glob; message="f-linesearch_fletcher/getGradSlopeX/&"//message -endif -! End procedure here -endsubroutine getGradSlopeX -!-- -endsubroutine linesearch_fletcher -!---------------------------------------------------- -subroutine brentmin(evalFunc,dataIN,dataOUT,linmin_ometh,xopt,fold,sdir,stpmax,stol,Ltol,itmax,xscale,& - fopt,lambda,fcalls,gcalls,retcode,message) -! Purpose: Brent line minimisation: search from xopt in direction sdir. -use types_dmsl_kit,only:data_ricz_type -use utilities_dmsl_kit,only:zero,one,two,assertEq -use numerix_dmsl_kit,only:linmin -implicit none -! Dummies -type(data_ricz_type),intent(in),optional::dataIN -type(data_ricz_type),intent(inout),optional::dataOUT -real(mrk),intent(inout)::xopt(:),sdir(:),lambda -real(mrk),intent(in)::fold -integer(mik),intent(in)::linmin_ometh -real(mrk),intent(in)::stpmax,stol,Ltol,xscale(:) -integer(mik),intent(in)::itmax -real(mrk),intent(inout)::fopt -integer(mik),intent(out)::fcalls,gcalls -integer(mik),intent(out)::retcode -character(*),intent(out)::message -interface - subroutine evalFunc(dataIN,dataOUT,x,feas,fx,gradFx,hessFx,err,message) - use kinds_dmsl_kit - use types_dmsl_kit,only:data_ricz_type - implicit none - type(data_ricz_type),intent(in),optional::dataIN - type(data_ricz_type),intent(inout),optional::dataOUT - real(mrk),intent(in)::x(:) - logical(mlk),intent(out)::feas - real(mrk),intent(out),optional::fx,gradFx(:),hessFx(:,:) - integer(mik),intent(out)::err - character(*),intent(out)::message - endsubroutine evalfunc -endinterface -! Locals -integer(mik)::err,ndum -real(mrk)::lambdaMin,lambdaMin1,lambdaMin2,relLen -logical(mlk),parameter::useFold=.true. -logical(mlk)::ok -! Start procedure here -call assertEq(size(xopt),size(sdir),size(xscale),ok,ndum) -if(ok)then - retcode=success_glob; message="brentmin/ok" -else - retcode=bugFail; message="f-brentmin/dimError"; return -endif -relLen=scaledStepLen(sdir,xopt,xscale) ! relative steplength (used in termination test) -if(relLen<=stol)then - retcode=success_glob; message="w-brentmin/zeroLen[sdir<=stol]" - fopt=fold; fcalls=0; gcalls=0; return -endif -lambdaMin1=stol/relLen ! minimum allowable steplength based on convergence test -lambdaMin2=epsRe*minval(max(abs(xopt),xscale)/max(abs(sdir),xscale)) ! lambda must be above noise -lambdaMin=max(lambdaMin1,lambdaMin2); fopt=fold -call linmin(evalFunc,dataIN,dataOUT,linmin_ometh,xopt,sdir,-stpmax,+stpmax,Ltol,xscale,& - itmax,lambda,fopt,useFold,fcalls,gcalls,err,message) -if(err/=0)then - retcode=failed_glob; message="f-brentmin/&"//message; return -elseif(lambdatrustBundle%niter_tr)then - err=failed_glob;message="trustDriver/tooManyBadTrustTries" - exit - elseif(itot>itotMax)then - err=bugFail;message="f-trustDriver/stuckInLoop?itotMaxExceeded" - return - endif -! 1. solve trust region subproblem - if(present(activeSet))then ! * bound-contrained optimisation - active=activeSet==freeVar_as - nact=count(active) - else - nact=ndim - endif - if(nact==0)then ! * all variables fixed - dx=zero;redExp=zero;logdetTemp=zero;condestTemp=zero;nchol=zero - err=bugFail;message="f-trustDriver/allVarsFixed" - return - endif - selectcase(hmeth) - case(bfgsFac_hmeth) ! ** Factored Hessian (BFGS only) - if(imeth==trustEx_imeth)then ! - hook step unsupported - err=bugFail;message="f-trustDriver/invalidIN:factoredHookstep" - return - elseif(trustBundle%pivotCholTrust)then ! - pivoting unsupported - err=bugFail;message="f-trustDriver/invalidIN:pivotedFactoredDog" - return - elseif(xscaleHmeth==xscaleH_hdiag)then ! - diagonal Hessian scaling unsupported - err=bugFail;message="f-trustDriver/invalidIN:factoredDog:xscaleH=hdiag" - return - endif - redoHess=(itot==1.or.didGradNewHess) ! scale (factored) scratch Hessian - if(redoHess)then ! (currently didGradNewHess===false for BFGS) - call getXscaleH(xscaleHmeth,hess0,xscale,fscale,xscaleH) - if(nact==ndim)then ! - effectively unconstrained - avar=arthsi(ndim) - call xscaleNewt(xscaleH,L0=hess0,LS=hessScaled,Ld0=Ld0,LdS=LdScaled) - else ! - active constraints present: need to muck around - avar=pack(arthsi(ndim),active) ! index of active variables - call terminateRowColMat(hess0,hessScaled(1:nact,1:nact),active,lerr,lmessage) - LdScaled=pack(Ld0,activeSet==freeVar_as) - call xscaleNewt(xscaleH(avar(1:nact)),& - LS=hessScaled(1:nact,1:nact),LdS=LdScaled(1:nact)) - endif - call xscaleNewt(xscaleH(avar(1:nact)),& - grad0=grad0(avar(1:nact)),gradS=gradScaled(1:nact)) - dog%haveFac=.true. ! factored (BFGS) Hessian available immediately - dog%posDef=.true. ! and is always positive definite - endif - case default ! ** Unfactored Hessians (all others) - redoHess=(itot==1.or.didGradNewHess) ! scale Hessian on first iteration or if refreshed - if(redoHess)then ! reconstruct active scaled Hessian - call getXscaleH(xscaleHmeth,hess0,xscale,fscale,xscaleH) - if(nact==ndim)then ! - effectively unconstrained - avar=arthsi(ndim) - call xscaleNewt(xscaleH,hess0=hess0,hessS=hessScaled) - else ! - active constraints present: need to muck around - avar=pack(arthsi(ndim),active) ! index of active variables - call terminateRowColMat(hess0,hessScaled(1:nact,1:nact),active,lerr,lmessage) - call xscaleNewt(xscaleH(avar(1:nact)),hessS=hessScaled(1:nact,1:nact)) - endif - call xscaleNewt(xscaleH(avar(1:nact)),& - grad0=grad0(avar(1:nact)),gradS=gradScaled(1:nact)) - dog=dogNew;hook=hookNew ! reset all dogs and hooks since Hessian is new - endif - selectcase(imeth) - case(trustEx_imeth) ! * Near-exact hook step trust only handles unfactored Hessians - call solveTrustHook(B=hessScaled(1:nact,1:nact),grad=gradScaled(1:nact),& ! data - doPivot=trustBundle%pivotCholTrust,trustRad=trustRad,& ! pivoting - ncholMax=trustBundle%ncholMax_tr,lambda=hook%lambdaPD,& ! trust settings - psol=dx(1:nact),pnorm=stepLen,stepResult=stepResult,& ! hookstep and its length - logdet=logdetTemp,condest=condestTemp,Einf=EinfTemp,& ! properties of Hessian - firstHook=redoHess,newtStep=newtStep(1:nact),newtLen=newtLen,& ! full Newton step on first call - negStep=negStep(1:nact),negLen=hook%negLen,& - nchol=nchol,err=lerr,message=lmessage) - endselect - endselect -! - if dogleg requested compute it from scaled factored/unfactored Hessians - selectcase(imeth) - case(dogLeg_imeth) ! * Dogleg trust: factored/unfactored input Hessian - call solveGeneralDogTrust(& - B=hessScaled(1:nact,1:nact),Ld=LdScaled(1:nact),& - indx=indx(1:nact),grad=gradScaled(1:nact),& - trustRad=trustRad,dogNewtBias=trustBundle%dogNewtBias,& - haveFac=dog%haveFac,haveNewt=dog%haveNewt,haveNeg=dog%haveNeg,& - doPivot=trustBundle%pivotCholTrust,hessFacBundle=hessFacBundle,& - haveGBG=dog%haveGBG,useL=useL,posDef=dog%posDef,& - newtStep=newtStep(1:nact),newtLen=newtLen,& - negEigen=EinfTemp,negStep=negStep(1:nact),& - normG=dog%normG,gBg=dog%gBg,absGdotNewt=dog%absGdotNewt,& - logdet=logdetTemp,condest=condestTemp,Einf=EinfTemp,& - psol=dx(1:nact),pLen=stepLen,stepResult=stepResult,& - nchol=nchol,err=lerr,message=lmessage) - case(trustEx_imeth) ! (-) Hook step already computed - case default - err=bugFail;message="trustDriver/BUG/unknownIMETH" - return - endselect -! - basic check of trust solver - selectcase(lerr) - case(okAlg) ! - sucesful completion - ncholstats(1)=ncholstats(1)+nchol ! total number of Cholesky factorizations - ncholstats(2)=ncholstats(2)+1 ! number of "minor" trust region iterations - call unXscaleNewt(xscaleH(avar(1:nact)),p0=dx(1:nact)) ! unscale trust step - if(nactstepLen*trustBundle%trustOstepMax_tr)then - trustRad=stepLen*trustBundle%trustOstepMax_tr - if(expandingTrust)reducedTrust=.true. - endif - case(onTrustBound,hardCase) ! keep trust region intact (for now...) - case default - err=bugFail;message="trustDriver/BUG/unknownStepRes/&"//lmessage - return - endselect -! - check for bound violation - if(boundedSearch)then ! may need 2 truncate step when colliding with bounds - call checkStepBounds(x0,xLo,xHi,activeset,dx,hitBound=hitBound) - elseif(present(xLo).or.present(xHi).or.present(activeset))then - err=10;message="trustDriver/inError/bug/bothBoundsMustBePresent";return - endif -! - safeguarded scaled step length and expected reduction in quadratic model - stepLen=getStepLen2(dx,xscaleH) - redExp=-quadDf(dx=dx,dfdx=grad0,d2fdx2=hess0,typeH=quadTypeH) - if(firstTrustIter)then -! save original expected function reduction given initial trust: -! this is used when assessing convergence of the globalisation strategy - fredExp=redExp - endif - if(firstTrustIter)then ! store Hessian properties (later values will be affected by - logdet=logdetTemp;condest=condestTemp;Einf=EinfTemp ! the trust region solution) - endif - firstTrustIter=.false. -! bounds grossly interfering with trust expansion: dont bother checking new point - if(expandingTrust.and.hitBound.and.stepLen<=trustBundle%boundFrac*stepLenB4Big)then - x=xtry; fx=fxtry; gradx=gradTry; dx=xtry-x0 ! fall back unto previous trust iteration - err=success_glob; message="trustDriver/ok/expansionFailed(bounds)" - exit - endif -! 2. Accept / Reject solution and Update trust region - if(nact==0)then ! all vars fixed - x=x0; fx=fx0; redRatio=zero; addFcalls=0 - err=success_glob; message="w-trustDriver/ok/&"//lmessage - exit - endif - call updateTrust(evalFunc,dataIN,dataOUT,x0,fx0,grad0,dx,stepLen,stepResult,redExp,& - xscale,fscale,reducedTrust,objFuncBundle,trustBundle,& - x,fx,trustRad,redRatio,addFcalls,lerr,lmessage) - fcalls=fcalls+addFcalls - selectcase(lerr) - case(suceed_tr) ! succesful iteration - call checkSR1updt() - err=success_glob;message="trustDriver/ok/&"//lmessage - exit - case(goBig_tr) ! succesful iteration, but re-take step with larger trust - call checkSR1updt() - xtry=x; fxtry=fx; gradTry=gradx; expandingTrust=.true. - stepLenB4Big=stepLen ! steplength before go-big step - i=i-1 ! do not count trust expansion as a trust "try" since it is a good thing! - case(collapsed_tr) ! collapsed trust region - if(redRatio<=zero)then ! reset current point of trial point worse than current - x=x0; fx=fx0; gradx=grad0; dx=zero - endif - err=failed_glob;message="trustDriver/&"//lmessage - exit - case(fconExpObs_tr) ! exp/obs reduction within function precision - didGradNewHess=.false.;err=success_glob;message="trustDriver/&"//lmessage - if(redRatio<=zero)then ! reset current point of trial point worse than current - x=x0; fx=fx0; gradx=grad0; dx=zero - endif - exit - case(blown_tr) ! trust region blown - call checkSR1updt() - err=success_glob;message="trustDriver/&"//lmessage - exit - case(unfeas_tr) ! unfeasible iteration: keep going... - if(expandingTrust)then ! ...fall back on pre-expanded results - x=xtry; fx=fxtry; gradx=gradTry; dx=xtry-x0 ! and do not update SR1 Hessian - err=success_glob; message="trustDriver/ok/expansionFailed(unfeas)" - exit - else - dx=zero; err=unfeas_glob - endif - case(failed_tr) ! failed iteration: - call checkSR1updt() - if(expandingTrust)then ! ...fall back on pre-expanded results - x=xtry; fx=fxtry; gradx=gradTry; dx=xtry-x0 - err=success_glob; message="trustDriver/ok/expansionFailed(normal)" - exit - else ! ...or keep going with reduced trust - dx=zero;reducedTrust=.true. ! (preventing agressive go-big steps) - if(redRatio<=zero)then ! reset current point if trial point worse than current - x=x0; fx=fx0; gradx=grad0; dx=zero - endif - err=failed_glob; message="trustDriver/trustFailed/&"//lmessage - endif - case(dxTiny_tr) ! negligible step suggested: exit with ... - didGradNewHess=.false.;message=trim(message)//"/&"//lmessage ! ... previous code (either unfeas or failed) - exit - case(expRedNonP_tr) ! expected reduction nonpositive: error? - selectcase(stepResult) - case(hardCase) ! hard case a bit dubious: force "steeper-descent" move - if(expandingTrust)then ! ...fall back on pre-expanded results - x=xtry; fx=fxtry; gradx=gradTry; dx=xtry-x0 - err=success_glob; message="trustDriver/ok/expansionFailed(HCfail)" - exit - else ! reset current point if trial point worse than current - reducedTrust=.true. ! (prevent agressive go-big steps) - dx=zero; x=x0; fx=fx0; gradx=grad0; dx=zero - err=failed_glob - trustRad=trustRad*trustBundle%radDown_tr - endif -! if(present(activeSet).and.& ! hard-case possibly interfering: try reducing trust -! stepResult==hardCase)then ! which forces a more "steepest-descent" move -! err=failed_glob -! trustRad=trustRad*trustBundle%radDown_tr - case default - err=bugFail; message="trustDriver/BUG?/&"//lmessage - dx=zero - exit - endselect - case default - dx=zero; err=bugFail -! err=failed_glob - write(message,'(a,i0,a)')"trustDriver/unknown/[lerr=",lerr,"]/&"//trim(lmessage) - exit - endselect -enddo -fredAct=fx0-fx ! actual reduction in function value -! End procedure here -contains -!---- -subroutine checkSR1updt() ! macro to check internal SR1 update -use utilities_dmsl_kit,only:getHxFromRelHx,getFDCDgrad,getCDgrad -implicit none -! locals -logical(mlk)::feas -integer(mik)::jerr -! Start procedure here -feas=.true.; jerr=0 -didGradNewHess=hmeth==SR1unFac_hmeth.and.& ! SR1 quasi-Hessian - (maxSR1update.or.& ! - maximal-frequency updating requested or model way off - ((fx0-fx)-redExp)1 biases faster L increase -real(mrk),parameter::sigma1=0.1_mrk,sigma2=0._mrk -logical(mlk),parameter::normW=.false. -real(mrk),parameter::cholTau=zero,cholTauBar=zero,cholMu=zero ! robust Cholesky -integer(mik),parameter::largeNorm=1 ! method for eigenvector estimation -logical(mlk),parameter::allowNewtReuse=.true.,allowNegReuse=.false. -real(mrk),parameter::sigma3reuseHard=0.3 -logical(mlk),parameter::usePivotDef=.false.,allowPivot=.true. -logical(mlk)::usePivot -! Start procedure here -! 0. Initial brackets for lambda -usePivot=merge(doPivot,usePivotDef,allowPivot) -if(trustRad<=zero)then ! this caused DK a lot of grief once... - err=failAlg;psol=zero;Pnorm=zero;stepResult=failed2Solve;return -elseif(.not.firstHook)then ! internal trust iteration: -! check if computed results can be reused to avoid redundant factorizations. -! this option is not fully tested unsupported - if(allowNewtReuse.and.stepResult==onTrustBound.and.newtLen<(one+sigma1)*trustRad)then -! * use available Newton step on this expansion since it is already known to be inside trust - if(newtLen>zero)then - stepResult=insideTrust;psol=newtStep;Pnorm=newtLen;nchol=0 - err=0;message="solveTrustHook/reusedNewtonStep" - return - endif - elseif(allowNegReuse.and.stepResult==hardCase.and.& - (negLen<(one+sigma1)*trustRad.or.negLen>sigma3reuseHard*trustRad))then -! * previous trust iteration was the "hard case" and now the trust has now -! (a) increased. Simply upscale negative curvature since this step would have been -! even "harder" and results are fairly predictable: a multiple of the negative -! curvature eigenvector -! (b) decreased not too much. Then downscale negative curvature direction since -! the current direction is probably reasonable. - if(negLen>zero)then - stepResult=hardCase;psol=(trustRad/negLen)*negStep;Pnorm=trustRad;nchol=0 - err=0;message="solveTrustHook/reusedUpscaledNegStep" - return - else -! - this should never occur and suggests a bug, since the hard case on the previous -! iteration must have used a scaled negative curvature step... - err=200;message="f-solveTrustHook/BUG/(negLen<0)" - return - endif - endif -endif -call flip_UtoL(B) ! ugly but currently necessary to compute Bnorm1 below -Hdiag=getdiag(B);Gnorm=norm2(grad);L_s=maxval(-Hdiag);Bnorm1=getKnorm(B,1) -L_lo=max(zero,L_s,Gnorm/trustRad-Bnorm1);Einf=hugeRe;stepResult=failed2Solve -L_hi=Gnorm/trustRad+Bnorm1; RZ2=zero; err=okAlg; message="solveTrustHook/ok" -do nchol = 1, ncholMax -! 1. Safeguard Lambda -! NB: inputting lambda=0 does not guarantee first solution will use lambda=0. - lambda=max(lambda,L_lo); lambda=min(lambda,L_hi) - if(lambda<=L_s)lambda=max(L_s_red*L_hi,(L_lo*L_hi**powLhi)**rootLhi) -! 2. Check positive definiteness of perturbed Hessian - call addDiag(B,lambda) ! augment Hessian diagonal - if(usePivot)then ! - requests pivoted (robust) Cholesky: not really necessary here - indx=-10 ! no prescrambling - call choles_dcmp(a=B,Ld=Ld,posDefinite=pd,& - doPivot=usePivot,indx=indx,skipRobust=.true.,& - tau=cholTau,tauBar=cholTauBar,mu=cholMu,& - ibad=ibad,logDet=logdetTemp,condest=condestTemp,& - err=jerr,message=jmessage) - else ! - standard un-pivoted Cholesky (satisfactory in trust methods) - indx=-20 ! to trap any possible bugs: indx should not be used. - call choles_dcmp(a=B,Ld=Ld,posDefinite=pd,& - ibad=ibad,logDet=logdetTemp,condest=condestTemp,& - err=jerr,message=jmessage) - endif - call putDiag(B,Hdiag) ! restore Hessian diagonal - if(nchol==1)then ! keep original properties (not always useful, though) - if(pd)then ! - input Hessian positive definite - logdet=logdetTemp;condest=condestTemp - else ! - input Hessian indefinite - logdet=-hugeRe;condest=-hugeRe - endif - endif - if(pd)then -! 3. Solve for restricted step direction using forward/backward substitution - if(lambdaL_s.and.PnormtolGnorm)then ! Newton update of lambda -! algorithm (3.2)-step 3: auxiliary vector - if(usePivot)psol=psol(indx) ! account for pivoting scrambling - call lower_rsolv(a=B,d=Ld,b=psol,x=q,transp=.false.,err=jerr) - Qnorm=norm2(q) ! Qnorm is residual for Newton-Hebden iteration -! algorithm (3.2)-step 4: Newton iteration on lambda (Hebden iteration) - lambda=lambda+(Pnorm/Qnorm)**2*(Pnorm-trustRad)/trustRad - elseif(pd.and.Pnorm>trustRad.and.L_s==zero.and.L_lo>=L_s.and.lambda==L_lo)then - lambda=max(2._mrk*lambda,L_s_red*L_hi,sqrt(L_lo*L_hi)) ! prevent rare cycling - else ! safeguarded update when Newton iteration fails - lambda=L_s - endif -enddo -if(nchol>ncholmax)then ! - failed to solve the trust region problem - err=failAlg - write(message,'(a,i0)')"solveTrustHook/nchol>ncholmax:",nchol - psol=zero;Pnorm=zero;stepResult=failed2Solve -else - err=okAlg; message="solveTrustHook/ok" -! call putDiag(B,Hdiag) ! may want the original Hessian in the calling routine -endif -! End procedure here -endsubroutine solveTrustHook -!---------------------------------------------------- -pure subroutine solveGeneralDogTrust(B,Ld,indx,grad,trustRad,dogNewtBias,& - haveFac,haveNewt,haveNeg,doPivot,hessFacBundle,haveGBG,useL,& - posDef,newtStep,newtLen,negEigen,negStep,& - normG,gBg,absGdotNewt,& - logdet,condest,Einf,psol,pLen,stepResult,nchol,err,message) -! --- -! Purpose: Implements the generalized dogleg trust region solution, -! handling Hessians with arbitrary convexity properties at the cost -! of a single (modified) Cholesky decomposition (except in the hard case). -! The method may not produce as accurate trust solutions as the near-exact -! approach of More and Sorensen, but can be much cheaper (for large problems) and -! not too shabby either. -! Recommended for large-scaled problems where memory is not an issue -! but where repeated Cholesky inversions are becoming onerous. -! The generalized dogleg is often referred to as the 2D subspace minimisation -! solution of the trust region subproblem. The implementation here is DK's -! concoction of Dennis and Schnabel, Nocedal and Wright, Schultz et al., -! Gill et al. concepts, resulting in a simple 1-factorization algorithm -! that often would require 1 Cholesky per _outer_ trust region iteration. -! In addition, factored quasi-Newton updating allows using the dogleg -! with no Cholesky factorizations, ie, solving the trust subproblem -! in O(2) cost. not shabby... (but then cannot handle the hard-case). -! NB: -! * Dogleg requires single Cholesky except in the hard case where inverse -! iteration eigenvector polish requested, in which case 4-5 Cholesky factorizations -! are usually sufficient. NB: hard case only arises for indefinite functions -! near saddle-points, so BFGS and Gauss-Newton Hessians 'should' never invoke -! the hard case code. SR1 can sometimes be problematic since it can become strongly -! indefinite with very large negative diagonals. Indeed, my experimentation suggests -! SR1 quasi-Newton can be expensive in the hard case. -! * In addition, the use of robust Cholesky in the dogleg method can flag marginal -! positive-definite matrices as indefinite. This can occur for unfactored BFGS -! and Gauss-Newton Hessians. Code then uses its "hard-case" algorithm to proceed. -! --- -! Programmer: Dmitri Kavetski. 17 January 2004 -! --- -! INPUT: -! B = depending on doChol, either -! (i) raw scaled active Hessian or -! (ii) permuted modified scaled active Hessian L factor (Ld=diag of L) -! grad = gradient -! haveFac = true if B already decomposed with L diagonal in Ld -! (otherwise instructs to carry out (robust) Cholesky decomposition -! indx = permutation vector -! dogNewtBias = dogleg bias towards Newton,0=single dogleg,1=scaledNewton (~0.8) -! INPUT/OUTPUT (input if haveFac,output if .not.haveFac) -! posDef = true if original B is positive definite -! newtStep = Newton step (posdef) or modified Newton step (.not.posdef) -! cauchyStep= Cauchy step -! negEigen = most negative eigenvalue of B -! negStep = step of negative curvature (eigenvector) -! logdet,condest,Einf = Hessian properties -! OUTPUT -! psol = solution of trust region problem -! pLen = length of trust region solution -! err = status completion -! message = description of performance -! --- -! USAGE -! * Trust region optimization has two iteration loops -! - Inner iteration ("trust acceptance") loop, where the function is -! trialled along the trust region trajectory until sufficient decrease -! obtained (not unlike a curvilinear search). -! - Outer iteration ("step") loop, -! * Normally, call this routine with all "have" vars set to false and -! {normG,gDotNewt}<0 and the routine will calculate (and return) whatever is -! needed for the trust region solution. -! * If have robust Cholesky factors (eg, factored quasi-Newton) then set -! "haveFac=true" and supply the lower triangle of L and diagonal Ld. -! Also need to supply posdef, if .false. then will assume it received -! a modified Newton step and will solve the "hard case" if it is too short. -! Note that pivoting complicates the use of this subroutine, so take care! -! * If lots of information is known apriori (eg, Newton steps), set -! corresponding "have"'s to .true. and the routine will use the supplied data -! (with no checks!, so be sure u no what u dooing...). -! * If the dogleg step failed to achieve sufficient decrease, call dogleg -! again with decreased trust region but do not alter any "have" variables. -! --- -! Algorithm: -! * The generalized dogleg step is a subset of the 2D subspace minimization -! strategy of solving the trust region subproblem. -! - If the Hessian is positive definite and Newton step inside trust region, -! simply take Newton step. -! - Whenever the (possibly modified) Newton step exceeds the trust region, the -! "exact" hookstep curve is replaced by piecewise linear intervals, connecting -! point A = current point -! point B = Cauchy point (constrained minimizer of linear model) -! (point C) = for double dogleg step, point along BD which biases towards Newton. -! point D = (modified) Newton point (unconstrained minimizer of quadratic model) -! - If the modified Newton step is shorter than the trust radius, we are dealing -! with the "hard case" and the modified Newton step is pumped all the way to -! the trust bound along a direction of negative curvature. This allows the -! trust region optimizer to escape from saddle points along directions of -! negative curvature (ie, eigenvectors of negative eigenvalues). -! - The "2D" bit in "2D subspace minimization" comes from the 2D subspace -! obtained by joining the Cauchy and Newton steps. The actual trust -! solution is a curve (hook), so the sucess of doglegs depends on -! whether curvature is important and whether the computed Hessian -! is reliable source of this information. -! * Dogleg method comes in two sub-flavours: single-dogleg and double-dogleg -! the double-dogleg is biased towards the Newton step even if the latter is -! outside the trust region, whereas the single-dogleg step (originally by Powell) -! simply connects the Cauchy and Newton points. Set dogNewtBias=0 for single dogleg -! or dogNewtBias=0.8 for standard double-dogleg (Dennis and Schnabel). -! dogNewtBias=1 will give total bias to Newton step and will simply scale it to the -! trust radius, discarding the Cauchy step, which seems a bit extreme and kind of -! contrary to the spirit of trust regions (interpolating steepest descent and Newton). -! * Three options for the hard case, set by eigmeth -! - fastChol: Fast O(N2) eigenvector estimation from the modified Cholesky factors using -! the method of Gill et al. Method generally reliable, but requires the -! reliable identification of offending rows of the Hessian. When pivoting -! enabled, this is usually accurately determined. -! - largeNorm: More accurate but more expensive O(N2) method based on large-norm method. -! - Both these methods are approximate, require the single robust Cholesky but -! can break down in some cases (since robust Cholesky usually overadds). -! - invIter: uses inverse iteration to polish up eigenvectors, which often -! saves otherwise ruined estimates. This may require additional O(N3) Choleskying, -! which may be unavoidable to reliably compute eigenvectors in the hard case. -! NB: The hook step code is particularly robust in the hard case. -! --- -! Refs: -! * More and Sorensen (1983) Computing a trust region step, -! SIAM Journal of Scientific and Statistical Computing,4(3),pp.553-572. -! * Dennis and Schnabel (1996) Numerical methods for unconstrained -! optimization and nonlinear equations. text and pseudocode. -! * Nocedal and Wright (1999) Numerical Optimization (dogleg chapters) -! * Schultz,G.A., Schnabel,R.B. and Byrd,R.H.(1985) A family of -! trust-region-based algorithms for unconstrained minimization with -! strong global convergence properties, SIAM Journal on Numerical -! Analysis,V.22(1),Feb.1985,pp.47-67. -! --- -use utilities_dmsl_kit,only:zero,twoThirds,one,norm2,assertEq,arthsi,& - getDiag,putDiag,addDiag,triang_minEig -use linalg_dmsl_kit,only:choles_dcmp,choles_fwbw,choles_negEigVec -implicit none -! dummies -logical(mlk),intent(inout)::haveFac,haveNewt,haveNeg,haveGBG -logical(mlk),intent(in)::doPivot,useL -type(hessFacBundle_type),intent(in)::hessFacBundle -real(mrk),intent(inout)::B(:,:),Ld(:) -real(mrk),intent(inout)::normG,gBg,absGdotNewt -real(mrk),intent(in)::grad(:),trustRad,dogNewtBias -integer(mik),intent(inout)::indx(:) -logical(mlk),intent(inout)::posDef -real(mrk),intent(inout)::newtStep(:),newtLen -real(mrk),intent(inout)::negStep(:),negEigen -real(mrk),intent(inout)::psol(:),pLen -real(mrk),intent(inout)::logdet,condest,Einf -integer(mik),intent(out)::stepResult,nchol,err -character(*),intent(out)::message -! locals -integer(mik)::n,job,cauchyStepType,iBad,ncholHC -real(mrk)::E(size(grad)),Gersh(size(grad)),cauchyStep(size(grad)),cauchyLen -real(mrk)::tempv(size(grad)),negeigChol,negeigHard -real(mrk)::tau,gamma,tempA,tempB,nu,eigZero -logical(mlk)::usePivot -! auxiliary -logical(mlk)::ok -integer(mik)::jerr -character(100)::jmsg -! algorithm parameters -real(mrk),parameter::sigma1=0.2_mrk ! tolerance on step and trust agreement -real(mrk),parameter::eigtol=1.e-1_mrk ! tolerance on negative curvature eigenvalue -integer(mik),parameter::ncholmaxHC=100 ! max Cholesky factorizations in the hard case -integer(mik),parameter::useNewt=0,doDog=1,hardCase=2 -integer(mik),parameter::fastChol=0,largeNorm=1,inviter=2 -integer(mik),parameter::eigmeth=invIter ! largeNorm ! fastChol ! ! hard-case eigenmethod -!integer(mik)::eigmeth ! hard-case eigenmethod -integer(mik)::cmeth ! eigenmethod Cholesky option -!logical(mlk),parameter::checkEig=.false. ! forces Cauchy step for ill-conditioned Hessians -logical(mlk)::checkEig ! forces Cauchy step for ill-conditioned Hessians -logical(mlk),parameter::normW=.true. -! Start procedure here -checkEig=.false. -call assertEq(size(B,1),size(B,2),size(grad),size(indx),size(psol),& - size(newtStep),size(cauchyStep),size(negStep),ok,n) -if(.not.ok)then - err=100;message="f-solveGeneralDogTrust/dimError" - return -endif -! * Process Hessian matrix -if(haveFac)then -! - Assumes B already decomposed and uses {Ld,indx,posDef,negEigen,negCurv} - usePivot=doPivot - nchol=0;err=0;message="solveGeneralDogTrust/usingInputLfac" -else -! - Robust Cholesky decomposition of B to establish whether it is positive -! definite and perturb if not (estimating negative eigenvalue) - selectcase(hessFacBundle%facmeth) ! select modified Hessian factorization method - case(schnab_facmeth) ! - revised modified Cholesky-Gershgorin of Schnabel and Eskew - usePivot=doPivot; indx=-1 ! (indicate no pre-scrambling) - call choles_dcmp(A=B,Ld=Ld,iBad=iBad,& - tau=hessFacBundle%tau,tauBar=hessFacBundle%tauBar,mu=hessFacBundle%mu,& - doPivot=usePivot,indx=indx,posDefinite=posDef,logDet=logdet,condest=condEst,& - Einf=negeigChol,E=E,Gout=Gersh,err=jerr,message=jmsg) - nchol=1 ! note if pivoting used then everything will be scrambled (and scaled) - case(dennis_facmeth) ! - perturbed Cholesky-Gershgorin of Dennis and Schnabel - usePivot=.false.; indx=-100 ! no pivoting here - call choles_dcmp(A=B,Ld=Ld,& - maxCond=hessFacBundle%maxHessCond,& - posDefinite=posDef,nchol=nchol,logDet=logdet,condest=condEst,& - Einf=Einf,err=jerr,message=jmsg) - endselect - haveFac=.true. - Einf=negeigChol ! store estimated most negative eigenvalue -! call addDiag(B,E) ! explicitly construct modified matrix in upper triangle -endif -! * Compute generalized Newton (if(posDef)=>classic Newton, else=modified) -if(.not.haveNewt)then ! perform Cholesky forward/backward substitution - if(.not.usePivot)then - indx=arthsi(n) ! assume unpivoted solution - elseif(any(indx<1.or.indx>n))then ! this catches evident errors, but is not - err=10;message="f-solveGeneralDogTrust/indxContentError" ! bombproof... - return - endif - call choles_fwbw(a=B,Ld=Ld,indx=indx,usePivot=usePivot,& - b=grad,x=newtStep,err=jerr,message=jmsg) - newtStep=-newtStep; haveNewt=.true. - newtLen=norm2(newtStep) ! length of (modified) Newton step -endif -! * Decide whether to (i) dogleg or (ii) use negative curvature -if(posDef)then -! - original Hessian positive definite: use dogleg step if Newton too big. - job=merge(doDog,useNewt,newtLen>(one+sigma1)*trustRad) -elseif(newtLen>(one-sigma1)*trustRad)then -! - modified Newton at least long enough, use dogleg if too big. - job=merge(doDog,useNewt,newtLen>(one+sigma1)*trustRad) -else -! - original Hessian indefinite and we are faced with the "hard case". - job=hardCase ! (since modified step too short) -endif -! * Carry out requested trust job: either dogleg or negative curvature -selectcase(job) -case(useNewt) ! - simply return Newton step as it is inside trust region - psol=newtStep; pLen=newtLen; stepResult=insideTrust - err=0; message="f-solveGeneralDogTrust/ok/usedNewtonInsideTrust" -case(doDog) ! - standard dogleg step if Newton or modified Newton too long -! - Compute Cauchy point ! ** this code is copied to below - if(useL)then ! - put Cholesky diagonal into B for a sec... - E=getDiag(B); call putDiag(B,Ld) - endif - if(useL.and.usePivot)then ! - account for pivoting (for gBg computation) - tempv=grad(indx) - else - tempv=grad - endif -! (NB: if normG,gBg known then this cheap call merely scales the Cauchy step) - call getCauchyStep(hess=B,useL=useL,grad=tempv,trustRad=trustRad,& - normG=normG,haveGBG=haveGBG,gBg=gBg,& - cauchyStepType=cauchyStepType,& - cauchyStep=cauchyStep,cauchyLen=cauchyLen) - if(useL)call putDiag(B,E) ! - restore diagonal of B - if(useL.and.usePivot)cauchyStep(indx)=cauchyStep ! - unscramble Cauchy - if(dogNewtBias>zero)then ! double dogleg step (biased towards Newton) - if(absGdotNewt-eigZero)then -! - pathological positive semi-definite (near-singular) Hessian -! DK's experimentation suggests taking Cauchy step for ill-conditioned Hessians -! is not always efficient, particularly with SR1 quasi-Hessians. -! take Cauchy step--- - if(useL)then ! ** this code is copied from Cauchy above - E=getDiag(B); call putDiag(B,Ld) - endif - if(useL.and.usePivot)then - tempv=grad(indx) - else - tempv=grad - endif - call getCauchyStep(hess=B,useL=useL,grad=grad,trustRad=trustRad,& - normG=normG,haveGBG=haveGBG,gBg=gBg,& - cauchyStepType=cauchyStepType,& - cauchyStep=cauchyStep,cauchyLen=cauchyLen) - if(useL)call putDiag(B,E) - if(useL.and.usePivot)cauchyStep(indx)=cauchyStep - stepResult=merge(insideTrust,onTrustBound,cauchyStepType==cauchyInside) - psol=cauchyStep; pLen=cauchyLen -! endtake Cauchy step--- - err=0; message="w-solveGeneralDogTrust/ok/usedCauchy(pathosB)" - else ! - yep.. hard case -! employs More and Sorensen algorithm for scaling the negative curvature -! eigenvector up to the trust bound, using the solution of the corresponding -! quadratic to preserve as much Newton direction as possible. -! This seems efficient even for near-singular Hessian matrices, since in this -! case the step comprises the direction where the function curves-up least. - call solveTrustHardCase(newtStep,newtLen,negStep,trustRad,psol=psol) - stepResult=hardCase - err=0; message="f-solveGeneralDogTrust/ok/usedHardCase" - endif -case default - err=200;message="f-solveGeneralDogTrust/BUG/unknownJob" -endselect -! End procedure here -endsubroutine solveGeneralDogTrust -!---------------------------------------------------- -pure subroutine getCauchyStep(hess,useL,grad,trustRad,normG,haveGBG,gBg,& - cauchyStep,cauchyLen,cauchyStepType) -! Purpose: Compute scaled Cauchy step to the minimizer of the linear model. -! All data is assumed to be prescaled (for efficiency). -! INPUT -! hess = scaled (possibly modified) Hessian. -! not used if haveGBG=true, in which case user supplies -! gBg = grad(tranpose).dot.hess.dot.grad -! grad = scaled gradient. Not used if normG=||grad||>0 -! trustRad = scaled trust radius -! useL = instructs to use Cholesky L in lowerTriangle of hess -! OUTPUT -! cauchyStep = step to Cauchy point CP -! cauchyLen = length of Cauchy step -! cauchyStepType = type of Cauchy step (eg, if reaches trust boundary, etc.) -!--- -! See eqn 4.7-4.8 in Nocedal. -! Programmer: Dmitri Kavetski, 17 January 2004. -use utilities_dmsl_kit,only:zero,one,norm2,quadform,fmatmul_mv -implicit none -! dummies -real(mrk),intent(in)::hess(:,:),grad(:),trustRad -logical(mlk),intent(in)::useL,haveGBG -real(mrk),intent(inout)::normG,gBg -real(mrk),intent(out)::cauchyStep(:),cauchyLen -integer(mik),intent(out)::cauchyStepType -! locals -real(mrk)::tau -real(mrk),parameter::normGminFac=1.e3_mrk,normGmin=tinyRe*normGminFac -! Start procedure here -if(.not.haveGBG)then ! compute {grad(t).B.grad} - if(useL)then ! - use (possibly modified) Cholesky factor L - cauchyStep=fmatmul_mv(m=hess,v=grad,typeMV="LTV") - gBg=norm2(cauchyStep)**2 - else ! - use (possibly modified) Hessian matrix - gBg=quadform(v=grad,mm=hess,typeM="SU") - endif -endif -if(normG=one)then ! -- yep, constrained - cauchyLen=trustRad; cauchyStepType=cauchyOnBound - else ! -- inside trust - cauchyLen=tau*trustRad; cauchyStepType=cauchyInside - endif -endif -if(normG>normGmin)then ! safeguard division by zero - cauchyStep=-cauchyLen*grad/normG -else - cauchyStep=-grad/normGmin; cauchyStepType=cauchyZeroGrad -endif -! End procedure here -endsubroutine getCauchyStep -!---------------------------------------------------- -pure subroutine solveTrustHardCase(newtStep,newtLen,negStep,trustRad,psol,tau) -! Purpose: Given modified Newton step and a direction of negative curvature, -! construct a globally convergent trust region step using a weighted -! combination of the modified Newton step and the negative curvature direction. -! This allows trust region methods to escape saddle point regions of attraction. -! * More and Sorensen (1983) Computing a trust region step, -! SIAM Journal of Scientific and Statistical Computing,4(3),553-572. -implicit none -! dummies -real(mrk),intent(in)::newtStep(:),negStep(:),newtLen,trustRad -real(mrk),intent(inout),optional::tau,psol(:) -! locals -real(mrk)::dotPZ,tau0 -! Start procedure here -dotPZ=dot_product(newtStep,negStep) ! multiple of eigenvector is calculated so that -tau0=(trustRad-newtLen)*(trustRad+newtLen) ! it does not cancel out the Newton -tau0=tau0/(dotPZ+sign(sqrt(dotPZ**2+tau0),dotPZ)) ! component of the step -if(present(tau))tau=tau0 ! (and thus keeps at least some Newton...) -if(present(psol))psol=newtStep+tau0*negStep -! End procedure here -endsubroutine solveTrustHardCase -!---------------------------------------------------- -subroutine updateTrust(evalFunc,dataIN,dataOUT,xold,fold,gold,dx,stepLen,stepResult,redExp,& - xscale,fscale,reducedTrust,objFuncBundle,trustBundle,& - x,fx,trustRad,redRatio,fcalls,retcode,message) -! Purpose: Given a proposal step dx obtained by solving the trust region -! subproblem, accept or reject step dx and update the trust region for the -! next iteration or step. -! -! Input: current point xold with function value fold -! expected reduction in function value -! trial (constrained) step dx of length stepLen -! Output: updated point x with function value fx -! updated trust region and reduction ratio -! status diagnostix -! Method: A modification of the basic trust update algorithm described by -! Nocedal and Wright (1999) and Fletcher (1996). -! Also includes Dennis and Schnabel details. -! -! Programmer: Dmitri Kavetski -! Algorithm: -! * The method assumes the input step has been truncated accounting for any bounds. -! It is a bit awkward to handle elliptical trust regions near rectangular bounds -! (see,eg.Nocedal). In these cases a box-step method may be more appropriate. -! Note that reducing the trust region to the distance to nearest bound is -! generally unsatisfactory since it will often unnecesarily truncate steps _away_ -! from 'em... -! * Care must be taken since the step may have been truncated by solution bounds -! In this case the trust region may be accurate but truncated step may be far shorted. -! In this case do not alter trust region. -! * If quadratic model is good but the trust region constrained the step, -! the step is re-attempted with larger trust radius. This may achieve a greater -! function reduction without additional gradient/Hessian calls, which becomes -! particularly beneficial whenever the dimensionality of the objective function is -! high and if derivatives are approximated by finite differences. -! * If trust region was close to constraining the step and the quadratic model -! was good, increase trust region for next step. -! * If quadratic model poor, reduce trust region (but usually accept step) -! * Alternative strategies may include a (curvilinear linesearch in the trust region -! direction, this would save those extra Cholesky decompositions when expanding -! trust region. -! * For SR1 quasi-Newton Hessian updating, it may be preferable to update the -! Hessian even along failed directions, in order to incorporate as much curvature -! information as possible into the quadratic model. -use types_dmsl_kit,only:data_ricz_type -use utilities_dmsl_kit,only:one,zero,half,minmax -implicit none -! dummies -type(data_ricz_type),intent(in),optional::dataIN -type(data_ricz_type),intent(inout),optional::dataOUT -real(mrk),intent(in)::xold(:),gold(:),fold,dx(:),stepLen,redExp -integer(mik),intent(in)::stepResult -type(trustBundle_type),intent(in)::trustBundle -type(objFuncBundle_type),intent(in)::objFuncBundle -logical(mlk),intent(in)::reducedTrust -real(mrk),intent(in)::xscale(:),fscale -real(mrk),intent(out)::x(:),fx,redRatio -real(mrk),intent(inout)::trustRad -integer(mik),intent(out)::fcalls -integer(mik),intent(out)::retcode -character(*),intent(out)::message -! user-provided function -interface - subroutine evalFunc(dataIN,dataOUT,x,feas,fx,gradFx,hessFx,err,message) - use kinds_dmsl_kit - use types_dmsl_kit,only:data_ricz_type - implicit none - type(data_ricz_type),intent(in),optional::dataIN - type(data_ricz_type),intent(inout),optional::dataOUT - real(mrk),intent(in)::x(:) - logical(mlk),intent(out)::feas - real(mrk),intent(out),optional::fx,gradFx(:),hessFx(:,:) - integer(mik),intent(out)::err - character(*),intent(out)::message - endsubroutine evalfunc -endinterface -! locals -integer(mik)::err -logical(mlk)::feas -real(mrk)::redObs,dirDer -! local parameters -logical(mlk),parameter::backtrackTrust=.false. ! trust reduction using backtracking -real(mrk),parameter::radDownMin=0.1_mrk,radDownMax=0.5_mrk ! safeguarded by [min,max] -real(mrk),parameter::safeEps=10._mrk*epsRe -logical(mlk),parameter::checkExpObs=.false. -! Start procedure here -retcode=failed_tr;fcalls=0;x=xold;fx=fold;redRatio=zero -if(all(abs(dx)<=safeEps*max(abs(xold),xscale)))then ! step a bit too small - retcode=dxTiny_tr; message="updateTrust/dxTiny" - return -elseif(redExp<=zero)then ! expected reduction non-positive: return now - redRatio=-one; retcode=expRedNonP_tr - write(message,'(a,sp,es13.6,s)')"f-updateTrust/expFredNonPosit(BUG?):",redExp - return -endif -x=xold+dx -! ** evaluate function at trial point -call evalFunc(dataIN,dataOUT,x,feas,fx,err=err,message=message); fcalls=fcalls+1 -if(err/=0)then ! strange, since point x has already been trialled with err=0 - message="f-updateTrust/userErr1/&"//message - retcode=badFunc_glob; return -elseif(.not.feas)then ! unfeasible point encountered - retcode=unfeas_tr; message="updateTrust/unfeasX" - trustRad=trustBundle%radDown_tr*stepLen - if(trustRadfold)then ! return initial point if (marginally) better - x=xold;fx=fold;redRatio=zero - endif - retcode=fconExpObs_tr;message="updateTrust/red[f](obs&exp)~epsF";return -endif -! Adjust trust radius if necessary -if(redRatiosafeEps*max(abs(fold),fscale))then -! ** Step satisfies sufficient decrease condition but agreement with quadratic model -! is poor. Accept step but deflate trust region for next step - if(backTrackTrust)then ! - use linesearch back-tracking to controllably reduce trust - dirDer=dot_product(gold,dx) - trustRad=-half*dirDer/(fx-fold-dirDer) - trustRad=minmax(trustRad,radDownMin,radDownMax) - trustRad=trustRad*stepLen - else ! - simple reduction (tends to work better - fewer assumptions) - trustRad=trustBundle%radDown_tr*stepLen - endif - retcode=suceed_tr; message="updateTrust/ok/trustGoingDown" -elseif(redRatio>trustBundle%roUpNow_tr.and.( & -! stepLen>trustRad*trustBundle%radUp_tr.or.& - stepResult==onTrustBound.or. & - stepResult==hardCase).and. & - .not.reducedTrust)then -! ** Step in good agreement with quadratic model and was near-constrained by the -! trust bound (likely unneccesarily). Re-attempt step with larger trust - trustRad=trustBundle%radUp_tr*trustRad - retcode=goBig_tr; message="updateTrust/goBig/trustGoingUp" - if(trustRad>trustBundle%trustMax)then ! * check for blown trust - trustRad=trustBundle%trustMax; retcode=blown_tr - message="updateTrust/trustRegionWantsBig" - endif -elseif(redRatio>trustBundle%roUp_tr.and.& - stepLen>trustBundle%stepOtrustUp_tr*trustRad.and.& - .not.reducedTrust)then -! ** Step in good agreement with quadratic model and close to trust radius -! Avoid possible future interference by pumping the trust up. - trustRad=trustBundle%radUp_tr*trustRad - retcode=suceed_tr; message="updateTrust/ok/trustGoingUp" - if(trustRad>trustBundle%trustMax)then ! * check for blown trust - trustRad=trustBundle%trustMax; retcode=blown_tr - message="updateTrust/trustRegionWantsBig" - endif -else -! ** (i) sufficient (but not great) decrease achieved or -! (ii) good agreement with quadratic model but trust region non-interfering -! accept step but do not alter trust radius - retcode=suceed_tr; message="updateTrust/ok/keepTrust" -endif -!print *, 'in updateTrust, fold = ', fold -!print *, 'in updateTrust, xold = ', xold -!print *, 'in updateTrust, dx = ', dx -!print *, 'in updateTrust, xold+dx = ', xold+dx -!print *, 'in updateTrust, fx = ', fx -!print *, 'in updateTrust, x = ', x -! End procedure here -endsubroutine updateTrust -!---------------------------------------------------- -endmodule optimiser_dmsl_kit -!****************************************************************** diff --git a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/pargrid_driver-copy.f90.svn-base b/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/pargrid_driver-copy.f90.svn-base deleted file mode 100644 index 7b4b5a7..0000000 --- a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/pargrid_driver-copy.f90.svn-base +++ /dev/null @@ -1,192 +0,0 @@ -PROGRAM PARGRID_DRIVER -! --------------------------------------------------------------------------------------- -! Creator: -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! Driver program for a parameter grid -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE ddirectory ! directory for data files -! data modules -USE model_defn,nstateFUSE=>nstate ! model definition structures -USE multiforce, ONLY: AFORCE, DELTIM, NUMTIM ! data interval = maximum model time step -USE multiparam, ONLY: LPARAM, PARATT, NUMPAR ! parameter metadata structures -USE multiroute, ONLY: AROUTE ! model routing structures -USE multistats ! model statistics structures -! informational modules -USE selectmodl_module ! reads model control file -USE getpar_str_module ! extracts parameter metadata -USE par_insert_module ! inserts model parameters -! model numerix -USE model_numerix ! defines decisions on model numerix -! access to model simulation modules -USE fuse_rmse_module ! run model and compute the root mean squared error -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -! (0) GET COMMAND-LINE ARGUMENTS... -! --------------------------------------------------------------------------------------- -CHARACTER(LEN=6) :: NSOLUTION=' ' ! numerical solution (0=implicit, 1=explicit) -CHARACTER(LEN=6) :: FADAPTIVE=' ' ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -CHARACTER(LEN=6) :: TRUNC_ABS=' ' ! absolute temporal truncation error tolerance -CHARACTER(LEN=6) :: TRUNC_REL=' ' ! relative temporal truncation error tolerance -CHARACTER(LEN=11) :: PAR_NAME1=' ' ! name of the 1st parameter in the grid -CHARACTER(LEN=11) :: PAR_NAME2=' ' ! name of the 2nd parameter in the grid -! --------------------------------------------------------------------------------------- -! (1) SETUP MODELS FOR SIMULATION -- POPULATE DATA STRUCTURES -! --------------------------------------------------------------------------------------- -! get model forcing data -INTEGER(I4B) :: NTIM ! number of time steps -INTEGER(I4B) :: INFERN_START ! start of inference period -! get model setup -INTEGER(I4B) :: I ! looping -INTEGER(I4B) :: NMOD ! number of models -INTEGER(I4B) :: ERR ! error code -CHARACTER(LEN=256) :: MESSAGE ! error message -! define model output -LOGICAL(LGT) :: OUTPUT_FLAG ! .TRUE. = write time series output -! --------------------------------------------------------------------------------------- -! (2) CREATE PARAMETER GRID -! --------------------------------------------------------------------------------------- -! Define error code for I/O -INTEGER(I4B) :: IERR ! error code for I/O -! Identify index of the parameter set -INTEGER(I4B) :: IPARSET ! parameter set index -CHARACTER(LEN=4) :: CPARSET ! convert parameter set index to a string -! Define the number of points in each direction -INTEGER(I4B),PARAMETER :: NGRID=101 ! number of samples across a single parameter dimension -! Looping variables -INTEGER(I4B) :: IPAR ! index of 1st model parameter -INTEGER(I4B) :: JPAR ! index of 2nd model parameter -INTEGER(I4B) :: KPAR ! loop through model parameters -INTEGER(I4B) :: MPAR ! loop through model parameter values -INTEGER(I4B) :: NPAR ! loop through model parameter values -! Identify the initial parameter set -TYPE(PARATT) :: PARAM_META ! parameter metadata (model parameters) -INTEGER(I4B) :: ONEMOD ! index of the model used (=1) -! Parameter vectors -REAL(SP),DIMENSION(:),ALLOCATABLE :: X0I ! parameter vector -REAL(SP),DIMENSION(:),ALLOCATABLE :: XLO ! lower bound on solution, either none or both bounds must be present -REAL(SP),DIMENSION(:),ALLOCATABLE :: XHI ! upper bound on solution, either none or both bounds must be present -REAL(SP),DIMENSION(:),ALLOCATABLE :: XDF ! default parameter vector -REAL(SP) :: FPAR ! function value for parameter set -! --------------------------------------------------------------------------------------- -! (0) READ COMMAND LINE ARGUMENTS -! --------------------------------------------------------------------------------------- -! read command-line arguments -CALL GETARG(1,NSOLUTION) ! numerical solution (0=explicit, 1=implicit) -CALL GETARG(2,FADAPTIVE) ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -CALL GETARG(3,TRUNC_ABS) ! absolute temporal truncation error tolerance -CALL GETARG(4,TRUNC_REL) ! relative temporal truncation error tolerance -CALL GETARG(5,PAR_NAME1) ! name of the 1st parameter in the grid -CALL GETARG(6,PAR_NAME2) ! name of the 2nd parameter in the grid -! check command-line arguments -IF (LEN_TRIM(NSOLUTION).EQ.0) STOP '1st command-line argument is missing (NSOLUTION)' -IF (LEN_TRIM(FADAPTIVE).EQ.0) STOP '2nd command-line argument is missing (FADAPTIVE)' -IF (LEN_TRIM(TRUNC_ABS).EQ.0) STOP '3rd command-line argument is missing (TRUNC_ABS)' -IF (LEN_TRIM(TRUNC_REL).EQ.0) STOP '4th command-line argument is missing (TRUNC_REL)' -IF (LEN_TRIM(PAR_NAME1).EQ.0) STOP '5th command-line argument is missing (PAR_NAME1)' -IF (LEN_TRIM(PAR_NAME2).EQ.0) STOP '6th command-line argument is missing (PAR_NAME2)' -! convert command-line arguments to integer flags and real numbers -CALL GETNUMERIX() ! defines method/parameters used for numerical solution -READ(NSOLUTION,*) SOLUTION_METHOD ! numerical solution (0=EE, 1=EH, 2=IE, 3=IH) -READ(FADAPTIVE,*) TEMPORAL_ERROR_CONTROL ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -READ(TRUNC_ABS,*) ERR_TRUNC_ABS ! absolute temporal truncation error tolerance -READ(TRUNC_REL,*) ERR_TRUNC_REL ! relative temporal truncation error tolerance -! additional checks -SELECT CASE(SOLUTION_METHOD); CASE(EXPLICIT_EULER,EXPLICIT_HEUN,IMPLICIT_EULER,IMPLICIT_HEUN,SEMI_IMPLICIT) -CASE DEFAULT; - STOP 'solution method (1st command line argument) must equal 0 (explicit_euler), 1 (explicit heun), & - &2 (implicit_euler), 3 (implicit_heun), or 4 (semi_implicit)' -END SELECT -SELECT CASE(TEMPORAL_ERROR_CONTROL); CASE(TS_FIXED,TS_ADAPT); CASE DEFAULT; - STOP 'temporal error control (2nd command line argument) must equal 0 (fixed steps) or 1 (adaptive steps)' -END SELECT -write(*,'(A5,1X,2(I1,1X),2(E12.5,1X),I6,1X,A11,1X,I6)') 'FUSE ', & -SOLUTION_METHOD, TEMPORAL_ERROR_CONTROL, ERR_TRUNC_ABS, ERR_TRUNC_REL -! --------------------------------------------------------------------------------------- -! (1) GET MODEL SETUP -- MODEL DEFINITION, AND PARAMETER AND VARIABLE INFO FOR ALL MODELS -! --------------------------------------------------------------------------------------- -! Read data from the "BATEA-compliant" ASCII files -CALL GETFORCING(INFERN_START,NTIM) -!INFERN_START=1; NTIM=20; NUMTIM=NTIM; DELTIM=1._SP -!ALLOCATE(AFORCE(NTIM),AROUTE(NTIM)) ! (shared in module multiroute) -!AFORCE(INFERN_START:NTIM)%PPT = (/0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,50.,50.,50.,50.,50.,0.,0.,0.,0.,0./) -!AFORCE(INFERN_START:NTIM)%PET = (/5.,5.,5.,5.,5.,5.,5.,5.,5.,5., 5., 5., 5., 5., 5.,5.,5.,5.,5.,5./) -! Define model attributes (valid for all models) -CALL UNIQUEMODL(NMOD) ! get nmod unique models -CALL GETPARMETA() ! read parameter metadata (parameter bounds etc.) -! Identify a single model (read control file ../DataFiles/m_decisions.txt) -CALL SELECTMODL(ISTATUS=ERR,MESSAGE=MESSAGE) -IF (ERR.NE.0) THEN - PRINT *, TRIM(MESSAGE); STOP -ENDIF -! Define list of states and parameters for the current model -CALL ASSIGN_STT() ! state definitions are stored in module model_defn -CALL ASSIGN_FLX() ! flux definitions are stored in module model_defn -CALL ASSIGN_PAR() ! parameter defintions are stored in module multiparam -! compute derived model parameters (bucket sizes, etc.) -CALL PAR_DERIVE() -! --------------------------------------------------------------------------------------- -! (2) MAKE A PARAMETER GRID -! --------------------------------------------------------------------------------------- -! allocate arrays -ALLOCATE(X0I(NUMPAR),XLO(NUMPAR),XHI(NUMPAR),XDF(NUMPAR), STAT=IERR) -IF (IERR.NE.0) STOP ' problem allocating space for parameter arrays ' -! get parameter bounds -DO IPAR=1,NUMPAR - CALL GETPAR_STR(LPARAM(IPAR)%PARNAME,PARAM_META) - XLO(IPAR) = PARAM_META%PARLOW - XHI(IPAR) = PARAM_META%PARUPP -END DO -IPARSET = 0 -! loop through example parameter sets -OPEN(21,FILE=TRIM(DATA_PATH)//'param_example.dat') -DO - ! read parameter set - READ(21,*,IOSTAT=IERR) XDF; IF (IERR.NE.0) EXIT - WRITE(*,'(20(A12,1X))') LPARAM(1:NUMPAR); WRITE(*,'(20(F12.6,1X))') XDF - ! increment counter - IPARSET = IPARSET + 1 - ! convert counter to a character string - CPARSET=' '; WRITE(CPARSET,'(I4)') IPARSET; CPARSET=ADJUSTR(CPARSET) - FORALL(I=1:LEN(CPARSET)-LEN_TRIM(ADJUSTL(CPARSET))) CPARSET(I:I)='0' - ! define NetCDF files (filename shared in MODULE model_defn) - FNAME_NETCDF = TRIM(OUTPUT_PATH)//TRIM(SMODL%MNAME)//'__'//CPARSET//'__'//& - TRIM(NSOLUTION)//'-'//TRIM(FADAPTIVE)//'__'//& - TRIM(TRUNC_ABS)//'-'//TRIM(TRUNC_REL)//'__'//& - TRIM(PAR_NAME1)//'-'//TRIM(PAR_NAME2)//'__pargrid.nc' - write(*,'(a)') trim(fname_netcdf) - ONEMOD=1 ! one file per model (i.e., model dimension = 1) - PCOUNT=0 ! counter for parameter sets in output file (shared in MODULE multistats) - FCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) - OUTPUT_FLAG = .FALSE. ! write model output - CALL DEF_PARAMS(ONEMOD) ! define model parameters (initial CREATE) - IF (OUTPUT_FLAG) CALL DEF_OUTPUT(NTIM) ! define model time series (REDEF) - CALL DEF_SSTATS() ! define summary statistics (REDEF) - X0I = XDF ! set parameters to their default value - ! initial run with default parameter sets - !CALL FUSE_RMSE(X0I,FPAR,OUTPUT_FLAG) - !CYCLE - ! identify IPAR and JPAR - DO KPAR=1,NUMPAR - IF (TRIM(LPARAM(KPAR)%PARNAME).EQ.TRIM(PAR_NAME1)) IPAR = KPAR - IF (TRIM(LPARAM(KPAR)%PARNAME).EQ.TRIM(PAR_NAME2)) JPAR = KPAR - END DO - ! loop through parameter perturbations - DO MPAR=1,NGRID - DO NPAR=1,NGRID - ! perturb parameters - X0I(IPAR) = XLO(IPAR) + REAL(MPAR-1,KIND(SP))/REAL(NGRID-1,KIND(SP)) * (XHI(IPAR)-XLO(IPAR)) - X0I(JPAR) = XLO(JPAR) + REAL(NPAR-1,KIND(SP))/REAL(NGRID-1,KIND(SP)) * (XHI(JPAR)-XLO(JPAR)) - ! run model (parameters and statistics are written in FUSE_RMSE) - CALL FUSE_RMSE(X0I,FPAR,OUTPUT_FLAG) - write(*,'(i6,1x,20(f9.3,1x))') PCOUNT, X0I - END DO ! npar - END DO ! mpar -END DO ! looping through example parameter sets -DEALLOCATE(X0I,XLO,XHI,XDF, STAT=IERR) -IF (IERR.NE.0) STOP ' problem deallocating space for parameter arrays ' -STOP -END PROGRAM PARGRID_DRIVER -! -------------------------------------------------------------------------------------- diff --git a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/pargrid_driver-slice.f90.svn-base b/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/pargrid_driver-slice.f90.svn-base deleted file mode 100644 index 9a54a7b..0000000 --- a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/pargrid_driver-slice.f90.svn-base +++ /dev/null @@ -1,193 +0,0 @@ -PROGRAM PARGRID_DRIVER -! --------------------------------------------------------------------------------------- -! Creator: -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! Driver program for a parameter grid -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE ddirectory ! directory for data files -! data modules -USE model_defn,nstateFUSE=>nstate ! model definition structures -USE multiforce, ONLY: AFORCE, DELTIM, NUMTIM ! data interval = maximum model time step -USE multiparam, ONLY: LPARAM, PARATT, NUMPAR ! parameter metadata structures -USE multiroute, ONLY: AROUTE ! model routing structures -USE multistats ! model statistics structures -! informational modules -USE selectmodl_module ! reads model control file -USE getpar_str_module ! extracts parameter metadata -USE par_insert_module ! inserts model parameters -! model numerix -USE model_numerix ! defines decisions on model numerix -! access to model simulation modules -USE fuse_rmse_module ! run model and compute the root mean squared error -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -! (0) GET COMMAND-LINE ARGUMENTS... -! --------------------------------------------------------------------------------------- -CHARACTER(LEN=6) :: NSOLUTION=' ' ! numerical solution (0=implicit, 1=explicit) -CHARACTER(LEN=6) :: FADAPTIVE=' ' ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -CHARACTER(LEN=6) :: TRUNC_ABS=' ' ! absolute temporal truncation error tolerance -CHARACTER(LEN=6) :: TRUNC_REL=' ' ! relative temporal truncation error tolerance -CHARACTER(LEN=11) :: PAR_NAME1=' ' ! name of the 1st parameter in the grid -CHARACTER(LEN=11) :: PAR_NAME2=' ' ! name of the 2nd parameter in the grid -! --------------------------------------------------------------------------------------- -! (1) SETUP MODELS FOR SIMULATION -- POPULATE DATA STRUCTURES -! --------------------------------------------------------------------------------------- -! get model forcing data -INTEGER(I4B) :: NTIM ! number of time steps -INTEGER(I4B) :: INFERN_START ! start of inference period -! get model setup -INTEGER(I4B) :: I ! looping -INTEGER(I4B) :: NMOD ! number of models -INTEGER(I4B) :: ERR ! error code -CHARACTER(LEN=256) :: MESSAGE ! error message -! define model output -LOGICAL(LGT) :: OUTPUT_FLAG ! .TRUE. = write time series output -! --------------------------------------------------------------------------------------- -! (2) CREATE PARAMETER GRID -! --------------------------------------------------------------------------------------- -! Define error code for I/O -INTEGER(I4B) :: IERR ! error code for I/O -! Identify index of the parameter set -INTEGER(I4B) :: IPARSET ! parameter set index -CHARACTER(LEN=4) :: CPARSET ! convert parameter set index to a string -! Define the number of points in each direction -INTEGER(I4B),PARAMETER :: NGRID=1001 ! number of samples across a single parameter dimension -! Looping variables -INTEGER(I4B) :: IPAR ! index of 1st model parameter -INTEGER(I4B) :: JPAR ! index of 2nd model parameter -INTEGER(I4B) :: KPAR ! loop through model parameters -INTEGER(I4B) :: MPAR ! loop through model parameter values -INTEGER(I4B) :: NPAR ! loop through model parameter values -! Identify the initial parameter set -TYPE(PARATT) :: PARAM_META ! parameter metadata (model parameters) -INTEGER(I4B) :: ONEMOD ! index of the model used (=1) -! Parameter vectors -REAL(SP),DIMENSION(:),ALLOCATABLE :: X0I ! parameter vector -REAL(SP),DIMENSION(:),ALLOCATABLE :: XLO ! lower bound on solution, either none or both bounds must be present -REAL(SP),DIMENSION(:),ALLOCATABLE :: XHI ! upper bound on solution, either none or both bounds must be present -REAL(SP),DIMENSION(:),ALLOCATABLE :: XDF ! default parameter vector -REAL(SP) :: FPAR ! function value for parameter set -! --------------------------------------------------------------------------------------- -! (0) READ COMMAND LINE ARGUMENTS -! --------------------------------------------------------------------------------------- -! read command-line arguments -CALL GETARG(1,NSOLUTION) ! numerical solution (0=explicit, 1=implicit) -CALL GETARG(2,FADAPTIVE) ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -CALL GETARG(3,TRUNC_ABS) ! absolute temporal truncation error tolerance -CALL GETARG(4,TRUNC_REL) ! relative temporal truncation error tolerance -CALL GETARG(5,PAR_NAME1) ! name of the 1st parameter in the grid -CALL GETARG(6,PAR_NAME2) ! name of the 2nd parameter in the grid -! check command-line arguments -IF (LEN_TRIM(NSOLUTION).EQ.0) STOP '1st command-line argument is missing (NSOLUTION)' -IF (LEN_TRIM(FADAPTIVE).EQ.0) STOP '2nd command-line argument is missing (FADAPTIVE)' -IF (LEN_TRIM(TRUNC_ABS).EQ.0) STOP '3rd command-line argument is missing (TRUNC_ABS)' -IF (LEN_TRIM(TRUNC_REL).EQ.0) STOP '4th command-line argument is missing (TRUNC_REL)' -IF (LEN_TRIM(PAR_NAME1).EQ.0) STOP '5th command-line argument is missing (PAR_NAME1)' -IF (LEN_TRIM(PAR_NAME2).EQ.0) STOP '6th command-line argument is missing (PAR_NAME2)' -! convert command-line arguments to integer flags and real numbers -CALL GETNUMERIX() ! defines method/parameters used for numerical solution -READ(NSOLUTION,*) SOLUTION_METHOD ! numerical solution (0=EE, 1=EH, 2=IE, 3=IH) -READ(FADAPTIVE,*) TEMPORAL_ERROR_CONTROL ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -READ(TRUNC_ABS,*) ERR_TRUNC_ABS ! absolute temporal truncation error tolerance -READ(TRUNC_REL,*) ERR_TRUNC_REL ! relative temporal truncation error tolerance -! additional checks -SELECT CASE(SOLUTION_METHOD); CASE(EXPLICIT_EULER,EXPLICIT_HEUN,IMPLICIT_EULER,IMPLICIT_HEUN,SEMI_IMPLICIT) -CASE DEFAULT; - STOP 'solution method (1st command line argument) must equal 0 (explicit_euler), 1 (explicit heun), & - &2 (implicit_euler), 3 (implicit_heun), or 4 (semi_implicit)' -END SELECT -SELECT CASE(TEMPORAL_ERROR_CONTROL); CASE(TS_FIXED,TS_ADAPT); CASE DEFAULT; - STOP 'temporal error control (2nd command line argument) must equal 0 (fixed steps) or 1 (adaptive steps)' -END SELECT -write(*,'(A5,1X,2(I1,1X),2(E12.5,1X),I6,1X,A11,1X,I6)') 'FUSE ', & -SOLUTION_METHOD, TEMPORAL_ERROR_CONTROL, ERR_TRUNC_ABS, ERR_TRUNC_REL -! --------------------------------------------------------------------------------------- -! (1) GET MODEL SETUP -- MODEL DEFINITION, AND PARAMETER AND VARIABLE INFO FOR ALL MODELS -! --------------------------------------------------------------------------------------- -! Read data from the "BATEA-compliant" ASCII files -CALL GETFORCING(INFERN_START,NTIM) -!INFERN_START=1; NTIM=20; NUMTIM=NTIM; DELTIM=1._SP -!ALLOCATE(AFORCE(NTIM),AROUTE(NTIM)) ! (shared in module multiroute) -!AFORCE(INFERN_START:NTIM)%PPT = (/0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,50.,50.,50.,50.,50.,0.,0.,0.,0.,0./) -!AFORCE(INFERN_START:NTIM)%PET = (/5.,5.,5.,5.,5.,5.,5.,5.,5.,5., 5., 5., 5., 5., 5.,5.,5.,5.,5.,5./) -! Define model attributes (valid for all models) -CALL UNIQUEMODL(NMOD) ! get nmod unique models -CALL GETPARMETA() ! read parameter metadata (parameter bounds etc.) -! Identify a single model (read control file ../DataFiles/m_decisions.txt) -CALL SELECTMODL(ISTATUS=ERR,MESSAGE=MESSAGE) -IF (ERR.NE.0) THEN - PRINT *, TRIM(MESSAGE); STOP -ENDIF -! Define list of states and parameters for the current model -CALL ASSIGN_STT() ! state definitions are stored in module model_defn -CALL ASSIGN_FLX() ! flux definitions are stored in module model_defn -CALL ASSIGN_PAR() ! parameter defintions are stored in module multiparam -! compute derived model parameters (bucket sizes, etc.) -CALL PAR_DERIVE() -! --------------------------------------------------------------------------------------- -! (2) MAKE A PARAMETER GRID -! --------------------------------------------------------------------------------------- -! allocate arrays -ALLOCATE(X0I(NUMPAR),XLO(NUMPAR),XHI(NUMPAR),XDF(NUMPAR), STAT=IERR) -IF (IERR.NE.0) STOP ' problem allocating space for parameter arrays ' -! get parameter bounds -DO IPAR=1,NUMPAR - CALL GETPAR_STR(LPARAM(IPAR)%PARNAME,PARAM_META) - XLO(IPAR) = PARAM_META%PARLOW - XHI(IPAR) = PARAM_META%PARUPP -END DO -IPARSET = 0 -! loop through example parameter sets -OPEN(21,FILE=TRIM(DATA_PATH)//'param_example.dat') -DO - ! read parameter set - READ(21,*,IOSTAT=IERR) XDF - WRITE(*,'(20(A,1X))') LPARAM(1:NUMPAR); WRITE(*,'(20(F9.3,1X))') XDF - IF (IERR.NE.0) EXIT - ! increment counter - IPARSET = IPARSET + 1 - ! convert counter to a character string - CPARSET=' '; WRITE(CPARSET,'(I4)') IPARSET; CPARSET=ADJUSTR(CPARSET) - FORALL(I=1:LEN(CPARSET)-LEN_TRIM(ADJUSTL(CPARSET))) CPARSET(I:I)='0' - ! define NetCDF files (filename shared in MODULE model_defn) - FNAME_NETCDF = TRIM(OUTPUT_PATH)//TRIM(SMODL%MNAME)//'__'//CPARSET//'__'//& - TRIM(NSOLUTION)//'-'//TRIM(FADAPTIVE)//'__'//& - TRIM(TRUNC_ABS)//'-'//TRIM(TRUNC_REL)//'__'//& - TRIM(PAR_NAME1)//'-'//TRIM(PAR_NAME2)//'__parslice.nc' - write(*,'(a)') trim(fname_netcdf) - ONEMOD=1 ! one file per model (i.e., model dimension = 1) - PCOUNT=0 ! counter for parameter sets in output file (shared in MODULE multistats) - FCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) - OUTPUT_FLAG = .FALSE. ! write model output - CALL DEF_PARAMS(ONEMOD) ! define model parameters (initial CREATE) - IF (OUTPUT_FLAG) CALL DEF_OUTPUT(NTIM) ! define model time series (REDEF) - CALL DEF_SSTATS() ! define summary statistics (REDEF) - X0I = XDF ! set parameters to their default value - ! initial run with default parameter sets - !CALL FUSE_RMSE(X0I,FPAR,OUTPUT_FLAG) - !PAUSE - ! identify IPAR and JPAR - DO KPAR=1,NUMPAR - IF (TRIM(LPARAM(KPAR)%PARNAME).EQ.TRIM(PAR_NAME1)) IPAR = KPAR - IF (TRIM(LPARAM(KPAR)%PARNAME).EQ.TRIM(PAR_NAME2)) JPAR = KPAR - END DO - ! loop through parameter perturbations - !DO MPAR=1,NGRID - DO NPAR=1,NGRID - ! perturb parameters - !X0I(IPAR) = XLO(IPAR) + REAL(MPAR-1,KIND(SP))/REAL(NGRID-1,KIND(SP)) * (XHI(IPAR)-XLO(IPAR)) - X0I(JPAR) = XLO(JPAR) + REAL(NPAR-1,KIND(SP))/REAL(NGRID-1,KIND(SP)) * (XHI(JPAR)-XLO(JPAR)) - ! run model (parameters and statistics are written in FUSE_RMSE) - CALL FUSE_RMSE(X0I,FPAR,OUTPUT_FLAG) - write(*,'(i6,1x,20(f9.3,1x))') PCOUNT, X0I - END DO ! npar - !END DO ! mpar -END DO ! looping through example parameter sets -DEALLOCATE(X0I,XLO,XHI,XDF, STAT=IERR) -IF (IERR.NE.0) STOP ' problem deallocating space for parameter arrays ' -STOP -END PROGRAM PARGRID_DRIVER -! -------------------------------------------------------------------------------------- diff --git a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/pargrid_driver.f90.svn-base b/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/pargrid_driver.f90.svn-base deleted file mode 100644 index 1ea93c3..0000000 --- a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/pargrid_driver.f90.svn-base +++ /dev/null @@ -1,209 +0,0 @@ -PROGRAM PARGRID_DRIVER -! --------------------------------------------------------------------------------------- -! Creator: -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! Driver program for a parameter grid -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE ddirectory ! directory for data files -! data modules -USE model_defn,nstateFUSE=>nstate ! model definition structures -USE multiforce, ONLY: AFORCE, DELTIM, NUMTIM ! data interval = maximum model time step -USE multiparam, ONLY: LPARAM, PARATT, NUMPAR ! parameter metadata structures -USE multiroute, ONLY: AROUTE ! model routing structures -USE multistats ! model statistics structures -! informational modules -USE selectmodl_module ! reads model control file -USE getpar_str_module ! extracts parameter metadata -USE par_insert_module ! inserts model parameters -! model numerix -USE model_numerix ! defines decisions on model numerix -! access to model simulation modules -USE fuse_rmse_module ! run model and compute the root mean squared error -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -! (0) GET COMMAND-LINE ARGUMENTS... -! --------------------------------------------------------------------------------------- -CHARACTER(LEN=12) :: DATSUBSET=' ' ! data subset used (PERIOD1; PERIOD2; ALLDATA) -CHARACTER(LEN=6) :: NSOLUTION=' ' ! numerical solution (0=implicit, 1=explicit) -CHARACTER(LEN=6) :: FADAPTIVE=' ' ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -CHARACTER(LEN=6) :: TRUNC_ABS=' ' ! absolute temporal truncation error tolerance -CHARACTER(LEN=6) :: TRUNC_REL=' ' ! relative temporal truncation error tolerance -CHARACTER(LEN=11) :: PAR_NAME1=' ' ! name of the 1st parameter in the grid -CHARACTER(LEN=11) :: PAR_NAME2=' ' ! name of the 2nd parameter in the grid -! --------------------------------------------------------------------------------------- -! (1) SETUP MODELS FOR SIMULATION -- POPULATE DATA STRUCTURES -! --------------------------------------------------------------------------------------- -! get model forcing data -INTEGER(I4B) :: NTIM ! number of time steps -INTEGER(I4B) :: INFERN_START ! start of inference period -! get model setup -INTEGER(I4B) :: I ! looping -INTEGER(I4B) :: NMOD ! number of models -INTEGER(I4B) :: ERR ! error code -CHARACTER(LEN=256) :: MESSAGE ! error message -! define model output -LOGICAL(LGT) :: OUTPUT_FLAG ! .TRUE. = write time series output -! --------------------------------------------------------------------------------------- -! (2) CREATE PARAMETER GRID -! --------------------------------------------------------------------------------------- -! Define error code for I/O -INTEGER(I4B) :: IERR ! error code for I/O -! Identify index of the parameter set -INTEGER(I4B) :: IPARSET ! parameter set index -CHARACTER(LEN=4) :: CPARSET ! convert parameter set index to a string -! Define the number of points in each direction -INTEGER(I4B),PARAMETER :: NGRID=10001 ! number of samples across a single parameter dimension -! Looping variables -INTEGER(I4B) :: IPAR ! index of 1st model parameter -INTEGER(I4B) :: JPAR ! index of 2nd model parameter -INTEGER(I4B) :: KPAR ! loop through model parameters -INTEGER(I4B) :: MPAR ! loop through model parameter values -INTEGER(I4B) :: NPAR ! loop through model parameter values -! Identify the initial parameter set -TYPE(PARATT) :: PARAM_META ! parameter metadata (model parameters) -INTEGER(I4B) :: ONEMOD ! index of the model used (=1) -! Parameter vectors -REAL(SP),DIMENSION(:),ALLOCATABLE :: X0I ! parameter vector -REAL(SP),DIMENSION(:),ALLOCATABLE :: XLO ! lower bound on solution, either none or both bounds must be present -REAL(SP),DIMENSION(:),ALLOCATABLE :: XHI ! upper bound on solution, either none or both bounds must be present -REAL(SP),DIMENSION(:),ALLOCATABLE :: XDF ! default parameter vector -REAL(SP) :: FPAR ! function value for parameter set -REAL(SP) :: T1,T2 ! CPU time -! --------------------------------------------------------------------------------------- -! (0) READ COMMAND LINE ARGUMENTS -! --------------------------------------------------------------------------------------- -! read command-line arguments -CALL GETARG(1,DATSUBSET) ! data subset used (PERIOD1; PERIOD2; ALLDATA) -CALL GETARG(2,NSOLUTION) ! numerical solution (0=explicit, 1=implicit) -CALL GETARG(3,FADAPTIVE) ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -CALL GETARG(4,TRUNC_ABS) ! absolute temporal truncation error tolerance -CALL GETARG(5,TRUNC_REL) ! relative temporal truncation error tolerance -CALL GETARG(6,PAR_NAME1) ! name of the 1st parameter in the grid -CALL GETARG(7,PAR_NAME2) ! name of the 2nd parameter in the grid -! check command-line arguments -IF (LEN_TRIM(DATSUBSET).EQ.0) STOP '1st command-line argument is missing (DATSUBSET)' -IF (LEN_TRIM(NSOLUTION).EQ.0) STOP '2nd command-line argument is missing (NSOLUTION)' -IF (LEN_TRIM(FADAPTIVE).EQ.0) STOP '3rd command-line argument is missing (FADAPTIVE)' -IF (LEN_TRIM(TRUNC_ABS).EQ.0) STOP '4th command-line argument is missing (TRUNC_ABS)' -IF (LEN_TRIM(TRUNC_REL).EQ.0) STOP '5th command-line argument is missing (TRUNC_REL)' -IF (LEN_TRIM(PAR_NAME1).EQ.0) STOP '6th command-line argument is missing (PAR_NAME1)' -IF (LEN_TRIM(PAR_NAME2).EQ.0) STOP '7th command-line argument is missing (PAR_NAME2)' -! convert command-line arguments to integer flags and real numbers -CALL GETNUMERIX() ! defines method/parameters used for numerical solution -READ(NSOLUTION,*) SOLUTION_METHOD ! numerical solution (0=EE, 1=EH, 2=IE, 3=IH) -READ(FADAPTIVE,*) TEMPORAL_ERROR_CONTROL ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -READ(TRUNC_ABS,*) ERR_TRUNC_ABS ! absolute temporal truncation error tolerance -READ(TRUNC_REL,*) ERR_TRUNC_REL ! relative temporal truncation error tolerance -! additional checks -SELECT CASE(SOLUTION_METHOD); CASE(EXPLICIT_EULER,EXPLICIT_HEUN,IMPLICIT_EULER,IMPLICIT_HEUN,SEMI_IMPLICIT) -CASE DEFAULT; - STOP 'solution method (1st command line argument) must equal 0 (explicit_euler), 1 (explicit heun), & - &2 (implicit_euler), 3 (implicit_heun), or 4 (semi_implicit)' -END SELECT -SELECT CASE(TEMPORAL_ERROR_CONTROL); CASE(TS_FIXED,TS_ADAPT); CASE DEFAULT; - STOP 'temporal error control (2nd command line argument) must equal 0 (fixed steps) or 1 (adaptive steps)' -END SELECT -write(*,'(A5,1X,2(I1,1X),2(E12.5,1X),I6,1X,A11,1X,I6)') 'FUSE ', & -SOLUTION_METHOD, TEMPORAL_ERROR_CONTROL, ERR_TRUNC_ABS, ERR_TRUNC_REL -! --------------------------------------------------------------------------------------- -! (1) GET MODEL SETUP -- MODEL DEFINITION, AND PARAMETER AND VARIABLE INFO FOR ALL MODELS -! --------------------------------------------------------------------------------------- -! Define data file (shared in ddirectory) -FORCINGINFO='forcinginfo.'//TRIM(DATSUBSET)//'.txt' -! Read data from the "BATEA-compliant" ASCII files -CALL GETFORCING(INFERN_START,NTIM) -!INFERN_START=1; NTIM=20; NUMTIM=NTIM; DELTIM=1._SP -!ALLOCATE(AFORCE(NTIM),AROUTE(NTIM)) ! (shared in module multiroute) -!AFORCE(INFERN_START:NTIM)%PPT = (/0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,50.,50.,50.,50.,50.,0.,0.,0.,0.,0./) -!AFORCE(INFERN_START:NTIM)%PET = (/5.,5.,5.,5.,5.,5.,5.,5.,5.,5., 5., 5., 5., 5., 5.,5.,5.,5.,5.,5./) -! Define model attributes (valid for all models) -CALL UNIQUEMODL(NMOD) ! get nmod unique models -CALL GETPARMETA() ! read parameter metadata (parameter bounds etc.) -! Identify a single model (read control file ../DataFiles/m_decisions.txt) -CALL SELECTMODL(ISTATUS=ERR,MESSAGE=MESSAGE) -IF (ERR.NE.0) THEN - PRINT *, TRIM(MESSAGE); STOP -ENDIF -! Define list of states and parameters for the current model -CALL ASSIGN_STT() ! state definitions are stored in module model_defn -CALL ASSIGN_FLX() ! flux definitions are stored in module model_defn -CALL ASSIGN_PAR() ! parameter defintions are stored in module multiparam -! compute derived model parameters (bucket sizes, etc.) -CALL PAR_DERIVE() -! --------------------------------------------------------------------------------------- -! (2) MAKE A PARAMETER GRID -! --------------------------------------------------------------------------------------- -! allocate arrays -ALLOCATE(X0I(NUMPAR),XLO(NUMPAR),XHI(NUMPAR),XDF(NUMPAR), STAT=IERR) -! allocate space for the constant Jacobians -ALLOCATE(fjacCOPY(nstateFUSE,nstateFUSE),fjacDCMP(nstateFUSE,nstateFUSE),fjacINDX(nstateFUSE)) -IF (IERR.NE.0) STOP ' problem allocating space for parameter arrays ' -! get parameter bounds -DO IPAR=1,NUMPAR - CALL GETPAR_STR(LPARAM(IPAR)%PARNAME,PARAM_META) - XLO(IPAR) = PARAM_META%PARLOW - XHI(IPAR) = PARAM_META%PARUPP - XDF(IPAR) = PARAM_META%PARDEF - !PRINT *, LPARAM(IPAR), PARAM_META%PARLOW, PARAM_META%PARUPP -END DO -IPARSET = 0 -! loop through example parameter sets -OPEN(21,FILE=TRIM(DATA_PATH)//'param_example.dat') -DO - ! read parameter set - READ(21,*,IOSTAT=IERR) XDF; IF (IERR.NE.0) EXIT - WRITE(*,'(20(A12,1X))') LPARAM(1:NUMPAR); WRITE(*,'(20(F12.6,1X))') XDF - ! increment counter - IPARSET = IPARSET + 1 - ! convert counter to a character string - CPARSET=' '; WRITE(CPARSET,'(I4)') IPARSET; CPARSET=ADJUSTR(CPARSET) - FORALL(I=1:LEN(CPARSET)-LEN_TRIM(ADJUSTL(CPARSET))) CPARSET(I:I)='0' - ! define NetCDF files (filename shared in MODULE model_defn) - FNAME_NETCDF = TRIM(OUTPUT_PATH)//TRIM(DATSUBSET)//'__'//TRIM(SMODL%MNAME)//'__'//CPARSET//'__'//& - TRIM(NSOLUTION)//'-'//TRIM(FADAPTIVE)//'__'//& - TRIM(TRUNC_ABS)//'-'//TRIM(TRUNC_REL)//'__'//& - TRIM(PAR_NAME1)//'-'//TRIM(PAR_NAME2)//'__pargrid.nc' - write(*,'(a)') trim(fname_netcdf) - ONEMOD=1 ! one file per model (i.e., model dimension = 1) - PCOUNT=0 ! counter for parameter sets in output file (shared in MODULE multistats) - FCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) - OUTPUT_FLAG = .FALSE. ! write model output - CALL DEF_PARAMS(ONEMOD) ! define model parameters (initial CREATE) - IF (OUTPUT_FLAG) CALL DEF_OUTPUT(NTIM) ! define model time series (REDEF) - CALL DEF_SSTATS() ! define summary statistics (REDEF) - X0I = XDF ! set parameters to their default value - ! initial run with default parameter sets - !JAC_RECOMPUTE=SMALL_F_RATIO - !THRESH_FRZE = 0.2 - !CALL CPU_TIME(T1) - !CALL FUSE_RMSE(X0I,FPAR,OUTPUT_FLAG) - !CALL CPU_TIME(T2) - !print *, T2-T1 - !STOP - ! identify IPAR and JPAR - DO KPAR=1,NUMPAR - IF (TRIM(LPARAM(KPAR)%PARNAME).EQ.TRIM(PAR_NAME1)) IPAR = KPAR - IF (TRIM(LPARAM(KPAR)%PARNAME).EQ.TRIM(PAR_NAME2)) JPAR = KPAR - END DO - ! loop through parameter perturbations - !DO MPAR=1,NGRID - DO NPAR=1,NGRID - ! perturb parameters - !X0I(IPAR) = XLO(IPAR) + REAL(MPAR-1,KIND(SP))/REAL(NGRID-1,KIND(SP)) * (XHI(IPAR)-XLO(IPAR)) - X0I(JPAR) = XLO(JPAR) + REAL(NPAR-1,KIND(SP))/REAL(NGRID-1,KIND(SP)) * (XHI(JPAR)-XLO(JPAR)) - ! run model (parameters and statistics are written in FUSE_RMSE) - CALL FUSE_RMSE(X0I,FPAR,OUTPUT_FLAG) - write(*,'(i6,1x,20(f9.3,1x))') PCOUNT, X0I - END DO ! npar - !END DO ! mpar -END DO ! looping through example parameter sets -DEALLOCATE(X0I,XLO,XHI,XDF, STAT=IERR) -IF (IERR.NE.0) STOP ' problem deallocating space for parameter arrays ' -DEALLOCATE(fjacCOPY,fjacDCMP,fjacINDX) -IF (IERR.NE.0) STOP ' problem deallocating space for jacabian copies ' -STOP -END PROGRAM PARGRID_DRIVER -! -------------------------------------------------------------------------------------- diff --git a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/parslice_optim.f90.svn-base b/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/parslice_optim.f90.svn-base deleted file mode 100644 index 627620a..0000000 --- a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/parslice_optim.f90.svn-base +++ /dev/null @@ -1,288 +0,0 @@ -PROGRAM PARSLICE_OPTIM -! --------------------------------------------------------------------------------------- -! Creator: -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! Driver program to create a parameter slice at the optimal value -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE ddirectory ! directory for data files -! data modules -USE model_defn,nstateFUSE=>nstate ! model definition structures -USE multiforce, ONLY: DELTIM ! data interval = maximum model time step -USE multiparam, ONLY: LPARAM, PARATT, NUMPAR ! parameter metadata structures -USE multiroute ! model routing structures -USE multistats ! model statistics structures -! informational modules -USE selectmodl_module ! reads model control file -USE getpar_str_module ! extracts parameter metadata -USE par_insert_module ! inserts model parameters -USE get_objfnc_module ! wrapper to get objective function from NetCDF output files -USE metaoutput, ONLY: Q_ONLY ! Q_ONLY=.TRUE. to restrict write to streamflow time series -! model numerix -USE model_numerix ! defines decisions on model numerix -! access to qnewton and model simulation modules -USE dmsl_wrapper_module ! wrapper for dmsl -USE fuse_rmse_module ! run model and compute the root mean squared error -! software settings (Windows only) -!use softwareData -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -! (0) GET COMMAND-LINE ARGUMENTS... -! --------------------------------------------------------------------------------------- -LOGICAL(LGT) :: READ_ARG ! .true. to read command-line arguments -CHARACTER(LEN=12) :: MBASIN_ID=' ' ! MOPEX basin ID -CHARACTER(LEN=6) :: FMODEL_ID=' ' ! integer defining FUSE model -CHARACTER(LEN=6) :: NSOLUTION=' ' ! numerical solution (0=implicit, 1=explicit) -CHARACTER(LEN=6) :: FADAPTIVE=' ' ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -CHARACTER(LEN=6) :: TRUNC_ABS=' ' ! absolute temporal truncation error tolerance -CHARACTER(LEN=6) :: TRUNC_REL=' ' ! relative temporal truncation error tolerance -CHARACTER(LEN=6) :: NUM_MULTI=' ' ! number of multiple re-starts -CHARACTER(LEN=6) :: SOBOLSEED=' ' ! starting seed in the Sobol sequence -CHARACTER(LEN=6) :: NUMDIGITS=' ' ! number of reliable digits in function evaluation -CHARACTER(LEN=6) :: DO_QNEWTN=' ' ! T means do the quasi-Newton -CHARACTER(LEN=11) :: PARAMNAME=' ' ! parameter name -! --------------------------------------------------------------------------------------- -! (1) SETUP MODELS FOR SIMULATION -- POPULATE DATA STRUCTURES -! --------------------------------------------------------------------------------------- -! get model forcing data -INTEGER(I4B) :: NTIM ! number of time steps -INTEGER(I4B) :: INFERN_START ! start of inference period -! get model setup -INTEGER(I4B) :: FUSE_ID ! integer defining FUSE model -INTEGER(I4B) :: I,J,K ! looping -INTEGER(I4B) :: NMOD ! number of models -INTEGER(I4B) :: ERR ! error code -CHARACTER(LEN=256) :: MESSAGE ! error message -! define model output -LOGICAL(LGT) :: OUTPUT_FLAG ! .TRUE. = write time series output -! --------------------------------------------------------------------------------------- -! (2) MULTI-START QUASI-NETWON OPTIMIZATION -! --------------------------------------------------------------------------------------- -! Check if there is a need to run the multi-start qNewton method -LOGICAL(LGT) :: QNEW_FLAG ! .TRUE. means run multi-start qNewton -CHARACTER(LEN=32) :: OF_NAME ! name of the desired objective function -REAL(SP), DIMENSION(:), ALLOCATABLE :: OF_VALS ! objective function values -! Control of the multi-start method -INTEGER(I4B) :: NMULTI ! number of multiple re-starts -INTEGER(I4B) :: IBEGIN ! starting seed in the Sobol sequence -! Define file unit -INTEGER(I4B), PARAMETER :: UOUT_QNEW=21 ! output unit for run-time information (quasi-newton) -! Looping variables -INTEGER(I4B) :: ISEED ! loop through seeds in the Sobol sequence -INTEGER(I4B) :: IPAR ! loop through model parameters -! Identify the initial parameter set -INTEGER(KIND=4) :: JSEED ! index in the Sobol sequence -REAL(KIND=4),DIMENSION(:),ALLOCATABLE :: URAND ! vector of uniform random numbers (from the Sobol sequence) -TYPE(PARATT) :: PARAM_META ! parameter metadata (model parameters) -REAL(SP),PARAMETER :: PSELECT=0.9_SP ! fraction of parameter space to select initial seed -INTEGER(I4B) :: ONEMOD ! index of the model used (=1) -! Input to qNewton -REAL(SP),DIMENSION(:),ALLOCATABLE :: X0I ! initial estimate of solution -REAL(SP),DIMENSION(:),ALLOCATABLE :: XLO ! lower bound on solution, either none or both bounds must be present -REAL(SP),DIMENSION(:),ALLOCATABLE :: XHI ! upper bound on solution, either none or both bounds must be present -REAL(SP),DIMENSION(:),ALLOCATABLE :: XSC ! typical scale of the parameters -INTEGER(I4B) :: FDIGITS ! number of reliable digits in function evaluation -!***** ! (-2=estimate,-1=full machine precision) -! Approximate optimal solution -REAL(SP),DIMENSION(:),ALLOCATABLE :: XOPT ! optimum value of "x", for which f(x) takes its minimum value -REAL(SP) :: FOPT ! function value at optimum -REAL(SP),DIMENSION(:,:),ALLOCATABLE :: XPAR ! parameter sets for all local optima -! Computational cost report -INTEGER(I4B) :: ITER ! number of steps (iterations) -INTEGER(I4B) :: FCALLS ! number of function calls -INTEGER(I4B) :: GCALLS ! number of gradient calls -INTEGER(I4B) :: HCALLS ! number of Hessian calls -! --------------------------------------------------------------------------------------- -! (2) PARAMETER SLICE -! --------------------------------------------------------------------------------------- -INTEGER(I4B) :: KPAR,MPAR ! loop through parameters -INTEGER(I4B) :: IWANT ! index of desired parameter set -INTEGER(I4B),DIMENSION(1) :: IMIN ! location of minimum value -INTEGER(I4B),PARAMETER :: NGRID=1001 ! number of elements in the slice -! --------------------------------------------------------------------------------------- -! (1) READ COMMAND LINE ARGUMENTS -! --------------------------------------------------------------------------------------- -! read command-line arguments -CALL GETARG( 1,MBASIN_ID) ! MOPEX basin ID -CALL GETARG( 2,FMODEL_ID) ! integer defining FUSE model -CALL GETARG( 3,NSOLUTION) ! numerical solution (0=explicit, 1=implicit) -CALL GETARG( 4,FADAPTIVE) ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -CALL GETARG( 5,TRUNC_ABS) ! absolute temporal truncation error tolerance -CALL GETARG( 6,TRUNC_REL) ! relative temporal truncation error tolerance -CALL GETARG( 7,NUM_MULTI) ! number of re-starts -CALL GETARG( 8,SOBOLSEED) ! starting seed in the Sobol sequence -CALL GETARG( 9,NUMDIGITS) ! number of reliable digits in function evaluation -CALL GETARG(10,DO_QNEWTN) ! T = run multi-start quasi-Newton -CALL GETARG(11,PARAMNAME) ! parameter name -! check command-line arguments -IF (LEN_TRIM(MBASIN_ID).EQ.0) STOP ' 1st command-line argument is missing (MBASIN_ID)' -IF (LEN_TRIM(FMODEL_ID).EQ.0) STOP ' 2nd command-line argument is missing (FMODEL_ID)' -IF (LEN_TRIM(NSOLUTION).EQ.0) STOP ' 3rd command-line argument is missing (NSOLUTION)' -IF (LEN_TRIM(FADAPTIVE).EQ.0) STOP ' 4th command-line argument is missing (FADAPTIVE)' -IF (LEN_TRIM(TRUNC_ABS).EQ.0) STOP ' 5th command-line argument is missing (TRUNC_ABS)' -IF (LEN_TRIM(TRUNC_REL).EQ.0) STOP ' 6th command-line argument is missing (TRUNC_REL)' -IF (LEN_TRIM(NUM_MULTI).EQ.0) STOP ' 7th command-line argument is missing (NUM_MULTI)' -IF (LEN_TRIM(SOBOLSEED).EQ.0) STOP ' 8th command-line argument is missing (SOBOLSEED)' -IF (LEN_TRIM(NUMDIGITS).EQ.0) STOP ' 9th command-line argument is missing (NUMDIGITS)' -IF (LEN_TRIM(DO_QNEWTN).EQ.0) STOP '10th command-line argument is missing (DO_QNEWTN)' -IF (LEN_TRIM(PARAMNAME).EQ.0) STOP '11th command-line argument is missing (PARAMNAME)' -! define basin desired -FORCINGINFO = 'forcinginfo.'//TRIM(MBASIN_ID)//'.txt' -! convert command-line arguments to integer flags and real numbers -CALL GETNUMERIX() ! defines method/parameters used for numerical solution -READ(FMODEL_ID,*) FUSE_ID ! integer definining FUSE model -READ(NSOLUTION,*) SOLUTION_METHOD ! numerical solution (0=implicit, 1=explicit) -READ(FADAPTIVE,*) TEMPORAL_ERROR_CONTROL ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -READ(TRUNC_ABS,*) ERR_TRUNC_ABS ! absolute temporal truncation error tolerance -READ(TRUNC_REL,*) ERR_TRUNC_REL ! relative temporal truncation error tolerance -READ(NUM_MULTI,*) NMULTI ! define the number of re-starts -READ(SOBOLSEED,*) IBEGIN ! starting seed in the Sobol sequence -READ(NUMDIGITS,*) FDIGITS ! number of reliable digits in function evaluation -! check if there is a need to run the multi-start quasi-Newton method -QNEW_FLAG=.FALSE. -IF (LEN_TRIM(DO_QNEWTN).EQ.1) THEN - IF (DO_QNEWTN.EQ.'T') QNEW_FLAG=.TRUE. -ENDIF -! additional checks -SELECT CASE(SOLUTION_METHOD); CASE(EXPLICIT_EULER,EXPLICIT_HEUN,IMPLICIT_EULER,IMPLICIT_HEUN,SEMI_IMPLICIT) -CASE DEFAULT - PRINT *, 'solution method (1st command line argument) must equal 0 (explicit_euler), 1 (explicit heun), '//& - '2 (implicit_euler), 3 (implicit_heun), or 4 (semi_implicit)' - STOP -END SELECT -SELECT CASE(TEMPORAL_ERROR_CONTROL); CASE(TS_FIXED,TS_ADAPT); CASE DEFAULT; - STOP 'temporal error control (2nd command line argument) must equal 0 (fixed steps) or 1 (adaptive steps)' -END SELECT -IF (NMULTI.LE.0) STOP 'number of re-starts (6th command line argument) must be > 0' -IF (IBEGIN.LE.0) STOP 'starting seed in the Sobol sequence must be greater > 0' -write(*,'(A5,1X,2(I1,1X),2(E12.5,1X),I6,1X,A11,1X,2(I6,1X))') 'FUSE ', & -SOLUTION_METHOD, TEMPORAL_ERROR_CONTROL, ERR_TRUNC_ABS, ERR_TRUNC_REL, & -NMULTI, TRIM(SOBOLSEED), IBEGIN, FDIGITS -! --------------------------------------------------------------------------------------- -! (1) GET MODEL SETUP -- MODEL DEFINITION, AND PARAMETER AND VARIABLE INFO FOR ALL MODELS -! --------------------------------------------------------------------------------------- -! Read data from the "BATEA-compliant" ASCII files -CALL GETFORCING(INFERN_START,NTIM) -! Define model attributes (valid for all models) -CALL UNIQUEMODL(NMOD) ! get nmod unique models -CALL GETPARMETA() ! read parameter metadata (parameter bounds etc.) -! Identify a single model (use FUSE_ID instead of reading ../input/m_decisions.txt) -CALL SELECTMODL(FUSE_ID,ISTATUS=ERR,MESSAGE=MESSAGE) -IF (ERR.NE.0) THEN - PRINT *, TRIM(MESSAGE); STOP -ENDIF -! Define list of states and parameters for the current model -CALL ASSIGN_STT() ! state definitions are stored in module model_defn -CALL ASSIGN_PAR() ! parameter defintions are stored in module multiparam -CALL ASSIGN_FLX() ! flux definitions stored in module model_defn -! compute derived model parameters (bucket sizes, etc.) -CALL PAR_DERIVE() -! allocate arrays for quasi-Newton -ALLOCATE(X0I(NUMPAR),XLO(NUMPAR),XHI(NUMPAR),XSC(NUMPAR),URAND(NUMPAR),XOPT(NUMPAR)) -! get parameter bounds -DO IPAR=1,NUMPAR - CALL GETPAR_STR(LPARAM(IPAR)%PARNAME,PARAM_META) - XLO(IPAR) = PARAM_META%PARLOW ! lower bound - XHI(IPAR) = PARAM_META%PARUPP ! upper bound -END DO -! -------------------------------------------------------------------------------------- -! (2) MULTI START QUASI-NEWTON... -! -------------------------------------------------------------------------------------- -! define the desired objective function and allocate space for the objective function values -OF_NAME = 'raw_rmse'; ALLOCATE(OF_VALS(NMULTI),XPAR(NUMPAR,NMULTI)) -! loop through different starting positions (use the Sobol sequence) -DO ISEED=IBEGIN,(IBEGIN+NMULTI)-1 - ! get the seed as a character string - WRITE(SOBOLSEED,'(i3.3)') ISEED - ! define file prefix (add seeds) - FNAME_PREFIX = TRIM(OUTPUT_PATH)//'DMSL_'//TRIM(MBASIN_ID)//'__'//TRIM(SMODL%MNAME)//'__'//TRIM(SOBOLSEED)//'__'//& - TRIM(NSOLUTION)//'-'//TRIM(FADAPTIVE)//'__'//TRIM(NUMDIGITS)//'__'//& - TRIM(TRUNC_ABS)//'__'//TRIM(TRUNC_REL) - ! define NetCDF files (filename shared in MODULE model_defn) - FNAME_NETCDF = TRIM(FNAME_PREFIX)//'__qnewton.nc' - ONEMOD=1 ! one file per model (i.e., model dimension = 1) - - ! check if there is a need to run quasi-Newton - IF (QNEW_FLAG) THEN ! need to run quasi-Newton - PCOUNT=0 ! counter for parameter sets in output file (shared in MODULE multistats) - FCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) - OUTPUT_FLAG = .TRUE. ! write model time series - Q_ONLY = .TRUE. ! restrict output time series to simulated runofff - CALL DEF_PARAMS(ONEMOD) ! define model parameters (initial CREATE) - IF (OUTPUT_FLAG) CALL DEF_OUTPUT(NTIM) ! define model time series (REDEF) - CALL DEF_SSTATS() ! define summary statistics (REDEF) - ! define ASCII files (filename shared in MODULE model_defn) - FNAME_ASCII = TRIM(FNAME_PREFIX)//'__qnewton.txt' - ! open ASCII file (unit 21) - OPEN(UOUT_QNEW,FILE=FNAME_ASCII, STATUS='unknown') - ! get new parameter sets - JSEED=ISEED; CALL I4_SOBOL(NUMPAR,JSEED,URAND) - WRITE(*,'(2(I4,1X),20(E10.2,1X))') ISEED, JSEED-1, URAND - X0I = XLO + ((1._SP - PSELECT)/2._SP)*(XHI-XLO) + (PSELECT*REAL(URAND,KIND(SP)))*(XHI-XLO) - ! find local optimum in the vicinity of the starting point - CALL QNEWTON_WRAPPER(X0I,XLO,XHI,XSC,FDIGITS,UOUT_QNEW,XOPT,FOPT,ITER,FCALLS,GCALLS,HCALLS,& - ERR,MESSAGE) - IF (ERR.NE.0) PRINT *, TRIM(MESSAGE) - WRITE(*,'(5(I6,1X),20(F9.3,1X))') FCOUNT,ITER,FCALLS,GCALLS,HCALLS,FOPT,XOPT - ! run model again with optimum parameter set (to populate structures and write model output) - CALL FUSE_RMSE(XOPT,FOPT,OUTPUT_FLAG) - ! write model parameters and summary statistics - CALL PUT_PARAMS(PCOUNT,ONEMOD) ! PCOUNT = index for parameter set; ONEMOD=1 (just one model structure) - CALL PUT_SSTATS(PCOUNT,ONEMOD) - CLOSE(UOUT_QNEW) - ENDIF - ! get objective function value for the first parameter set - PCOUNT=1; CALL GET_OBJFNC(FNAME_NETCDF,OF_NAME,ONEMOD,PCOUNT,FOPT,XOPT) - OF_VALS(ISEED) = FOPT - XPAR(:,ISEED) = XOPT(:) - write(*,'(20(f12.6,1x))') OF_VALS(ISEED), XPAR(:,ISEED) -END DO -! -------------------------------------------------------------------------------------- -! (3) PARAMETER SLICE... -! -------------------------------------------------------------------------------------- -! identify the maximum seed and retrieve model parameter set -IMIN = MINLOC(OF_VALS) -FOPT = OF_VALS(IMIN(1)) -XOPT(:) = XPAR(:,IMIN(1)) -write(*,'(i3,1x,20(f12.6,1x))') IMIN(1), FOPT, XOPT -! get parameter bounds -DO IPAR=1,NUMPAR - CALL GETPAR_STR(LPARAM(IPAR)%PARNAME,PARAM_META) - XLO(IPAR) = PARAM_META%PARLOW - XHI(IPAR) = PARAM_META%PARUPP - WRITE(*,'(A15,1X,F12.5)') LPARAM(IPAR)%PARNAME, XOPT(IPAR) -END DO -STOP -! define write parameters for model output -PCOUNT=0 ! counter for parameter sets in output file (shared in MODULE multistats) -FCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) -OUTPUT_FLAG = .TRUE. ! write model time series -Q_ONLY = .TRUE. ! restrict output time series to simulated runoff -! define file prefix (no seeds in the filename) -FNAME_PREFIX = TRIM(OUTPUT_PATH)//'DMSL_'//TRIM(MBASIN_ID)//'__'//TRIM(SMODL%MNAME)//'__'//& - TRIM(NSOLUTION)//'-'//TRIM(FADAPTIVE)//'__'//TRIM(NUMDIGITS)//'__'//& - TRIM(TRUNC_ABS)//'__'//TRIM(TRUNC_REL)//'__'//TRIM(PARAMNAME) -! define NetCDF files (filename shared in MODULE model_defn) -FNAME_NETCDF = TRIM(FNAME_PREFIX)//'__parslice.nc' -CALL DEF_PARAMS(ONEMOD) ! define model parameters (initial CREATE) -IF (OUTPUT_FLAG) CALL DEF_OUTPUT(NTIM) ! define model time series (REDEF) -CALL DEF_SSTATS() ! define summary statistics (REDEF) -! identify parameter index -DO KPAR=1,NUMPAR - IF (TRIM(LPARAM(KPAR)%PARNAME).EQ.TRIM(PARAMNAME)) IWANT = KPAR -END DO -! loop through parameter perturbations -DO MPAR=1,NGRID - ! perturb parameters - !XOPT(IWANT) = XLO(IWANT) + REAL(MPAR-1,KIND(SP))/REAL(NGRID-1,KIND(SP)) * (XHI(IWANT)-XLO(IWANT)) - ! run model (parameters and statistics are written in FUSE_RMSE) - CALL FUSE_RMSE(XOPT,FOPT,OUTPUT_FLAG) - STOP -END DO -! deallocate parameter vectors -DEALLOCATE(X0I,XLO,XHI,XSC,URAND,XOPT) -STOP -END PROGRAM PARSLICE_OPTIM -! -------------------------------------------------------------------------------------- diff --git a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/qnewton_mcmc__driver.f90.svn-base b/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/qnewton_mcmc__driver.f90.svn-base deleted file mode 100644 index cde4ef0..0000000 --- a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/qnewton_mcmc__driver.f90.svn-base +++ /dev/null @@ -1,366 +0,0 @@ - -!****************************************************************** -!module softwareData -! Purpose: -! Programmer: Dmitri Kavetski -! Last modified: -! Comments: -!use DFWIN,only:GetCurrentProcessId -!implicit none -! type definitions -! variable definitions -!integer(INT_PTR_KIND())::myProcID -!---------------------------------------------------- -!contains -!---------------------------------------------------- -!function getMyProcID() -! Purpose: Returns the processID of the callling process. -! Programmer: Dmitri Kavetski -! Last modified: -! Performance -! IN: -! OUT: -! Comments: -!use DFWIN,only:GetCurrentProcessId -!implicit none -! dummies -!integer(INT_PTR_KIND())::getMyProcID -! Start procedure here -!getMyProcID=GetCurrentProcessId() -! End procedure here -!endfunction getMyProcID -!---------------------------------------------------- -!endmodule softwareData -!****************************************************************** - - - -PROGRAM QNEW_MCMC__DRIVER -! --------------------------------------------------------------------------------------- -! Creator: -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! Driver program for multi-start quasi-newton optimization -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE ddirectory ! directory for data files -! data modules -USE model_defn,nstateFUSE=>nstate ! model definition structures -USE multiforce, ONLY: DELTIM ! data interval = maximum model time step -USE multiparam, ONLY: LPARAM, PARATT, NUMPAR ! parameter metadata structures -USE multiroute ! model routing structures -USE multistats ! model statistics structures -! informational modules -USE selectmodl_module ! reads model control file -USE getpar_str_module ! extracts parameter metadata -USE par_insert_module ! inserts model parameters -USE get_objfnc_module ! wrapper to get objective function from NetCDF output files -USE metaoutput, ONLY: Q_ONLY ! Q_ONLY=.TRUE. to restrict write to streamflow time series -! model numerix -USE model_numerix ! defines decisions on model numerix -! access to qnewton and model simulation modules -USE dmsl_wrapper_module ! wrapper for dmsl -USE fuse_rmse_module ! run model and compute the root mean squared error -! software settings (Windows only) -!use softwareData -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -! (0) GET COMMAND-LINE ARGUMENTS... -! --------------------------------------------------------------------------------------- -LOGICAL(LGT) :: READ_ARG ! .true. to read command-line arguments -CHARACTER(LEN=12) :: MBASIN_ID=' ' ! MOPEX basin ID -CHARACTER(LEN=6) :: FMODEL_ID=' ' ! integer defining FUSE model -CHARACTER(LEN=6) :: NSOLUTION=' ' ! numerical solution (0=implicit, 1=explicit) -CHARACTER(LEN=6) :: FADAPTIVE=' ' ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -CHARACTER(LEN=6) :: TRUNC_ABS=' ' ! absolute temporal truncation error tolerance -CHARACTER(LEN=6) :: TRUNC_REL=' ' ! relative temporal truncation error tolerance -CHARACTER(LEN=6) :: NUM_MULTI=' ' ! number of multiple re-starts -CHARACTER(LEN=6) :: SOBOLSEED=' ' ! starting seed in the Sobol sequence -CHARACTER(LEN=6) :: NUMDIGITS=' ' ! number of reliable digits in function evaluation -CHARACTER(LEN=6) :: DO_QNEWTN=' ' ! T means do the quasi-Newton -! --------------------------------------------------------------------------------------- -! (1) SETUP MODELS FOR SIMULATION -- POPULATE DATA STRUCTURES -! --------------------------------------------------------------------------------------- -! get model forcing data -INTEGER(I4B) :: NTIM ! number of time steps -INTEGER(I4B) :: INFERN_START ! start of inference period -! get model setup -INTEGER(I4B) :: FUSE_ID ! integer defining FUSE model -INTEGER(I4B) :: I,J,K ! looping -INTEGER(I4B) :: NMOD ! number of models -INTEGER(I4B) :: ERR ! error code -CHARACTER(LEN=256) :: MESSAGE ! error message -! define model output -LOGICAL(LGT) :: OUTPUT_FLAG ! .TRUE. = write time series output -! --------------------------------------------------------------------------------------- -! (2) MULTI-START QUASI-NETWON OPTIMIZATION -! --------------------------------------------------------------------------------------- -! Check if there is a need to run the multi-start qNewton method -LOGICAL(LGT) :: QNEW_FLAG ! .TRUE. means run multi-start qNewton -CHARACTER(LEN=32) :: OF_NAME ! name of the desired objective function -REAL(SP), DIMENSION(:), ALLOCATABLE :: OF_VALS ! objective functioni values -! Control of the multi-start method -INTEGER(I4B) :: NMULTI ! number of multiple re-starts -INTEGER(I4B) :: IBEGIN ! starting seed in the Sobol sequence -! Define file unit -INTEGER(I4B), PARAMETER :: UOUT_QNEW=21 ! output unit for run-time information (quasi-newton) -! Looping variables -INTEGER(I4B) :: ISEED ! loop through seeds in the Sobol sequence -INTEGER(I4B) :: IPAR ! loop through model parameters -! Identify the initial parameter set -INTEGER(KIND=4) :: JSEED ! index in the Sobol sequence -REAL(KIND=4),DIMENSION(:),ALLOCATABLE :: URAND ! vector of uniform random numbers (from the Sobol sequence) -TYPE(PARATT) :: PARAM_META ! parameter metadata (model parameters) -REAL(SP),PARAMETER :: PSELECT=0.9_SP ! fraction of parameter space to select initial seed -INTEGER(I4B) :: ONEMOD ! index of the model used (=1) -! Input to qNewton -REAL(SP),DIMENSION(:),ALLOCATABLE :: X0I ! initial estimate of solution -REAL(SP),DIMENSION(:),ALLOCATABLE :: XLO ! lower bound on solution, either none or both bounds must be present -REAL(SP),DIMENSION(:),ALLOCATABLE :: XHI ! upper bound on solution, either none or both bounds must be present -REAL(SP),DIMENSION(:),ALLOCATABLE :: XSC ! typical scale of the parameters -INTEGER(I4B) :: FDIGITS ! number of reliable digits in function evaluation -!***** ! (-2=estimate,-1=full machine precision) -! Approximate optimal solution -REAL(SP),DIMENSION(:),ALLOCATABLE :: XOPT ! optimum value of "x", for which f(x) takes its minimum value -REAL(SP) :: FOPT ! function value at optimum -! Computational cost report -INTEGER(I4B) :: ITER ! number of steps (iterations) -INTEGER(I4B) :: FCALLS ! number of function calls -INTEGER(I4B) :: GCALLS ! number of gradient calls -INTEGER(I4B) :: HCALLS ! number of Hessian calls -! --------------------------------------------------------------------------------------- -! (2) MONTE-CARLO MARKOV CHAINS -! --------------------------------------------------------------------------------------- -! Define initial sample and diagonal of the covariance matrix -real(mrk),dimension(:),allocatable :: sample0,covDiag0 -! Define files -CHARACTER(LEN=256) :: FNAME_PRODKT ! name of MCMC production file -LOGICAL(LGT) :: LEXIST ! logical flag if the file exists -INTEGER(I4B), PARAMETER :: UIN_MCMC=31 ! input unit for MCMC production files -LOGICAL(LGT) :: JUMP_FLAG ! flag to denote a jump in MCMC -INTEGER(I4B), DIMENSION(1) :: IMIN ! index of seed with highest OF value -REAL(SP),DIMENSION(:,:),ALLOCATABLE :: XPAR ! parameter sets for all local optima -INTEGER(I4B) :: IWANT ! used to skip parameter sets - - - -!MyProcID=GetCurrentProcessId() -! --------------------------------------------------------------------------------------- -! (1) READ COMMAND LINE ARGUMENTS -! --------------------------------------------------------------------------------------- -! read command-line arguments -read_arg=.true. -if(read_arg)then - CALL GETARG( 1,MBASIN_ID) ! MOPEX basin ID - CALL GETARG( 2,FMODEL_ID) ! integer defining FUSE model - CALL GETARG( 3,NSOLUTION) ! numerical solution (0=explicit, 1=implicit) - CALL GETARG( 4,FADAPTIVE) ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) - CALL GETARG( 5,TRUNC_ABS) ! absolute temporal truncation error tolerance - CALL GETARG( 6,TRUNC_REL) ! relative temporal truncation error tolerance - CALL GETARG( 7,NUM_MULTI) ! number of re-starts - CALL GETARG( 8,SOBOLSEED) ! starting seed in the Sobol sequence - CALL GETARG( 9,NUMDIGITS) ! number of reliable digits in function evaluation - CALL GETARG(10,DO_QNEWTN) ! T = run multi-start quasi-Newton -else - MBASIN_ID="mahurangi" - FMODEL_ID="070" - NSOLUTION="2" ! implicit Euler - FADAPTIVE="0" ! fixed-step - TRUNC_ABS="1.e-2" - TRUNC_REL="1.e-2" - NUM_MULTI="2" - SOBOLSEED="1" - NUMDIGITS="10" - DO_QNEWTN="T" -endif -! check command-line arguments -IF (LEN_TRIM(MBASIN_ID).EQ.0) STOP '1st command-line argument is missing (MBASIN_ID)' -IF (LEN_TRIM(FMODEL_ID).EQ.0) STOP '2nd command-line argument is missing (FMODEL_ID)' -IF (LEN_TRIM(NSOLUTION).EQ.0) STOP '3rd command-line argument is missing (NSOLUTION)' -IF (LEN_TRIM(FADAPTIVE).EQ.0) STOP '4th command-line argument is missing (FADAPTIVE)' -IF (LEN_TRIM(TRUNC_ABS).EQ.0) STOP '5th command-line argument is missing (TRUNC_ABS)' -IF (LEN_TRIM(TRUNC_REL).EQ.0) STOP '6th command-line argument is missing (TRUNC_REL)' -IF (LEN_TRIM(NUM_MULTI).EQ.0) STOP '7th command-line argument is missing (NUM_MULTI)' -IF (LEN_TRIM(SOBOLSEED).EQ.0) STOP '8th command-line argument is missing (SOBOLSEED)' -IF (LEN_TRIM(NUMDIGITS).EQ.0) STOP '9th command-line argument is missing (NUMDIGITS)' -! define basin desired -FORCINGINFO = 'forcinginfo.'//TRIM(MBASIN_ID)//'.all' -! convert command-line arguments to integer flags and real numbers -CALL GETNUMERIX() ! defines method/parameters used for numerical solution -READ(FMODEL_ID,*) FUSE_ID ! integer definining FUSE model -READ(NSOLUTION,*) SOLUTION_METHOD ! numerical solution (0=implicit, 1=explicit) -READ(FADAPTIVE,*) TEMPORAL_ERROR_CONTROL ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -READ(TRUNC_ABS,*) ERR_TRUNC_ABS ! absolute temporal truncation error tolerance -READ(TRUNC_REL,*) ERR_TRUNC_REL ! relative temporal truncation error tolerance -READ(NUM_MULTI,*) NMULTI ! define the number of re-starts -READ(SOBOLSEED,*) IBEGIN ! starting seed in the Sobol sequence -READ(NUMDIGITS,*) FDIGITS ! number of reliable digits in function evaluation -! check if there is a need to run the multi-start quasi-Newton method -QNEW_FLAG=.FALSE. -IF (LEN_TRIM(DO_QNEWTN).EQ.1) THEN - IF (DO_QNEWTN.EQ.'T') QNEW_FLAG=.TRUE. -ENDIF -! additional checks -SELECT CASE(SOLUTION_METHOD); CASE(EXPLICIT_EULER,EXPLICIT_HEUN,IMPLICIT_EULER,IMPLICIT_HEUN,SEMI_IMPLICIT) -CASE DEFAULT - PRINT *, 'solution method (1st command line argument) must equal 0 (explicit_euler), 1 (explicit heun), '//& - '2 (implicit_euler), 3 (implicit_heun), or 4 (semi_implicit)' - STOP -END SELECT -SELECT CASE(TEMPORAL_ERROR_CONTROL); CASE(TS_FIXED,TS_ADAPT); CASE DEFAULT; - STOP 'temporal error control (2nd command line argument) must equal 0 (fixed steps) or 1 (adaptive steps)' -END SELECT -IF (NMULTI.LE.0) STOP 'number of re-starts (6th command line argument) must be > 0' -IF (IBEGIN.LE.0) STOP 'starting seed in the Sobol sequence must be greater > 0' -write(*,'(A5,1X,2(I1,1X),2(E12.5,1X),I6,1X,A11,1X,2(I6,1X))') 'FUSE ', & -SOLUTION_METHOD, TEMPORAL_ERROR_CONTROL, ERR_TRUNC_ABS, ERR_TRUNC_REL, & -NMULTI, TRIM(SOBOLSEED), IBEGIN, FDIGITS -! --------------------------------------------------------------------------------------- -! (1) GET MODEL SETUP -- MODEL DEFINITION, AND PARAMETER AND VARIABLE INFO FOR ALL MODELS -! --------------------------------------------------------------------------------------- -! Read data from the "BATEA-compliant" ASCII files -CALL GETFORCING(INFERN_START,NTIM) -! Define model attributes (valid for all models) -CALL UNIQUEMODL(NMOD) ! get nmod unique models -CALL GETPARMETA() ! read parameter metadata (parameter bounds etc.) -! Identify a single model (use FUSE_ID instead of reading ../input/m_decisions.txt) -CALL SELECTMODL(FUSE_ID,ISTATUS=ERR,MESSAGE=MESSAGE) -IF (ERR.NE.0) THEN - PRINT *, TRIM(MESSAGE); STOP -ENDIF -! Define list of states and parameters for the current model -CALL ASSIGN_STT() ! state definitions are stored in module model_defn -CALL ASSIGN_PAR() ! parameter defintions are stored in module multiparam -CALL ASSIGN_FLX() ! flux definitions stored in module model_defn -! compute derived model parameters (bucket sizes, etc.) -CALL PAR_DERIVE() -! allocate arrays for quasi-Newton -ALLOCATE(X0I(NUMPAR),XLO(NUMPAR),XHI(NUMPAR),XSC(NUMPAR),URAND(NUMPAR),XOPT(NUMPAR)) -! allocate arrays for MCMC -allocate(sample0(0:numpar),covDiag0(0:numpar)) -! get parameter bounds and random numbers -DO IPAR=1,NUMPAR - CALL GETPAR_STR(LPARAM(IPAR)%PARNAME,PARAM_META) - XLO(IPAR) = PARAM_META%PARLOW ! lower bound - XHI(IPAR) = PARAM_META%PARUPP ! upper bound - XSC(IPAR) = PARAM_META%PARSCL ! typical scale -END DO -! -------------------------------------------------------------------------------------- -! (2) MULTI START QUASI-NEWTON... -! -------------------------------------------------------------------------------------- -! define the desired objective function and allocate space for the objective function values -OF_NAME = 'raw_rmse'; ALLOCATE(OF_VALS(NMULTI),XPAR(NUMPAR,NMULTI)) -! loop through different starting positions (use the Sobol sequence) -DO ISEED=IBEGIN,(IBEGIN+NMULTI)-1 - ! get the seed as a character string - WRITE(SOBOLSEED,'(i3.3)') ISEED - ! define file prefix (add seeds) - FNAME_PREFIX = TRIM(OUTPUT_PATH)//'DMSL_'//TRIM(MBASIN_ID)//'__'//TRIM(SMODL%MNAME)//'__'//TRIM(SOBOLSEED)//'__'//& - TRIM(NSOLUTION)//'-'//TRIM(FADAPTIVE)//'__'//TRIM(NUMDIGITS)//'__'//& - TRIM(TRUNC_ABS)//'__'//TRIM(TRUNC_REL) - ! define NetCDF files (filename shared in MODULE model_defn) - FNAME_NETCDF = TRIM(FNAME_PREFIX)//'__qnewton.nc' - ONEMOD=1 ! one file per model (i.e., model dimension = 1) - - ! check if there is a need to run quasi-Newton - IF (QNEW_FLAG) THEN ! need to run quasi-Newton - PCOUNT=0 ! counter for parameter sets in output file (shared in MODULE multistats) - FCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) - OUTPUT_FLAG = .TRUE. ! write model time series - Q_ONLY = .TRUE. ! restrict output time series to simulated runofff - CALL DEF_PARAMS(ONEMOD) ! define model parameters (initial CREATE) - IF (OUTPUT_FLAG) CALL DEF_OUTPUT(NTIM) ! define model time series (REDEF) - CALL DEF_SSTATS() ! define summary statistics (REDEF) - ! define ASCII files (filename shared in MODULE model_defn) - FNAME_ASCII = TRIM(FNAME_PREFIX)//'__qnewton.txt' - ! open ASCII file (unit 21) - OPEN(UOUT_QNEW,FILE=FNAME_ASCII, STATUS='unknown') - ! get new parameter sets - JSEED=ISEED; CALL I4_SOBOL(NUMPAR,JSEED,URAND) - WRITE(*,'(2(I4,1X),20(E10.2,1X))') ISEED, JSEED-1, URAND - X0I = XLO + ((1._SP - PSELECT)/2._SP)*(XHI-XLO) + (PSELECT*REAL(URAND,KIND(SP)))*(XHI-XLO) - ! find local optimum in the vicinity of the starting point - CALL QNEWTON_WRAPPER(X0I,XLO,XHI,XSC,FDIGITS,UOUT_QNEW,XOPT,FOPT,ITER,FCALLS,GCALLS,HCALLS,& - ERR,MESSAGE) - IF (ERR.NE.0) PRINT *, TRIM(MESSAGE) - WRITE(*,'(5(I6,1X),20(F9.3,1X))') FCOUNT,ITER,FCALLS,GCALLS,HCALLS,FOPT,XOPT - ! run model again with optimum parameter set (to populate structures and write model output) - CALL FUSE_RMSE(XOPT,FOPT,OUTPUT_FLAG) - ! write model parameters and summary statistics - CALL PUT_PARAMS(PCOUNT,ONEMOD) ! PCOUNT = index for parameter set; ONEMOD=1 (just one model structure) - CALL PUT_SSTATS(PCOUNT,ONEMOD) - CLOSE(UOUT_QNEW) - ENDIF - ! get objective function value for the first parameter set - PCOUNT=1; CALL GET_OBJFNC(FNAME_NETCDF,OF_NAME,ONEMOD,PCOUNT,FOPT,XOPT) - OF_VALS(ISEED) = FOPT - XPAR(:,ISEED) = XOPT(:) - !write(*,'(I4,1X,20(f12.6,1x))') ISEED, OF_VALS(ISEED), XPAR(:,ISEED) -END DO -! -------------------------------------------------------------------------------------- -! (3a) MCMC... -! -------------------------------------------------------------------------------------- -! identify the maximum seed and retrieve model parameter set -IMIN = MINLOC(OF_VALS) -FOPT = OF_VALS(IMIN(1)) -XOPT(:) = XPAR(:,IMIN(1)) -! ensure the parameter set is within bounds -DO IPAR=1,NUMPAR - CALL GETPAR_STR(LPARAM(IPAR)%PARNAME,PARAM_META) - XOPT(IPAR) = MAX(XOPT(IPAR),PARAM_META%PARLOW) - XOPT(IPAR) = MIN(XOPT(IPAR),PARAM_META%PARUPP) -END DO -!write(*,'(i3,1x,20(f12.6,1x))') IMIN(1), FOPT, XOPT -! define write parameters for model output -PCOUNT=0 ! counter for parameter sets in output file (shared in MODULE multistats) -FCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) -OUTPUT_FLAG = .TRUE. ! write model time series -Q_ONLY = .TRUE. ! restrict output time series to simulated runofff -! define file prefix (no seeds in the filename) -FNAME_PREFIX = TRIM(OUTPUT_PATH)//'DMSL_'//TRIM(MBASIN_ID)//'__'//TRIM(SMODL%MNAME)//'__'//& - TRIM(NSOLUTION)//'-'//TRIM(FADAPTIVE)//'__'//TRIM(NUMDIGITS)//'__'//& - TRIM(TRUNC_ABS)//'__'//TRIM(TRUNC_REL) -! define NetCDF files (filename shared in MODULE model_defn) -FNAME_NETCDF = TRIM(FNAME_PREFIX)//'__predict.nc' -CALL DEF_PARAMS(ONEMOD) ! define model parameters (initial CREATE) -IF (OUTPUT_FLAG) CALL DEF_OUTPUT(NTIM) ! define model time series (REDEF) -CALL DEF_SSTATS() ! define summary statistics (REDEF) -! get MCMC samples -sample0(0) = log10(FOPT**2) ! variance -sample0(1:) = XOPT(1:) -!write(*,'(es22.14e3)') sample0 -!write(*,'(Z16.16)') sample0 -covDiag0(0) = 0.1_mrk*max(abs(sample0(0)),1._mrk) ! assume typical RMSE = 1 mm/day for "optimal" param set -covDiag0(1:) = 0.1_mrk*max(abs(sample0(1:)),xsc(1:)) -!CALL MCMC_WRAPPER(sample0,covDiag0,err,message) -IF (ERR.NE.0) PRINT *, TRIM(MESSAGE) -! read the ASCII production MCMC output file and re-run for each of the parameter sets -FNAME_PRODKT = TRIM(FNAME_PREFIX)//'__prodkt.sam' -INQUIRE(FILE=TRIM(FNAME_PRODKT),EXIST=LEXIST) -IF (.NOT.LEXIST) STOP ' PRODKT FILE DOES NOT EXIST ' -OPEN(UIN_MCMC,FILE=TRIM(FNAME_PRODKT),IOSTAT=ERR) -IF (ERR.NE.0) THEN; PRINT *, ERR, ' PROBLEM OPENING FILE '; STOP; ENDIF - IWANT = 1 - DO ! continuous do loop with exit clause - ! read a parameter set - READ(UIN_MCMC,*,IOSTAT=ERR) sample0, MSTATS%LOGP_SIMULN, JUMP_FLAG; IF (ERR.NE.0) EXIT - MSTATS%JUMP_TAKEN = 0._SP; IF (JUMP_FLAG) MSTATS%JUMP_TAKEN = 1._SP ! (convert flag to real) - IF (IWANT.EQ.50) THEN - ! run FUSE - CALL FUSE_RMSE(sample0(1:),FOPT,OUTPUT_FLAG) - ! write model parameters and summary statistics - CALL PUT_PARAMS(PCOUNT,ONEMOD) ! PCOUNT = index for parameter set; ONEMOD=1 (just one model structure) - CALL PUT_SSTATS(PCOUNT,ONEMOD) - IWANT = 1 - ELSE - IWANT = IWANT+1 - ENDIF - END DO -CLOSE(UIN_MCMC) -! -------------------------------------------------------------------------------------- -! deallocate parameter vectors -DEALLOCATE(X0I,XLO,XHI,XSC,URAND,XOPT,sample0,covDiag0) -STOP -END PROGRAM QNEW_MCMC__DRIVER -! -------------------------------------------------------------------------------------- diff --git a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/sce_merge.f90.svn-base b/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/sce_merge.f90.svn-base deleted file mode 100644 index 308c8ba..0000000 --- a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/sce_merge.f90.svn-base +++ /dev/null @@ -1,108 +0,0 @@ -PROGRAM SCE_MERGE -! --------------------------------------------------------------------------------------- -! Creator: -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! Driver program to merge SCE runs from multiple models -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE ddirectory ! directory for data files -! data modules -USE model_defn,nstateFUSE=>nstate ! model definition structures -USE multiparam, ONLY: LPARAM, PARATT, NUMPAR ! parameter metadata structures -USE multistats, ONLY: PCOUNT, MOD_IX ! parameter set / model counters -! access to model simulation modules -USE fuse_rmse_module ! run model and compute the root mean squared error -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -! (0) GET COMMAND-LINE ARGUMENTS -! --------------------------------------------------------------------------------------- -CHARACTER(LEN=120) :: FILE_LIST ! list of NetCDF output files for SCE -! --------------------------------------------------------------------------------------- -! (1) PRELIMINARIES... GET DATA AND NUMERIX DECISIONS -! --------------------------------------------------------------------------------------- -! get model forcing data -INTEGER(I4B) :: NTIM ! number of time steps -INTEGER(I4B) :: INFERN_START ! start of inference period -! --------------------------------------------------------------------------------------- -! (2) READ LIST OF OUTPUT FILES, AND RUN MODEL FOR BEST PARAMETER SET IN EACH ONE -! --------------------------------------------------------------------------------------- -INTEGER(I4B) :: I,J,K ! looping -INTEGER(I4B) :: IERR ! error code for reading input files -LOGICAL(LGT) :: LEXIST ! .TRUE. if the file exists -INTEGER(I4B) :: NMODEL ! number of models in the file list -CHARACTER(LEN=120) :: FILE_NAME ! name of single NetCDF output file -INTEGER(I4B) :: ONEMOD=1 ! just one model in output file -LOGICAL(LGT) :: OUTPUT_FLAG ! switch off/on model output -INTEGER(I4B) :: MPAR ! number of model parameters -REAL(SP), DIMENSION(:), ALLOCATABLE :: XPAR ! model parameters -REAL(SP) :: RMSE ! root mean squared error -! --------------------------------------------------------------------------------------- -! (0) GET COMMAND-LINE ARGUMENTS -! --------------------------------------------------------------------------------------- -! pad FILE_LIST with blanks -DO I=1,LEN(FILE_LIST); FILE_LIST(I:I)=' '; END DO -! read input filename from the command line -CALL GETARG(1,FILE_LIST) -IF (LEN_TRIM(FILE_LIST).EQ.0) STOP '1st command-line argument is missing (FILE_LIST)' -! --------------------------------------------------------------------------------------- -! (1) PRELIMINARIES... GET DATA AND NUMERIX DECISIONS -! --------------------------------------------------------------------------------------- -! Define method/parameters used for numerical solution -CALL GETNUMERIX() -! Read data from the "BATEA-compliant" ASCII files -CALL GETFORCING(INFERN_START,NTIM) -! Read parameter metadata (parameter bounds etc.) for all models -CALL GETPARMETA() -! --------------------------------------------------------------------------------------- -! (2) READ LIST OF OUTPUT FILES, AND RUN MODEL FOR BEST PARAMETER SET IN EACH ONE -! --------------------------------------------------------------------------------------- -! check that the file containing list of SCE output files exists -INQUIRE(FILE=TRIM(FILE_LIST),EXIST=LEXIST) -IF (.NOT.LEXIST) STOP 'file containing list of SCE output files does not exist' -! get number of output files (models) to process -NMODEL = 0 -OPEN(21,FILE=TRIM(FILE_LIST)) - DO; READ(21,*,IOSTAT=IERR) FILE_NAME; IF (IERR.NE.0) EXIT; NMODEL=NMODEL+1; END DO -CLOSE(21) -! Define output file names (shared in MODULE model_defn) -FNAME_NETCDF = TRIM(OUTPUT_PATH)//'SCE_merge.nc' -! Define NetCDF output files (only write parameters and summary statistics) -OUTPUT_FLAG = .TRUE. ! .TRUE. if desire time series output -CALL DEF_PARAMS(NMODEL) ! define model parameters (initial CREATE) -CALL DEF_SSTATS() ! define summary statistics (REDEF) -IF (OUTPUT_FLAG) CALL DEF_OUTPUT(NTIM) ! define model time series (REDEF) -! initialize the model index (stared in module multistats) -MOD_IX = 0 -! loop thtough output files -OPEN(21,FILE=TRIM(FILE_LIST)) - DO ! loop through output files - ! get output filename - READ(21,*,IOSTAT=IERR) FILE_NAME - IF (IERR.NE.0) EXIT - ! identify model (populate SMODL) - CALL GET_SMODEL(FILE_NAME,ONEMOD) - ! Define list of states and parameters for the current model - CALL ASSIGN_STT() ! state definitions are stored in module model_defn - CALL ASSIGN_FLX() ! flux definitions are stored in module model_defn - CALL ASSIGN_PAR() ! parameter defintions are stored in module multiparam - ! get final parameter set - MPAR = NUMPAR ! (number of model parameter sets) - ALLOCATE(XPAR(MPAR),STAT=IERR); IF (IERR.NE.0) STOP ' problem allocating XPAR ' - CALL GET_FPARAM(FILE_NAME,ONEMOD,MPAR,XPAR) - WRITE(*,'(20(A11,1X))') LPARAM(1:NUMPAR) - WRITE(*,'(20(F11.3,1X))') XPAR(1:NUMPAR) - ! compute derived model parameters (bucket sizes, etc.) - CALL PAR_DERIVE() - ! define indices for data write - PCOUNT=0 ! ensure the parameter counter is set to zero (incremented in fuse_rmse) - MOD_IX=MOD_IX + 1 ! increment the model index - ! run zee model - CALL FUSE_RMSE(XPAR,RMSE,OUTPUT_FLAG) - ! deallocate space - DEALLOCATE(XPAR, STAT=IERR); IF (IERR.NE.0) STOP ' problem deallocating XPAR ' - END DO ! (looping through output files) -CLOSE(21) -STOP -END PROGRAM SCE_MERGE diff --git a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/sobol.f90.svn-base b/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/sobol.f90.svn-base deleted file mode 100644 index b1f8844..0000000 --- a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/sobol.f90.svn-base +++ /dev/null @@ -1,3649 +0,0 @@ -subroutine get_unit ( iunit ) - -!*****************************************************************************80 -! -!! GET_UNIT returns a free FORTRAN unit number. -! -! Discussion: -! -! A "free" FORTRAN unit number is an integer between 1 and 99 which -! is not currently associated with an I/O device. A free FORTRAN unit -! number is needed in order to open a file with the OPEN command. -! -! If IUNIT = 0, then no free FORTRAN unit could be found, although -! all 99 units were checked (except for units 5, 6 and 9, which -! are commonly reserved for console I/O). -! -! Otherwise, IUNIT is an integer between 1 and 99, representing a -! free FORTRAN unit. Note that GET_UNIT assumes that units 5 and 6 -! are special, and will never return those values. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 18 September 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, integer IUNIT, the free unit number. -! - implicit none - - integer i - integer ios - integer iunit - logical lopen - - iunit = 0 - - do i = 1, 99 - - if ( i /= 5 .and. i /= 6 .and. i /= 9 ) then - - inquire ( unit = i, opened = lopen, iostat = ios ) - - if ( ios == 0 ) then - if ( .not. lopen ) then - iunit = i - return - end if - end if - - end if - - end do - - return -end -function i4_bit_hi1 ( n ) - -!*****************************************************************************80 -! -!! I4_BIT_HI1 returns the position of the high 1 bit base 2 in an integer. -! -! Discussion: -! -! This routine uses the default integer precision, which is -! presumed to correspond to a KIND of 4. -! -! Example: -! -! N Binary Hi 1 -! ---- -------- ---- -! 0 0 0 -! 1 1 1 -! 2 10 2 -! 3 11 2 -! 4 100 3 -! 5 101 3 -! 6 110 3 -! 7 111 3 -! 8 1000 4 -! 9 1001 4 -! 10 1010 4 -! 11 1011 4 -! 12 1100 4 -! 13 1101 4 -! 14 1110 4 -! 15 1111 4 -! 16 10000 5 -! 17 10001 5 -! 1023 1111111111 10 -! 1024 10000000000 11 -! 1025 10000000001 11 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 May 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the integer to be measured. -! N should be nonnegative. If N is nonpositive, I4_BIT_HI1 -! will always be 0. -! -! Output, integer ( kind = 4 ) I4_BIT_HI1, the number of bits base 2. -! - implicit none - - integer ( kind = 4 ) bit - integer ( kind = 4 ) i4_bit_hi1 - integer ( kind = 4 ) i - integer ( kind = 4 ) n - - i = n - bit = 0 - - do - - if ( i <= 0 ) then - exit - end if - - bit = bit + 1 - i = i / 2 - - end do - - i4_bit_hi1 = bit - - return -end -function i4_bit_lo0 ( n ) - -!*****************************************************************************80 -! -!! I4_BIT_LO0 returns the position of the low 0 bit base 2 in an integer. -! -! Discussion: -! -! This routine uses the default integer precision, which is -! presumed to correspond to a KIND of 4. -! -! Example: -! -! N Binary Lo 0 -! ---- -------- ---- -! 0 0 1 -! 1 1 2 -! 2 10 1 -! 3 11 3 -! 4 100 1 -! 5 101 2 -! 6 110 1 -! 7 111 4 -! 8 1000 1 -! 9 1001 2 -! 10 1010 1 -! 11 1011 3 -! 12 1100 1 -! 13 1101 2 -! 14 1110 1 -! 15 1111 5 -! 16 10000 1 -! 17 10001 2 -! 1023 1111111111 1 -! 1024 10000000000 1 -! 1025 10000000001 1 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 May 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the integer to be measured. -! N should be nonnegative. -! -! Output, integer ( kind = 4 ) I4_BIT_LO0, the position of the low 1 bit. -! - implicit none - - integer ( kind = 4 ) bit - integer ( kind = 4 ) i - integer ( kind = 4 ) i2 - integer ( kind = 4 ) i4_bit_lo0 - integer ( kind = 4 ) n - - bit = 0 - i = n - - do - - bit = bit + 1 - i2 = i / 2 - - if ( i == 2 * i2 ) then - exit - end if - - i = i2 - - end do - - i4_bit_lo0 = bit - - return -end -subroutine i4_sobol ( dim_num, seed, quasi ) - -!*****************************************************************************80 -! -!! I4_SOBOL generates a new quasirandom Sobol vector with each call. -! -! Discussion: -! -! The routine adapts the ideas of Antonov and Saleev. -! -! This routine uses the default integer precision, which is -! presumed to correspond to a KIND of 4. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 25 June 2008 -! -! Author: -! -! FORTRAN77 original version by Bennett Fox. -! FORTRAN90 version by John Burkardt -! -! Reference: -! -! IA Antonov, VM Saleev, -! An Economic Method of Computing LP Tau-Sequences, -! USSR Computational Mathematics and Mathematical Physics, -! Volume 19, 1980, pages 252-256. -! -! Paul Bratley, Bennett Fox, -! Algorithm 659: -! Implementing Sobol's Quasirandom Sequence Generator, -! ACM Transactions on Mathematical Software, -! Volume 14, Number 1, March 1988, pages 88-100 -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, December 1986, pages 362-376. -! -! Stephen Joe, Frances Kuo, -! Remark on Algorithm 659: -! Implementing Sobol's Quasirandom Sequence Generator, -! ACM Transactions on Mathematical Software, -! Volume 29, Number 1, March 2003, pages 49-57. -! -! Ilya Sobol, -! Uniformly Distributed Sequences with an Additional Uniform Property, -! USSR Computational Mathematics and Mathematical Physics, -! Volume 16, 1977, pages 236-242. -! -! Ilya Sobol, YL Levitan, -! The Production of Points Uniformly Distributed in a Multidimensional -! Cube (in Russian), -! Preprint IPM Akademii Nauk SSSR, -! Number 40, Moscow 1976. -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the number of spatial dimensions. -! DIM_NUM must satisfy 2 <= DIM_NUM <= 1111. -! -! Input/output, integer ( kind = 4 ) SEED, the "seed" for the sequence. -! This is essentially the index in the sequence of the quasirandom -! value to be generated. On output, SEED has been set to the -! appropriate next value, usually simply SEED+1. -! If SEED is less than 0 on input, it is treated as though it were 0. -! An input value of 0 requests the first (0-th) element of the sequence. -! -! Output, real ( kind = 4 ) QUASI(DIM_NUM), the next quasirandom vector. -! - implicit none - - integer ( kind = 4 ) dim_num - integer ( kind = 4 ), parameter :: dim_max = 1111 - integer ( kind = 4 ), parameter :: log_max = 30 - - integer ( kind = 4 ) atmost - integer ( kind = 4 ), save :: dim_num_save = 0 - integer ( kind = 4 ) i - integer ( kind = 4 ) i4_bit_hi1 - integer ( kind = 4 ) i4_bit_lo0 - integer ( kind = 4 ) inc - logical includ(log_max) - logical, save :: initialized = .false. - integer ( kind = 4 ) j - integer ( kind = 4 ) j2 - integer ( kind = 4 ) k - integer ( kind = 4 ) l - integer ( kind = 4 ), save, dimension(dim_max) :: lastq - integer ( kind = 4 ) m - integer ( kind = 4 ), save :: maxcol - integer ( kind = 4 ) newv - integer ( kind = 4 ), save, dimension(1:dim_max) :: poly - real ( kind = 4 ) quasi(dim_num) - real ( kind = 4 ), save :: recipd - integer ( kind = 4 ) seed - integer ( kind = 4 ), save :: seed_save = - 1 - integer ( kind = 4 ) seed_temp - integer ( kind = 4 ), save, dimension(1:dim_max,1:log_max) :: v - - if ( .not. initialized .or. dim_num /= dim_num_save ) then - - initialized = .true. - - v(1:dim_max,1:log_max) = 0 -! -! Initialize (part of) V. -! - v(2:1111,1) = 1 - v(3:401,2) = (/ & - 1,3,1,3,1,3,3,1,3,1,3,1,3,1,1,3,1,3,1,3, & - 1,3,3,1,1,1,3,1,3,1,3,3,1,3,1,1,1,3,1,3,1,1,1,3,3,1,3,3,1,1, & - 3,3,1,3,3,3,1,3,1,3,1,1,3,3,1,1,1,1,3,1,1,3,1,1,1,3,3,1,3,3, & - 1,3,3,3,1,3,3,3,1,3,3,1,3,3,3,1,3,1,3,1,1,3,3,1,3,3,1,1,1,3, & - 3,1,3,3,1,3,1,1,3,3,3,1,1,1,3,1,1,3,1,1,3,3,1,3,1,3,3,3,3,1, & - 1,1,3,3,1,1,3,1,1,1,1,1,1,3,1,3,1,1,1,3,1,3,1,3,3,3,1,1,3,3, & - 1,3,1,3,1,1,3,1,3,1,3,1,3,1,1,1,3,3,1,3,3,1,3,1,1,1,3,1,3,1, & - 1,3,1,1,3,3,1,1,3,3,3,1,3,3,3,1,3,1,3,1,1,1,3,1,1,1,3,1,1,1, & - 1,1,3,3,3,1,1,1,1,3,3,3,1,3,3,1,1,1,1,3,1,1,3,1,3,3,1,1,3,3, & - 1,1,1,1,3,1,3,3,1,3,3,1,1,1,3,3,3,1,3,3,1,3,3,1,3,1,3,3,3,1, & - 3,1,1,3,1,3,1,1,1,3,3,3,1,1,3,1,3,1,1,1,1,1,1,3,1,1,3,1,3,3, & - 1,1,1,1,3,1,3,1,3,1,1,1,1,3,3,1,1,1,1,1,3,3,3,1,1,3,3,3,3,3, & - 1,3,3,1,3,3,3,3,1,1,1,1,1,1,3,1,1,3,1,1,1,3,1,1,1,3,3,3,1,3, & - 1,1,3,3,3,1,3,3,1,3,1,3,3,1,3,3,3,1,1/) - v(402:800,2) = (/ & - 3,3,1,3,1,3,1,1,1,3,3,3,3,1,3,1,1,3,1, & - 3,1,1,1,3,1,3,1,3,1,3,3,3,3,3,3,3,3,1,3,3,3,3,3,1,3,1,3,3,3, & - 1,3,1,3,1,3,3,1,3,3,3,3,3,3,3,3,3,1,1,1,1,1,1,3,3,1,1,3,3,1, & - 1,1,3,3,1,1,3,3,3,3,1,1,3,1,3,3,1,3,3,1,1,1,3,3,3,1,1,3,3,3, & - 3,3,1,1,1,3,1,3,3,1,3,3,3,3,1,1,3,1,1,3,1,3,1,3,1,3,3,1,1,3, & - 3,1,3,3,1,3,3,1,1,3,1,3,3,1,1,3,1,3,1,3,1,1,3,3,1,1,1,3,3,1, & - 3,1,1,3,3,1,1,3,1,3,1,1,1,1,1,3,1,1,1,1,3,1,3,1,1,3,3,1,1,3, & - 1,3,1,3,3,3,1,3,3,3,1,1,3,3,3,1,1,1,1,3,1,3,1,3,1,1,3,3,1,1, & - 1,3,3,1,3,1,3,1,1,1,1,1,1,3,1,3,3,1,3,3,3,1,3,1,1,3,3,1,1,3, & - 3,1,1,1,3,1,3,3,1,1,3,1,1,3,1,3,1,1,1,3,3,3,3,1,1,3,3,1,1,1, & - 1,3,1,1,3,3,3,1,1,3,3,1,3,3,1,1,3,3,3,3,3,3,3,1,3,3,1,3,1,3, & - 1,1,3,3,1,1,1,3,1,3,3,1,3,3,1,3,1,1,3,3,3,1,1,1,3,1,1,1,3,3, & - 3,1,3,3,1,3,1,1,3,3,3,1,3,3,1,1,1,3,1,3,3,3,3,3,3,3,3,1,3,3, & - 1,3,1,1,3,3,3,1,3,3,3,3,3,1,3,3,3,1,1,1/) - v(801:1111,2) = (/ & - 3,3,1,3,3,1,3,1,3,1,3,1,3,3,3,3,3,3, & - 1,1,3,1,3,1,1,1,1,1,3,1,1,1,3,1,3,1,1,3,3,3,1,3,1,3,1,1,3,1, & - 3,3,1,3,1,3,3,1,3,3,1,3,3,3,3,3,3,1,3,1,1,3,3,3,1,1,3,3,3,3, & - 3,3,3,1,3,3,3,3,1,3,1,3,3,3,1,3,1,3,1,1,1,3,3,1,3,1,1,3,3,1, & - 3,1,1,1,1,3,1,3,1,1,3,1,3,1,3,3,3,3,3,3,1,3,3,3,3,1,3,3,1,3, & - 3,3,3,3,1,1,1,1,3,3,3,1,3,3,1,1,3,3,1,1,3,3,1,3,1,1,3,1,3,3, & - 3,3,3,1,3,1,1,3,3,3,3,1,3,1,1,3,3,3,3,3,3,1,1,3,1,3,1,1,3,1, & - 1,1,1,3,3,1,1,3,1,1,1,3,1,3,1,1,3,3,1,3,1,1,3,3,3,3,3,1,3,1, & - 1,1,3,1,1,1,3,1,1,3,1,3,3,3,3,3,1,1,1,3,3,3,3,1,3,3,3,3,1,1, & - 3,3,3,1,3,1,1,3,3,1,3,3,1,1,1,1,1,3,1,1,3,3,1,1,1,3,1,1,3,3, & - 1,3,3,3,3,3,3,3,3,1,1,3,3,1,1,3,1,3,3,3,3,3,1/) - v(4:402,3) = (/ & - 7,5,1,3,3,7,5,5,7,7,1,3,3,7,5,1,1,5,3,7, & - 1,7,5,1,3,7,7,1,1,1,5,7,7,5,1,3,3,7,5,5,5,3,3,3,1,1,5,1,1,5, & - 3,3,3,3,1,3,7,5,7,3,7,1,3,3,5,1,3,5,5,7,7,7,1,1,3,3,1,1,5,1, & - 5,7,5,1,7,5,3,3,1,5,7,1,7,5,1,7,3,1,7,1,7,3,3,5,7,3,3,5,1,3, & - 3,1,3,5,1,3,3,3,7,1,1,7,3,1,3,7,5,5,7,5,5,3,1,3,3,3,1,3,3,7, & - 3,3,1,7,5,1,7,7,5,7,5,1,3,1,7,3,7,3,5,7,3,1,3,3,3,1,5,7,3,3, & - 7,7,7,5,3,1,7,1,3,7,5,3,3,3,7,1,1,3,1,5,7,1,3,5,3,5,3,3,7,5, & - 5,3,3,1,3,7,7,7,1,5,7,1,3,1,1,7,1,3,1,7,1,5,3,5,3,1,1,5,5,3, & - 3,5,7,1,5,3,7,7,3,5,3,3,1,7,3,1,3,5,7,1,3,7,1,5,1,3,1,5,3,1, & - 7,1,5,5,5,3,7,1,1,7,3,1,1,7,5,7,5,7,7,3,7,1,3,7,7,3,5,1,1,7, & - 1,5,5,5,1,5,1,7,5,5,7,1,1,7,1,7,7,1,1,3,3,3,7,7,5,3,7,3,1,3, & - 7,5,3,3,5,7,1,1,5,5,7,7,1,1,1,1,5,5,5,7,5,7,1,1,3,5,1,3,3,7, & - 3,7,5,3,5,3,1,7,1,7,7,1,1,7,7,7,5,5,1,1,7,5,5,7,5,1,1,5,5,5, & - 5,5,5,1,3,1,5,7,3,3,5,7,3,7,1,7,7,1,3/) - v(403:801,3) = (/ & - 5,1,5,5,3,7,3,7,7,5,7,5,7,1,1,5,3,5,1, & - 5,3,7,1,5,7,7,3,5,1,3,5,1,5,3,3,3,7,3,5,1,3,7,7,3,7,5,3,3,1, & - 7,5,1,1,3,7,1,7,1,7,3,7,3,5,7,3,5,3,1,1,1,5,7,7,3,3,1,1,1,5, & - 5,7,3,1,1,3,3,7,3,3,5,1,3,7,3,3,7,3,5,7,5,7,7,3,3,5,1,3,5,3, & - 1,3,5,1,1,3,7,7,1,5,1,3,7,3,7,3,5,1,7,1,1,3,5,3,7,1,5,5,1,1, & - 3,1,3,3,7,1,7,3,1,7,3,1,7,3,5,3,5,7,3,3,3,5,1,7,7,1,3,1,3,7, & - 7,1,3,7,3,1,5,3,1,1,1,5,3,3,7,1,5,3,5,1,3,1,3,1,5,7,7,1,1,5, & - 3,1,5,1,1,7,7,3,5,5,1,7,1,5,1,1,3,1,5,7,5,7,7,1,5,1,1,3,5,1, & - 5,5,3,1,3,1,5,5,3,3,3,3,1,1,3,1,3,5,5,7,5,5,7,5,7,1,3,7,7,3, & - 5,5,7,5,5,3,3,3,1,7,1,5,5,5,3,3,5,1,3,1,3,3,3,7,1,7,7,3,7,1, & - 1,5,7,1,7,1,7,7,1,3,7,5,1,3,5,5,5,1,1,7,1,7,1,7,7,3,1,1,5,1, & - 5,1,5,3,5,5,5,5,5,3,3,7,3,3,5,5,3,7,1,5,7,5,1,5,5,3,5,5,7,5, & - 3,5,5,5,1,5,5,5,5,1,3,5,3,1,7,5,5,7,1,5,3,3,1,5,3,7,1,7,5,1, & - 1,3,1,1,7,1,5,5,3,7,3,7,5,3,1,1,3,1,3,5/) - v(802:1111,3) = (/ & - 5,7,5,3,7,7,7,3,7,3,7,1,3,1,7,7,1,7, & - 3,7,3,7,3,7,3,5,1,1,7,3,1,5,5,7,1,5,5,5,7,1,5,5,1,5,5,3,1,3, & - 1,7,3,1,3,5,7,7,7,1,1,7,3,1,5,5,5,1,1,1,1,1,5,3,5,1,3,5,3,1, & - 1,1,1,3,7,3,7,5,7,1,5,5,7,5,3,3,7,5,3,1,1,3,1,3,1,1,3,7,1,7, & - 1,1,5,1,7,5,3,7,3,5,3,1,1,5,5,1,7,7,3,7,3,7,1,5,1,5,3,7,3,5, & - 7,7,7,3,3,1,1,5,5,3,7,1,1,1,3,5,3,1,1,3,3,7,5,1,1,3,7,1,5,7, & - 3,7,5,5,7,3,5,3,1,5,3,1,1,7,5,1,7,3,7,5,1,7,1,7,7,1,1,7,1,5, & - 5,1,1,7,5,7,1,5,3,5,3,3,7,1,5,1,1,5,5,3,3,7,5,5,1,1,1,3,1,5, & - 7,7,1,7,5,7,3,7,3,1,3,7,3,1,5,5,3,5,1,3,5,5,5,1,1,7,7,1,5,5, & - 1,3,5,1,5,3,5,3,3,7,5,7,3,7,3,1,3,7,7,3,3,1,1,3,3,3,3,3,5,5, & - 3,3,3,1,3,5,7,7,1,5,7,3,7,1,1,3,5,7,5,3,3,3/) - v(6:357,4) = (/ & - 1,7,9,13,11,1,3,7,9,5,13,13,11,3,15,5,3, & - 15,7,9,13,9,1,11,7,5,15,1,15,11,5,11,1,7,9,7,7,1,15,15,15,13, & - 3,3,15,5,9,7,13,3,7,5,11,9,1,9,1,5,7,13,9,9,1,7,3,5,1,11,11, & - 13,7,7,9,9,1,1,3,9,15,1,5,13,1,9,9,9,9,9,13,11,3,5,11,11,13, & - 5,3,15,1,11,11,7,13,15,11,13,9,11,15,15,13,3,15,7,9,11,13,11, & - 9,9,5,13,9,1,13,7,7,7,7,7,5,9,7,13,11,9,11,15,3,13,11,1,11,3, & - 3,9,11,1,7,1,15,15,3,1,9,1,7,13,11,3,13,11,7,3,3,5,13,11,5, & - 11,1,3,9,7,15,7,5,13,7,9,13,15,13,9,7,15,7,9,5,11,11,13,13,9, & - 3,5,13,9,11,15,11,7,1,7,13,3,13,3,13,9,15,7,13,13,3,13,15,15, & - 11,9,13,9,15,1,1,15,11,11,7,1,11,13,9,13,3,5,11,13,9,9,13,1, & - 11,15,13,3,13,7,15,1,15,3,3,11,7,13,7,7,9,7,5,15,9,5,5,7,15, & - 13,15,5,15,5,3,1,11,7,1,5,7,9,3,11,1,15,1,3,15,11,13,5,13,1, & - 7,1,15,7,5,1,1,15,13,11,11,13,5,11,7,9,7,1,5,3,9,5,5,11,5,1, & - 7,1,11,7,9,13,15,13,3,1,11,13,15,1,1,11,9,13,3,13,11,15,13,9, & - 9,9,5,5,5,5,1,15,5,9/) - v(358:710,4) = (/ & - 11,7,15,5,3,13,5,3,11,5,1,11,13,9,11, & - 3,7,13,15,1,7,11,1,13,1,15,1,9,7,3,9,11,1,9,13,13,3,11,7,9,1, & - 7,15,9,1,5,13,5,11,3,9,15,11,13,5,1,7,7,5,13,7,7,9,5,11,11,1, & - 1,15,3,13,9,13,9,9,11,5,5,13,15,3,9,15,3,11,11,15,15,3,11,15, & - 15,3,1,3,1,3,3,1,3,13,1,11,5,15,7,15,9,1,7,1,9,11,15,1,13,9, & - 13,11,7,3,7,3,13,7,9,7,7,3,3,9,9,7,5,11,13,13,7,7,15,9,5,5,3, & - 3,13,3,9,3,1,11,1,3,11,15,11,11,11,9,13,7,9,15,9,11,1,3,3,9, & - 7,15,13,13,7,15,9,13,9,15,13,15,9,13,1,11,7,11,3,13,5,1,7,15, & - 3,13,7,13,13,11,3,5,3,13,11,9,9,3,11,11,7,9,13,11,7,15,13,7, & - 5,3,1,5,15,15,3,11,1,7,3,15,11,5,5,3,5,5,1,15,5,1,5,3,7,5,11, & - 3,13,9,13,15,5,3,5,9,5,3,11,1,13,9,15,3,5,11,9,1,3,15,9,9,9, & - 11,7,5,13,1,15,3,13,9,13,5,1,5,1,13,13,7,7,1,9,5,11,9,11,13, & - 3,15,15,13,15,7,5,7,9,7,9,9,9,11,9,3,11,15,13,13,5,9,15,1,1, & - 9,5,13,3,13,15,3,1,3,11,13,1,15,9,9,3,1,9,1,9,1,13,11,15,7, & - 11,15,13,15,1,9,9,7/) - v(711:1065,4) = (/ & - 3,5,11,7,3,9,5,15,7,5,3,13,7,1,1,9, & - 15,15,15,11,3,5,15,13,7,15,15,11,11,9,5,15,9,7,3,13,1,1,5,1, & - 3,1,7,1,1,5,1,11,11,9,9,5,13,7,7,7,1,1,9,9,11,11,15,7,5,5,3, & - 11,1,3,7,13,7,7,7,3,15,15,11,9,3,9,3,15,13,5,3,3,3,5,9,15,9, & - 9,1,5,9,9,15,5,15,7,9,1,9,9,5,11,5,15,15,11,7,7,7,1,1,11,11, & - 13,15,3,13,5,1,7,1,11,3,13,15,3,5,3,5,7,3,9,9,5,1,7,11,9,3,5, & - 11,13,13,13,9,15,5,7,1,15,11,9,15,15,13,13,13,1,11,9,15,9,5, & - 15,5,7,3,11,3,15,7,13,11,7,3,7,13,5,13,15,5,13,9,1,15,11,5,5, & - 1,11,3,3,7,1,9,7,15,9,9,3,11,15,7,1,3,1,1,1,9,1,5,15,15,7,5, & - 5,7,9,7,15,13,13,11,1,9,11,1,13,1,7,15,15,5,5,1,11,3,9,11,9, & - 9,9,1,9,3,5,15,1,1,9,7,3,3,1,9,9,11,9,9,13,13,3,13,11,13,5,1, & - 5,5,9,9,3,13,13,9,15,9,11,7,11,9,13,9,1,15,9,7,7,1,7,9,9,15, & - 1,11,1,13,13,15,9,13,7,15,3,9,3,1,13,7,5,9,3,1,7,1,1,13,3,3, & - 11,1,7,13,15,15,5,7,13,13,15,11,13,1,13,13,3,9,15,15,11,15,9, & - 15,1,13,15,1,1,5/) - v(1066:1111,4) = (/ & - 11,5,1,11,11,5,3,9,1,3,5,13,9,7,7,1, & - 9,9,15,7,5,5,15,13,9,7,13,3,13,11,13,7,9,13,13,13,15,9,5,5,3, & - 3,3,1,3,15/) - v(8:331,5) = (/ & - 9,3,27,15,29,21,23,19,11,25,7,13,17,1, & - 25,29,3,31,11,5,23,27,19,21,5,1,17,13,7,15,9,31,25,3,5,23,7, & - 3,17,23,3,3,21,25,25,23,11,19,3,11,31,7,9,5,17,23,17,17,25, & - 13,11,31,27,19,17,23,7,5,11,19,19,7,13,21,21,7,9,11,1,5,21, & - 11,13,25,9,7,7,27,15,25,15,21,17,19,19,21,5,11,3,5,29,31,29, & - 5,5,1,31,27,11,13,1,3,7,11,7,3,23,13,31,17,1,27,11,25,1,23, & - 29,17,25,7,25,27,17,13,17,23,5,17,5,13,11,21,5,11,5,9,31,19, & - 17,9,9,27,21,15,15,1,1,29,5,31,11,17,23,19,21,25,15,11,5,5,1, & - 19,19,19,7,13,21,17,17,25,23,19,23,15,13,5,19,25,9,7,3,21,17, & - 25,1,27,25,27,25,9,13,3,17,25,23,9,25,9,13,17,17,3,15,7,7,29, & - 3,19,29,29,19,29,13,15,25,27,1,3,9,9,13,31,29,31,5,15,29,1, & - 19,5,9,19,5,15,3,5,7,15,17,17,23,11,9,23,19,3,17,1,27,9,9,17, & - 13,25,29,23,29,11,31,25,21,29,19,27,31,3,5,3,3,13,21,9,29,3, & - 17,11,11,9,21,19,7,17,31,25,1,27,5,15,27,29,29,29,25,27,25,3, & - 21,17,25,13,15,17,13,23,9,3,11,7,9,9,7,17,7,1/) - v(332:654,5) = (/ & - 27,1,9,5,31,21,25,25,21,11,1,23,19,27, & - 15,3,5,23,9,25,7,29,11,9,13,5,11,1,3,31,27,3,17,27,11,13,15, & - 29,15,1,15,23,25,13,21,15,3,29,29,5,25,17,11,7,15,5,21,7,31, & - 13,11,23,5,7,23,27,21,29,15,7,27,27,19,7,15,27,27,19,19,9,15, & - 1,3,29,29,5,27,31,9,1,7,3,19,19,29,9,3,21,31,29,25,1,3,9,27, & - 5,27,25,21,11,29,31,27,21,29,17,9,17,13,11,25,15,21,11,19,31, & - 3,19,5,3,3,9,13,13,3,29,7,5,9,23,13,21,23,21,31,11,7,7,3,23, & - 1,23,5,9,17,21,1,17,29,7,5,17,13,25,17,9,19,9,5,7,21,19,13,9, & - 7,3,9,3,15,31,29,29,25,13,9,21,9,31,7,15,5,31,7,15,27,25,19, & - 9,9,25,25,23,1,9,7,11,15,19,15,27,17,11,11,31,13,25,25,9,7, & - 13,29,19,5,19,31,25,13,25,15,5,9,29,31,9,29,27,25,27,11,17,5, & - 17,3,23,15,9,9,17,17,31,11,19,25,13,23,15,25,21,31,19,3,11, & - 25,7,15,19,7,5,3,13,13,1,23,5,25,11,25,15,13,21,11,23,29,5, & - 17,27,9,19,15,5,29,23,19,1,27,3,23,21,19,27,11,17,13,27,11, & - 31,23,5,9,21,31,29,11,21,17,15,7,15,7,9,21,27,25/) - v(655:975,5) = (/ & - 29,11,3,21,13,23,19,27,17,29,25,17,9, & - 1,19,23,5,23,1,17,17,13,27,23,7,7,11,13,17,13,11,21,13,23,1, & - 27,13,9,7,1,27,29,5,13,25,21,3,31,15,13,3,19,13,1,27,15,17,1, & - 3,13,13,13,31,29,27,7,7,21,29,15,17,17,21,19,17,3,15,5,27,27, & - 3,31,31,7,21,3,13,11,17,27,25,1,9,7,29,27,21,23,13,25,29,15, & - 17,29,9,15,3,21,15,17,17,31,9,9,23,19,25,3,1,11,27,29,1,31, & - 29,25,29,1,23,29,25,13,3,31,25,5,5,11,3,21,9,23,7,11,23,11,1, & - 1,3,23,25,23,1,23,3,27,9,27,3,23,25,19,29,29,13,27,5,9,29,29, & - 13,17,3,23,19,7,13,3,19,23,5,29,29,13,13,5,19,5,17,9,11,11, & - 29,27,23,19,17,25,13,1,13,3,11,1,17,29,1,13,17,9,17,21,1,11, & - 1,1,25,5,7,29,29,19,19,1,29,13,3,1,31,15,13,3,1,11,19,5,29, & - 13,29,23,3,1,31,13,19,17,5,5,1,29,23,3,19,25,19,27,9,27,13, & - 15,29,23,13,25,25,17,19,17,15,27,3,25,17,27,3,27,31,23,13,31, & - 11,15,7,21,19,27,19,21,29,7,31,13,9,9,7,21,13,11,9,11,29,19, & - 11,19,21,5,29,13,7,19,19,27,23,31,1,27,21,7,3,7,11/) - v(976:1111,5) = (/ & - 23,13,29,11,31,19,1,5,5,11,5,3,27,5, & - 7,11,31,1,27,31,31,23,5,21,27,9,25,3,15,19,1,19,9,5,25,21,15, & - 25,29,15,21,11,19,15,3,7,13,11,25,17,1,5,31,13,29,23,9,5,29, & - 7,17,27,7,17,31,9,31,9,9,7,21,3,3,3,9,11,21,11,31,9,25,5,1, & - 31,13,29,9,29,1,11,19,7,27,13,31,7,31,7,25,23,21,29,11,11,13, & - 11,27,1,23,31,21,23,21,19,31,5,31,25,25,19,17,11,25,7,13,1, & - 29,17,23,15,7,29,17,13,3,17/) - v(14:324,6) = (/ & - 37,33,7,5,11,39,63,59,17,15,23,29,3,21, & - 13,31,25,9,49,33,19,29,11,19,27,15,25,63,55,17,63,49,19,41, & - 59,3,57,33,49,53,57,57,39,21,7,53,9,55,15,59,19,49,31,3,39,5, & - 5,41,9,19,9,57,25,1,15,51,11,19,61,53,29,19,11,9,21,19,43,13, & - 13,41,25,31,9,11,19,5,53,37,7,51,45,7,7,61,23,45,7,59,41,1, & - 29,61,37,27,47,15,31,35,31,17,51,13,25,45,5,5,33,39,5,47,29, & - 35,47,63,45,37,47,59,21,59,33,51,9,27,13,25,43,3,17,21,59,61, & - 27,47,57,11,17,39,1,63,21,59,17,13,31,3,31,7,9,27,37,23,31,9, & - 45,43,31,63,21,39,51,27,7,53,11,1,59,39,23,49,23,7,55,59,3, & - 19,35,13,9,13,15,23,9,7,43,55,3,19,9,27,33,27,49,23,47,19,7, & - 11,55,27,35,5,5,55,35,37,9,33,29,47,25,11,47,53,61,59,3,53, & - 47,5,19,59,5,47,23,45,53,3,49,61,47,39,29,17,57,5,17,31,23, & - 41,39,5,27,7,29,29,33,31,41,31,29,17,29,29,9,9,31,27,53,35,5, & - 61,1,49,13,57,29,5,21,43,25,57,49,37,27,11,61,37,49,5,63,63, & - 3,45,37,63,21,21,19,27,59,21,45,23,13,15,3,43,63,39,19/) - v(325:632,6) = (/ & - 63,31,41,41,15,43,63,53,1,63,31,7,17, & - 11,61,31,51,37,29,59,25,63,59,47,15,27,19,29,45,35,55,39,19, & - 43,21,19,13,17,51,37,5,33,35,49,25,45,1,63,47,9,63,15,25,25, & - 15,41,13,3,19,51,49,37,25,49,13,53,47,23,35,29,33,21,35,23,3, & - 43,31,63,9,1,61,43,3,11,55,11,35,1,63,35,49,19,45,9,57,51,1, & - 47,41,9,11,37,19,55,23,55,55,13,7,47,37,11,43,17,3,25,19,55, & - 59,37,33,43,1,5,21,5,63,49,61,21,51,15,19,43,47,17,9,53,45, & - 11,51,25,11,25,47,47,1,43,29,17,31,15,59,27,63,11,41,51,29,7, & - 27,63,31,43,3,29,39,3,59,59,1,53,63,23,63,47,51,23,61,39,47, & - 21,39,15,3,9,57,61,39,37,21,51,1,23,43,27,25,11,13,21,43,7, & - 11,33,55,1,37,35,27,61,39,5,19,61,61,57,59,21,59,61,57,25,55, & - 27,31,41,33,63,19,57,35,13,63,35,17,11,11,49,41,55,5,45,17, & - 35,5,31,31,37,17,45,51,1,39,49,55,19,41,13,5,51,5,49,1,21,13, & - 17,59,51,11,3,61,1,33,37,33,61,25,27,59,7,49,13,63,3,33,3,15, & - 9,13,35,39,11,59,59,1,57,11,5,57,13,31,13,11,55,45,9,55,55/) - v(633:942,6) = (/ & - 19,25,41,23,45,29,63,59,27,39,21,37,7, & - 61,49,35,39,9,29,7,25,23,57,5,19,15,33,49,37,25,17,45,29,15, & - 25,3,3,49,11,39,15,19,57,39,15,11,3,57,31,55,61,19,5,41,35, & - 59,61,39,41,53,53,63,31,9,59,13,35,55,41,49,5,41,25,27,43,5, & - 5,43,5,5,17,5,15,27,29,17,9,3,55,31,1,45,45,13,57,17,3,61,15, & - 49,15,47,9,37,45,9,51,61,21,33,11,21,63,63,47,57,61,49,9,59, & - 19,29,21,23,55,23,43,41,57,9,39,27,41,35,61,29,57,63,21,31, & - 59,35,49,3,49,47,49,33,21,19,21,35,11,17,37,23,59,13,37,35, & - 55,57,1,29,45,11,1,15,9,33,19,53,43,39,23,7,13,13,1,19,41,55, & - 1,13,15,59,55,15,3,57,37,31,17,1,3,21,29,25,55,9,37,33,53,41, & - 51,19,57,13,63,43,19,7,13,37,33,19,15,63,51,11,49,23,57,47, & - 51,15,53,41,1,15,37,61,11,35,29,33,23,55,11,59,19,61,61,45, & - 13,49,13,63,5,61,5,31,17,61,63,13,27,57,1,21,5,11,39,57,51, & - 53,39,25,41,39,37,23,31,25,33,17,57,29,27,23,47,41,29,19,47, & - 41,25,5,51,43,39,29,7,31,45,51,49,55,17,43,49,45,9,29,3,5,47, & - 9,15,19/) - v(943:1111,6) = (/ & - 51,45,57,63,9,21,59,3,9,13,45,23,15, & - 31,21,15,51,35,9,11,61,23,53,29,51,45,31,29,5,35,29,53,35,17, & - 59,55,27,51,59,27,47,15,29,37,7,49,55,5,19,45,29,19,57,33,53, & - 45,21,9,3,35,29,43,31,39,3,45,1,41,29,5,59,41,33,35,27,19,13, & - 25,27,43,33,35,17,17,23,7,35,15,61,61,53,5,15,23,11,13,43,55, & - 47,25,43,15,57,45,1,49,63,57,15,31,31,7,53,27,15,47,23,7,29, & - 53,47,9,53,3,25,55,45,63,21,17,23,31,27,27,43,63,55,63,45,51, & - 15,27,5,37,43,11,27,5,27,59,21,7,39,27,63,35,47,55,17,17,17, & - 3,19,21,13,49,61,39,15/) - v(20:305,7) = (/ & - 13,33,115,41,79,17,29,119,75,73,105,7, & - 59,65,21,3,113,61,89,45,107,21,71,79,19,71,61,41,57,121,87, & - 119,55,85,121,119,11,23,61,11,35,33,43,107,113,101,29,87,119, & - 97,29,17,89,5,127,89,119,117,103,105,41,83,25,41,55,69,117, & - 49,127,29,1,99,53,83,15,31,73,115,35,21,89,5,1,91,53,35,95, & - 83,19,85,55,51,101,33,41,55,45,95,61,27,37,89,75,57,61,15, & - 117,15,21,27,25,27,123,39,109,93,51,21,91,109,107,45,15,93, & - 127,3,53,81,79,107,79,87,35,109,73,35,83,107,1,51,7,59,33, & - 115,43,111,45,121,105,125,87,101,41,95,75,1,57,117,21,27,67, & - 29,53,117,63,1,77,89,115,49,127,15,79,81,29,65,103,33,73,79, & - 29,21,113,31,33,107,95,111,59,99,117,63,63,99,39,9,35,63,125, & - 99,45,93,33,93,9,105,75,51,115,11,37,17,41,21,43,73,19,93,7, & - 95,81,93,79,81,55,9,51,63,45,89,73,19,115,39,47,81,39,5,5,45, & - 53,65,49,17,105,13,107,5,5,19,73,59,43,83,97,115,27,1,69,103, & - 3,99,103,63,67,25,121,97,77,13,83,103,41,11,27,81,37,33,125, & - 71,41,41,59,41,87,123/) - v(306:589,7) = (/ & - 43,101,63,45,39,21,97,15,97,111,21,49, & - 13,17,79,91,65,105,75,1,45,67,83,107,125,87,15,81,95,105,65, & - 45,59,103,23,103,99,67,99,47,117,71,89,35,53,73,9,115,49,37, & - 1,35,9,45,81,19,127,17,17,105,89,49,101,7,37,33,11,95,95,17, & - 111,105,41,115,5,69,101,27,27,101,103,53,9,21,43,79,91,65, & - 117,87,125,55,45,63,85,83,97,45,83,87,113,93,95,5,17,77,77, & - 127,123,45,81,85,121,119,27,85,41,49,15,107,21,51,119,11,87, & - 101,115,63,63,37,121,109,7,43,69,19,77,49,71,59,35,7,13,55, & - 101,127,103,85,109,29,61,67,21,111,67,23,57,75,71,101,123,41, & - 107,101,107,125,27,47,119,41,19,127,33,31,109,7,91,91,39,125, & - 105,47,125,123,91,9,103,45,23,117,9,125,73,11,37,61,79,21,5, & - 47,117,67,53,85,33,81,121,47,61,51,127,29,65,45,41,95,57,73, & - 33,117,61,111,59,123,65,47,105,23,29,107,37,81,67,29,115,119, & - 75,73,99,103,7,57,45,61,95,49,101,101,35,47,119,39,67,31,103, & - 7,61,127,87,3,35,29,73,95,103,71,75,51,87,57,97,11,105,87,41, & - 73,109,69,35,121,39,111,1,77/) - v(590:875,7) = (/ & - 39,47,53,91,3,17,51,83,39,125,85,111, & - 21,69,85,29,55,11,117,1,47,17,65,63,47,117,17,115,51,25,33, & - 123,123,83,51,113,95,121,51,91,109,43,55,35,55,87,33,37,5,3, & - 45,21,105,127,35,17,35,37,97,97,21,77,123,17,89,53,105,75,25, & - 125,13,47,21,125,23,55,63,61,5,17,93,57,121,69,73,93,121,105, & - 75,91,67,95,75,9,69,97,99,93,11,53,19,73,5,33,79,107,65,69, & - 79,125,25,93,55,61,17,117,69,97,87,111,37,93,59,79,95,53,115, & - 53,85,85,65,59,23,75,21,67,27,99,79,27,3,95,27,69,19,75,47, & - 59,41,85,77,99,55,49,93,93,119,51,125,63,13,15,45,61,19,105, & - 115,17,83,7,7,11,61,37,63,89,95,119,113,67,123,91,33,37,99, & - 43,11,33,65,81,79,81,107,63,63,55,89,91,25,93,101,27,55,75, & - 121,79,43,125,73,27,109,35,21,71,113,89,59,95,41,45,113,119, & - 113,39,59,73,15,13,59,67,121,27,7,105,15,59,59,35,91,89,23, & - 125,97,53,41,91,111,29,31,3,103,61,71,35,7,119,29,45,49,111, & - 41,109,59,125,13,27,19,79,9,75,83,81,33,91,109,33,29,107,111, & - 101,107,109,65,59,43,37/) - v(876:1111,7) = (/ & - 1,9,15,109,37,111,113,119,79,73,65, & - 71,93,17,101,87,97,43,23,75,109,41,49,53,31,97,105,109,119, & - 51,9,53,113,97,73,89,79,49,61,105,13,99,53,71,7,87,21,101,5, & - 71,31,123,121,121,73,79,115,13,39,101,19,37,51,83,97,55,81, & - 91,127,105,89,63,47,49,75,37,77,15,49,107,23,23,35,19,69,17, & - 59,63,73,29,125,61,65,95,101,81,57,69,83,37,11,37,95,1,73,27, & - 29,57,7,65,83,99,69,19,103,43,95,25,19,103,41,125,97,71,105, & - 83,83,61,39,9,45,117,63,31,5,117,67,125,41,117,43,77,97,15, & - 29,5,59,25,63,87,39,39,77,85,37,81,73,89,29,125,109,21,23, & - 119,105,43,93,97,15,125,29,51,69,37,45,31,75,109,119,53,5, & - 101,125,121,35,29,7,63,17,63,13,69,15,105,51,127,105,9,57,95, & - 59,109,35,49,23,33,107,55,33,57,79,73,69,59,107,55,11,63,95, & - 103,23,125,91,31,91,51,65,61,75,69,107,65,101,59,35,15/) - v(38:299,8) = (/ & - 7,23,39,217,141,27,53,181,169,35,15, & - 207,45,247,185,117,41,81,223,151,81,189,61,95,185,23,73,113, & - 239,85,9,201,83,53,183,203,91,149,101,13,111,239,3,205,253, & - 247,121,189,169,179,197,175,217,249,195,95,63,19,7,5,75,217, & - 245,111,189,165,169,141,221,249,159,253,207,249,219,23,49, & - 127,237,5,25,177,37,103,65,167,81,87,119,45,79,143,57,79,187, & - 143,183,75,97,211,149,175,37,135,189,225,241,63,33,43,13,73, & - 213,57,239,183,117,21,29,115,43,205,223,15,3,159,51,101,127, & - 99,239,171,113,171,119,189,245,201,27,185,229,105,153,189,33, & - 35,137,77,97,17,181,55,197,201,155,37,197,137,223,25,179,91, & - 23,235,53,253,49,181,249,53,173,97,247,67,115,103,159,239,69, & - 173,217,95,221,247,97,91,123,223,213,129,181,87,239,85,89, & - 249,141,39,57,249,71,101,159,33,137,189,71,253,205,171,13, & - 249,109,131,199,189,179,31,99,113,41,173,23,189,197,3,135,9, & - 95,195,27,183,1,123,73,53,99,197,59,27,101,55,193,31,61,119, & - 11,7,255,233,53,157,193,97,83,65,81,239,167,69,71,109/) - v(300:559,8) = (/ & - 97,137,71,193,189,115,79,205,37,227, & - 53,33,91,229,245,105,77,229,161,103,93,13,161,229,223,69,15, & - 25,23,233,93,25,217,247,61,75,27,9,223,213,55,197,145,89,199, & - 41,201,5,149,35,119,183,53,11,13,3,179,229,43,55,187,233,47, & - 133,91,47,71,93,105,145,45,255,221,115,175,19,129,5,209,197, & - 57,177,115,187,119,77,211,111,33,113,23,87,137,41,7,83,43, & - 121,145,5,219,27,11,111,207,55,97,63,229,53,33,149,23,187, & - 153,91,193,183,59,211,93,139,59,179,163,209,77,39,111,79,229, & - 85,237,199,137,147,25,73,121,129,83,87,93,205,167,53,107,229, & - 213,95,219,109,175,13,209,97,61,147,19,13,123,73,35,141,81, & - 19,171,255,111,107,233,113,133,89,9,231,95,69,33,1,253,219, & - 253,247,129,11,251,221,153,35,103,239,7,27,235,181,5,207,53, & - 149,155,225,165,137,155,201,97,245,203,47,39,35,105,239,49, & - 15,253,7,237,213,55,87,199,27,175,49,41,229,85,3,149,179,129, & - 185,249,197,15,97,197,139,203,63,33,251,217,199,199,99,249, & - 33,229,177,13,209,147,97,31,125,177,137/) - v(560:819,8) = (/ & - 187,11,91,223,29,169,231,59,31,163,41, & - 57,87,247,25,127,101,207,187,73,61,105,27,91,171,243,33,3,1, & - 21,229,93,71,61,37,183,65,211,53,11,151,165,47,5,129,79,101, & - 147,169,181,19,95,77,139,197,219,97,239,183,143,9,13,209,23, & - 215,53,137,203,19,151,171,133,219,231,3,15,253,225,33,111, & - 183,213,169,119,111,15,201,123,121,225,113,113,225,161,165,1, & - 139,55,3,93,217,193,97,29,69,231,161,93,69,143,137,9,87,183, & - 113,183,73,215,137,89,251,163,41,227,145,57,81,57,11,135,145, & - 161,175,159,25,55,167,157,211,97,247,249,23,129,159,71,197, & - 127,141,219,5,233,131,217,101,131,33,157,173,69,207,239,81, & - 205,11,41,169,65,193,77,201,173,1,221,157,1,15,113,147,137, & - 205,225,73,45,49,149,113,253,99,17,119,105,117,129,243,75, & - 203,53,29,247,35,247,171,31,199,213,29,251,7,251,187,91,11, & - 149,13,205,37,249,137,139,9,7,113,183,205,187,39,3,79,155, & - 227,89,185,51,127,63,83,41,133,183,181,127,19,255,219,59,251, & - 3,187,57,217,115,217,229,181,185,149,83,115,11/) - v(820:1074,8) = (/ & - 123,19,109,165,103,123,219,129,155, & - 207,177,9,49,181,231,33,233,67,155,41,9,95,123,65,117,249,85, & - 169,129,241,173,251,225,147,165,69,81,239,95,23,83,227,249, & - 143,171,193,9,21,57,73,97,57,29,239,151,159,191,47,51,1,223, & - 251,251,151,41,119,127,131,33,209,123,53,241,25,31,183,107, & - 25,115,39,11,213,239,219,109,185,35,133,123,185,27,55,245,61, & - 75,205,213,169,163,63,55,49,83,195,51,31,41,15,203,41,63,127, & - 161,5,143,7,199,251,95,75,101,15,43,237,197,117,167,155,21, & - 83,205,255,49,101,213,237,135,135,21,73,93,115,7,85,223,237, & - 79,89,5,57,239,67,65,201,155,71,85,195,89,181,119,135,147, & - 237,173,41,155,67,113,111,21,183,23,103,207,253,69,219,205, & - 195,43,197,229,139,177,129,69,97,201,163,189,11,99,91,253, & - 239,91,145,19,179,231,121,7,225,237,125,191,119,59,175,237, & - 131,79,43,45,205,199,251,153,207,37,179,113,255,107,217,61,7, & - 181,247,31,13,113,145,107,233,233,43,79,23,169,137,129,183, & - 53,91,55,103,223,87,177,157,79,213,139/) - v(1075:1111,8) = (/ & - 183,231,205,143,129,243,205,93,59, & - 15,89,9,11,47,133,227,75,9,91,19,171,163,79,7,103,5,119,155, & - 75,11,71,95,17,13,243,207,187/) - v(54:299,9) = (/ & - 235,307,495,417,57,151,19,119,375,451, & - 55,449,501,53,185,317,17,21,487,13,347,393,15,391,307,189, & - 381,71,163,99,467,167,433,337,257,179,47,385,23,117,369,425, & - 207,433,301,147,333,85,221,423,49,3,43,229,227,201,383,281, & - 229,207,21,343,251,397,173,507,421,443,399,53,345,77,385,317, & - 155,187,269,501,19,169,235,415,61,247,183,5,257,401,451,95, & - 455,49,489,75,459,377,87,463,155,233,115,429,211,419,143,487, & - 195,209,461,193,157,193,363,181,271,445,381,231,135,327,403, & - 171,197,181,343,113,313,393,311,415,267,247,425,233,289,55, & - 39,247,327,141,5,189,183,27,337,341,327,87,429,357,265,251, & - 437,201,29,339,257,377,17,53,327,47,375,393,369,403,125,429, & - 257,157,217,85,267,117,337,447,219,501,41,41,193,509,131,207, & - 505,421,149,111,177,167,223,291,91,29,305,151,177,337,183, & - 361,435,307,507,77,181,507,315,145,423,71,103,493,271,469, & - 339,237,437,483,31,219,61,131,391,233,219,69,57,459,225,421, & - 7,461,111,451,277,185,193,125,251,199,73,71,7,409,417,149/) - v(300:550,9) = (/ & - 193,53,437,29,467,229,31,35,75,105, & - 503,75,317,401,367,131,365,441,433,93,377,405,465,259,283, & - 443,143,445,3,461,329,309,77,323,155,347,45,381,315,463,207, & - 321,157,109,479,313,345,167,439,307,235,473,79,101,245,19, & - 381,251,35,25,107,187,115,113,321,115,445,61,77,293,405,13, & - 53,17,171,299,41,79,3,485,331,13,257,59,201,497,81,451,199, & - 171,81,253,365,75,451,149,483,81,453,469,485,305,163,401,15, & - 91,3,129,35,239,355,211,387,101,299,67,375,405,357,267,363, & - 79,83,437,457,39,97,473,289,179,57,23,49,79,71,341,287,95, & - 229,271,475,49,241,261,495,353,381,13,291,37,251,105,399,81, & - 89,265,507,205,145,331,129,119,503,249,1,289,463,163,443,63, & - 123,361,261,49,429,137,355,175,507,59,277,391,25,185,381,197, & - 39,5,429,119,247,177,329,465,421,271,467,151,45,429,137,471, & - 11,17,409,347,199,463,177,11,51,361,95,497,163,351,127,395, & - 511,327,353,49,105,151,321,331,329,509,107,109,303,467,287, & - 161,45,385,289,363,331,265,407,37,433,315,343,63,51,185,71, & - 27,267/) - v(551:798,9) = (/ & - 503,239,293,245,281,297,75,461,371, & - 129,189,189,339,287,111,111,379,93,27,185,347,337,247,507, & - 161,231,43,499,73,327,263,331,249,493,37,25,115,3,167,197, & - 127,357,497,103,125,191,165,55,101,95,79,351,341,43,125,135, & - 173,289,373,133,421,241,281,213,177,363,151,227,145,363,239, & - 431,81,397,241,67,291,255,405,421,399,75,399,105,329,41,425, & - 7,283,375,475,427,277,209,411,3,137,195,289,509,121,55,147, & - 275,251,19,129,285,415,487,491,193,219,403,23,97,65,285,75, & - 21,373,261,339,239,495,415,333,107,435,297,213,149,463,199, & - 323,45,19,301,121,499,187,229,63,425,99,281,35,125,349,87, & - 101,59,195,511,355,73,263,243,101,165,141,11,389,219,187,449, & - 447,393,477,305,221,51,355,209,499,479,265,377,145,411,173, & - 11,433,483,135,385,341,89,209,391,33,395,319,451,119,341,227, & - 375,61,331,493,411,293,47,203,375,167,395,155,5,237,361,489, & - 127,21,345,101,371,233,431,109,119,277,125,263,73,135,123,83, & - 123,405,69,75,287,401,23,283,393,41,379,431,11,475,505,19, & - 365,265,271/) - v(799:1045,9) = (/ & - 499,489,443,165,91,83,291,319,199, & - 107,245,389,143,137,89,125,281,381,215,131,299,249,375,455, & - 43,73,281,217,297,229,431,357,81,357,171,451,481,13,387,491, & - 489,439,385,487,177,393,33,71,375,443,129,407,395,127,65,333, & - 309,119,197,435,497,373,71,379,509,387,159,265,477,463,449, & - 47,353,249,335,505,89,141,55,235,187,87,363,93,363,101,67, & - 215,321,331,305,261,411,491,479,65,307,469,415,131,315,487, & - 83,455,19,113,163,503,99,499,251,239,81,167,391,255,317,363, & - 359,395,419,307,251,267,171,461,183,465,165,163,293,477,223, & - 403,389,97,335,357,297,19,469,501,249,85,213,311,265,379,297, & - 283,393,449,463,289,159,289,499,407,129,137,221,43,89,403, & - 271,75,83,445,453,389,149,143,423,499,317,445,157,137,453, & - 163,87,23,391,119,427,323,173,89,259,377,511,249,31,363,229, & - 353,329,493,427,57,205,389,91,83,13,219,439,45,35,371,441,17, & - 267,501,53,25,333,17,201,475,257,417,345,381,377,55,403,77, & - 389,347,363,211,413,419,5,167,219,201,285,425,11,77,269,489, & - 281,403,79/) - v(1046:1111,9) = (/ & - 425,125,81,331,437,271,397,299,475, & - 271,249,413,233,261,495,171,69,27,409,21,421,367,81,483,255, & - 15,219,365,497,181,75,431,99,325,407,229,281,63,83,493,5,113, & - 15,271,37,87,451,299,83,451,311,441,47,455,47,253,13,109,369, & - 347,11,409,275,63,441,15/) - v(102:344,10) = (/ & - 519,307,931,1023,517,771,151,1023, & - 539,725,45,927,707,29,125,371,275,279,817,389,453,989,1015, & - 29,169,743,99,923,981,181,693,309,227,111,219,897,377,425, & - 609,227,19,221,143,581,147,919,127,725,793,289,411,835,921, & - 957,443,349,813,5,105,457,393,539,101,197,697,27,343,515,69, & - 485,383,855,693,133,87,743,747,475,87,469,763,721,345,479, & - 965,527,121,271,353,467,177,245,627,113,357,7,691,725,355, & - 889,635,737,429,545,925,357,873,187,351,677,999,921,477,233, & - 765,495,81,953,479,89,173,473,131,961,411,291,967,65,511,13, & - 805,945,369,827,295,163,835,259,207,331,29,315,999,133,967, & - 41,117,677,471,717,881,755,351,723,259,879,455,721,289,149, & - 199,805,987,851,423,597,129,11,733,549,153,285,451,559,377, & - 109,357,143,693,615,677,701,475,767,85,229,509,547,151,389, & - 711,785,657,319,509,99,1007,775,359,697,677,85,497,105,615, & - 891,71,449,835,609,377,693,665,627,215,911,503,729,131,19, & - 895,199,161,239,633,1013,537,255,23,149,679,1021,595,199,557, & - 659,251,829,727,439,495,647,223/) - v(345:586,10) = (/ & - 949,625,87,481,85,799,917,769,949, & - 739,115,499,945,547,225,1015,469,737,495,353,103,17,665,639, & - 525,75,447,185,43,729,577,863,735,317,99,17,477,893,537,519, & - 1017,375,297,325,999,353,343,729,135,489,859,267,141,831,141, & - 893,249,807,53,613,131,547,977,131,999,175,31,341,739,467, & - 675,241,645,247,391,583,183,973,433,367,131,467,571,309,385, & - 977,111,917,935,473,345,411,313,97,149,959,841,839,669,431, & - 51,41,301,247,1015,377,329,945,269,67,979,581,643,823,557,91, & - 405,117,801,509,347,893,303,227,783,555,867,99,703,111,797, & - 873,541,919,513,343,319,517,135,871,917,285,663,301,15,763, & - 89,323,757,317,807,309,1013,345,499,279,711,915,411,281,193, & - 739,365,315,375,809,469,487,621,857,975,537,939,585,129,625, & - 447,129,1017,133,83,3,415,661,53,115,903,49,79,55,385,261, & - 345,297,199,385,617,25,515,275,849,401,471,377,661,535,505, & - 939,465,225,929,219,955,659,441,117,527,427,515,287,191,33, & - 389,197,825,63,417,949,35,571,9,131,609,439,95,19,569,893, & - 451,397,971,801/) - v(587:824,10) = (/ & - 125,471,187,257,67,949,621,453,411, & - 621,955,309,783,893,597,377,753,145,637,941,593,317,555,375, & - 575,175,403,571,555,109,377,931,499,649,653,329,279,271,647, & - 721,665,429,957,803,767,425,477,995,105,495,575,687,385,227, & - 923,563,723,481,717,111,633,113,369,955,253,321,409,909,367, & - 33,967,453,863,449,539,781,911,113,7,219,725,1015,971,1021, & - 525,785,873,191,893,297,507,215,21,153,645,913,755,371,881, & - 113,903,225,49,587,201,927,429,599,513,97,319,331,833,325, & - 887,139,927,399,163,307,803,169,1019,869,537,907,479,335,697, & - 479,353,769,787,1023,855,493,883,521,735,297,1011,991,879, & - 855,591,415,917,375,453,553,189,841,339,211,601,57,765,745, & - 621,209,875,639,7,595,971,263,1009,201,23,77,621,33,535,963, & - 661,523,263,917,103,623,231,47,301,549,337,675,189,357,1005, & - 789,189,319,721,1005,525,675,539,191,813,917,51,167,415,579, & - 755,605,721,837,529,31,327,799,961,279,409,847,649,241,285, & - 545,407,161,591,73,313,811,17,663,269,261,37,783,127,917,231, & - 577,975,793/) - v(825:1065,10) = (/ & - 921,343,751,139,221,79,817,393,545, & - 11,781,71,1,699,767,917,9,107,341,587,903,965,599,507,843, & - 739,579,397,397,325,775,565,925,75,55,979,931,93,957,857,753, & - 965,795,67,5,87,909,97,995,271,875,671,613,33,351,69,811,669, & - 729,401,647,241,435,447,721,271,745,53,775,99,343,451,427, & - 593,339,845,243,345,17,573,421,517,971,499,435,769,75,203, & - 793,985,343,955,735,523,659,703,303,421,951,405,631,825,735, & - 433,841,485,49,749,107,669,211,497,143,99,57,277,969,107,397, & - 563,551,447,381,187,57,405,731,769,923,955,915,737,595,341, & - 253,823,197,321,315,181,885,497,159,571,981,899,785,947,217, & - 217,135,753,623,565,717,903,581,955,621,361,869,87,943,907, & - 853,353,335,197,771,433,743,195,91,1023,63,301,647,205,485, & - 927,1003,987,359,577,147,141,1017,701,273,89,589,487,859,343, & - 91,847,341,173,287,1003,289,639,983,685,697,35,701,645,911, & - 501,705,873,763,745,657,559,699,315,347,429,197,165,955,859, & - 167,303,833,531,473,635,641,195,589,821,205,3,635,371,891, & - 249,123/) - v(1066:1111,10) = (/ & - 77,623,993,401,525,427,71,655,951, & - 357,851,899,535,493,323,1003,343,515,859,1017,5,423,315,1011, & - 703,41,777,163,95,831,79,975,235,633,723,297,589,317,679,981, & - 195,399,1003,121,501,155/) - v(162:376,11) = (/ & - 7,2011,1001,49,825,415,1441,383,1581, & - 623,1621,1319,1387,619,839,217,75,1955,505,281,1629,1379,53, & - 1111,1399,301,209,49,155,1647,631,129,1569,335,67,1955,1611, & - 2021,1305,121,37,877,835,1457,669,1405,935,1735,665,551,789, & - 1543,1267,1027,1,1911,163,1929,67,1975,1681,1413,191,1711, & - 1307,401,725,1229,1403,1609,2035,917,921,1789,41,2003,187,67, & - 1635,717,1449,277,1903,1179,363,1211,1231,647,1261,1029,1485, & - 1309,1149,317,1335,171,243,271,1055,1601,1129,1653,205,1463, & - 1681,1621,197,951,573,1697,1265,1321,1805,1235,1853,1307,945, & - 1197,1411,833,273,1517,1747,1095,1345,869,57,1383,221,1713, & - 335,1751,1141,839,523,1861,1105,389,1177,1877,805,93,1591, & - 423,1835,99,1781,1515,1909,1011,303,385,1635,357,973,1781, & - 1707,1363,1053,649,1469,623,1429,1241,1151,1055,503,921,3, & - 349,1149,293,45,303,877,1565,1583,1001,663,1535,395,1141, & - 1481,1797,643,1507,465,2027,1695,367,937,719,545,1991,83,819, & - 239,1791,1461,1647,1501,1161,1629,139,1595,1921,1267,1415, & - 509,347,777,1083,363,269,1015/) - v(377:589,11) = (/ & - 1809,1105,1429,1471,2019,381,2025, & - 1223,827,1733,887,1321,803,1951,1297,1995,833,1107,1135,1181, & - 1251,983,1389,1565,273,137,71,735,1005,933,67,1471,551,457, & - 1667,1729,919,285,1629,1815,653,1919,1039,531,393,1411,359, & - 221,699,1485,471,1357,1715,595,1677,153,1903,1281,215,781, & - 543,293,1807,965,1695,443,1985,321,879,1227,1915,839,1945, & - 1993,1165,51,557,723,1491,817,1237,947,1215,1911,1225,1965, & - 1889,1503,1177,73,1767,303,177,1897,1401,321,921,217,1779, & - 327,1889,333,615,1665,1825,1639,237,1205,361,129,1655,983, & - 1089,1171,401,677,643,749,303,1407,1873,1579,1491,1393,1247, & - 789,763,49,5,1607,1891,735,1557,1909,1765,1777,1127,813,695, & - 97,731,1503,1751,333,769,865,693,377,1919,957,1359,1627,1039, & - 1783,1065,1665,1917,1947,991,1997,841,459,221,327,1595,1881, & - 1269,1007,129,1413,475,1105,791,1983,1359,503,691,659,691, & - 343,1375,1919,263,1373,603,1383,297,781,145,285,767,1739, & - 1715,715,317,1333,85,831,1615,81,1667,1467,1457,1453,1825, & - 109,387,1207,2039,213,1351,1329,1173/) - v(590:802,11) = (/ & - 57,1769,951,183,23,451,1155,1551, & - 2037,811,635,1671,1451,863,1499,1673,363,1029,1077,1525,277, & - 1023,655,665,1869,1255,965,277,1601,329,1603,1901,395,65, & - 1307,2029,21,1321,543,1569,1185,1905,1701,413,2041,1697,725, & - 1417,1847,411,211,915,1891,17,1877,1699,687,1089,1973,1809, & - 851,1495,1257,63,1323,1307,609,881,1543,177,617,1505,1747, & - 1537,925,183,77,1723,1877,1703,397,459,521,257,1177,389,1947, & - 1553,1583,1831,261,485,289,1281,1543,1591,1123,573,821,1065, & - 1933,1373,2005,905,207,173,1573,1597,573,1883,1795,1499,1743, & - 553,335,333,1645,791,871,1157,969,557,141,223,1129,1685,423, & - 1069,391,99,95,1847,531,1859,1833,1833,341,237,1997,1799,409, & - 431,1917,363,335,1039,1085,1657,1975,1527,1111,659,389,899, & - 595,1439,1861,1979,1569,1087,1009,165,1895,1481,1583,29,1193, & - 1673,1075,301,1081,1377,1747,1497,1103,1789,887,739,1577,313, & - 1367,1299,1801,1131,1837,73,1865,1065,843,635,55,1655,913, & - 1037,223,1871,1161,461,479,511,1721,1107,389,151,35,375,1099, & - 937,1185,1701,769,639,1633/) - v(803:1018,11) = (/ & - 1609,379,1613,2031,685,289,975,671, & - 1599,1447,871,647,99,139,1427,959,89,117,841,891,1959,223, & - 1697,1145,499,1435,1809,1413,1445,1675,171,1073,1349,1545, & - 2039,1027,1563,859,215,1673,1919,1633,779,411,1845,1477,1489, & - 447,1545,351,1989,495,183,1639,1385,1805,1097,1249,1431,1571, & - 591,697,1509,709,31,1563,165,513,1425,1299,1081,145,1841, & - 1211,941,609,845,1169,1865,1593,347,293,1277,157,211,93,1679, & - 1799,527,41,473,563,187,1525,575,1579,857,703,1211,647,709, & - 981,285,697,163,981,153,1515,47,1553,599,225,1147,381,135, & - 821,1965,609,1033,983,503,1117,327,453,2005,1257,343,1649, & - 1199,599,1877,569,695,1587,1475,187,973,233,511,51,1083,665, & - 1321,531,1875,1939,859,1507,1979,1203,1965,737,921,1565,1943, & - 819,223,365,167,1705,413,1577,745,1573,655,1633,1003,91,1123, & - 477,1741,1663,35,715,37,1513,815,941,1379,263,1831,1735,1111, & - 1449,353,1941,1655,1349,877,285,1723,125,1753,985,723,175, & - 439,791,1051,1261,717,1555,1757,1777,577,1583,1957,873,331, & - 1163,313,1,1963,963,1905,821/) - v(1019:1111,11) = (/ & - 1677,185,709,545,1723,215,1885, & - 1249,583,1803,839,885,485,413,1767,425,129,1035,329,1263, & - 1881,1779,1565,359,367,453,707,1419,831,1889,887,1871,1869, & - 747,223,1547,1799,433,1441,553,2021,1303,1505,1735,1619,1065, & - 1161,2047,347,867,881,1447,329,781,1065,219,589,645,1257, & - 1833,749,1841,1733,1179,1191,1025,1639,1955,1423,1685,1711, & - 493,549,783,1653,397,895,233,759,1505,677,1449,1573,1297, & - 1821,1691,791,289,1187,867,1535,575,183/) - v(338:545,12) = (/ & - 3915,97,3047,937,2897,953,127,1201, & - 3819,193,2053,3061,3759,1553,2007,2493,603,3343,3751,1059, & - 783,1789,1589,283,1093,3919,2747,277,2605,2169,2905,721,4069, & - 233,261,1137,3993,3619,2881,1275,3865,1299,3757,1193,733,993, & - 1153,2945,3163,3179,437,271,3493,3971,1005,2615,2253,1131, & - 585,2775,2171,2383,2937,2447,1745,663,1515,3767,2709,1767, & - 3185,3017,2815,1829,87,3341,793,2627,2169,1875,3745,367,3783, & - 783,827,3253,2639,2955,3539,1579,2109,379,2939,3019,1999, & - 2253,2911,3733,481,1767,1055,4019,4085,105,1829,2097,2379, & - 1567,2713,737,3423,3941,2659,3961,1755,3613,1937,1559,2287, & - 2743,67,2859,325,2601,1149,3259,2403,3947,2011,175,3389,3915, & - 1315,2447,141,359,3609,3933,729,2051,1755,2149,2107,1741, & - 1051,3681,471,1055,845,257,1559,1061,2803,2219,1315,1369, & - 3211,4027,105,11,1077,2857,337,3553,3503,3917,2665,3823,3403, & - 3711,2085,1103,1641,701,4095,2883,1435,653,2363,1597,767,869, & - 1825,1117,1297,501,505,149,873,2673,551,1499,2793,3277,2143, & - 3663,533,3991,575,1877,1009,3929,473,3009,2595,3249,675,3593/) - v(546:752,12) = (/ & - 2453,1567,973,595,1335,1715,589,85, & - 2265,3069,461,1659,2627,1307,1731,1501,1699,3545,3803,2157, & - 453,2813,2047,2999,3841,2361,1079,573,69,1363,1597,3427,2899, & - 2771,1327,1117,1523,3521,2393,2537,1979,3179,683,2453,453, & - 1227,779,671,3483,2135,3139,3381,3945,57,1541,3405,3381,2371, & - 2879,1985,987,3017,3031,3839,1401,3749,2977,681,1175,1519, & - 3355,907,117,771,3741,3337,1743,1227,3335,2755,1909,3603, & - 2397,653,87,2025,2617,3257,287,3051,3809,897,2215,63,2043, & - 1757,3671,297,3131,1305,293,3865,3173,3397,2269,3673,717, & - 3041,3341,3595,3819,2871,3973,1129,513,871,1485,3977,2473, & - 1171,1143,3063,3547,2183,3993,133,2529,2699,233,2355,231, & - 3241,611,1309,3829,1839,1495,301,1169,1613,2673,243,3601, & - 3669,2813,2671,2679,3463,2477,1795,617,2317,1855,1057,1703, & - 1761,2515,801,1205,1311,473,3963,697,1221,251,381,3887,1761, & - 3093,3721,2079,4085,379,3601,3845,433,1781,29,1897,1599,2163, & - 75,3475,3957,1641,3911,2959,2833,1279,1099,403,799,2183,2699, & - 1711,2037,727,289,1785,1575,3633,2367,1261,3953,1735,171, & - 1959/) - v(753:960,12) = (/ & - 2867,859,2951,3211,15,1279,1323,599, & - 1651,3951,1011,315,3513,3351,1725,3793,2399,287,4017,3571, & - 1007,541,3115,429,1585,1285,755,1211,3047,915,3611,2697,2129, & - 3669,81,3939,2437,915,779,3567,3701,2479,3807,1893,3927,2619, & - 2543,3633,2007,3857,3837,487,1769,3759,3105,2727,3155,2479, & - 1341,1657,2767,2541,577,2105,799,17,2871,3637,953,65,69,2897, & - 3841,3559,4067,2335,3409,1087,425,2813,1705,1701,1237,821, & - 1375,3673,2693,3925,1541,1871,2285,847,4035,1101,2029,855, & - 2733,2503,121,2855,1069,3463,3505,1539,607,1349,575,2301, & - 2321,1101,333,291,2171,4085,2173,2541,1195,925,4039,1379,699, & - 1979,275,953,1755,1643,325,101,2263,3329,3673,3413,1977,2727, & - 2313,1419,887,609,2475,591,2613,2081,3805,3435,2409,111,3557, & - 3607,903,231,3059,473,2959,2925,3861,2043,3887,351,2865,369, & - 1377,2639,1261,3625,3279,2201,2949,3049,449,1297,897,1891, & - 411,2773,749,2753,1825,853,2775,3547,3923,3923,987,3723,2189, & - 3877,3577,297,2763,1845,3083,2951,483,2169,3985,245,3655, & - 3441,1023,235,835,3693,3585,327,1003,543,3059,2637/) - v(961:1111,12) = (/ & - 2923,87,3617,1031,1043,903,2913, & - 2177,2641,3279,389,2009,525,4085,3299,987,2409,813,2683,373, & - 2695,3775,2375,1119,2791,223,325,587,1379,2877,2867,3793,655, & - 831,3425,1663,1681,2657,1865,3943,2977,1979,2271,3247,1267, & - 1747,811,159,429,2001,1195,3065,553,1499,3529,1081,2877,3077, & - 845,1793,2409,3995,2559,4081,1195,2955,1117,1409,785,287, & - 1521,1607,85,3055,3123,2533,2329,3477,799,3683,3715,337,3139, & - 3311,431,3511,2299,365,2941,3067,1331,1081,1097,2853,2299, & - 495,1745,749,3819,619,1059,3559,183,3743,723,949,3501,733, & - 2599,3983,3961,911,1899,985,2493,1795,653,157,433,2361,3093, & - 3119,3679,2367,1701,1445,1321,2397,1241,3305,3985,2349,4067, & - 3805,3073,2837,1567,3783,451,2441,1181,487,543,1201,3735, & - 2517,733,1535,2175,3613,3019/) - v(482:680,13) = (/ & - 2319,653,1379,1675,1951,7075,2087, & - 7147,1427,893,171,2019,7235,5697,3615,1961,7517,6849,2893, & - 1883,2863,2173,4543,73,381,3893,6045,1643,7669,1027,1549, & - 3983,1985,6589,7497,2745,2375,7047,1117,1171,1975,5199,3915, & - 3695,8113,4303,3773,7705,6855,1675,2245,2817,1719,569,1021, & - 2077,5945,1833,2631,4851,6371,833,7987,331,1899,8093,6719, & - 6903,5903,5657,5007,2689,6637,2675,1645,1819,689,6709,7717, & - 6295,7013,7695,3705,7069,2621,3631,6571,6259,7261,3397,7645, & - 1115,4753,2047,7579,2271,5403,4911,7629,4225,1209,6955,6951, & - 1829,5579,5231,1783,4285,7425,599,5785,3275,5643,2263,657, & - 6769,6261,1251,3249,4447,4111,3991,1215,131,4397,3487,7585, & - 5565,7199,3573,7105,7409,1671,949,3889,5971,3333,225,3647, & - 5403,3409,7459,6879,5789,6567,5581,4919,1927,4407,8085,4691, & - 611,3005,591,753,589,171,5729,5891,1033,3049,6567,5257,8003, & - 1757,4489,4923,6379,5171,1757,689,3081,1389,4113,455,2761, & - 847,7575,5829,633,6629,1103,7635,803,6175,6587,2711,3879,67, & - 1179,4761,7281,1557,3379,2459,4273,4127,7147,35/) - v(681:877,13) = (/ & - 3549,395,3735,5787,4179,5889,5057, & - 7473,4713,2133,2897,1841,2125,1029,1695,6523,1143,5105,7133, & - 3351,2775,3971,4503,7589,5155,4305,1641,4717,2427,5617,1267, & - 399,5831,4305,4241,3395,3045,4899,1713,171,411,7099,5473, & - 5209,1195,1077,1309,2953,7343,4887,3229,6759,6721,6775,675, & - 4039,2493,7511,3269,4199,6625,7943,2013,4145,667,513,2303, & - 4591,7941,2741,987,8061,3161,5951,1431,831,5559,7405,1357, & - 4319,4235,5421,2559,4415,2439,823,1725,6219,4903,6699,5451, & - 349,7703,2927,7809,6179,1417,5987,3017,4983,3479,4525,4643, & - 4911,227,5475,2287,5581,6817,1937,1421,4415,7977,1789,3907, & - 6815,6789,6003,5609,4507,337,7427,7943,3075,6427,1019,7121, & - 4763,81,3587,2929,1795,8067,2415,1265,4025,5599,4771,3025, & - 2313,6129,7611,6881,5253,4413,7869,105,3173,1629,2537,1023, & - 4409,7209,4413,7107,7469,33,1955,2881,5167,6451,4211,179, & - 5573,7879,3387,7759,5455,7157,1891,5683,5689,6535,3109,6555, & - 6873,1249,4251,6437,49,2745,1201,7327,4179,6783,623,2779, & - 5963,2585,6927,5333,4033,285,7467,4443,4917,3/) - v(878:1070,13) = (/ & - 4319,5517,3449,813,5499,2515,5771, & - 3357,2073,4395,4925,2643,7215,5817,1199,1597,1619,7535,4833, & - 609,4797,8171,6847,793,6757,8165,3371,2431,5235,4739,7703, & - 7223,6525,5891,5605,4433,3533,5267,5125,5037,225,6717,1121, & - 5741,2013,4327,4839,569,5227,7677,4315,2391,5551,859,3627, & - 6377,3903,4311,6527,7573,4905,7731,1909,1555,3279,1949,1887, & - 6675,5509,2033,5473,3539,5033,5935,6095,4761,1771,1271,1717, & - 4415,5083,6277,3147,7695,2461,4783,4539,5833,5583,651,1419, & - 2605,5511,3913,5795,2333,2329,4431,3725,6069,2699,7055,6879, & - 1017,3121,2547,4603,2385,6915,6103,5669,7833,2001,4287,6619, & - 955,2761,5711,6291,3415,3909,2841,5627,4939,7671,6059,6275, & - 6517,1931,4583,7301,1267,7509,1435,2169,6939,3515,2985,2787, & - 2123,1969,3307,353,4359,7059,5273,5873,6657,6765,6229,3179, & - 1583,6237,2155,371,273,7491,3309,6805,3015,6831,7819,713, & - 4747,3935,4109,1311,709,3089,7059,4247,2989,1509,4919,1841, & - 3045,3821,6929,4655,1333,6429,6649,2131,5265,1051,261,8057, & - 3379,2179,1993,5655,3063,6381/) - v(1071:1111,13) = (/ & - 3587,7417,1579,1541,2107,5085,2873, & - 6141,955,3537,2157,841,1999,1465,5171,5651,1535,7235,4349, & - 1263,1453,1005,6893,2919,1947,1635,3963,397,969,4569,655, & - 6737,2995,7235,7713,973,4821,2377,1673,1,6541/) -! -! Set POLY. -! - poly(1:211)= (/ & - 1,3,7,11,13,19,25,37,59,47,61,55,41,67,97,91, & - 109,103,115,131,193,137,145,143,241,157,185,167,229,171,213, & - 191,253,203,211,239,247,285,369,299,301,333,351,355,357,361, & - 391,397,425,451,463,487,501,529,539,545,557,563,601,607,617, & - 623,631,637,647,661,675,677,687,695,701,719,721,731,757,761, & - 787,789,799,803,817,827,847,859,865,875,877,883,895,901,911, & - 949,953,967,971,973,981,985,995,1001,1019,1033,1051,1063, & - 1069,1125,1135,1153,1163,1221,1239,1255,1267,1279,1293,1305, & - 1315,1329,1341,1347,1367,1387,1413,1423,1431,1441,1479,1509, & - 1527,1531,1555,1557,1573,1591,1603,1615,1627,1657,1663,1673, & - 1717,1729,1747,1759,1789,1815,1821,1825,1849,1863,1869,1877, & - 1881,1891,1917,1933,1939,1969,2011,2035,2041,2053,2071,2091, & - 2093,2119,2147,2149,2161,2171,2189,2197,2207,2217,2225,2255, & - 2257,2273,2279,2283,2293,2317,2323,2341,2345,2363,2365,2373, & - 2377,2385,2395,2419,2421,2431,2435,2447,2475,2477,2489,2503, & - 2521,2533,2551,2561,2567,2579,2581,2601,2633,2657,2669/) - poly(212:401)= (/ & - 2681,2687,2693,2705,2717,2727,2731,2739, & - 2741,2773,2783,2793,2799,2801,2811,2819,2825,2833,2867,2879, & - 2881,2891,2905,2911,2917,2927,2941,2951,2955,2963,2965,2991, & - 2999,3005,3017,3035,3037,3047,3053,3083,3085,3097,3103,3159, & - 3169,3179,3187,3205,3209,3223,3227,3229,3251,3263,3271,3277, & - 3283,3285,3299,3305,3319,3331,3343,3357,3367,3373,3393,3399, & - 3413,3417,3427,3439,3441,3475,3487,3497,3515,3517,3529,3543, & - 3547,3553,3559,3573,3589,3613,3617,3623,3627,3635,3641,3655, & - 3659,3669,3679,3697,3707,3709,3713,3731,3743,3747,3771,3791, & - 3805,3827,3833,3851,3865,3889,3895,3933,3947,3949,3957,3971, & - 3985,3991,3995,4007,4013,4021,4045,4051,4069,4073,4179,4201, & - 4219,4221,4249,4305,4331,4359,4383,4387,4411,4431,4439,4449, & - 4459,4485,4531,4569,4575,4621,4663,4669,4711,4723,4735,4793, & - 4801,4811,4879,4893,4897,4921,4927,4941,4977,5017,5027,5033, & - 5127,5169,5175,5199,5213,5223,5237,5287,5293,5331,5391,5405, & - 5453,5523,5573,5591,5597,5611,5641,5703,5717,5721,5797,5821, & - 5909,5913/) - poly(402:591)= (/ & - 5955,5957,6005,6025,6061,6067,6079,6081, & - 6231,6237,6289,6295,6329,6383,6427,6453,6465,6501,6523,6539, & - 6577,6589,6601,6607,6631,6683,6699,6707,6761,6795,6865,6881, & - 6901,6923,6931,6943,6999,7057,7079,7103,7105,7123,7173,7185, & - 7191,7207,7245,7303,7327,7333,7355,7365,7369,7375,7411,7431, & - 7459,7491,7505,7515,7541,7557,7561,7701,7705,7727,7749,7761, & - 7783,7795,7823,7907,7953,7963,7975,8049,8089,8123,8125,8137, & - 8219,8231,8245,8275,8293,8303,8331,8333,8351,8357,8367,8379, & - 8381,8387,8393,8417,8435,8461,8469,8489,8495,8507,8515,8551, & - 8555,8569,8585,8599,8605,8639,8641,8647,8653,8671,8675,8689, & - 8699,8729,8741,8759,8765,8771,8795,8797,8825,8831,8841,8855, & - 8859,8883,8895,8909,8943,8951,8955,8965,8999,9003,9031,9045, & - 9049,9071,9073,9085,9095,9101,9109,9123,9129,9137,9143,9147, & - 9185,9197,9209,9227,9235,9247,9253,9257,9277,9297,9303,9313, & - 9325,9343,9347,9371,9373,9397,9407,9409,9415,9419,9443,9481, & - 9495,9501,9505,9517,9529,9555,9557,9571,9585,9591,9607,9611, & - 9621,9625/) - poly(592:765)= (/ & - 9631,9647,9661,9669,9679,9687,9707,9731, & - 9733,9745,9773,9791,9803,9811,9817,9833,9847,9851,9863,9875, & - 9881,9905,9911,9917,9923,9963,9973,10003,10025,10043,10063, & - 10071,10077,10091,10099,10105,10115,10129,10145,10169,10183, & - 10187,10207,10223,10225,10247,10265,10271,10275,10289,10299, & - 10301,10309,10343,10357,10373,10411,10413,10431,10445,10453, & - 10463,10467,10473,10491,10505,10511,10513,10523,10539,10549, & - 10559,10561,10571,10581,10615,10621,10625,10643,10655,10671, & - 10679,10685,10691,10711,10739,10741,10755,10767,10781,10785, & - 10803,10805,10829,10857,10863,10865,10875,10877,10917,10921, & - 10929,10949,10967,10971,10987,10995,11009,11029,11043,11045, & - 11055,11063,11075,11081,11117,11135,11141,11159,11163,11181, & - 11187,11225,11237,11261,11279,11297,11307,11309,11327,11329, & - 11341,11377,11403,11405,11413,11427,11439,11453,11461,11473, & - 11479,11489,11495,11499,11533,11545,11561,11567,11575,11579, & - 11589,11611,11623,11637,11657,11663,11687,11691,11701,11747, & - 11761,11773,11783,11795,11797,11817,11849,11855,11867,11869, & - 11873,11883,11919/) - poly(766:936)= (/ & - 11921,11927,11933,11947,11955,11961, & - 11999,12027,12029,12037,12041,12049,12055,12095,12097,12107, & - 12109,12121,12127,12133,12137,12181,12197,12207,12209,12239, & - 12253,12263,12269,12277,12287,12295,12309,12313,12335,12361, & - 12367,12391,12409,12415,12433,12449,12469,12479,12481,12499, & - 12505,12517,12527,12549,12559,12597,12615,12621,12639,12643, & - 12657,12667,12707,12713,12727,12741,12745,12763,12769,12779, & - 12781,12787,12799,12809,12815,12829,12839,12857,12875,12883, & - 12889,12901,12929,12947,12953,12959,12969,12983,12987,12995, & - 13015,13019,13031,13063,13077,13103,13137,13149,13173,13207, & - 13211,13227,13241,13249,13255,13269,13283,13285,13303,13307, & - 13321,13339,13351,13377,13389,13407,13417,13431,13435,13447, & - 13459,13465,13477,13501,13513,13531,13543,13561,13581,13599, & - 13605,13617,13623,13637,13647,13661,13677,13683,13695,13725, & - 13729,13753,13773,13781,13785,13795,13801,13807,13825,13835, & - 13855,13861,13871,13883,13897,13905,13915,13939,13941,13969, & - 13979,13981,13997,14027,14035,14037,14051,14063,14085,14095, & - 14107,14113,14125,14137,14145/) - poly(937:1107)= (/ & - 14151,14163,14193,14199,14219,14229, & - 14233,14243,14277,14287,14289,14295,14301,14305,14323,14339, & - 14341,14359,14365,14375,14387,14411,14425,14441,14449,14499, & - 14513,14523,14537,14543,14561,14579,14585,14593,14599,14603, & - 14611,14641,14671,14695,14701,14723,14725,14743,14753,14759, & - 14765,14795,14797,14803,14831,14839,14845,14855,14889,14895, & - 14909,14929,14941,14945,14951,14963,14965,14985,15033,15039, & - 15053,15059,15061,15071,15077,15081,15099,15121,15147,15149, & - 15157,15167,15187,15193,15203,15205,15215,15217,15223,15243, & - 15257,15269,15273,15287,15291,15313,15335,15347,15359,15373, & - 15379,15381,15391,15395,15397,15419,15439,15453,15469,15491, & - 15503,15517,15527,15531,15545,15559,15593,15611,15613,15619, & - 15639,15643,15649,15661,15667,15669,15681,15693,15717,15721, & - 15741,15745,15765,15793,15799,15811,15825,15835,15847,15851, & - 15865,15877,15881,15887,15899,15915,15935,15937,15955,15973, & - 15977,16011,16035,16061,16069,16087,16093,16097,16121,16141, & - 16153,16159,16165,16183,16189,16195,16197,16201,16209,16215, & - 16225,16259,16265,16273,16299/) - poly(1108:1111)= (/ & - 16309,16355,16375,16381/) - - end if - - if ( dim_num /= dim_num_save ) then -! -! Check parameters. -! - if ( dim_num < 2 .or. dim_max < dim_num ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I4_SOBOL - Fatal error!' - write ( *, '(a)' ) ' The spatial dimension DIM_NUM should satisfy:' - write ( *, '(a,i8)' ) ' 2 <= DIM_NUM <= ', dim_max - write ( *, '(a,i8)' ) ' But this input value is DIM_NUM = ', dim_num - stop - end if - - dim_num_save = dim_num -! -! Set ATMOST = 2**LOG_MAX - 1. -! - atmost = 0 - do i = 1, log_max - atmost = 2 * atmost + 1 - end do -! -! Find the highest 1 bit in ATMOST (should be LOG_MAX). -! - maxcol = i4_bit_hi1 ( atmost ) -! -! Initialize row 1 of V. -! - v(1,1:maxcol) = 1 -! -! Initialize the remaining rows of V. -! - do i = 2, dim_num -! -! The bit pattern of the integer POLY(I) gives the form -! of polynomial I. -! -! Find the degree of polynomial I from binary encoding. -! - j = poly(i) - m = 0 - - do - - j = j / 2 - - if ( j <= 0 ) then - exit - end if - - m = m + 1 - - end do -! -! We expand this bit pattern to separate components -! of the logical array INCLUD. -! - j = poly(i) - do k = m, 1, - 1 - j2 = j / 2 - includ(k) = ( j /= ( 2 * j2 ) ) - j = j2 - end do -! -! Calculate the remaining elements of row I as explained -! in Bratley and Fox, section 2. -! - do j = m + 1, maxcol - - newv = v(i,j-m) - l = 1 - - do k = 1, m - - l = 2 * l - - if ( includ(k) ) then - newv = ieor ( newv, l * v(i,j-k) ) - end if - - end do - - v(i,j) = newv - - end do - - end do -! -! Multiply columns of V by appropriate power of 2. -! - l = 1 - do j = maxcol - 1, 1, - 1 - l = 2 * l - v(1:dim_num,j) = v(1:dim_num,j) * l - end do -! -! RECIPD is 1/(common denominator of the elements in V) = 1 / ( 2 * L ). -! - recipd = real ( l, kind = 4 ) - recipd = 0.5E+00 / recipd - - end if - - if ( seed < 0 ) then - seed = 0 - end if - - if ( seed == 0 ) then - - l = 1 - lastq(1:dim_num) = 0 - - else if ( seed == seed_save + 1 ) then -! -! Find the position of the right-hand zero in SEED. -! - l = i4_bit_lo0 ( seed ) - - else if ( seed <= seed_save ) then - - seed_save = 0 - l = 1 - lastq(1:dim_num) = 0 - - do seed_temp = seed_save, seed - 1 - l = i4_bit_lo0 ( seed_temp ) - lastq(1:dim_num) = ieor ( lastq(1:dim_num), v(1:dim_num,l) ) - end do - - l = i4_bit_lo0 ( seed ) - - else if ( seed_save+1 < seed ) then - - do seed_temp = seed_save+1, seed - 1 - l = i4_bit_lo0 ( seed_temp ) - lastq(1:dim_num) = ieor ( lastq(1:dim_num), v(1:dim_num,l) ) - end do - - l = i4_bit_lo0 ( seed ) - - end if - -! write ( *, * ) ' seed = ', seed, ' l = ', l -! -! Check that the user is not calling too many times! -! - if ( maxcol < l ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I4_SOBOL - Fatal error!' - write ( *, '(a)' ) ' Too many calls!' - write ( *, '(a,i12)' ) ' MAXCOL = ', maxcol - write ( *, '(a,i12)' ) ' L = ', l - stop - end if -! -! Calculate the new components of QUASI. -! - quasi(1:dim_num) = real ( lastq(1:dim_num), kind = 4 ) * recipd - lastq(1:dim_num) = ieor ( lastq(1:dim_num), v(1:dim_num,l) ) - - seed_save = seed - seed = seed + 1 - - return -end -subroutine i4_sobol_generate ( m, n, skip, r ) - -!*****************************************************************************80 -! -!! I4_SOBOL_GENERATE generates a Sobol dataset. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, the spatial dimension. -! -! Input, integer ( kind = 4 ) N, the number of points to generate. -! -! Input, integer ( kind = 4 ) SKIP, the number of initial points to skip. -! -! Output, real ( kind = 4 ) R(M,N), the points. -! - implicit none - - integer ( kind = 4 ) m - integer ( kind = 4 ) n - - integer ( kind = 4 ) j - real ( kind = 4 ), dimension ( m, n ) :: r - integer ( kind = 4 ) seed - integer ( kind = 4 ) skip - - do j = 1, n - seed = skip + j - 1 - call i4_sobol ( m, seed, r(1:m,j) ) - end do - - return -end -subroutine i4_sobol_write ( m, n, skip, r, file_out_name ) - -!*****************************************************************************80 -! -!! I4_SOBOL_WRITE writes a Sobol dataset to a file. -! -! Discussion: -! -! The initial lines of the file are comments, which begin with a -! '#' character. -! -! Thereafter, each line of the file contains the M-dimensional -! components of the SKIP+I-1 entry of the Sobol sequence. -! -! For the Sobol sequence, the value of SKIP is the same -! as the value of SEED used to generate the first point. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer M, the spatial dimension. -! -! Input, integer N, the number of (successive) points. -! -! Input, integer SKIP, the number of skipped points. -! -! Input, real R(M,N), the points. -! -! Input, character ( len = * ) FILE_OUT_NAME, the name of -! the output file. -! - implicit none - - integer ( kind = 4 ) m - integer ( kind = 4 ) n - - character ( len = * ) file_out_name - integer file_out_unit - integer ios - integer ( kind = 4 ) j - real ( kind = 4 ) r(m,n) - integer ( kind = 4 ) skip - character string - - call get_unit ( file_out_unit ) - - open ( unit = file_out_unit, file = file_out_name, status = 'replace', & - iostat = ios ) - - if ( ios /= 0 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I4_SOBOL_WRITE - Fatal error!' - write ( *, '(a)' ) ' Could not open the output file.' - stop - end if - - call timestring ( string ) - - write ( file_out_unit, '(a)' ) '# ' // trim ( file_out_name ) - write ( file_out_unit, '(a)' ) '# created by I4_SOBOL_WRITE.F90.' - write ( file_out_unit, '(a)' ) '#' - write ( file_out_unit, '(a)' ) '# File generated on ' & - // trim ( string ) - write ( file_out_unit, '(a)' ) '#' - write ( file_out_unit, '(a,i8)' ) '# Spatial dimension M = ', m - write ( file_out_unit, '(a,i8)' ) '# Number of points N = ', n - write ( file_out_unit, '(a,g14.6)' ) '# Epsilon (unit roundoff) = ', & - epsilon ( r(1,1) ) - write ( file_out_unit, '(a,i8)' ) '# Initial values skipped = ', skip - write ( file_out_unit, '(a)' ) '#' - - write ( string, '(a,i3,a)' ) '(', m, '(2x,f10.6))' - do j = 1, n - write ( file_out_unit, string ) r(1:m,j) - end do - - close ( unit = file_out_unit ) - - return -end -function i4_uniform ( a, b, seed ) - -!*****************************************************************************80 -! -!! I4_UNIFORM returns a scaled pseudorandom I4. -! -! Discussion: -! -! An I4 is an integer ( kind = 4 ) value. -! -! The pseudorandom number will be scaled to be uniformly distributed -! between A and B. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 November 2006 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Paul Bratley, Bennett Fox, Linus Schrage, -! A Guide to Simulation, -! Springer Verlag, pages 201-202, 1983. -! -! Pierre L'Ecuyer, -! Random Number Generation, -! in Handbook of Simulation, -! edited by Jerry Banks, -! Wiley Interscience, page 95, 1998. -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, pages 362-376, 1986. -! -! Peter Lewis, Allen Goodman, James Miller -! A Pseudo-Random Number Generator for the System/360, -! IBM Systems Journal, -! Volume 8, pages 136-143, 1969. -! -! Parameters: -! -! Input, integer ( kind = 4 ) A, B, the limits of the interval. -! -! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which -! should NOT be 0. On output, SEED has been updated. -! -! Output, integer ( kind = 4 ) I4_UNIFORM, a number between A and B. -! - implicit none - - integer ( kind = 4 ) a - integer ( kind = 4 ) b - integer ( kind = 4 ) i4_uniform - integer ( kind = 4 ) k - real ( kind = 4 ) r - integer ( kind = 4 ) seed - integer ( kind = 4 ) value - - if ( seed == 0 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I4_UNIFORM - Fatal error!' - write ( *, '(a)' ) ' Input value of SEED = 0.' - stop - end if - - k = seed / 127773 - - seed = 16807 * ( seed - k * 127773 ) - k * 2836 - - if ( seed < 0 ) then - seed = seed + 2147483647 - end if - - r = real ( seed, kind = 4 ) * 4.656612875E-10 -! -! Scale R to lie between A-0.5 and B+0.5. -! - r = ( 1.0E+00 - r ) * ( real ( min ( a, b ), kind = 4 ) - 0.5E+00 ) & - + r * ( real ( max ( a, b ), kind = 4 ) + 0.5E+00 ) -! -! Use rounding to convert R to an integer between A and B. -! - value = nint ( r, kind = 4 ) - - value = max ( value, min ( a, b ) ) - value = min ( value, max ( a, b ) ) - - i4_uniform = value - - return -end -function i4_xor ( i, j ) - -!*****************************************************************************80 -! -!! I4_XOR calculates the exclusive OR of two integers. -! -! Discussion: -! -! This function is NOT needed in FORTRAN90, which supplies the -! intrinsic IEOR function for this purpose. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) I, J, two values whose exclusive OR is needed. -! -! Output, integer ( kind = 4 ) I4_XOR, the exclusive OR of I and J. -! - implicit none - - integer ( kind = 4 ) i - integer ( kind = 4 ) i1 - integer ( kind = 4 ) i2 - integer ( kind = 4 ) i4_xor - integer ( kind = 4 ) j - integer ( kind = 4 ) j1 - integer ( kind = 4 ) j2 - integer ( kind = 4 ) k - integer ( kind = 4 ) l - - i1 = i - j1 = j - k = 0 - l = 1 - - do while ( i1 /= 0 .or. j1 /= 0 ) - - i2 = i1 / 2 - j2 = j1 / 2 - - if ( & - ( ( i1 == 2 * i2 ) .and. ( j1 /= 2 * j2 ) ) .or. & - ( ( i1 /= 2 * i2 ) .and. ( j1 == 2 * j2 ) ) ) then - k = k + l - end if - - i1 = i2 - j1 = j2 - l = 2 * l - - end do - - i4_xor = k - - return -end -function i8_bit_hi1 ( n ) - -!*****************************************************************************80 -! -!! I8_BIT_HI1 returns the position of the high 1 bit base 2 in an integer. -! -! Discussion: -! -! This routine uses the integer precision corresponding to a KIND of 8. -! -! Example: -! -! N Binary Hi 1 -! ---- -------- ---- -! 0 0 0 -! 1 1 1 -! 2 10 2 -! 3 11 2 -! 4 100 3 -! 5 101 3 -! 6 110 3 -! 7 111 3 -! 8 1000 4 -! 9 1001 4 -! 10 1010 4 -! 11 1011 4 -! 12 1100 4 -! 13 1101 4 -! 14 1110 4 -! 15 1111 4 -! 16 10000 5 -! 17 10001 5 -! 1023 1111111111 10 -! 1024 10000000000 11 -! 1025 10000000001 11 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 May 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 8 ) N, the integer to be measured. -! N should be nonnegative. If N is nonpositive, I8_BIT_HI1 -! will always be 0. -! -! Output, integer ( kind = 8 ) I8_BIT_HI1, the number of bits base 2. -! - implicit none - - integer ( kind = 8 ) :: bit - integer ( kind = 8 ) :: i8_bit_hi1 - integer ( kind = 8 ) :: i - integer ( kind = 8 ) :: n - - i = n - bit = 0 - - do - - if ( i <= 0 ) then - exit - end if - - bit = bit + 1 - i = i / 2 - - end do - - i8_bit_hi1 = bit - - return -end -function i8_bit_lo0 ( n ) - -!*****************************************************************************80 -! -!! I8_BIT_LO0 returns the position of the low 0 bit base 2 in an integer. -! -! Discussion: -! -! This routine uses the integer precision corresponding to a KIND of 8. -! -! Example: -! -! N Binary Lo 0 -! ---- -------- ---- -! 0 0 1 -! 1 1 2 -! 2 10 1 -! 3 11 3 -! 4 100 1 -! 5 101 2 -! 6 110 1 -! 7 111 4 -! 8 1000 1 -! 9 1001 2 -! 10 1010 1 -! 11 1011 3 -! 12 1100 1 -! 13 1101 2 -! 14 1110 1 -! 15 1111 5 -! 16 10000 1 -! 17 10001 2 -! 1023 1111111111 1 -! 1024 10000000000 1 -! 1025 10000000001 1 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 May 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 8 ) N, the integer to be measured. -! N should be nonnegative. -! -! Output, integer ( kind = 8 ) I8_BIT_LO0, the position of the low 1 bit. -! - implicit none - - integer ( kind = 8 ) :: bit - integer ( kind = 8 ) :: i - integer ( kind = 8 ) :: i2 - integer ( kind = 8 ) :: i8_bit_lo0 - integer ( kind = 8 ) :: n - - bit = 0 - i = n - - do - - bit = bit + 1 - i2 = i / 2 - - if ( i == 2 * i2 ) then - exit - end if - - i = i2 - - end do - - i8_bit_lo0 = bit - - return -end -subroutine i8_sobol ( dim_num, seed, quasi ) - -!*****************************************************************************80 -! -!! I8_SOBOL generates a new quasirandom Sobol vector with each call. -! -! Discussion: -! -! The routine adapts the ideas of Antonov and Saleev. -! -! This routine uses the integer and real precisions corresponding -! to a KIND of 8. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 25 June 2008 -! -! Author: -! -! FORTRAN77 original version by Bennett Fox -! FORTRAN90 version by John Burkardt -! -! Reference: -! -! IA Antonov, VM Saleev, -! An Economic Method of Computing LP Tau-Sequences, -! USSR Computational Mathematics and Mathematical Physics, -! Volume 19, 1980, pages 252-256. -! -! Paul Bratley, Bennett Fox, -! Algorithm 659: -! Implementing Sobol's Quasirandom Sequence Generator, -! ACM Transactions on Mathematical Software, -! Volume 14, Number 1, March 1988, pages 88-100 -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, December 1986, pages 362-376. -! -! Stephen Joe, Frances Kuo, -! Remark on Algorithm 659: -! Implementing Sobol's Quasirandom Sequence Generator, -! ACM Transactions on Mathematical Software, -! Volume 29, Number 1, March 2003, pages 49-57. -! -! Ilya Sobol, -! Uniformly Distributed Sequences with an Additional Uniform Property, -! USSR Computational Mathematics and Mathematical Physics, -! Volume 16, 1977, pages 236-242. -! -! Ilya Sobol, YL Levitan, -! The Production of Points Uniformly Distributed in a Multidimensional -! Cube (in Russian), -! Preprint IPM Akademii Nauk SSSR, -! Number 40, Moscow 1976. -! -! Parameters: -! -! Input, integer ( kind = 8 ) DIM_NUM, the number of spatial dimensions. -! DIM_NUM must satisfy 2 <= DIM_NUM <= 1111. -! -! Input/output, integer ( kind = 8 ) SEED, the "seed" for the sequence. -! This is essentially the index in the sequence of the quasirandom -! value to be generated. On output, SEED has been set to the -! appropriate next value, usually simply SEED+1. -! If SEED is less than 0 on input, it is treated as though it were 0. -! An input value of 0 requests the first (0-th) element of the sequence. -! -! Output, real ( kind = 8 ) QUASI(DIM_NUM), the next quasirandom vector. -! - implicit none - - integer ( kind = 8 ) :: dim_num - integer ( kind = 8 ), parameter :: dim_max = 1111 - integer ( kind = 8 ), parameter :: log_max = 62 - - integer ( kind = 8 ) :: atmost - integer ( kind = 8 ), save :: dim_num_save = 0 - integer ( kind = 8 ) :: i - integer ( kind = 8 ) :: i8_bit_hi1 - integer ( kind = 8 ) :: i8_bit_lo0 - integer ( kind = 8 ) :: inc - logical includ(log_max) - logical, save :: initialized = .false. - integer ( kind = 8 ) :: j - integer ( kind = 8 ) :: j2 - integer ( kind = 8 ) :: k - integer ( kind = 8 ) :: l - integer ( kind = 8 ), save, dimension(dim_max) :: lastq - integer ( kind = 8 ) :: m - integer ( kind = 8 ), save :: maxcol - integer ( kind = 8 ) :: newv - integer ( kind = 8 ), save, dimension(1:dim_max) :: poly - real ( kind = 8 ), dimension ( dim_num ) :: quasi - real ( kind = 8 ), save :: recipd - integer ( kind = 8 ) :: seed - integer ( kind = 8 ), save :: seed_save = - 1 - integer ( kind = 8 ) :: seed_temp - integer ( kind = 8 ), save, dimension(1:dim_max,1:log_max) :: v - - if ( .not. initialized .or. dim_num /= dim_num_save ) then - - initialized = .true. - - v(1:dim_max,1:log_max) = 0 -! -! Initialize (part of) V. -! - v(2:1111,1) = 1 - v(3:401,2) = (/ & - 1,3,1,3,1,3,3,1,3,1,3,1,3,1,1,3,1,3,1,3, & - 1,3,3,1,1,1,3,1,3,1,3,3,1,3,1,1,1,3,1,3,1,1,1,3,3,1,3,3,1,1, & - 3,3,1,3,3,3,1,3,1,3,1,1,3,3,1,1,1,1,3,1,1,3,1,1,1,3,3,1,3,3, & - 1,3,3,3,1,3,3,3,1,3,3,1,3,3,3,1,3,1,3,1,1,3,3,1,3,3,1,1,1,3, & - 3,1,3,3,1,3,1,1,3,3,3,1,1,1,3,1,1,3,1,1,3,3,1,3,1,3,3,3,3,1, & - 1,1,3,3,1,1,3,1,1,1,1,1,1,3,1,3,1,1,1,3,1,3,1,3,3,3,1,1,3,3, & - 1,3,1,3,1,1,3,1,3,1,3,1,3,1,1,1,3,3,1,3,3,1,3,1,1,1,3,1,3,1, & - 1,3,1,1,3,3,1,1,3,3,3,1,3,3,3,1,3,1,3,1,1,1,3,1,1,1,3,1,1,1, & - 1,1,3,3,3,1,1,1,1,3,3,3,1,3,3,1,1,1,1,3,1,1,3,1,3,3,1,1,3,3, & - 1,1,1,1,3,1,3,3,1,3,3,1,1,1,3,3,3,1,3,3,1,3,3,1,3,1,3,3,3,1, & - 3,1,1,3,1,3,1,1,1,3,3,3,1,1,3,1,3,1,1,1,1,1,1,3,1,1,3,1,3,3, & - 1,1,1,1,3,1,3,1,3,1,1,1,1,3,3,1,1,1,1,1,3,3,3,1,1,3,3,3,3,3, & - 1,3,3,1,3,3,3,3,1,1,1,1,1,1,3,1,1,3,1,1,1,3,1,1,1,3,3,3,1,3, & - 1,1,3,3,3,1,3,3,1,3,1,3,3,1,3,3,3,1,1/) - v(402:800,2) = (/ & - 3,3,1,3,1,3,1,1,1,3,3,3,3,1,3,1,1,3,1, & - 3,1,1,1,3,1,3,1,3,1,3,3,3,3,3,3,3,3,1,3,3,3,3,3,1,3,1,3,3,3, & - 1,3,1,3,1,3,3,1,3,3,3,3,3,3,3,3,3,1,1,1,1,1,1,3,3,1,1,3,3,1, & - 1,1,3,3,1,1,3,3,3,3,1,1,3,1,3,3,1,3,3,1,1,1,3,3,3,1,1,3,3,3, & - 3,3,1,1,1,3,1,3,3,1,3,3,3,3,1,1,3,1,1,3,1,3,1,3,1,3,3,1,1,3, & - 3,1,3,3,1,3,3,1,1,3,1,3,3,1,1,3,1,3,1,3,1,1,3,3,1,1,1,3,3,1, & - 3,1,1,3,3,1,1,3,1,3,1,1,1,1,1,3,1,1,1,1,3,1,3,1,1,3,3,1,1,3, & - 1,3,1,3,3,3,1,3,3,3,1,1,3,3,3,1,1,1,1,3,1,3,1,3,1,1,3,3,1,1, & - 1,3,3,1,3,1,3,1,1,1,1,1,1,3,1,3,3,1,3,3,3,1,3,1,1,3,3,1,1,3, & - 3,1,1,1,3,1,3,3,1,1,3,1,1,3,1,3,1,1,1,3,3,3,3,1,1,3,3,1,1,1, & - 1,3,1,1,3,3,3,1,1,3,3,1,3,3,1,1,3,3,3,3,3,3,3,1,3,3,1,3,1,3, & - 1,1,3,3,1,1,1,3,1,3,3,1,3,3,1,3,1,1,3,3,3,1,1,1,3,1,1,1,3,3, & - 3,1,3,3,1,3,1,1,3,3,3,1,3,3,1,1,1,3,1,3,3,3,3,3,3,3,3,1,3,3, & - 1,3,1,1,3,3,3,1,3,3,3,3,3,1,3,3,3,1,1,1/) - v(801:1111,2) = (/ & - 3,3,1,3,3,1,3,1,3,1,3,1,3,3,3,3,3,3, & - 1,1,3,1,3,1,1,1,1,1,3,1,1,1,3,1,3,1,1,3,3,3,1,3,1,3,1,1,3,1, & - 3,3,1,3,1,3,3,1,3,3,1,3,3,3,3,3,3,1,3,1,1,3,3,3,1,1,3,3,3,3, & - 3,3,3,1,3,3,3,3,1,3,1,3,3,3,1,3,1,3,1,1,1,3,3,1,3,1,1,3,3,1, & - 3,1,1,1,1,3,1,3,1,1,3,1,3,1,3,3,3,3,3,3,1,3,3,3,3,1,3,3,1,3, & - 3,3,3,3,1,1,1,1,3,3,3,1,3,3,1,1,3,3,1,1,3,3,1,3,1,1,3,1,3,3, & - 3,3,3,1,3,1,1,3,3,3,3,1,3,1,1,3,3,3,3,3,3,1,1,3,1,3,1,1,3,1, & - 1,1,1,3,3,1,1,3,1,1,1,3,1,3,1,1,3,3,1,3,1,1,3,3,3,3,3,1,3,1, & - 1,1,3,1,1,1,3,1,1,3,1,3,3,3,3,3,1,1,1,3,3,3,3,1,3,3,3,3,1,1, & - 3,3,3,1,3,1,1,3,3,1,3,3,1,1,1,1,1,3,1,1,3,3,1,1,1,3,1,1,3,3, & - 1,3,3,3,3,3,3,3,3,1,1,3,3,1,1,3,1,3,3,3,3,3,1/) - v(4:402,3) = (/ & - 7,5,1,3,3,7,5,5,7,7,1,3,3,7,5,1,1,5,3,7, & - 1,7,5,1,3,7,7,1,1,1,5,7,7,5,1,3,3,7,5,5,5,3,3,3,1,1,5,1,1,5, & - 3,3,3,3,1,3,7,5,7,3,7,1,3,3,5,1,3,5,5,7,7,7,1,1,3,3,1,1,5,1, & - 5,7,5,1,7,5,3,3,1,5,7,1,7,5,1,7,3,1,7,1,7,3,3,5,7,3,3,5,1,3, & - 3,1,3,5,1,3,3,3,7,1,1,7,3,1,3,7,5,5,7,5,5,3,1,3,3,3,1,3,3,7, & - 3,3,1,7,5,1,7,7,5,7,5,1,3,1,7,3,7,3,5,7,3,1,3,3,3,1,5,7,3,3, & - 7,7,7,5,3,1,7,1,3,7,5,3,3,3,7,1,1,3,1,5,7,1,3,5,3,5,3,3,7,5, & - 5,3,3,1,3,7,7,7,1,5,7,1,3,1,1,7,1,3,1,7,1,5,3,5,3,1,1,5,5,3, & - 3,5,7,1,5,3,7,7,3,5,3,3,1,7,3,1,3,5,7,1,3,7,1,5,1,3,1,5,3,1, & - 7,1,5,5,5,3,7,1,1,7,3,1,1,7,5,7,5,7,7,3,7,1,3,7,7,3,5,1,1,7, & - 1,5,5,5,1,5,1,7,5,5,7,1,1,7,1,7,7,1,1,3,3,3,7,7,5,3,7,3,1,3, & - 7,5,3,3,5,7,1,1,5,5,7,7,1,1,1,1,5,5,5,7,5,7,1,1,3,5,1,3,3,7, & - 3,7,5,3,5,3,1,7,1,7,7,1,1,7,7,7,5,5,1,1,7,5,5,7,5,1,1,5,5,5, & - 5,5,5,1,3,1,5,7,3,3,5,7,3,7,1,7,7,1,3/) - v(403:801,3) = (/ & - 5,1,5,5,3,7,3,7,7,5,7,5,7,1,1,5,3,5,1, & - 5,3,7,1,5,7,7,3,5,1,3,5,1,5,3,3,3,7,3,5,1,3,7,7,3,7,5,3,3,1, & - 7,5,1,1,3,7,1,7,1,7,3,7,3,5,7,3,5,3,1,1,1,5,7,7,3,3,1,1,1,5, & - 5,7,3,1,1,3,3,7,3,3,5,1,3,7,3,3,7,3,5,7,5,7,7,3,3,5,1,3,5,3, & - 1,3,5,1,1,3,7,7,1,5,1,3,7,3,7,3,5,1,7,1,1,3,5,3,7,1,5,5,1,1, & - 3,1,3,3,7,1,7,3,1,7,3,1,7,3,5,3,5,7,3,3,3,5,1,7,7,1,3,1,3,7, & - 7,1,3,7,3,1,5,3,1,1,1,5,3,3,7,1,5,3,5,1,3,1,3,1,5,7,7,1,1,5, & - 3,1,5,1,1,7,7,3,5,5,1,7,1,5,1,1,3,1,5,7,5,7,7,1,5,1,1,3,5,1, & - 5,5,3,1,3,1,5,5,3,3,3,3,1,1,3,1,3,5,5,7,5,5,7,5,7,1,3,7,7,3, & - 5,5,7,5,5,3,3,3,1,7,1,5,5,5,3,3,5,1,3,1,3,3,3,7,1,7,7,3,7,1, & - 1,5,7,1,7,1,7,7,1,3,7,5,1,3,5,5,5,1,1,7,1,7,1,7,7,3,1,1,5,1, & - 5,1,5,3,5,5,5,5,5,3,3,7,3,3,5,5,3,7,1,5,7,5,1,5,5,3,5,5,7,5, & - 3,5,5,5,1,5,5,5,5,1,3,5,3,1,7,5,5,7,1,5,3,3,1,5,3,7,1,7,5,1, & - 1,3,1,1,7,1,5,5,3,7,3,7,5,3,1,1,3,1,3,5/) - v(802:1111,3) = (/ & - 5,7,5,3,7,7,7,3,7,3,7,1,3,1,7,7,1,7, & - 3,7,3,7,3,7,3,5,1,1,7,3,1,5,5,7,1,5,5,5,7,1,5,5,1,5,5,3,1,3, & - 1,7,3,1,3,5,7,7,7,1,1,7,3,1,5,5,5,1,1,1,1,1,5,3,5,1,3,5,3,1, & - 1,1,1,3,7,3,7,5,7,1,5,5,7,5,3,3,7,5,3,1,1,3,1,3,1,1,3,7,1,7, & - 1,1,5,1,7,5,3,7,3,5,3,1,1,5,5,1,7,7,3,7,3,7,1,5,1,5,3,7,3,5, & - 7,7,7,3,3,1,1,5,5,3,7,1,1,1,3,5,3,1,1,3,3,7,5,1,1,3,7,1,5,7, & - 3,7,5,5,7,3,5,3,1,5,3,1,1,7,5,1,7,3,7,5,1,7,1,7,7,1,1,7,1,5, & - 5,1,1,7,5,7,1,5,3,5,3,3,7,1,5,1,1,5,5,3,3,7,5,5,1,1,1,3,1,5, & - 7,7,1,7,5,7,3,7,3,1,3,7,3,1,5,5,3,5,1,3,5,5,5,1,1,7,7,1,5,5, & - 1,3,5,1,5,3,5,3,3,7,5,7,3,7,3,1,3,7,7,3,3,1,1,3,3,3,3,3,5,5, & - 3,3,3,1,3,5,7,7,1,5,7,3,7,1,1,3,5,7,5,3,3,3/) - v(6:357,4) = (/ & - 1,7,9,13,11,1,3,7,9,5,13,13,11,3,15,5,3, & - 15,7,9,13,9,1,11,7,5,15,1,15,11,5,11,1,7,9,7,7,1,15,15,15,13, & - 3,3,15,5,9,7,13,3,7,5,11,9,1,9,1,5,7,13,9,9,1,7,3,5,1,11,11, & - 13,7,7,9,9,1,1,3,9,15,1,5,13,1,9,9,9,9,9,13,11,3,5,11,11,13, & - 5,3,15,1,11,11,7,13,15,11,13,9,11,15,15,13,3,15,7,9,11,13,11, & - 9,9,5,13,9,1,13,7,7,7,7,7,5,9,7,13,11,9,11,15,3,13,11,1,11,3, & - 3,9,11,1,7,1,15,15,3,1,9,1,7,13,11,3,13,11,7,3,3,5,13,11,5, & - 11,1,3,9,7,15,7,5,13,7,9,13,15,13,9,7,15,7,9,5,11,11,13,13,9, & - 3,5,13,9,11,15,11,7,1,7,13,3,13,3,13,9,15,7,13,13,3,13,15,15, & - 11,9,13,9,15,1,1,15,11,11,7,1,11,13,9,13,3,5,11,13,9,9,13,1, & - 11,15,13,3,13,7,15,1,15,3,3,11,7,13,7,7,9,7,5,15,9,5,5,7,15, & - 13,15,5,15,5,3,1,11,7,1,5,7,9,3,11,1,15,1,3,15,11,13,5,13,1, & - 7,1,15,7,5,1,1,15,13,11,11,13,5,11,7,9,7,1,5,3,9,5,5,11,5,1, & - 7,1,11,7,9,13,15,13,3,1,11,13,15,1,1,11,9,13,3,13,11,15,13,9, & - 9,9,5,5,5,5,1,15,5,9/) - v(358:710,4) = (/ & - 11,7,15,5,3,13,5,3,11,5,1,11,13,9,11, & - 3,7,13,15,1,7,11,1,13,1,15,1,9,7,3,9,11,1,9,13,13,3,11,7,9,1, & - 7,15,9,1,5,13,5,11,3,9,15,11,13,5,1,7,7,5,13,7,7,9,5,11,11,1, & - 1,15,3,13,9,13,9,9,11,5,5,13,15,3,9,15,3,11,11,15,15,3,11,15, & - 15,3,1,3,1,3,3,1,3,13,1,11,5,15,7,15,9,1,7,1,9,11,15,1,13,9, & - 13,11,7,3,7,3,13,7,9,7,7,3,3,9,9,7,5,11,13,13,7,7,15,9,5,5,3, & - 3,13,3,9,3,1,11,1,3,11,15,11,11,11,9,13,7,9,15,9,11,1,3,3,9, & - 7,15,13,13,7,15,9,13,9,15,13,15,9,13,1,11,7,11,3,13,5,1,7,15, & - 3,13,7,13,13,11,3,5,3,13,11,9,9,3,11,11,7,9,13,11,7,15,13,7, & - 5,3,1,5,15,15,3,11,1,7,3,15,11,5,5,3,5,5,1,15,5,1,5,3,7,5,11, & - 3,13,9,13,15,5,3,5,9,5,3,11,1,13,9,15,3,5,11,9,1,3,15,9,9,9, & - 11,7,5,13,1,15,3,13,9,13,5,1,5,1,13,13,7,7,1,9,5,11,9,11,13, & - 3,15,15,13,15,7,5,7,9,7,9,9,9,11,9,3,11,15,13,13,5,9,15,1,1, & - 9,5,13,3,13,15,3,1,3,11,13,1,15,9,9,3,1,9,1,9,1,13,11,15,7, & - 11,15,13,15,1,9,9,7/) - v(711:1065,4) = (/ & - 3,5,11,7,3,9,5,15,7,5,3,13,7,1,1,9, & - 15,15,15,11,3,5,15,13,7,15,15,11,11,9,5,15,9,7,3,13,1,1,5,1, & - 3,1,7,1,1,5,1,11,11,9,9,5,13,7,7,7,1,1,9,9,11,11,15,7,5,5,3, & - 11,1,3,7,13,7,7,7,3,15,15,11,9,3,9,3,15,13,5,3,3,3,5,9,15,9, & - 9,1,5,9,9,15,5,15,7,9,1,9,9,5,11,5,15,15,11,7,7,7,1,1,11,11, & - 13,15,3,13,5,1,7,1,11,3,13,15,3,5,3,5,7,3,9,9,5,1,7,11,9,3,5, & - 11,13,13,13,9,15,5,7,1,15,11,9,15,15,13,13,13,1,11,9,15,9,5, & - 15,5,7,3,11,3,15,7,13,11,7,3,7,13,5,13,15,5,13,9,1,15,11,5,5, & - 1,11,3,3,7,1,9,7,15,9,9,3,11,15,7,1,3,1,1,1,9,1,5,15,15,7,5, & - 5,7,9,7,15,13,13,11,1,9,11,1,13,1,7,15,15,5,5,1,11,3,9,11,9, & - 9,9,1,9,3,5,15,1,1,9,7,3,3,1,9,9,11,9,9,13,13,3,13,11,13,5,1, & - 5,5,9,9,3,13,13,9,15,9,11,7,11,9,13,9,1,15,9,7,7,1,7,9,9,15, & - 1,11,1,13,13,15,9,13,7,15,3,9,3,1,13,7,5,9,3,1,7,1,1,13,3,3, & - 11,1,7,13,15,15,5,7,13,13,15,11,13,1,13,13,3,9,15,15,11,15,9, & - 15,1,13,15,1,1,5/) - v(1066:1111,4) = (/ & - 11,5,1,11,11,5,3,9,1,3,5,13,9,7,7,1, & - 9,9,15,7,5,5,15,13,9,7,13,3,13,11,13,7,9,13,13,13,15,9,5,5,3, & - 3,3,1,3,15/) - v(8:331,5) = (/ & - 9,3,27,15,29,21,23,19,11,25,7,13,17,1, & - 25,29,3,31,11,5,23,27,19,21,5,1,17,13,7,15,9,31,25,3,5,23,7, & - 3,17,23,3,3,21,25,25,23,11,19,3,11,31,7,9,5,17,23,17,17,25, & - 13,11,31,27,19,17,23,7,5,11,19,19,7,13,21,21,7,9,11,1,5,21, & - 11,13,25,9,7,7,27,15,25,15,21,17,19,19,21,5,11,3,5,29,31,29, & - 5,5,1,31,27,11,13,1,3,7,11,7,3,23,13,31,17,1,27,11,25,1,23, & - 29,17,25,7,25,27,17,13,17,23,5,17,5,13,11,21,5,11,5,9,31,19, & - 17,9,9,27,21,15,15,1,1,29,5,31,11,17,23,19,21,25,15,11,5,5,1, & - 19,19,19,7,13,21,17,17,25,23,19,23,15,13,5,19,25,9,7,3,21,17, & - 25,1,27,25,27,25,9,13,3,17,25,23,9,25,9,13,17,17,3,15,7,7,29, & - 3,19,29,29,19,29,13,15,25,27,1,3,9,9,13,31,29,31,5,15,29,1, & - 19,5,9,19,5,15,3,5,7,15,17,17,23,11,9,23,19,3,17,1,27,9,9,17, & - 13,25,29,23,29,11,31,25,21,29,19,27,31,3,5,3,3,13,21,9,29,3, & - 17,11,11,9,21,19,7,17,31,25,1,27,5,15,27,29,29,29,25,27,25,3, & - 21,17,25,13,15,17,13,23,9,3,11,7,9,9,7,17,7,1/) - v(332:654,5) = (/ & - 27,1,9,5,31,21,25,25,21,11,1,23,19,27, & - 15,3,5,23,9,25,7,29,11,9,13,5,11,1,3,31,27,3,17,27,11,13,15, & - 29,15,1,15,23,25,13,21,15,3,29,29,5,25,17,11,7,15,5,21,7,31, & - 13,11,23,5,7,23,27,21,29,15,7,27,27,19,7,15,27,27,19,19,9,15, & - 1,3,29,29,5,27,31,9,1,7,3,19,19,29,9,3,21,31,29,25,1,3,9,27, & - 5,27,25,21,11,29,31,27,21,29,17,9,17,13,11,25,15,21,11,19,31, & - 3,19,5,3,3,9,13,13,3,29,7,5,9,23,13,21,23,21,31,11,7,7,3,23, & - 1,23,5,9,17,21,1,17,29,7,5,17,13,25,17,9,19,9,5,7,21,19,13,9, & - 7,3,9,3,15,31,29,29,25,13,9,21,9,31,7,15,5,31,7,15,27,25,19, & - 9,9,25,25,23,1,9,7,11,15,19,15,27,17,11,11,31,13,25,25,9,7, & - 13,29,19,5,19,31,25,13,25,15,5,9,29,31,9,29,27,25,27,11,17,5, & - 17,3,23,15,9,9,17,17,31,11,19,25,13,23,15,25,21,31,19,3,11, & - 25,7,15,19,7,5,3,13,13,1,23,5,25,11,25,15,13,21,11,23,29,5, & - 17,27,9,19,15,5,29,23,19,1,27,3,23,21,19,27,11,17,13,27,11, & - 31,23,5,9,21,31,29,11,21,17,15,7,15,7,9,21,27,25/) - v(655:975,5) = (/ & - 29,11,3,21,13,23,19,27,17,29,25,17,9, & - 1,19,23,5,23,1,17,17,13,27,23,7,7,11,13,17,13,11,21,13,23,1, & - 27,13,9,7,1,27,29,5,13,25,21,3,31,15,13,3,19,13,1,27,15,17,1, & - 3,13,13,13,31,29,27,7,7,21,29,15,17,17,21,19,17,3,15,5,27,27, & - 3,31,31,7,21,3,13,11,17,27,25,1,9,7,29,27,21,23,13,25,29,15, & - 17,29,9,15,3,21,15,17,17,31,9,9,23,19,25,3,1,11,27,29,1,31, & - 29,25,29,1,23,29,25,13,3,31,25,5,5,11,3,21,9,23,7,11,23,11,1, & - 1,3,23,25,23,1,23,3,27,9,27,3,23,25,19,29,29,13,27,5,9,29,29, & - 13,17,3,23,19,7,13,3,19,23,5,29,29,13,13,5,19,5,17,9,11,11, & - 29,27,23,19,17,25,13,1,13,3,11,1,17,29,1,13,17,9,17,21,1,11, & - 1,1,25,5,7,29,29,19,19,1,29,13,3,1,31,15,13,3,1,11,19,5,29, & - 13,29,23,3,1,31,13,19,17,5,5,1,29,23,3,19,25,19,27,9,27,13, & - 15,29,23,13,25,25,17,19,17,15,27,3,25,17,27,3,27,31,23,13,31, & - 11,15,7,21,19,27,19,21,29,7,31,13,9,9,7,21,13,11,9,11,29,19, & - 11,19,21,5,29,13,7,19,19,27,23,31,1,27,21,7,3,7,11/) - v(976:1111,5) = (/ & - 23,13,29,11,31,19,1,5,5,11,5,3,27,5, & - 7,11,31,1,27,31,31,23,5,21,27,9,25,3,15,19,1,19,9,5,25,21,15, & - 25,29,15,21,11,19,15,3,7,13,11,25,17,1,5,31,13,29,23,9,5,29, & - 7,17,27,7,17,31,9,31,9,9,7,21,3,3,3,9,11,21,11,31,9,25,5,1, & - 31,13,29,9,29,1,11,19,7,27,13,31,7,31,7,25,23,21,29,11,11,13, & - 11,27,1,23,31,21,23,21,19,31,5,31,25,25,19,17,11,25,7,13,1, & - 29,17,23,15,7,29,17,13,3,17/) - v(14:324,6) = (/ & - 37,33,7,5,11,39,63,59,17,15,23,29,3,21, & - 13,31,25,9,49,33,19,29,11,19,27,15,25,63,55,17,63,49,19,41, & - 59,3,57,33,49,53,57,57,39,21,7,53,9,55,15,59,19,49,31,3,39,5, & - 5,41,9,19,9,57,25,1,15,51,11,19,61,53,29,19,11,9,21,19,43,13, & - 13,41,25,31,9,11,19,5,53,37,7,51,45,7,7,61,23,45,7,59,41,1, & - 29,61,37,27,47,15,31,35,31,17,51,13,25,45,5,5,33,39,5,47,29, & - 35,47,63,45,37,47,59,21,59,33,51,9,27,13,25,43,3,17,21,59,61, & - 27,47,57,11,17,39,1,63,21,59,17,13,31,3,31,7,9,27,37,23,31,9, & - 45,43,31,63,21,39,51,27,7,53,11,1,59,39,23,49,23,7,55,59,3, & - 19,35,13,9,13,15,23,9,7,43,55,3,19,9,27,33,27,49,23,47,19,7, & - 11,55,27,35,5,5,55,35,37,9,33,29,47,25,11,47,53,61,59,3,53, & - 47,5,19,59,5,47,23,45,53,3,49,61,47,39,29,17,57,5,17,31,23, & - 41,39,5,27,7,29,29,33,31,41,31,29,17,29,29,9,9,31,27,53,35,5, & - 61,1,49,13,57,29,5,21,43,25,57,49,37,27,11,61,37,49,5,63,63, & - 3,45,37,63,21,21,19,27,59,21,45,23,13,15,3,43,63,39,19/) - v(325:632,6) = (/ & - 63,31,41,41,15,43,63,53,1,63,31,7,17, & - 11,61,31,51,37,29,59,25,63,59,47,15,27,19,29,45,35,55,39,19, & - 43,21,19,13,17,51,37,5,33,35,49,25,45,1,63,47,9,63,15,25,25, & - 15,41,13,3,19,51,49,37,25,49,13,53,47,23,35,29,33,21,35,23,3, & - 43,31,63,9,1,61,43,3,11,55,11,35,1,63,35,49,19,45,9,57,51,1, & - 47,41,9,11,37,19,55,23,55,55,13,7,47,37,11,43,17,3,25,19,55, & - 59,37,33,43,1,5,21,5,63,49,61,21,51,15,19,43,47,17,9,53,45, & - 11,51,25,11,25,47,47,1,43,29,17,31,15,59,27,63,11,41,51,29,7, & - 27,63,31,43,3,29,39,3,59,59,1,53,63,23,63,47,51,23,61,39,47, & - 21,39,15,3,9,57,61,39,37,21,51,1,23,43,27,25,11,13,21,43,7, & - 11,33,55,1,37,35,27,61,39,5,19,61,61,57,59,21,59,61,57,25,55, & - 27,31,41,33,63,19,57,35,13,63,35,17,11,11,49,41,55,5,45,17, & - 35,5,31,31,37,17,45,51,1,39,49,55,19,41,13,5,51,5,49,1,21,13, & - 17,59,51,11,3,61,1,33,37,33,61,25,27,59,7,49,13,63,3,33,3,15, & - 9,13,35,39,11,59,59,1,57,11,5,57,13,31,13,11,55,45,9,55,55/) - v(633:942,6) = (/ & - 19,25,41,23,45,29,63,59,27,39,21,37,7, & - 61,49,35,39,9,29,7,25,23,57,5,19,15,33,49,37,25,17,45,29,15, & - 25,3,3,49,11,39,15,19,57,39,15,11,3,57,31,55,61,19,5,41,35, & - 59,61,39,41,53,53,63,31,9,59,13,35,55,41,49,5,41,25,27,43,5, & - 5,43,5,5,17,5,15,27,29,17,9,3,55,31,1,45,45,13,57,17,3,61,15, & - 49,15,47,9,37,45,9,51,61,21,33,11,21,63,63,47,57,61,49,9,59, & - 19,29,21,23,55,23,43,41,57,9,39,27,41,35,61,29,57,63,21,31, & - 59,35,49,3,49,47,49,33,21,19,21,35,11,17,37,23,59,13,37,35, & - 55,57,1,29,45,11,1,15,9,33,19,53,43,39,23,7,13,13,1,19,41,55, & - 1,13,15,59,55,15,3,57,37,31,17,1,3,21,29,25,55,9,37,33,53,41, & - 51,19,57,13,63,43,19,7,13,37,33,19,15,63,51,11,49,23,57,47, & - 51,15,53,41,1,15,37,61,11,35,29,33,23,55,11,59,19,61,61,45, & - 13,49,13,63,5,61,5,31,17,61,63,13,27,57,1,21,5,11,39,57,51, & - 53,39,25,41,39,37,23,31,25,33,17,57,29,27,23,47,41,29,19,47, & - 41,25,5,51,43,39,29,7,31,45,51,49,55,17,43,49,45,9,29,3,5,47, & - 9,15,19/) - v(943:1111,6) = (/ & - 51,45,57,63,9,21,59,3,9,13,45,23,15, & - 31,21,15,51,35,9,11,61,23,53,29,51,45,31,29,5,35,29,53,35,17, & - 59,55,27,51,59,27,47,15,29,37,7,49,55,5,19,45,29,19,57,33,53, & - 45,21,9,3,35,29,43,31,39,3,45,1,41,29,5,59,41,33,35,27,19,13, & - 25,27,43,33,35,17,17,23,7,35,15,61,61,53,5,15,23,11,13,43,55, & - 47,25,43,15,57,45,1,49,63,57,15,31,31,7,53,27,15,47,23,7,29, & - 53,47,9,53,3,25,55,45,63,21,17,23,31,27,27,43,63,55,63,45,51, & - 15,27,5,37,43,11,27,5,27,59,21,7,39,27,63,35,47,55,17,17,17, & - 3,19,21,13,49,61,39,15/) - v(20:305,7) = (/ & - 13,33,115,41,79,17,29,119,75,73,105,7, & - 59,65,21,3,113,61,89,45,107,21,71,79,19,71,61,41,57,121,87, & - 119,55,85,121,119,11,23,61,11,35,33,43,107,113,101,29,87,119, & - 97,29,17,89,5,127,89,119,117,103,105,41,83,25,41,55,69,117, & - 49,127,29,1,99,53,83,15,31,73,115,35,21,89,5,1,91,53,35,95, & - 83,19,85,55,51,101,33,41,55,45,95,61,27,37,89,75,57,61,15, & - 117,15,21,27,25,27,123,39,109,93,51,21,91,109,107,45,15,93, & - 127,3,53,81,79,107,79,87,35,109,73,35,83,107,1,51,7,59,33, & - 115,43,111,45,121,105,125,87,101,41,95,75,1,57,117,21,27,67, & - 29,53,117,63,1,77,89,115,49,127,15,79,81,29,65,103,33,73,79, & - 29,21,113,31,33,107,95,111,59,99,117,63,63,99,39,9,35,63,125, & - 99,45,93,33,93,9,105,75,51,115,11,37,17,41,21,43,73,19,93,7, & - 95,81,93,79,81,55,9,51,63,45,89,73,19,115,39,47,81,39,5,5,45, & - 53,65,49,17,105,13,107,5,5,19,73,59,43,83,97,115,27,1,69,103, & - 3,99,103,63,67,25,121,97,77,13,83,103,41,11,27,81,37,33,125, & - 71,41,41,59,41,87,123/) - v(306:589,7) = (/ & - 43,101,63,45,39,21,97,15,97,111,21,49, & - 13,17,79,91,65,105,75,1,45,67,83,107,125,87,15,81,95,105,65, & - 45,59,103,23,103,99,67,99,47,117,71,89,35,53,73,9,115,49,37, & - 1,35,9,45,81,19,127,17,17,105,89,49,101,7,37,33,11,95,95,17, & - 111,105,41,115,5,69,101,27,27,101,103,53,9,21,43,79,91,65, & - 117,87,125,55,45,63,85,83,97,45,83,87,113,93,95,5,17,77,77, & - 127,123,45,81,85,121,119,27,85,41,49,15,107,21,51,119,11,87, & - 101,115,63,63,37,121,109,7,43,69,19,77,49,71,59,35,7,13,55, & - 101,127,103,85,109,29,61,67,21,111,67,23,57,75,71,101,123,41, & - 107,101,107,125,27,47,119,41,19,127,33,31,109,7,91,91,39,125, & - 105,47,125,123,91,9,103,45,23,117,9,125,73,11,37,61,79,21,5, & - 47,117,67,53,85,33,81,121,47,61,51,127,29,65,45,41,95,57,73, & - 33,117,61,111,59,123,65,47,105,23,29,107,37,81,67,29,115,119, & - 75,73,99,103,7,57,45,61,95,49,101,101,35,47,119,39,67,31,103, & - 7,61,127,87,3,35,29,73,95,103,71,75,51,87,57,97,11,105,87,41, & - 73,109,69,35,121,39,111,1,77/) - v(590:875,7) = (/ & - 39,47,53,91,3,17,51,83,39,125,85,111, & - 21,69,85,29,55,11,117,1,47,17,65,63,47,117,17,115,51,25,33, & - 123,123,83,51,113,95,121,51,91,109,43,55,35,55,87,33,37,5,3, & - 45,21,105,127,35,17,35,37,97,97,21,77,123,17,89,53,105,75,25, & - 125,13,47,21,125,23,55,63,61,5,17,93,57,121,69,73,93,121,105, & - 75,91,67,95,75,9,69,97,99,93,11,53,19,73,5,33,79,107,65,69, & - 79,125,25,93,55,61,17,117,69,97,87,111,37,93,59,79,95,53,115, & - 53,85,85,65,59,23,75,21,67,27,99,79,27,3,95,27,69,19,75,47, & - 59,41,85,77,99,55,49,93,93,119,51,125,63,13,15,45,61,19,105, & - 115,17,83,7,7,11,61,37,63,89,95,119,113,67,123,91,33,37,99, & - 43,11,33,65,81,79,81,107,63,63,55,89,91,25,93,101,27,55,75, & - 121,79,43,125,73,27,109,35,21,71,113,89,59,95,41,45,113,119, & - 113,39,59,73,15,13,59,67,121,27,7,105,15,59,59,35,91,89,23, & - 125,97,53,41,91,111,29,31,3,103,61,71,35,7,119,29,45,49,111, & - 41,109,59,125,13,27,19,79,9,75,83,81,33,91,109,33,29,107,111, & - 101,107,109,65,59,43,37/) - v(876:1111,7) = (/ & - 1,9,15,109,37,111,113,119,79,73,65, & - 71,93,17,101,87,97,43,23,75,109,41,49,53,31,97,105,109,119, & - 51,9,53,113,97,73,89,79,49,61,105,13,99,53,71,7,87,21,101,5, & - 71,31,123,121,121,73,79,115,13,39,101,19,37,51,83,97,55,81, & - 91,127,105,89,63,47,49,75,37,77,15,49,107,23,23,35,19,69,17, & - 59,63,73,29,125,61,65,95,101,81,57,69,83,37,11,37,95,1,73,27, & - 29,57,7,65,83,99,69,19,103,43,95,25,19,103,41,125,97,71,105, & - 83,83,61,39,9,45,117,63,31,5,117,67,125,41,117,43,77,97,15, & - 29,5,59,25,63,87,39,39,77,85,37,81,73,89,29,125,109,21,23, & - 119,105,43,93,97,15,125,29,51,69,37,45,31,75,109,119,53,5, & - 101,125,121,35,29,7,63,17,63,13,69,15,105,51,127,105,9,57,95, & - 59,109,35,49,23,33,107,55,33,57,79,73,69,59,107,55,11,63,95, & - 103,23,125,91,31,91,51,65,61,75,69,107,65,101,59,35,15/) - v(38:299,8) = (/ & - 7,23,39,217,141,27,53,181,169,35,15, & - 207,45,247,185,117,41,81,223,151,81,189,61,95,185,23,73,113, & - 239,85,9,201,83,53,183,203,91,149,101,13,111,239,3,205,253, & - 247,121,189,169,179,197,175,217,249,195,95,63,19,7,5,75,217, & - 245,111,189,165,169,141,221,249,159,253,207,249,219,23,49, & - 127,237,5,25,177,37,103,65,167,81,87,119,45,79,143,57,79,187, & - 143,183,75,97,211,149,175,37,135,189,225,241,63,33,43,13,73, & - 213,57,239,183,117,21,29,115,43,205,223,15,3,159,51,101,127, & - 99,239,171,113,171,119,189,245,201,27,185,229,105,153,189,33, & - 35,137,77,97,17,181,55,197,201,155,37,197,137,223,25,179,91, & - 23,235,53,253,49,181,249,53,173,97,247,67,115,103,159,239,69, & - 173,217,95,221,247,97,91,123,223,213,129,181,87,239,85,89, & - 249,141,39,57,249,71,101,159,33,137,189,71,253,205,171,13, & - 249,109,131,199,189,179,31,99,113,41,173,23,189,197,3,135,9, & - 95,195,27,183,1,123,73,53,99,197,59,27,101,55,193,31,61,119, & - 11,7,255,233,53,157,193,97,83,65,81,239,167,69,71,109/) - v(300:559,8) = (/ & - 97,137,71,193,189,115,79,205,37,227, & - 53,33,91,229,245,105,77,229,161,103,93,13,161,229,223,69,15, & - 25,23,233,93,25,217,247,61,75,27,9,223,213,55,197,145,89,199, & - 41,201,5,149,35,119,183,53,11,13,3,179,229,43,55,187,233,47, & - 133,91,47,71,93,105,145,45,255,221,115,175,19,129,5,209,197, & - 57,177,115,187,119,77,211,111,33,113,23,87,137,41,7,83,43, & - 121,145,5,219,27,11,111,207,55,97,63,229,53,33,149,23,187, & - 153,91,193,183,59,211,93,139,59,179,163,209,77,39,111,79,229, & - 85,237,199,137,147,25,73,121,129,83,87,93,205,167,53,107,229, & - 213,95,219,109,175,13,209,97,61,147,19,13,123,73,35,141,81, & - 19,171,255,111,107,233,113,133,89,9,231,95,69,33,1,253,219, & - 253,247,129,11,251,221,153,35,103,239,7,27,235,181,5,207,53, & - 149,155,225,165,137,155,201,97,245,203,47,39,35,105,239,49, & - 15,253,7,237,213,55,87,199,27,175,49,41,229,85,3,149,179,129, & - 185,249,197,15,97,197,139,203,63,33,251,217,199,199,99,249, & - 33,229,177,13,209,147,97,31,125,177,137/) - v(560:819,8) = (/ & - 187,11,91,223,29,169,231,59,31,163,41, & - 57,87,247,25,127,101,207,187,73,61,105,27,91,171,243,33,3,1, & - 21,229,93,71,61,37,183,65,211,53,11,151,165,47,5,129,79,101, & - 147,169,181,19,95,77,139,197,219,97,239,183,143,9,13,209,23, & - 215,53,137,203,19,151,171,133,219,231,3,15,253,225,33,111, & - 183,213,169,119,111,15,201,123,121,225,113,113,225,161,165,1, & - 139,55,3,93,217,193,97,29,69,231,161,93,69,143,137,9,87,183, & - 113,183,73,215,137,89,251,163,41,227,145,57,81,57,11,135,145, & - 161,175,159,25,55,167,157,211,97,247,249,23,129,159,71,197, & - 127,141,219,5,233,131,217,101,131,33,157,173,69,207,239,81, & - 205,11,41,169,65,193,77,201,173,1,221,157,1,15,113,147,137, & - 205,225,73,45,49,149,113,253,99,17,119,105,117,129,243,75, & - 203,53,29,247,35,247,171,31,199,213,29,251,7,251,187,91,11, & - 149,13,205,37,249,137,139,9,7,113,183,205,187,39,3,79,155, & - 227,89,185,51,127,63,83,41,133,183,181,127,19,255,219,59,251, & - 3,187,57,217,115,217,229,181,185,149,83,115,11/) - v(820:1074,8) = (/ & - 123,19,109,165,103,123,219,129,155, & - 207,177,9,49,181,231,33,233,67,155,41,9,95,123,65,117,249,85, & - 169,129,241,173,251,225,147,165,69,81,239,95,23,83,227,249, & - 143,171,193,9,21,57,73,97,57,29,239,151,159,191,47,51,1,223, & - 251,251,151,41,119,127,131,33,209,123,53,241,25,31,183,107, & - 25,115,39,11,213,239,219,109,185,35,133,123,185,27,55,245,61, & - 75,205,213,169,163,63,55,49,83,195,51,31,41,15,203,41,63,127, & - 161,5,143,7,199,251,95,75,101,15,43,237,197,117,167,155,21, & - 83,205,255,49,101,213,237,135,135,21,73,93,115,7,85,223,237, & - 79,89,5,57,239,67,65,201,155,71,85,195,89,181,119,135,147, & - 237,173,41,155,67,113,111,21,183,23,103,207,253,69,219,205, & - 195,43,197,229,139,177,129,69,97,201,163,189,11,99,91,253, & - 239,91,145,19,179,231,121,7,225,237,125,191,119,59,175,237, & - 131,79,43,45,205,199,251,153,207,37,179,113,255,107,217,61,7, & - 181,247,31,13,113,145,107,233,233,43,79,23,169,137,129,183, & - 53,91,55,103,223,87,177,157,79,213,139/) - v(1075:1111,8) = (/ & - 183,231,205,143,129,243,205,93,59, & - 15,89,9,11,47,133,227,75,9,91,19,171,163,79,7,103,5,119,155, & - 75,11,71,95,17,13,243,207,187/) - v(54:299,9) = (/ & - 235,307,495,417,57,151,19,119,375,451, & - 55,449,501,53,185,317,17,21,487,13,347,393,15,391,307,189, & - 381,71,163,99,467,167,433,337,257,179,47,385,23,117,369,425, & - 207,433,301,147,333,85,221,423,49,3,43,229,227,201,383,281, & - 229,207,21,343,251,397,173,507,421,443,399,53,345,77,385,317, & - 155,187,269,501,19,169,235,415,61,247,183,5,257,401,451,95, & - 455,49,489,75,459,377,87,463,155,233,115,429,211,419,143,487, & - 195,209,461,193,157,193,363,181,271,445,381,231,135,327,403, & - 171,197,181,343,113,313,393,311,415,267,247,425,233,289,55, & - 39,247,327,141,5,189,183,27,337,341,327,87,429,357,265,251, & - 437,201,29,339,257,377,17,53,327,47,375,393,369,403,125,429, & - 257,157,217,85,267,117,337,447,219,501,41,41,193,509,131,207, & - 505,421,149,111,177,167,223,291,91,29,305,151,177,337,183, & - 361,435,307,507,77,181,507,315,145,423,71,103,493,271,469, & - 339,237,437,483,31,219,61,131,391,233,219,69,57,459,225,421, & - 7,461,111,451,277,185,193,125,251,199,73,71,7,409,417,149/) - v(300:550,9) = (/ & - 193,53,437,29,467,229,31,35,75,105, & - 503,75,317,401,367,131,365,441,433,93,377,405,465,259,283, & - 443,143,445,3,461,329,309,77,323,155,347,45,381,315,463,207, & - 321,157,109,479,313,345,167,439,307,235,473,79,101,245,19, & - 381,251,35,25,107,187,115,113,321,115,445,61,77,293,405,13, & - 53,17,171,299,41,79,3,485,331,13,257,59,201,497,81,451,199, & - 171,81,253,365,75,451,149,483,81,453,469,485,305,163,401,15, & - 91,3,129,35,239,355,211,387,101,299,67,375,405,357,267,363, & - 79,83,437,457,39,97,473,289,179,57,23,49,79,71,341,287,95, & - 229,271,475,49,241,261,495,353,381,13,291,37,251,105,399,81, & - 89,265,507,205,145,331,129,119,503,249,1,289,463,163,443,63, & - 123,361,261,49,429,137,355,175,507,59,277,391,25,185,381,197, & - 39,5,429,119,247,177,329,465,421,271,467,151,45,429,137,471, & - 11,17,409,347,199,463,177,11,51,361,95,497,163,351,127,395, & - 511,327,353,49,105,151,321,331,329,509,107,109,303,467,287, & - 161,45,385,289,363,331,265,407,37,433,315,343,63,51,185,71, & - 27,267/) - v(551:798,9) = (/ & - 503,239,293,245,281,297,75,461,371, & - 129,189,189,339,287,111,111,379,93,27,185,347,337,247,507, & - 161,231,43,499,73,327,263,331,249,493,37,25,115,3,167,197, & - 127,357,497,103,125,191,165,55,101,95,79,351,341,43,125,135, & - 173,289,373,133,421,241,281,213,177,363,151,227,145,363,239, & - 431,81,397,241,67,291,255,405,421,399,75,399,105,329,41,425, & - 7,283,375,475,427,277,209,411,3,137,195,289,509,121,55,147, & - 275,251,19,129,285,415,487,491,193,219,403,23,97,65,285,75, & - 21,373,261,339,239,495,415,333,107,435,297,213,149,463,199, & - 323,45,19,301,121,499,187,229,63,425,99,281,35,125,349,87, & - 101,59,195,511,355,73,263,243,101,165,141,11,389,219,187,449, & - 447,393,477,305,221,51,355,209,499,479,265,377,145,411,173, & - 11,433,483,135,385,341,89,209,391,33,395,319,451,119,341,227, & - 375,61,331,493,411,293,47,203,375,167,395,155,5,237,361,489, & - 127,21,345,101,371,233,431,109,119,277,125,263,73,135,123,83, & - 123,405,69,75,287,401,23,283,393,41,379,431,11,475,505,19, & - 365,265,271/) - v(799:1045,9) = (/ & - 499,489,443,165,91,83,291,319,199, & - 107,245,389,143,137,89,125,281,381,215,131,299,249,375,455, & - 43,73,281,217,297,229,431,357,81,357,171,451,481,13,387,491, & - 489,439,385,487,177,393,33,71,375,443,129,407,395,127,65,333, & - 309,119,197,435,497,373,71,379,509,387,159,265,477,463,449, & - 47,353,249,335,505,89,141,55,235,187,87,363,93,363,101,67, & - 215,321,331,305,261,411,491,479,65,307,469,415,131,315,487, & - 83,455,19,113,163,503,99,499,251,239,81,167,391,255,317,363, & - 359,395,419,307,251,267,171,461,183,465,165,163,293,477,223, & - 403,389,97,335,357,297,19,469,501,249,85,213,311,265,379,297, & - 283,393,449,463,289,159,289,499,407,129,137,221,43,89,403, & - 271,75,83,445,453,389,149,143,423,499,317,445,157,137,453, & - 163,87,23,391,119,427,323,173,89,259,377,511,249,31,363,229, & - 353,329,493,427,57,205,389,91,83,13,219,439,45,35,371,441,17, & - 267,501,53,25,333,17,201,475,257,417,345,381,377,55,403,77, & - 389,347,363,211,413,419,5,167,219,201,285,425,11,77,269,489, & - 281,403,79/) - v(1046:1111,9) = (/ & - 425,125,81,331,437,271,397,299,475, & - 271,249,413,233,261,495,171,69,27,409,21,421,367,81,483,255, & - 15,219,365,497,181,75,431,99,325,407,229,281,63,83,493,5,113, & - 15,271,37,87,451,299,83,451,311,441,47,455,47,253,13,109,369, & - 347,11,409,275,63,441,15/) - v(102:344,10) = (/ & - 519,307,931,1023,517,771,151,1023, & - 539,725,45,927,707,29,125,371,275,279,817,389,453,989,1015, & - 29,169,743,99,923,981,181,693,309,227,111,219,897,377,425, & - 609,227,19,221,143,581,147,919,127,725,793,289,411,835,921, & - 957,443,349,813,5,105,457,393,539,101,197,697,27,343,515,69, & - 485,383,855,693,133,87,743,747,475,87,469,763,721,345,479, & - 965,527,121,271,353,467,177,245,627,113,357,7,691,725,355, & - 889,635,737,429,545,925,357,873,187,351,677,999,921,477,233, & - 765,495,81,953,479,89,173,473,131,961,411,291,967,65,511,13, & - 805,945,369,827,295,163,835,259,207,331,29,315,999,133,967, & - 41,117,677,471,717,881,755,351,723,259,879,455,721,289,149, & - 199,805,987,851,423,597,129,11,733,549,153,285,451,559,377, & - 109,357,143,693,615,677,701,475,767,85,229,509,547,151,389, & - 711,785,657,319,509,99,1007,775,359,697,677,85,497,105,615, & - 891,71,449,835,609,377,693,665,627,215,911,503,729,131,19, & - 895,199,161,239,633,1013,537,255,23,149,679,1021,595,199,557, & - 659,251,829,727,439,495,647,223/) - v(345:586,10) = (/ & - 949,625,87,481,85,799,917,769,949, & - 739,115,499,945,547,225,1015,469,737,495,353,103,17,665,639, & - 525,75,447,185,43,729,577,863,735,317,99,17,477,893,537,519, & - 1017,375,297,325,999,353,343,729,135,489,859,267,141,831,141, & - 893,249,807,53,613,131,547,977,131,999,175,31,341,739,467, & - 675,241,645,247,391,583,183,973,433,367,131,467,571,309,385, & - 977,111,917,935,473,345,411,313,97,149,959,841,839,669,431, & - 51,41,301,247,1015,377,329,945,269,67,979,581,643,823,557,91, & - 405,117,801,509,347,893,303,227,783,555,867,99,703,111,797, & - 873,541,919,513,343,319,517,135,871,917,285,663,301,15,763, & - 89,323,757,317,807,309,1013,345,499,279,711,915,411,281,193, & - 739,365,315,375,809,469,487,621,857,975,537,939,585,129,625, & - 447,129,1017,133,83,3,415,661,53,115,903,49,79,55,385,261, & - 345,297,199,385,617,25,515,275,849,401,471,377,661,535,505, & - 939,465,225,929,219,955,659,441,117,527,427,515,287,191,33, & - 389,197,825,63,417,949,35,571,9,131,609,439,95,19,569,893, & - 451,397,971,801/) - v(587:824,10) = (/ & - 125,471,187,257,67,949,621,453,411, & - 621,955,309,783,893,597,377,753,145,637,941,593,317,555,375, & - 575,175,403,571,555,109,377,931,499,649,653,329,279,271,647, & - 721,665,429,957,803,767,425,477,995,105,495,575,687,385,227, & - 923,563,723,481,717,111,633,113,369,955,253,321,409,909,367, & - 33,967,453,863,449,539,781,911,113,7,219,725,1015,971,1021, & - 525,785,873,191,893,297,507,215,21,153,645,913,755,371,881, & - 113,903,225,49,587,201,927,429,599,513,97,319,331,833,325, & - 887,139,927,399,163,307,803,169,1019,869,537,907,479,335,697, & - 479,353,769,787,1023,855,493,883,521,735,297,1011,991,879, & - 855,591,415,917,375,453,553,189,841,339,211,601,57,765,745, & - 621,209,875,639,7,595,971,263,1009,201,23,77,621,33,535,963, & - 661,523,263,917,103,623,231,47,301,549,337,675,189,357,1005, & - 789,189,319,721,1005,525,675,539,191,813,917,51,167,415,579, & - 755,605,721,837,529,31,327,799,961,279,409,847,649,241,285, & - 545,407,161,591,73,313,811,17,663,269,261,37,783,127,917,231, & - 577,975,793/) - v(825:1065,10) = (/ & - 921,343,751,139,221,79,817,393,545, & - 11,781,71,1,699,767,917,9,107,341,587,903,965,599,507,843, & - 739,579,397,397,325,775,565,925,75,55,979,931,93,957,857,753, & - 965,795,67,5,87,909,97,995,271,875,671,613,33,351,69,811,669, & - 729,401,647,241,435,447,721,271,745,53,775,99,343,451,427, & - 593,339,845,243,345,17,573,421,517,971,499,435,769,75,203, & - 793,985,343,955,735,523,659,703,303,421,951,405,631,825,735, & - 433,841,485,49,749,107,669,211,497,143,99,57,277,969,107,397, & - 563,551,447,381,187,57,405,731,769,923,955,915,737,595,341, & - 253,823,197,321,315,181,885,497,159,571,981,899,785,947,217, & - 217,135,753,623,565,717,903,581,955,621,361,869,87,943,907, & - 853,353,335,197,771,433,743,195,91,1023,63,301,647,205,485, & - 927,1003,987,359,577,147,141,1017,701,273,89,589,487,859,343, & - 91,847,341,173,287,1003,289,639,983,685,697,35,701,645,911, & - 501,705,873,763,745,657,559,699,315,347,429,197,165,955,859, & - 167,303,833,531,473,635,641,195,589,821,205,3,635,371,891, & - 249,123/) - v(1066:1111,10) = (/ & - 77,623,993,401,525,427,71,655,951, & - 357,851,899,535,493,323,1003,343,515,859,1017,5,423,315,1011, & - 703,41,777,163,95,831,79,975,235,633,723,297,589,317,679,981, & - 195,399,1003,121,501,155/) - v(162:376,11) = (/ & - 7,2011,1001,49,825,415,1441,383,1581, & - 623,1621,1319,1387,619,839,217,75,1955,505,281,1629,1379,53, & - 1111,1399,301,209,49,155,1647,631,129,1569,335,67,1955,1611, & - 2021,1305,121,37,877,835,1457,669,1405,935,1735,665,551,789, & - 1543,1267,1027,1,1911,163,1929,67,1975,1681,1413,191,1711, & - 1307,401,725,1229,1403,1609,2035,917,921,1789,41,2003,187,67, & - 1635,717,1449,277,1903,1179,363,1211,1231,647,1261,1029,1485, & - 1309,1149,317,1335,171,243,271,1055,1601,1129,1653,205,1463, & - 1681,1621,197,951,573,1697,1265,1321,1805,1235,1853,1307,945, & - 1197,1411,833,273,1517,1747,1095,1345,869,57,1383,221,1713, & - 335,1751,1141,839,523,1861,1105,389,1177,1877,805,93,1591, & - 423,1835,99,1781,1515,1909,1011,303,385,1635,357,973,1781, & - 1707,1363,1053,649,1469,623,1429,1241,1151,1055,503,921,3, & - 349,1149,293,45,303,877,1565,1583,1001,663,1535,395,1141, & - 1481,1797,643,1507,465,2027,1695,367,937,719,545,1991,83,819, & - 239,1791,1461,1647,1501,1161,1629,139,1595,1921,1267,1415, & - 509,347,777,1083,363,269,1015/) - v(377:589,11) = (/ & - 1809,1105,1429,1471,2019,381,2025, & - 1223,827,1733,887,1321,803,1951,1297,1995,833,1107,1135,1181, & - 1251,983,1389,1565,273,137,71,735,1005,933,67,1471,551,457, & - 1667,1729,919,285,1629,1815,653,1919,1039,531,393,1411,359, & - 221,699,1485,471,1357,1715,595,1677,153,1903,1281,215,781, & - 543,293,1807,965,1695,443,1985,321,879,1227,1915,839,1945, & - 1993,1165,51,557,723,1491,817,1237,947,1215,1911,1225,1965, & - 1889,1503,1177,73,1767,303,177,1897,1401,321,921,217,1779, & - 327,1889,333,615,1665,1825,1639,237,1205,361,129,1655,983, & - 1089,1171,401,677,643,749,303,1407,1873,1579,1491,1393,1247, & - 789,763,49,5,1607,1891,735,1557,1909,1765,1777,1127,813,695, & - 97,731,1503,1751,333,769,865,693,377,1919,957,1359,1627,1039, & - 1783,1065,1665,1917,1947,991,1997,841,459,221,327,1595,1881, & - 1269,1007,129,1413,475,1105,791,1983,1359,503,691,659,691, & - 343,1375,1919,263,1373,603,1383,297,781,145,285,767,1739, & - 1715,715,317,1333,85,831,1615,81,1667,1467,1457,1453,1825, & - 109,387,1207,2039,213,1351,1329,1173/) - v(590:802,11) = (/ & - 57,1769,951,183,23,451,1155,1551, & - 2037,811,635,1671,1451,863,1499,1673,363,1029,1077,1525,277, & - 1023,655,665,1869,1255,965,277,1601,329,1603,1901,395,65, & - 1307,2029,21,1321,543,1569,1185,1905,1701,413,2041,1697,725, & - 1417,1847,411,211,915,1891,17,1877,1699,687,1089,1973,1809, & - 851,1495,1257,63,1323,1307,609,881,1543,177,617,1505,1747, & - 1537,925,183,77,1723,1877,1703,397,459,521,257,1177,389,1947, & - 1553,1583,1831,261,485,289,1281,1543,1591,1123,573,821,1065, & - 1933,1373,2005,905,207,173,1573,1597,573,1883,1795,1499,1743, & - 553,335,333,1645,791,871,1157,969,557,141,223,1129,1685,423, & - 1069,391,99,95,1847,531,1859,1833,1833,341,237,1997,1799,409, & - 431,1917,363,335,1039,1085,1657,1975,1527,1111,659,389,899, & - 595,1439,1861,1979,1569,1087,1009,165,1895,1481,1583,29,1193, & - 1673,1075,301,1081,1377,1747,1497,1103,1789,887,739,1577,313, & - 1367,1299,1801,1131,1837,73,1865,1065,843,635,55,1655,913, & - 1037,223,1871,1161,461,479,511,1721,1107,389,151,35,375,1099, & - 937,1185,1701,769,639,1633/) - v(803:1018,11) = (/ & - 1609,379,1613,2031,685,289,975,671, & - 1599,1447,871,647,99,139,1427,959,89,117,841,891,1959,223, & - 1697,1145,499,1435,1809,1413,1445,1675,171,1073,1349,1545, & - 2039,1027,1563,859,215,1673,1919,1633,779,411,1845,1477,1489, & - 447,1545,351,1989,495,183,1639,1385,1805,1097,1249,1431,1571, & - 591,697,1509,709,31,1563,165,513,1425,1299,1081,145,1841, & - 1211,941,609,845,1169,1865,1593,347,293,1277,157,211,93,1679, & - 1799,527,41,473,563,187,1525,575,1579,857,703,1211,647,709, & - 981,285,697,163,981,153,1515,47,1553,599,225,1147,381,135, & - 821,1965,609,1033,983,503,1117,327,453,2005,1257,343,1649, & - 1199,599,1877,569,695,1587,1475,187,973,233,511,51,1083,665, & - 1321,531,1875,1939,859,1507,1979,1203,1965,737,921,1565,1943, & - 819,223,365,167,1705,413,1577,745,1573,655,1633,1003,91,1123, & - 477,1741,1663,35,715,37,1513,815,941,1379,263,1831,1735,1111, & - 1449,353,1941,1655,1349,877,285,1723,125,1753,985,723,175, & - 439,791,1051,1261,717,1555,1757,1777,577,1583,1957,873,331, & - 1163,313,1,1963,963,1905,821/) - v(1019:1111,11) = (/ & - 1677,185,709,545,1723,215,1885, & - 1249,583,1803,839,885,485,413,1767,425,129,1035,329,1263, & - 1881,1779,1565,359,367,453,707,1419,831,1889,887,1871,1869, & - 747,223,1547,1799,433,1441,553,2021,1303,1505,1735,1619,1065, & - 1161,2047,347,867,881,1447,329,781,1065,219,589,645,1257, & - 1833,749,1841,1733,1179,1191,1025,1639,1955,1423,1685,1711, & - 493,549,783,1653,397,895,233,759,1505,677,1449,1573,1297, & - 1821,1691,791,289,1187,867,1535,575,183/) - v(338:545,12) = (/ & - 3915,97,3047,937,2897,953,127,1201, & - 3819,193,2053,3061,3759,1553,2007,2493,603,3343,3751,1059, & - 783,1789,1589,283,1093,3919,2747,277,2605,2169,2905,721,4069, & - 233,261,1137,3993,3619,2881,1275,3865,1299,3757,1193,733,993, & - 1153,2945,3163,3179,437,271,3493,3971,1005,2615,2253,1131, & - 585,2775,2171,2383,2937,2447,1745,663,1515,3767,2709,1767, & - 3185,3017,2815,1829,87,3341,793,2627,2169,1875,3745,367,3783, & - 783,827,3253,2639,2955,3539,1579,2109,379,2939,3019,1999, & - 2253,2911,3733,481,1767,1055,4019,4085,105,1829,2097,2379, & - 1567,2713,737,3423,3941,2659,3961,1755,3613,1937,1559,2287, & - 2743,67,2859,325,2601,1149,3259,2403,3947,2011,175,3389,3915, & - 1315,2447,141,359,3609,3933,729,2051,1755,2149,2107,1741, & - 1051,3681,471,1055,845,257,1559,1061,2803,2219,1315,1369, & - 3211,4027,105,11,1077,2857,337,3553,3503,3917,2665,3823,3403, & - 3711,2085,1103,1641,701,4095,2883,1435,653,2363,1597,767,869, & - 1825,1117,1297,501,505,149,873,2673,551,1499,2793,3277,2143, & - 3663,533,3991,575,1877,1009,3929,473,3009,2595,3249,675,3593/) - v(546:752,12) = (/ & - 2453,1567,973,595,1335,1715,589,85, & - 2265,3069,461,1659,2627,1307,1731,1501,1699,3545,3803,2157, & - 453,2813,2047,2999,3841,2361,1079,573,69,1363,1597,3427,2899, & - 2771,1327,1117,1523,3521,2393,2537,1979,3179,683,2453,453, & - 1227,779,671,3483,2135,3139,3381,3945,57,1541,3405,3381,2371, & - 2879,1985,987,3017,3031,3839,1401,3749,2977,681,1175,1519, & - 3355,907,117,771,3741,3337,1743,1227,3335,2755,1909,3603, & - 2397,653,87,2025,2617,3257,287,3051,3809,897,2215,63,2043, & - 1757,3671,297,3131,1305,293,3865,3173,3397,2269,3673,717, & - 3041,3341,3595,3819,2871,3973,1129,513,871,1485,3977,2473, & - 1171,1143,3063,3547,2183,3993,133,2529,2699,233,2355,231, & - 3241,611,1309,3829,1839,1495,301,1169,1613,2673,243,3601, & - 3669,2813,2671,2679,3463,2477,1795,617,2317,1855,1057,1703, & - 1761,2515,801,1205,1311,473,3963,697,1221,251,381,3887,1761, & - 3093,3721,2079,4085,379,3601,3845,433,1781,29,1897,1599,2163, & - 75,3475,3957,1641,3911,2959,2833,1279,1099,403,799,2183,2699, & - 1711,2037,727,289,1785,1575,3633,2367,1261,3953,1735,171, & - 1959/) - v(753:960,12) = (/ & - 2867,859,2951,3211,15,1279,1323,599, & - 1651,3951,1011,315,3513,3351,1725,3793,2399,287,4017,3571, & - 1007,541,3115,429,1585,1285,755,1211,3047,915,3611,2697,2129, & - 3669,81,3939,2437,915,779,3567,3701,2479,3807,1893,3927,2619, & - 2543,3633,2007,3857,3837,487,1769,3759,3105,2727,3155,2479, & - 1341,1657,2767,2541,577,2105,799,17,2871,3637,953,65,69,2897, & - 3841,3559,4067,2335,3409,1087,425,2813,1705,1701,1237,821, & - 1375,3673,2693,3925,1541,1871,2285,847,4035,1101,2029,855, & - 2733,2503,121,2855,1069,3463,3505,1539,607,1349,575,2301, & - 2321,1101,333,291,2171,4085,2173,2541,1195,925,4039,1379,699, & - 1979,275,953,1755,1643,325,101,2263,3329,3673,3413,1977,2727, & - 2313,1419,887,609,2475,591,2613,2081,3805,3435,2409,111,3557, & - 3607,903,231,3059,473,2959,2925,3861,2043,3887,351,2865,369, & - 1377,2639,1261,3625,3279,2201,2949,3049,449,1297,897,1891, & - 411,2773,749,2753,1825,853,2775,3547,3923,3923,987,3723,2189, & - 3877,3577,297,2763,1845,3083,2951,483,2169,3985,245,3655, & - 3441,1023,235,835,3693,3585,327,1003,543,3059,2637/) - v(961:1111,12) = (/ & - 2923,87,3617,1031,1043,903,2913, & - 2177,2641,3279,389,2009,525,4085,3299,987,2409,813,2683,373, & - 2695,3775,2375,1119,2791,223,325,587,1379,2877,2867,3793,655, & - 831,3425,1663,1681,2657,1865,3943,2977,1979,2271,3247,1267, & - 1747,811,159,429,2001,1195,3065,553,1499,3529,1081,2877,3077, & - 845,1793,2409,3995,2559,4081,1195,2955,1117,1409,785,287, & - 1521,1607,85,3055,3123,2533,2329,3477,799,3683,3715,337,3139, & - 3311,431,3511,2299,365,2941,3067,1331,1081,1097,2853,2299, & - 495,1745,749,3819,619,1059,3559,183,3743,723,949,3501,733, & - 2599,3983,3961,911,1899,985,2493,1795,653,157,433,2361,3093, & - 3119,3679,2367,1701,1445,1321,2397,1241,3305,3985,2349,4067, & - 3805,3073,2837,1567,3783,451,2441,1181,487,543,1201,3735, & - 2517,733,1535,2175,3613,3019/) - v(482:680,13) = (/ & - 2319,653,1379,1675,1951,7075,2087, & - 7147,1427,893,171,2019,7235,5697,3615,1961,7517,6849,2893, & - 1883,2863,2173,4543,73,381,3893,6045,1643,7669,1027,1549, & - 3983,1985,6589,7497,2745,2375,7047,1117,1171,1975,5199,3915, & - 3695,8113,4303,3773,7705,6855,1675,2245,2817,1719,569,1021, & - 2077,5945,1833,2631,4851,6371,833,7987,331,1899,8093,6719, & - 6903,5903,5657,5007,2689,6637,2675,1645,1819,689,6709,7717, & - 6295,7013,7695,3705,7069,2621,3631,6571,6259,7261,3397,7645, & - 1115,4753,2047,7579,2271,5403,4911,7629,4225,1209,6955,6951, & - 1829,5579,5231,1783,4285,7425,599,5785,3275,5643,2263,657, & - 6769,6261,1251,3249,4447,4111,3991,1215,131,4397,3487,7585, & - 5565,7199,3573,7105,7409,1671,949,3889,5971,3333,225,3647, & - 5403,3409,7459,6879,5789,6567,5581,4919,1927,4407,8085,4691, & - 611,3005,591,753,589,171,5729,5891,1033,3049,6567,5257,8003, & - 1757,4489,4923,6379,5171,1757,689,3081,1389,4113,455,2761, & - 847,7575,5829,633,6629,1103,7635,803,6175,6587,2711,3879,67, & - 1179,4761,7281,1557,3379,2459,4273,4127,7147,35/) - v(681:877,13) = (/ & - 3549,395,3735,5787,4179,5889,5057, & - 7473,4713,2133,2897,1841,2125,1029,1695,6523,1143,5105,7133, & - 3351,2775,3971,4503,7589,5155,4305,1641,4717,2427,5617,1267, & - 399,5831,4305,4241,3395,3045,4899,1713,171,411,7099,5473, & - 5209,1195,1077,1309,2953,7343,4887,3229,6759,6721,6775,675, & - 4039,2493,7511,3269,4199,6625,7943,2013,4145,667,513,2303, & - 4591,7941,2741,987,8061,3161,5951,1431,831,5559,7405,1357, & - 4319,4235,5421,2559,4415,2439,823,1725,6219,4903,6699,5451, & - 349,7703,2927,7809,6179,1417,5987,3017,4983,3479,4525,4643, & - 4911,227,5475,2287,5581,6817,1937,1421,4415,7977,1789,3907, & - 6815,6789,6003,5609,4507,337,7427,7943,3075,6427,1019,7121, & - 4763,81,3587,2929,1795,8067,2415,1265,4025,5599,4771,3025, & - 2313,6129,7611,6881,5253,4413,7869,105,3173,1629,2537,1023, & - 4409,7209,4413,7107,7469,33,1955,2881,5167,6451,4211,179, & - 5573,7879,3387,7759,5455,7157,1891,5683,5689,6535,3109,6555, & - 6873,1249,4251,6437,49,2745,1201,7327,4179,6783,623,2779, & - 5963,2585,6927,5333,4033,285,7467,4443,4917,3/) - v(878:1070,13) = (/ & - 4319,5517,3449,813,5499,2515,5771, & - 3357,2073,4395,4925,2643,7215,5817,1199,1597,1619,7535,4833, & - 609,4797,8171,6847,793,6757,8165,3371,2431,5235,4739,7703, & - 7223,6525,5891,5605,4433,3533,5267,5125,5037,225,6717,1121, & - 5741,2013,4327,4839,569,5227,7677,4315,2391,5551,859,3627, & - 6377,3903,4311,6527,7573,4905,7731,1909,1555,3279,1949,1887, & - 6675,5509,2033,5473,3539,5033,5935,6095,4761,1771,1271,1717, & - 4415,5083,6277,3147,7695,2461,4783,4539,5833,5583,651,1419, & - 2605,5511,3913,5795,2333,2329,4431,3725,6069,2699,7055,6879, & - 1017,3121,2547,4603,2385,6915,6103,5669,7833,2001,4287,6619, & - 955,2761,5711,6291,3415,3909,2841,5627,4939,7671,6059,6275, & - 6517,1931,4583,7301,1267,7509,1435,2169,6939,3515,2985,2787, & - 2123,1969,3307,353,4359,7059,5273,5873,6657,6765,6229,3179, & - 1583,6237,2155,371,273,7491,3309,6805,3015,6831,7819,713, & - 4747,3935,4109,1311,709,3089,7059,4247,2989,1509,4919,1841, & - 3045,3821,6929,4655,1333,6429,6649,2131,5265,1051,261,8057, & - 3379,2179,1993,5655,3063,6381/) - v(1071:1111,13) = (/ & - 3587,7417,1579,1541,2107,5085,2873, & - 6141,955,3537,2157,841,1999,1465,5171,5651,1535,7235,4349, & - 1263,1453,1005,6893,2919,1947,1635,3963,397,969,4569,655, & - 6737,2995,7235,7713,973,4821,2377,1673,1,6541/) -! -! Set POLY. -! - poly(1:211)= (/ & - 1,3,7,11,13,19,25,37,59,47,61,55,41,67,97,91, & - 109,103,115,131,193,137,145,143,241,157,185,167,229,171,213, & - 191,253,203,211,239,247,285,369,299,301,333,351,355,357,361, & - 391,397,425,451,463,487,501,529,539,545,557,563,601,607,617, & - 623,631,637,647,661,675,677,687,695,701,719,721,731,757,761, & - 787,789,799,803,817,827,847,859,865,875,877,883,895,901,911, & - 949,953,967,971,973,981,985,995,1001,1019,1033,1051,1063, & - 1069,1125,1135,1153,1163,1221,1239,1255,1267,1279,1293,1305, & - 1315,1329,1341,1347,1367,1387,1413,1423,1431,1441,1479,1509, & - 1527,1531,1555,1557,1573,1591,1603,1615,1627,1657,1663,1673, & - 1717,1729,1747,1759,1789,1815,1821,1825,1849,1863,1869,1877, & - 1881,1891,1917,1933,1939,1969,2011,2035,2041,2053,2071,2091, & - 2093,2119,2147,2149,2161,2171,2189,2197,2207,2217,2225,2255, & - 2257,2273,2279,2283,2293,2317,2323,2341,2345,2363,2365,2373, & - 2377,2385,2395,2419,2421,2431,2435,2447,2475,2477,2489,2503, & - 2521,2533,2551,2561,2567,2579,2581,2601,2633,2657,2669/) - poly(212:401)= (/ & - 2681,2687,2693,2705,2717,2727,2731,2739, & - 2741,2773,2783,2793,2799,2801,2811,2819,2825,2833,2867,2879, & - 2881,2891,2905,2911,2917,2927,2941,2951,2955,2963,2965,2991, & - 2999,3005,3017,3035,3037,3047,3053,3083,3085,3097,3103,3159, & - 3169,3179,3187,3205,3209,3223,3227,3229,3251,3263,3271,3277, & - 3283,3285,3299,3305,3319,3331,3343,3357,3367,3373,3393,3399, & - 3413,3417,3427,3439,3441,3475,3487,3497,3515,3517,3529,3543, & - 3547,3553,3559,3573,3589,3613,3617,3623,3627,3635,3641,3655, & - 3659,3669,3679,3697,3707,3709,3713,3731,3743,3747,3771,3791, & - 3805,3827,3833,3851,3865,3889,3895,3933,3947,3949,3957,3971, & - 3985,3991,3995,4007,4013,4021,4045,4051,4069,4073,4179,4201, & - 4219,4221,4249,4305,4331,4359,4383,4387,4411,4431,4439,4449, & - 4459,4485,4531,4569,4575,4621,4663,4669,4711,4723,4735,4793, & - 4801,4811,4879,4893,4897,4921,4927,4941,4977,5017,5027,5033, & - 5127,5169,5175,5199,5213,5223,5237,5287,5293,5331,5391,5405, & - 5453,5523,5573,5591,5597,5611,5641,5703,5717,5721,5797,5821, & - 5909,5913/) - poly(402:591)= (/ & - 5955,5957,6005,6025,6061,6067,6079,6081, & - 6231,6237,6289,6295,6329,6383,6427,6453,6465,6501,6523,6539, & - 6577,6589,6601,6607,6631,6683,6699,6707,6761,6795,6865,6881, & - 6901,6923,6931,6943,6999,7057,7079,7103,7105,7123,7173,7185, & - 7191,7207,7245,7303,7327,7333,7355,7365,7369,7375,7411,7431, & - 7459,7491,7505,7515,7541,7557,7561,7701,7705,7727,7749,7761, & - 7783,7795,7823,7907,7953,7963,7975,8049,8089,8123,8125,8137, & - 8219,8231,8245,8275,8293,8303,8331,8333,8351,8357,8367,8379, & - 8381,8387,8393,8417,8435,8461,8469,8489,8495,8507,8515,8551, & - 8555,8569,8585,8599,8605,8639,8641,8647,8653,8671,8675,8689, & - 8699,8729,8741,8759,8765,8771,8795,8797,8825,8831,8841,8855, & - 8859,8883,8895,8909,8943,8951,8955,8965,8999,9003,9031,9045, & - 9049,9071,9073,9085,9095,9101,9109,9123,9129,9137,9143,9147, & - 9185,9197,9209,9227,9235,9247,9253,9257,9277,9297,9303,9313, & - 9325,9343,9347,9371,9373,9397,9407,9409,9415,9419,9443,9481, & - 9495,9501,9505,9517,9529,9555,9557,9571,9585,9591,9607,9611, & - 9621,9625/) - poly(592:765)= (/ & - 9631,9647,9661,9669,9679,9687,9707,9731, & - 9733,9745,9773,9791,9803,9811,9817,9833,9847,9851,9863,9875, & - 9881,9905,9911,9917,9923,9963,9973,10003,10025,10043,10063, & - 10071,10077,10091,10099,10105,10115,10129,10145,10169,10183, & - 10187,10207,10223,10225,10247,10265,10271,10275,10289,10299, & - 10301,10309,10343,10357,10373,10411,10413,10431,10445,10453, & - 10463,10467,10473,10491,10505,10511,10513,10523,10539,10549, & - 10559,10561,10571,10581,10615,10621,10625,10643,10655,10671, & - 10679,10685,10691,10711,10739,10741,10755,10767,10781,10785, & - 10803,10805,10829,10857,10863,10865,10875,10877,10917,10921, & - 10929,10949,10967,10971,10987,10995,11009,11029,11043,11045, & - 11055,11063,11075,11081,11117,11135,11141,11159,11163,11181, & - 11187,11225,11237,11261,11279,11297,11307,11309,11327,11329, & - 11341,11377,11403,11405,11413,11427,11439,11453,11461,11473, & - 11479,11489,11495,11499,11533,11545,11561,11567,11575,11579, & - 11589,11611,11623,11637,11657,11663,11687,11691,11701,11747, & - 11761,11773,11783,11795,11797,11817,11849,11855,11867,11869, & - 11873,11883,11919/) - poly(766:936)= (/ & - 11921,11927,11933,11947,11955,11961, & - 11999,12027,12029,12037,12041,12049,12055,12095,12097,12107, & - 12109,12121,12127,12133,12137,12181,12197,12207,12209,12239, & - 12253,12263,12269,12277,12287,12295,12309,12313,12335,12361, & - 12367,12391,12409,12415,12433,12449,12469,12479,12481,12499, & - 12505,12517,12527,12549,12559,12597,12615,12621,12639,12643, & - 12657,12667,12707,12713,12727,12741,12745,12763,12769,12779, & - 12781,12787,12799,12809,12815,12829,12839,12857,12875,12883, & - 12889,12901,12929,12947,12953,12959,12969,12983,12987,12995, & - 13015,13019,13031,13063,13077,13103,13137,13149,13173,13207, & - 13211,13227,13241,13249,13255,13269,13283,13285,13303,13307, & - 13321,13339,13351,13377,13389,13407,13417,13431,13435,13447, & - 13459,13465,13477,13501,13513,13531,13543,13561,13581,13599, & - 13605,13617,13623,13637,13647,13661,13677,13683,13695,13725, & - 13729,13753,13773,13781,13785,13795,13801,13807,13825,13835, & - 13855,13861,13871,13883,13897,13905,13915,13939,13941,13969, & - 13979,13981,13997,14027,14035,14037,14051,14063,14085,14095, & - 14107,14113,14125,14137,14145/) - poly(937:1107)= (/ & - 14151,14163,14193,14199,14219,14229, & - 14233,14243,14277,14287,14289,14295,14301,14305,14323,14339, & - 14341,14359,14365,14375,14387,14411,14425,14441,14449,14499, & - 14513,14523,14537,14543,14561,14579,14585,14593,14599,14603, & - 14611,14641,14671,14695,14701,14723,14725,14743,14753,14759, & - 14765,14795,14797,14803,14831,14839,14845,14855,14889,14895, & - 14909,14929,14941,14945,14951,14963,14965,14985,15033,15039, & - 15053,15059,15061,15071,15077,15081,15099,15121,15147,15149, & - 15157,15167,15187,15193,15203,15205,15215,15217,15223,15243, & - 15257,15269,15273,15287,15291,15313,15335,15347,15359,15373, & - 15379,15381,15391,15395,15397,15419,15439,15453,15469,15491, & - 15503,15517,15527,15531,15545,15559,15593,15611,15613,15619, & - 15639,15643,15649,15661,15667,15669,15681,15693,15717,15721, & - 15741,15745,15765,15793,15799,15811,15825,15835,15847,15851, & - 15865,15877,15881,15887,15899,15915,15935,15937,15955,15973, & - 15977,16011,16035,16061,16069,16087,16093,16097,16121,16141, & - 16153,16159,16165,16183,16189,16195,16197,16201,16209,16215, & - 16225,16259,16265,16273,16299/) - poly(1108:1111)= (/ & - 16309,16355,16375,16381/) - - end if - - if ( dim_num /= dim_num_save ) then -! -! Check parameters. -! - if ( dim_num < 2 .or. dim_max < dim_num ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I8_SOBOL - Fatal error!' - write ( *, '(a)' ) ' The spatial dimension DIM_NUM should satisfy:' - write ( *, '(a,i8)' ) ' 2 <= DIM_NUM <= ', dim_max - write ( *, '(a,i8)' ) ' But this input value is DIM_NUM = ', dim_num - stop - end if - - dim_num_save = dim_num -! -! Set ATMOST = 2**LOG_MAX - 1. -! - atmost = 0 - do i = 1, log_max - atmost = 2 * atmost + 1 - end do -! -! Find the highest 1 bit in ATMOST (should be LOG_MAX). -! - maxcol = i8_bit_hi1 ( atmost ) -! -! Initialize row 1 of V. -! - v(1,1:maxcol) = 1 -! -! Initialize the remaining rows of V. -! - do i = 2, dim_num -! -! The bit pattern of the integer POLY(I) gives the form -! of polynomial I. -! -! Find the degree of polynomial I from binary encoding. -! - j = poly(i) - m = 0 - - do - - j = j / 2 - - if ( j <= 0 ) then - exit - end if - - m = m + 1 - - end do -! -! We expand this bit pattern to separate components -! of the logical array INCLUD. -! - j = poly(i) - do k = m, 1, - 1 - j2 = j / 2 - includ(k) = ( j /= ( 2 * j2 ) ) - j = j2 - end do -! -! Calculate the remaining elements of row I as explained -! in Bratley and Fox, section 2. -! - do j = m + 1, maxcol - - newv = v(i,j-m) - l = 1 - - do k = 1, m - - l = 2 * l - - if ( includ(k) ) then - newv = ieor ( newv, l * v(i,j-k) ) - end if - - end do - - v(i,j) = newv - - end do - - end do -! -! Multiply columns of V by appropriate power of 2. -! - l = 1 - do j = maxcol - 1, 1, - 1 - l = 2 * l - v(1:dim_num,j) = v(1:dim_num,j) * l - end do -! -! RECIPD is 1/(common denominator of the elements in V) = 1 / ( 2 * L ). -! - recipd = real ( l, kind = 8 ) - recipd = 0.5D+00 / recipd - - end if - - if ( seed < 0 ) then - seed = 0 - end if - - if ( seed == 0 ) then - - l = 1 - lastq(1:dim_num) = 0 - - else if ( seed == seed_save + 1 ) then -! -! Find the position of the right-hand zero in SEED. -! - l = i8_bit_lo0 ( seed ) - - else if ( seed <= seed_save ) then - - seed_save = 0 - l = 1 - lastq(1:dim_num) = 0 - - do seed_temp = seed_save, seed - 1 - l = i8_bit_lo0 ( seed_temp ) - lastq(1:dim_num) = ieor ( lastq(1:dim_num), v(1:dim_num,l) ) - end do - - l = i8_bit_lo0 ( seed ) - - else if ( seed_save+1 < seed ) then - - do seed_temp = seed_save+1, seed - 1 - l = i8_bit_lo0 ( seed_temp ) - lastq(1:dim_num) = ieor ( lastq(1:dim_num), v(1:dim_num,l) ) - end do - - l = i8_bit_lo0 ( seed ) - - end if -! -! Check that the user is not calling too many times! -! - if ( maxcol < l ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I8_SOBOL - Fatal error!' - write ( *, '(a)' ) ' Too many calls!' - write ( *, '(a,i12)' ) ' MAXCOL = ', maxcol - write ( *, '(a,i12)' ) ' L = ', l - stop - end if -! -! Calculate the new components of QUASI. -! - quasi(1:dim_num) = real ( lastq(1:dim_num), kind = 8 ) * recipd - lastq(1:dim_num) = ieor ( lastq(1:dim_num), v(1:dim_num,l) ) - - seed_save = seed - seed = seed + 1 - - return -end -subroutine i8_sobol_generate ( m, n, skip, r ) - -!*****************************************************************************80 -! -!! I8_SOBOL_GENERATE generates a Sobol dataset. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 August 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer M, the spatial dimension. -! -! Input, integer N, the number of points to generate. -! -! Input, integer ( kind = 8 ) SKIP, the number of initial points to skip. -! -! Output, real ( kind = 8 ) R(M,N), the points. -! - implicit none - - integer ( kind = 8 ) m - integer ( kind = 8 ) n - - integer ( kind = 8 ) j - real ( kind = 8 ), dimension ( m, n ) :: r - integer ( kind = 8 ) seed - integer ( kind = 8 ) skip - - do j = 1, n - seed = skip + j - 1 - call i8_sobol ( m, seed, r(1:m,j) ) - end do - - return -end -subroutine i8_sobol_write ( m, n, skip, r, file_out_name ) - -!*****************************************************************************80 -! -!! I8_SOBOL_WRITE writes a Sobol dataset to a file. -! -! Discussion: -! -! The initial lines of the file are comments, which begin with a -! '#' character. -! -! Thereafter, each line of the file contains the M-dimensional -! components of the SKIP+I-1 entry of the Sobol sequence. -! -! For the Sobol sequence, the value of SKIP is the same -! as the value of SEED used to generate the first point. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 04 June 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 8 ) M, the spatial dimension. -! -! Input, integer ( kind = 8 ) N, the number of (successive) points. -! -! Input, integer ( kind = 8 ) SKIP, the number of skipped points. -! -! Input, real ( kind = 8 ) R(M,N), the points. -! -! Input, character ( len = * ) FILE_OUT_NAME, the name of -! the output file. -! - implicit none - - integer ( kind = 8 ) m - integer ( kind = 8 ) n - - character ( len = * ) file_out_name - integer file_out_unit - integer ios - integer ( kind = 8 ) j - real ( kind = 8 ) r(m,n) - integer ( kind = 8 ) skip - character ( len = 40 ) string - - call get_unit ( file_out_unit ) - - open ( unit = file_out_unit, file = file_out_name, status = 'replace', & - iostat = ios ) - - if ( ios /= 0 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I8_SOBOL_WRITE - Fatal error!' - write ( *, '(a)' ) ' Could not open the output file.' - stop - end if - - call timestring ( string ) - - write ( file_out_unit, '(a)' ) '# ' // trim ( file_out_name ) - write ( file_out_unit, '(a)' ) '# created by I8_SOBOL_WRITE.F90.' - write ( file_out_unit, '(a)' ) '#' - write ( file_out_unit, '(a)' ) '# File generated on ' & - // trim ( string ) - write ( file_out_unit, '(a)' ) '#' - write ( file_out_unit, '(a,i8)' ) '# Spatial dimension M = ', m - write ( file_out_unit, '(a,i8)' ) '# Number of points N = ', n - write ( file_out_unit, '(a,g14.6)' ) '# Epsilon (unit roundoff) = ', & - epsilon ( r(1,1) ) - write ( file_out_unit, '(a,i8)' ) '# Initial values skipped = ', skip - write ( file_out_unit, '(a)' ) '#' - - write ( string, '(a,i3,a)' ) '(', m, '(2x,f10.6))' - do j = 1, n - write ( file_out_unit, string ) r(1:m,j) - end do - - close ( unit = file_out_unit ) - - return -end -function i8_uniform ( a, b, seed ) - -!*****************************************************************************80 -! -!! I8_UNIFORM returns a scaled pseudorandom I8. -! -! Discussion: -! -! An I8 is an integer ( kind = 8 ) value. -! -! Note that ALL integer variables in this routine are -! of type integer ( kind = 8 )! -! -! The pseudorandom number should be uniformly distributed -! between A and B. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 November 2006 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Paul Bratley, Bennett Fox, Linus Schrage, -! A Guide to Simulation, -! Springer Verlag, pages 201-202, 1983. -! -! Pierre L'Ecuyer, -! Random Number Generation, -! in Handbook of Simulation, -! edited by Jerry Banks, -! Wiley Interscience, page 95, 1998. -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, pages 362-376, 1986. -! -! Peter Lewis, Allen Goodman, James Miller -! A Pseudo-Random Number Generator for the System/360, -! IBM Systems Journal, -! Volume 8, pages 136-143, 1969. -! -! Parameters: -! -! Input, integer ( kind = 8 ) A, B, the limits of the interval. -! -! Input/output, integer ( kind = 8 ) SEED, the "seed" value, which -! should NOT be 0. On output, SEED has been updated. -! -! Output, integer ( kind = 8 ) I8_UNIFORM, a number between A and B. -! - implicit none - - integer ( kind = 8 ) a - integer ( kind = 8 ) b - integer ( kind = 8 ) i8_uniform - real ( kind = 8 ) r - real ( kind = 8 ) r8i8_uniform_01 - integer ( kind = 8 ) seed - integer ( kind = 8 ) value - - if ( seed == 0 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I8_UNIFORM - Fatal error!' - write ( *, '(a)' ) ' Input value of SEED = 0.' - stop - end if - - r = r8i8_uniform_01 ( seed ) -! -! Scale R to lie between A-0.5 and B+0.5. -! - r = ( 1.0D+00 - r ) * ( real ( min ( a, b ), kind = 8 ) - 0.5D+00 ) & - + r * ( real ( max ( a, b ), kind = 8 ) + 0.5D+00 ) -! -! Use rounding to convert R to an integer between A and B. -! - value = nint ( r, kind = 8 ) - - value = max ( value, min ( a, b ) ) - value = min ( value, max ( a, b ) ) - - i8_uniform = value - - return -end -function i8_xor ( i, j ) - -!*****************************************************************************80 -! -!! I8_XOR calculates the exclusive OR of two integers. -! -! Discussion: -! -! This function is NOT needed in FORTRAN90, which supplies the -! intrinsic IEOR function for this purpose. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 8 ) I, J, two values whose exclusive OR is needed. -! -! Output, integer ( kind = 8 ) I8_XOR, the exclusive OR of I and J. -! - implicit none - - integer ( kind = 8 ) i - integer ( kind = 8 ) i1 - integer ( kind = 8 ) i2 - integer ( kind = 8 ) i8_xor - integer ( kind = 8 ) j - integer ( kind = 8 ) j1 - integer ( kind = 8 ) j2 - integer ( kind = 8 ) k - integer ( kind = 8 ) l - - i1 = i - j1 = j - k = 0 - l = 1 - - do while ( i1 /= 0 .or. j1 /= 0 ) - - i2 = i1 / 2 - j2 = j1 / 2 - - if ( & - ( ( i1 == 2 * i2 ) .and. ( j1 /= 2 * j2 ) ) .or. & - ( ( i1 /= 2 * i2 ) .and. ( j1 == 2 * j2 ) ) ) then - k = k + l - end if - - i1 = i2 - j1 = j2 - l = 2 * l - - end do - - i8_xor = k - - return -end -function r8i8_uniform_01 ( seed ) - -!*****************************************************************************80 -! -!! R8I8_UNIFORM_01 returns a unit pseudorandom R8 using an I8 seed. -! -! Discussion: -! -! An R8 is a real ( kind = 8 ) value. -! -! An I8 is an integer ( kind = 8 ) value. -! -! This routine implements the recursion -! -! seed = 16807 * seed mod ( 2**31 - 1 ) -! r8_uniform_01 = seed / ( 2**31 - 1 ) -! -! The integer arithmetic never requires more than 32 bits, -! including a sign bit. -! -! If the initial seed is 12345, then the first three computations are -! -! Input Output R8I8_UNIFORM_01 -! SEED SEED -! -! 12345 207482415 0.096616 -! 207482415 1790989824 0.833995 -! 1790989824 2035175616 0.947702 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 20 September 2006 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Paul Bratley, Bennett Fox, Linus Schrage, -! A Guide to Simulation, -! Springer Verlag, pages 201-202, 1983. -! -! Pierre L'Ecuyer, -! Random Number Generation, -! in Handbook of Simulation, -! edited by Jerry Banks, -! Wiley Interscience, page 95, 1998. -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, pages 362-376, 1986. -! -! Peter Lewis, Allen Goodman, James Miller -! A Pseudo-Random Number Generator for the System/360, -! IBM Systems Journal, -! Volume 8, pages 136-143, 1969. -! -! Parameters: -! -! Input/output, integer ( kind = 8 ) SEED, the "seed" value, which should -! NOT be 0. On output, SEED has been updated. -! -! Output, real ( kind = 8 ) R8I8_UNIFORM_01, a new pseudorandom variate, -! strictly between 0 and 1. -! - implicit none - - integer ( kind = 8 ) k - real ( kind = 8 ) r8i8_uniform_01 - integer ( kind = 8 ) seed - - if ( seed == 0 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'R8I8_UNIFORM_01 - Fatal error!' - write ( *, '(a)' ) ' Input value of SEED = 0.' - stop - end if - - k = seed / 127773 - - seed = 16807 * ( seed - k * 127773 ) - k * 2836 - - if ( seed < 0 ) then - seed = seed + huge ( seed ) - end if - - r8i8_uniform_01 = real ( seed, kind = 8 ) * 4.656612875D-10 - - return -end -function tau_sobol ( dim_num ) - -!*****************************************************************************80 -! -!! TAU_SOBOL defines favorable starting seeds for Sobol sequences. -! -! Discussion: -! -! For spatial dimensions 1 through 13, this routine returns -! a "favorable" value TAU by which an appropriate starting point -! in the Sobol sequence can be determined. -! -! These starting points have the form N = 2**K, where -! for integration problems, it is desirable that -! TAU + DIM_NUM - 1 <= K -! while for optimization problems, it is desirable that -! TAU < K. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 July 2006 -! -! Author: -! -! FORTRAN77 original version by Bennett Fox. -! FORTRAN90 version by John Burkardt -! -! Reference: -! -! IA Antonov, VM Saleev, -! USSR Computational Mathematics and Mathematical Physics, -! Volume 19, 1980, pages 252 - 256. -! -! Paul Bratley, Bennett Fox, -! Algorithm 659: -! Implementing Sobol's Quasirandom Sequence Generator, -! ACM Transactions on Mathematical Software, -! Volume 14, Number 1, pages 88-100, 1988. -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, pages 362-376, 1986. -! -! Stephen Joe, Frances Kuo -! Remark on Algorithm 659: -! Implementing Sobol's Quasirandom Sequence Generator, -! ACM Transactions on Mathematical Software, -! Volume 29, Number 1, pages 49-57, March 2003. -! -! Ilya Sobol, -! USSR Computational Mathematics and Mathematical Physics, -! Volume 16, pages 236-242, 1977. -! -! Ilya Sobol, YL Levitan, -! The Production of Points Uniformly Distributed in a Multidimensional -! Cube (in Russian), -! Preprint IPM Akad. Nauk SSSR, -! Number 40, Moscow 1976. -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. Only values -! of 1 through 13 will result in useful responses. -! -! Output, integer ( kind = 4 ) TAU_SOBOL, the value TAU. -! - implicit none - - integer ( kind = 4 ), parameter :: dim_max = 13 - - integer ( kind = 4 ) dim_num - integer ( kind = 4 ), save, dimension ( dim_max ) :: tau = (/ & - 0, 0, 1, 3, 5, & - 8, 11, 15, 19, 23, & - 27, 31, 35 /) - integer ( kind = 4 ) tau_sobol - - if ( 1 <= dim_num .and. dim_num <= dim_max ) then - tau_sobol = tau(dim_num) - else - tau_sobol = - 1 - end if - - return -end -subroutine timestamp ( ) - -!*****************************************************************************80 -! -!! TIMESTAMP prints the current YMDHMS date as a time stamp. -! -! Example: -! -! May 31 2001 9:45:54.872 AM -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 31 May 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! None -! - implicit none - - character ( len = 8 ) ampm - integer d - character ( len = 8 ) date - integer h - integer m - integer mm - character ( len = 9 ), parameter, dimension(12) :: month = (/ & - 'January ', 'February ', 'March ', 'April ', & - 'May ', 'June ', 'July ', 'August ', & - 'September', 'October ', 'November ', 'December ' /) - integer n - integer s - character ( len = 10 ) time - integer values(8) - integer y - character ( len = 5 ) zone - - call date_and_time ( date, time, zone, values ) - - y = values(1) - m = values(2) - d = values(3) - h = values(5) - n = values(6) - s = values(7) - mm = values(8) - - if ( h < 12 ) then - ampm = 'AM' - else if ( h == 12 ) then - if ( n == 0 .and. s == 0 ) then - ampm = 'Noon' - else - ampm = 'PM' - end if - else - h = h - 12 - if ( h < 12 ) then - ampm = 'PM' - else if ( h == 12 ) then - if ( n == 0 .and. s == 0 ) then - ampm = 'Midnight' - else - ampm = 'AM' - end if - end if - end if - - write ( *, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & - trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm ) - - return -end -subroutine timestring ( string ) - -!*****************************************************************************80 -! -!! TIMESTRING writes the current YMDHMS date into a string. -! -! Example: -! -! STRING = 'May 31 2001 9:45:54.872 AM' -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 15 March 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, character ( len = * ) STRING, contains the date information. -! A character length of 40 should always be sufficient. -! - implicit none - - character ( len = 8 ) ampm - integer d - character ( len = 8 ) date - integer h - integer m - integer mm - character ( len = 9 ), parameter, dimension(12) :: month = (/ & - 'January ', 'February ', 'March ', 'April ', & - 'May ', 'June ', 'July ', 'August ', & - 'September', 'October ', 'November ', 'December ' /) - integer n - integer s - character ( len = * ) string - character ( len = 10 ) time - integer values(8) - integer y - character ( len = 5 ) zone - - call date_and_time ( date, time, zone, values ) - - y = values(1) - m = values(2) - d = values(3) - h = values(5) - n = values(6) - s = values(7) - mm = values(8) - - if ( h < 12 ) then - ampm = 'AM' - else if ( h == 12 ) then - if ( n == 0 .and. s == 0 ) then - ampm = 'Noon' - else - ampm = 'PM' - end if - else - h = h - 12 - if ( h < 12 ) then - ampm = 'PM' - else if ( h == 12 ) then - if ( n == 0 .and. s == 0 ) then - ampm = 'Midnight' - else - ampm = 'AM' - end if - end if - end if - - write ( string, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & - trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm ) - - return -end diff --git a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/sobol_driver.f90.svn-base b/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/sobol_driver.f90.svn-base deleted file mode 100644 index 3740a3a..0000000 --- a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/sobol_driver.f90.svn-base +++ /dev/null @@ -1,204 +0,0 @@ -PROGRAM SOBOL_DRIVER -! --------------------------------------------------------------------------------------- -! Creator: -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! Driver program to loop through example parameter sets -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE ddirectory ! directory for data files -! data modules -USE model_defn,nstateFUSE=>nstate ! model definition structures -USE multiforce, ONLY: DELTIM ! data interval = maximum model time step -USE multiparam, ONLY: LPARAM, PARATT, NUMPAR, SOBOL_INDX ! parameter metadata structures -USE multiroute ! model routing structures -USE multistats ! model statistics structures -! informational modules -USE selectmodl_module ! reads model control file -USE getpar_str_module ! extracts parameter metadata -USE par_insert_module ! inserts model parameters -! model numerix -USE model_numerix ! defines decisions on model numerix -! access to model simulation modules -USE fuse_rmse_module ! run model and compute the root mean squared error -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -! (0) GET COMMAND-LINE ARGUMENTS... -! --------------------------------------------------------------------------------------- -CHARACTER(LEN=12) :: MBASIN_ID=' ' ! MOPEX basin ID -CHARACTER(LEN=6) :: FMODEL_ID=' ' ! integer defining FUSE model -CHARACTER(LEN=6) :: NSOLUTION=' ' ! numerical solution (0=implicit, 1=explicit) -CHARACTER(LEN=6) :: FADAPTIVE=' ' ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -CHARACTER(LEN=6) :: TRUNC_ABS=' ' ! absolute temporal truncation error tolerance -CHARACTER(LEN=6) :: TRUNC_REL=' ' ! relative temporal truncation error tolerance -CHARACTER(LEN=256) :: PARAMFILE ! filename with list of parameter sets -! --------------------------------------------------------------------------------------- -! (1) SETUP MODELS FOR SIMULATION -- POPULATE DATA STRUCTURES -! --------------------------------------------------------------------------------------- -! get model forcing data -INTEGER(I4B) :: NTIM ! number of time steps -INTEGER(I4B) :: INFERN_START ! start of inference period -! get model setup -INTEGER(I4B) :: FUSE_ID ! integer defining FUSE model -INTEGER(I4B) :: I,J,K ! looping -INTEGER(I4B) :: NMOD ! number of models -INTEGER(I4B) :: ERR ! error code -CHARACTER(LEN=256) :: MESSAGE ! error message -! define model output -LOGICAL(LGT) :: OUTPUT_FLAG ! .TRUE. = write time series output -! --------------------------------------------------------------------------------------- -! (2) CREATE PARAMETER GRID -! --------------------------------------------------------------------------------------- -! Identify existence of the parameter file -LOGICAL(LGT) :: LEXIST ! .TRUE. if the parameter file exists -INTEGER(I4B), PARAMETER :: IN_UNIT=21 ! file unit for parameter fie -! Define error code for I/O -INTEGER(I4B) :: IERR ! error code for I/O -! Define parameters -CHARACTER(LEN=512) :: CHEAD ! header text -INTEGER(I4B) :: NUM_ALLPAR ! number of all possible parameters -TYPE PAR_TXT - CHARACTER(LEN=11) :: PARAM_NAME ! parameter name -ENDTYPE PAR_TXT -TYPE(PAR_TXT),DIMENSION(:),ALLOCATABLE :: PARNAMES_ALL ! list of all possible parameter names -INTEGER(I4B) :: IPOS,JPOS,KPOS ! position in header string -INTEGER(I4B) :: IPAR_ALL ! loop through all possible model parameters -! Index and values of parameters -REAL(SP),DIMENSION(:),ALLOCATABLE :: ALLPARS ! vector of model all parameters -REAL(SP),DIMENSION(:),ALLOCATABLE :: TRYPARS ! vector of model parameters to trial -INTEGER(I4B) :: IPAR_MOD ! loop through parameters of the current model -INTEGER(I4B) :: ONEMOD ! index of the model used (=1) -REAL(SP) :: FPAR ! function value for parameter set -! --------------------------------------------------------------------------------------- -! (0) READ COMMAND LINE ARGUMENTS -! --------------------------------------------------------------------------------------- -! read command-line arguments -CALL GETARG(1,MBASIN_ID) ! MOPEX basin ID -CALL GETARG(2,FMODEL_ID) ! integer defining FUSE model -CALL GETARG(3,NSOLUTION) ! numerical solution (0=explicit, 1=implicit) -CALL GETARG(4,FADAPTIVE) ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -CALL GETARG(5,TRUNC_ABS) ! absolute temporal truncation error tolerance -CALL GETARG(6,TRUNC_REL) ! relative temporal truncation error tolerance -CALL GETARG(7,PARAMFILE) ! filename of the parameter sets -! check command-line arguments -IF (LEN_TRIM(MBASIN_ID).EQ.0) STOP '1st command-line argument is missing (MBASIN_ID)' -IF (LEN_TRIM(FMODEL_ID).EQ.0) STOP '2nd command-line argument is missing (FMODEL_ID)' -IF (LEN_TRIM(NSOLUTION).EQ.0) STOP '3rd command-line argument is missing (NSOLUTION)' -IF (LEN_TRIM(FADAPTIVE).EQ.0) STOP '4th command-line argument is missing (FADAPTIVE)' -IF (LEN_TRIM(TRUNC_ABS).EQ.0) STOP '5th command-line argument is missing (TRUNC_ABS)' -IF (LEN_TRIM(TRUNC_REL).EQ.0) STOP '6th command-line argument is missing (TRUNC_REL)' -IF (LEN_TRIM(PARAMFILE).EQ.0) STOP '7th command-line argument is missing (PARAMFILE)' -! define basin desired -FORCINGINFO = 'forcinginfo.'//TRIM(MBASIN_ID)//'.txt' -! convert command-line arguments to integer flags and real numbers -CALL GETNUMERIX() ! defines method/parameters used for numerical solution -READ(FMODEL_ID,*) FUSE_ID ! integer definining FUSE model -READ(NSOLUTION,*) SOLUTION_METHOD ! numerical solution (0=implicit, 1=explicit) -READ(FADAPTIVE,*) TEMPORAL_ERROR_CONTROL ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -READ(TRUNC_ABS,*) ERR_TRUNC_ABS ! absolute temporal truncation error tolerance -READ(TRUNC_REL,*) ERR_TRUNC_REL ! relative temporal truncation error tolerance -! additional checks -SELECT CASE(SOLUTION_METHOD); CASE(EXPLICIT_EULER,EXPLICIT_HEUN,IMPLICIT_EULER,IMPLICIT_HEUN,SEMI_IMPLICIT) -CASE DEFAULT - PRINT *, 'solution method (1st command line argument) must equal 0 (explicit_euler), 1 (explicit heun), '//& - '2 (implicit_euler), 3 (implicit_heun), or 4 (semi_implicit)' - STOP -END SELECT -SELECT CASE(TEMPORAL_ERROR_CONTROL); CASE(TS_FIXED,TS_ADAPT); CASE DEFAULT; - STOP 'temporal error control (2nd command line argument) must equal 0 (fixed steps) or 1 (adaptive steps)' -END SELECT -write(*,'(A5,1X,2(I1,1X),2(E12.5,1X),I6,1X,A11,1X,I6)') 'FUSE ', & -SOLUTION_METHOD, TEMPORAL_ERROR_CONTROL, ERR_TRUNC_ABS, ERR_TRUNC_REL -! --------------------------------------------------------------------------------------- -! (1) GET MODEL SETUP -- MODEL DEFINITION, AND PARAMETER AND VARIABLE INFO FOR ALL MODELS -! --------------------------------------------------------------------------------------- -! Read data from the "BATEA-compliant" ASCII files -CALL GETFORCING(INFERN_START,NTIM) -! Define model attributes (valid for all models) -CALL UNIQUEMODL(NMOD) ! get nmod unique models -CALL GETPARMETA() ! read parameter metadata (parameter bounds etc.) -! Identify a single model (read control file ../DataFiles/m_decisions.txt) -CALL SELECTMODL(FUSE_ID,ISTATUS=ERR,MESSAGE=MESSAGE) -IF (ERR.NE.0) THEN - PRINT *, TRIM(MESSAGE); STOP -ENDIF -! Define list of states and parameters for the current model -CALL ASSIGN_STT() ! state definitions are stored in module model_defn -CALL ASSIGN_PAR() ! parameter defintions are stored in module multiparam -CALL ASSIGN_FLX() ! flux definitions stored in module model_defn -! compute derived model parameters (bucket sizes, etc.) -CALL PAR_DERIVE() -! define NetCDF files (filename shared in MODULE model_defn) -FNAME_NETCDF = TRIM(OUTPUT_PATH)//'DMSL_'//TRIM(MBASIN_ID)//'__'//TRIM(SMODL%MNAME)//'__'//& - TRIM(NSOLUTION)//'-'//TRIM(FADAPTIVE)//'__'//TRIM(PARAMFILE)//'.nc' -write(*,'(a)') trim(fname_netcdf) -ONEMOD=1 ! one file per model (i.e., model dimension = 1) -PCOUNT=0 ! counter for parameter sets in output file (shared in MODULE multistats) -FCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) -OUTPUT_FLAG = .FALSE. ! write model output -CALL DEF_PARAMS(ONEMOD) ! define model parameters (initial CREATE) -IF (OUTPUT_FLAG) CALL DEF_OUTPUT(NTIM) ! define model time series (REDEF) -CALL DEF_SSTATS() ! define summary statistics (REDEF) -! --------------------------------------------------------------------------------------- -! (2) LOOP THROUGH EXAMPLE PARAMETER SETS -! --------------------------------------------------------------------------------------- -! check that the file exists -write(*,'(a)') TRIM(DATA_PATH)//TRIM(PARAMFILE)//'.dat' -INQUIRE(FILE=TRIM(DATA_PATH)//TRIM(PARAMFILE)//'.dat',EXIST=LEXIST) -IF (.NOT.LEXIST) STOP ' parameter file does not exist ' -! open file -OPEN(IN_UNIT,FILE=TRIM(DATA_PATH)//TRIM(PARAMFILE)//'.dat',STATUS='old') - NUM_ALLPAR=0 - ! read header - DO - READ(IN_UNIT,'(A512)') CHEAD ! read header line - IF (CHEAD(1:7).EQ.'ParFlag') EXIT ! title line identified by 'ParFlag' - NUM_ALLPAR=NUM_ALLPAR+1 ! increment number total parameters - END DO - ! strip out the parameter names - ALLOCATE(PARNAMES_ALL(NUM_ALLPAR)); IPOS=8 - IPAR_ALL=0 - DO - ! get param index - IPAR_ALL=IPAR_ALL+1 - IF (IPAR_ALL.GT.NUM_ALLPAR) EXIT - ! extract a "word" - JPOS=INDEX(CHEAD(IPOS:LEN_TRIM(CHEAD)),' ') - KPOS=INDEX(CHEAD(JPOS:LEN_TRIM(CHEAD)),' ') - ! add the parameter name to the structure (and fill with white space) - PARNAMES_ALL(IPAR_ALL)%PARAM_NAME(JPOS:KPOS+1) = CHEAD(IPOS+JPOS:IPOS+JPOS+KPOS) - IF (KPOS+1.LT.LEN(PARNAMES_ALL(IPAR_ALL)%PARAM_NAME)) & - FORALL(I=KPOS+2:LEN(PARNAMES_ALL(IPAR_ALL)%PARAM_NAME)) PARNAMES_ALL(IPAR_ALL)%PARAM_NAME(I:I)=' ' - ! move to the next word - IPOS=IPOS+JPOS+KPOS - DO - IF (CHEAD(IPOS+1:IPOS+1).NE.' ') EXIT - IPOS=IPOS+1 - END DO - ! check exit criteria - IF (IPOS.GT.LEN_TRIM(CHEAD)) EXIT - END DO - ! allocate vector for the parameters - ALLOCATE(ALLPARS(NUM_ALLPAR),TRYPARS(NUMPAR)) - ! loop through parameters - DO - ! read a line of parameters (SOBOL_INDX is stored in module multiparam) - READ(IN_UNIT,*,IOSTAT=IERR) SOBOL_INDX, ALLPARS - IF (IERR.NE.0) EXIT - ! extract the parameters that we need - DO IPAR_MOD=1,NUMPAR - DO IPAR_ALL=1,NUM_ALLPAR - IF (TRIM(LPARAM(IPAR_MOD)%PARNAME).EQ.TRIM(PARNAMES_ALL(IPAR_ALL)%PARAM_NAME)) THEN - TRYPARS(IPAR_MOD) = ALLPARS(IPAR_ALL) - !WRITE(*,'(A11,1X,F9.3,1X)') TRIM(LPARAM(IPAR_MOD)%PARNAME), TRYPARS(IPAR_MOD) - ENDIF - END DO - END DO - ! run model (parameters and statistics are written in FUSE_RMSE) - CALL FUSE_RMSE(TRYPARS,FPAR,OUTPUT_FLAG) - END DO -CLOSE(IN_UNIT) -STOP -END PROGRAM SOBOL_DRIVER -! -------------------------------------------------------------------------------------- diff --git a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/test_fidelity.f90.svn-base b/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/test_fidelity.f90.svn-base deleted file mode 100644 index c2d8be0..0000000 --- a/build/FUSE_SRC/FUSE_DMSL/.svn/text-base/test_fidelity.f90.svn-base +++ /dev/null @@ -1,156 +0,0 @@ -PROGRAM TEST_FIDELITY -! --------------------------------------------------------------------------------------- -! Creator: -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! Driver program to test the fidelity of the different numerical methods -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE ddirectory ! directory for data files -! data modules -USE model_defn,nstateFUSE=>nstate ! model definition structures -USE multiforce, ONLY: AFORCE, DELTIM, NUMTIM ! data interval = maximum model time step -USE multiparam, ONLY: LPARAM, PARATT, NUMPAR ! parameter metadata structures -USE multiroute, ONLY: AROUTE ! model routing structures -USE multistats ! model statistics structures -! informational modules -USE selectmodl_module ! reads model control file -USE getpar_str_module ! extracts parameter metadata -USE par_insert_module ! inserts model parameters -! model numerix -USE model_numerix ! defines decisions on model numerix -! access to model simulation modules -USE fuse_rmse_module ! run model and compute the root mean squared error -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -! (0) GET COMMAND-LINE ARGUMENTS... -! --------------------------------------------------------------------------------------- -CHARACTER(LEN=6) :: FMODEL_ID=' ' ! integer defining FUSE model -CHARACTER(LEN=6) :: NSOLUTION=' ' ! numerical solution (0=implicit, 1=explicit) -CHARACTER(LEN=6) :: FADAPTIVE=' ' ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -CHARACTER(LEN=6) :: TRUNC_ABS=' ' ! absolute temporal truncation error tolerance -CHARACTER(LEN=6) :: TRUNC_REL=' ' ! relative temporal truncation error tolerance -! --------------------------------------------------------------------------------------- -! (1) SETUP MODELS FOR SIMULATION -- POPULATE DATA STRUCTURES -! --------------------------------------------------------------------------------------- -! get model forcing data -INTEGER(I4B) :: NTIM ! number of time steps -INTEGER(I4B) :: INFERN_START ! start of inference period -! get model setup -INTEGER(I4B) :: FUSE_ID ! integer defining FUSE model -INTEGER(I4B) :: I ! looping -INTEGER(I4B) :: NMOD ! number of models -INTEGER(I4B) :: ERR ! error code -CHARACTER(LEN=256) :: MESSAGE ! error message -! define model output -LOGICAL(LGT) :: OUTPUT_FLAG ! .TRUE. = write time series output -INTEGER(I4B) :: ONEMOD ! index of the model used (=1) -! --------------------------------------------------------------------------------------- -! (2) TEST FIDELITY -! --------------------------------------------------------------------------------------- -! Define error code for I/O -INTEGER(I4B) :: IERR ! error code for I/O -! Identify index of the parameter set -INTEGER(I4B) :: IPARSET ! parameter set index -CHARACTER(LEN=4) :: CPARSET ! convert parameter set index to a string -! Parameter vectors -REAL(SP),DIMENSION(:),ALLOCATABLE :: XDF ! default parameter vector -REAL(SP) :: FPAR ! function value for parameter set -! Loop through different time steps -INTEGER(I4B) :: IDEL ! loop through different time steps -! --------------------------------------------------------------------------------------- -! (0) READ COMMAND LINE ARGUMENTS -! --------------------------------------------------------------------------------------- -! read command-line arguments -CALL GETARG(1,FMODEL_ID) ! integer defining FUSE model -CALL GETARG(2,NSOLUTION) ! numerical solution (0=explicit, 1=implicit) -CALL GETARG(3,FADAPTIVE) ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -CALL GETARG(4,TRUNC_ABS) ! absolute temporal truncation error tolerance -CALL GETARG(5,TRUNC_REL) ! relative temporal truncation error tolerance -! check command-line arguments -IF (LEN_TRIM(FMODEL_ID).EQ.0) STOP '1st command-line argument is missing (FMODEL_ID)' -IF (LEN_TRIM(NSOLUTION).EQ.0) STOP '2nd command-line argument is missing (NSOLUTION)' -IF (LEN_TRIM(FADAPTIVE).EQ.0) STOP '3rd command-line argument is missing (FADAPTIVE)' -IF (LEN_TRIM(TRUNC_ABS).EQ.0) STOP '4th command-line argument is missing (TRUNC_ABS)' -IF (LEN_TRIM(TRUNC_REL).EQ.0) STOP '5th command-line argument is missing (TRUNC_REL)' -! convert command-line arguments to integer flags and real numbers -CALL GETNUMERIX() ! defines method/parameters used for numerical solution -READ(FMODEL_ID,*) FUSE_ID ! integer definining FUSE model -READ(NSOLUTION,*) SOLUTION_METHOD ! numerical solution (0=EE, 1=EH, 2=IE, 3=IH) -READ(FADAPTIVE,*) TEMPORAL_ERROR_CONTROL ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -READ(TRUNC_ABS,*) ERR_TRUNC_ABS ! absolute temporal truncation error tolerance -READ(TRUNC_REL,*) ERR_TRUNC_REL ! relative temporal truncation error tolerance -! additional checks -SELECT CASE(SOLUTION_METHOD); CASE(EXPLICIT_EULER,EXPLICIT_HEUN,IMPLICIT_EULER,IMPLICIT_HEUN,SEMI_IMPLICIT) -CASE DEFAULT; - STOP 'solution method (1st command line argument) must equal 0 (explicit_euler), 1 (explicit heun), & - &2 (implicit_euler), 3 (implicit_heun), or 4 (semi_implicit)' -END SELECT -SELECT CASE(TEMPORAL_ERROR_CONTROL); CASE(TS_FIXED,TS_ADAPT); CASE DEFAULT; - STOP 'temporal error control (2nd command line argument) must equal 0 (fixed steps) or 1 (adaptive steps)' -END SELECT -write(*,'(A5,1X,2(I1,1X),2(E12.5,1X),I6,1X,A11,1X,I6)') 'FUSE ', & -SOLUTION_METHOD, TEMPORAL_ERROR_CONTROL, ERR_TRUNC_ABS, ERR_TRUNC_REL -! --------------------------------------------------------------------------------------- -! (1) GET MODEL SETUP -- MODEL DEFINITION, AND PARAMETER AND VARIABLE INFO FOR ALL MODELS -! --------------------------------------------------------------------------------------- -! Just assign data -INFERN_START=1; NTIM=1; NUMTIM=NTIM; DELTIM=1._SP -ALLOCATE(AFORCE(NTIM),AROUTE(NTIM)) ! (shared in module multiroute) -AFORCE(INFERN_START:NTIM)%PPT = (/50./) -AFORCE(INFERN_START:NTIM)%PET = (/ 5./) -! Define model attributes (valid for all models) -CALL UNIQUEMODL(NMOD) ! get nmod unique models -CALL GETPARMETA() ! read parameter metadata (parameter bounds etc.) -! Identify a single model (use command-line argument) -CALL SELECTMODL(FUSE_ID,ISTATUS=ERR,MESSAGE=MESSAGE) -IF (ERR.NE.0) THEN - PRINT *, TRIM(MESSAGE); STOP -ENDIF -! Define list of states and parameters for the current model -CALL ASSIGN_STT() ! state definitions are stored in module model_defn -CALL ASSIGN_FLX() ! flux definitions are stored in module model_defn -CALL ASSIGN_PAR() ! parameter defintions are stored in module multiparam -! compute derived model parameters (bucket sizes, etc.) -CALL PAR_DERIVE() -! --------------------------------------------------------------------------------------- -! (2) TEST METHOD FIDELITY -! --------------------------------------------------------------------------------------- -! allocate arrays -ALLOCATE(XDF(NUMPAR), STAT=IERR) -IF (IERR.NE.0) STOP ' problem allocating space for parameter arrays ' -IPARSET = 0 -! loop through example parameter sets -OPEN(21,FILE=TRIM(DATA_PATH)//'param_fidelity.dat') -DO - ! read parameter set - READ(21,*,IOSTAT=IERR) XDF; IF (IERR.NE.0) EXIT - WRITE(*,'(20(A,1X))') LPARAM(1:NUMPAR); WRITE(*,'(20(F9.3,1X))') XDF - ! increment counter - IPARSET = IPARSET + 1 - ! convert counter to a character string - CPARSET=' '; WRITE(CPARSET,'(I4)') IPARSET; CPARSET=ADJUSTR(CPARSET) - FORALL(I=1:LEN(CPARSET)-LEN_TRIM(ADJUSTL(CPARSET))) CPARSET(I:I)='0' - ! define NetCDF files (filename shared in MODULE model_defn) - FNAME_NETCDF = TRIM(OUTPUT_PATH)//TRIM(SMODL%MNAME)//'__'//CPARSET//'__'//& - TRIM(NSOLUTION)//'-'//TRIM(FADAPTIVE)//'__fidelity.nc' - write(*,'(a)') trim(fname_netcdf) - ONEMOD=1 ! one file per model (i.e., model dimension = 1) - PCOUNT=0 ! counter for parameter sets in output file (shared in MODULE multistats) - FCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) - OUTPUT_FLAG = .TRUE. ! write model output - CALL DEF_PARAMS(ONEMOD) ! define model parameters (initial CREATE) - IF (OUTPUT_FLAG) CALL DEF_OUTPUT(NTIM) ! define model time series (REDEF) - CALL DEF_SSTATS() ! define summary statistics (REDEF) - DO IDEL=1,100 - DELTIM = REAL(IDEL,KIND(SP))/100._SP - ! run model with example parameter sets - CALL FUSE_RMSE(XDF,FPAR,OUTPUT_FLAG) - END DO -END DO ! looping through example parameter sets -DEALLOCATE(XDF, STAT=IERR) -IF (IERR.NE.0) STOP ' problem deallocating space for parameter arrays ' -STOP -END PROGRAM TEST_FIDELITY -! -------------------------------------------------------------------------------------- diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/all-wcprops b/build/FUSE_SRC/FUSE_ENGINE/.svn/all-wcprops deleted file mode 100644 index a2d7328..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/all-wcprops +++ /dev/null @@ -1,443 +0,0 @@ -K 25 -svn:wc:ra_dav:version-url -V 63 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/63/trunk/FUSE_SRC/FUSE_ENGINE -END -qsatexcess.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/qsatexcess.f90 -END -adjust_stt.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/adjust_stt.f90 -END -wgt_fluxes.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/wgt_fluxes.f90 -END -metaparams.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/metaparams.f90 -END -q_misscell.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/q_misscell.f90 -END -fuse_deriv.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/fuse_deriv.f90 -END -assign_flx.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/assign_flx.f90 -END -sumextract.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/sumextract.f90 -END -meta_stats.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/meta_stats.f90 -END -limit_xtry.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/limit_xtry.f90 -END -evap_upper.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/evap_upper.f90 -END -metaoutput.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/metaoutput.f90 -END -flux_deriv.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/flux_deriv.f90 -END -viol_state.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/viol_state.f90 -END -ode_int.f90 -K 25 -svn:wc:ra_dav:version-url -V 74 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/ode_int.f90 -END -q_baseflow.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/q_baseflow.f90 -END -uniquemodl.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/uniquemodl.f90 -END -qbsaturatn.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/qbsaturatn.f90 -END -assign_par.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/assign_par.f90 -END -getnumerix.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/23/trunk/FUSE_SRC/FUSE_ENGINE/getnumerix.f90 -END -fmin.f90 -K 25 -svn:wc:ra_dav:version-url -V 71 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/fmin.f90 -END -getparmeta.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/17/trunk/FUSE_SRC/FUSE_ENGINE/getparmeta.f90 -END -multistate.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/multistate.f90 -END -mod_derivs.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/mod_derivs.f90 -END -selectmodl.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/selectmodl.f90 -END -disaggflux.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/disaggflux.f90 -END -mean_stats.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/mean_stats.f90 -END -qpercolate.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/qpercolate.f90 -END -model_defnames.f90 -K 25 -svn:wc:ra_dav:version-url -V 82 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/model_defnames.f90 -END -mean_tipow.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/mean_tipow.f90 -END -putpar_str.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/putpar_str.f90 -END -init_state.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/init_state.f90 -END -multistats.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/multistats.f90 -END -updatstate.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/updatstate.f90 -END -xtry_2_str.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/xtry_2_str.f90 -END -par_derive.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/par_derive.f90 -END -funcv.f90 -K 25 -svn:wc:ra_dav:version-url -V 73 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/funcv.f90 -END -init_stats.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/init_stats.f90 -END -varextract.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/varextract.f90 -END -qrainerror.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/qrainerror.f90 -END -logismooth.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/logismooth.f90 -END -multi_flux.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/multi_flux.f90 -END -qinterflow.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/qinterflow.f90 -END -model_defn.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/63/trunk/FUSE_SRC/FUSE_ENGINE/model_defn.f90 -END -get_limits.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/9/trunk/FUSE_SRC/FUSE_ENGINE/get_limits.f90 -END -interfaceb.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/interfaceb.f90 -END -fuse_sieul.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/fuse_sieul.f90 -END -par_insert.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/par_insert.f90 -END -model_numerix.f90 -K 25 -svn:wc:ra_dav:version-url -V 80 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/model_numerix.f90 -END -meanfluxes.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/meanfluxes.f90 -END -multiroute.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/63/trunk/FUSE_SRC/FUSE_ENGINE/multiroute.f90 -END -multiforce.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/multiforce.f90 -END -multiparam.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/63/trunk/FUSE_SRC/FUSE_ENGINE/multiparam.f90 -END -assign_stt.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/assign_stt.f90 -END -str_2_xtry.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/str_2_xtry.f90 -END -frac_error.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/frac_error.f90 -END -getforcing.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/9/trunk/FUSE_SRC/FUSE_ENGINE/getforcing.f90 -END -lnsrch.f90 -K 25 -svn:wc:ra_dav:version-url -V 73 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/lnsrch.f90 -END -q_overland.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/63/trunk/FUSE_SRC/FUSE_ENGINE/q_overland.f90 -END -initfluxes.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/initfluxes.f90 -END -qtimedelay.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/63/trunk/FUSE_SRC/FUSE_ENGINE/qtimedelay.f90 -END -newtoniter.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/newtoniter.f90 -END -fdjac_ode.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/11/trunk/FUSE_SRC/FUSE_ENGINE/fdjac_ode.f90 -END -mstate_eqn.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/mstate_eqn.f90 -END -evap_lower.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/evap_lower.f90 -END -fdjac.f90 -K 25 -svn:wc:ra_dav:version-url -V 72 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/fdjac.f90 -END -bucketsize.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/bucketsize.f90 -END -fix_states.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_ENGINE/fix_states.f90 -END -fuse_solve.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/fuse_solve.f90 -END -getpar_str.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/getpar_str.f90 -END -batea_file.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/11/trunk/FUSE_SRC/FUSE_ENGINE/batea_file.f90 -END -comp_stats.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/comp_stats.f90 -END -parextract.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_ENGINE/parextract.f90 -END diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/entries b/build/FUSE_SRC/FUSE_ENGINE/.svn/entries deleted file mode 100644 index 33be6fa..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/entries +++ /dev/null @@ -1,2510 +0,0 @@ -10 - -dir -63 -https://venture1.projectlocker.com/UoNEnvEngGroup/FUSE/svn/trunk/FUSE_SRC/FUSE_ENGINE -https://venture1.projectlocker.com/UoNEnvEngGroup/FUSE/svn - - - -2013-06-05T15:45:44.760997Z -63 -kavetski - - - - - - - - - - - - - - -7fd0be38-6417-4f01-9cbe-fd474d0c6e94 - -qsatexcess.f90 -file - - - - -2013-06-12T18:10:49.367578Z -1571839d922fb2de2cee789afc3bb22c -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -3727 - -adjust_stt.f90 -file - - - - -2013-06-12T18:10:49.367578Z -55bdabeb1f8f557b8334a3d629ca3002 -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -2925 - -wgt_fluxes.f90 -file - - - - -2013-06-12T18:10:49.367578Z -25550bc3227a6a5f933d97f5308a30b8 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -3488 - -metaparams.f90 -file - - - - -2013-06-12T18:10:49.367578Z -f7e3d9ccbfc161de499720a3787d84be -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -7675 - -q_misscell.f90 -file - - - - -2013-06-12T18:10:49.367578Z -377fa0a3f9c0b5bd9bd807b54f2d0cbf -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -9419 - -fuse_deriv.f90 -file - - - - -2013-06-12T18:10:49.367578Z -32bc73bb22cd5456665c8dc87291deda -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1551 - -assign_flx.f90 -file - - - - -2013-06-12T18:10:49.367578Z -acc174f19cfd12d8dbffe70f8051ce26 -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -4097 - -sumextract.f90 -file - - - - -2013-06-12T18:10:49.367578Z -787e9133f3ca65fdba2a81b1b55e403b -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -2642 - -meta_stats.f90 -file - - - - -2013-06-12T18:10:49.367578Z -2c644ab45010cf44f575643a927de26e -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -3472 - -limit_xtry.f90 -file - - - - -2013-06-12T18:10:49.367578Z -0b501c738cd49111aeea98a49b3c93cb -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -3958 - -evap_upper.f90 -file - - - - -2013-06-12T18:10:49.367578Z -a8086c7e58c4524784f97becbc047ca5 -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -3411 - -metaoutput.f90 -file - - - - -2013-06-12T18:10:49.367578Z -95ce9b04ba56d7e6065f8a86b6105566 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -7508 - -flux_deriv.f90 -file - - - - -2013-06-12T18:10:49.367578Z -fd51f0ec4b38de0d4c80387fbe1a826d -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -3842 - -viol_state.f90 -file - - - - -2013-06-12T18:10:49.367578Z -4dfc37ac6716b18cbb0c9e5b86642bd1 -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -4105 - -ode_int.f90 -file - - - - -2013-06-12T18:10:49.367578Z -2dc11adbc24180fee3c83f640ab5ddec -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -21436 - -q_baseflow.f90 -file - - - - -2013-06-12T18:10:49.367578Z -c2cc26cbfcb9daa439e1ded67285e35b -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -3152 - -uniquemodl.f90 -file - - - - -2013-06-12T18:10:49.367578Z -170948b197c1fc6cd5cc0997b533ee9d -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -7043 - -qbsaturatn.f90 -file - - - - -2013-06-12T18:10:49.367578Z -2e8b181881be5e1199b7585d06866d90 -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -3130 - -assign_par.f90 -file - - - - -2013-06-12T18:10:49.367578Z -9c74368072560be3dc3445c0a7f0f4c6 -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -11290 - -getnumerix.f90 -file - - - - -2013-06-12T18:10:49.367578Z -2f8de021ce9542bfa60276892e9a2e83 -2010-12-22T03:57:38.848125Z -23 -kavetski - - - - - - - - - - - - - - - - - - - - - -3608 - -fmin.f90 -file - - - - -2013-06-12T18:10:49.367578Z -09a24a5c7a8f86dbdd07c2dd78302c7c -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1641 - -getparmeta.f90 -file - - - - -2013-06-12T18:10:49.367578Z -ce0aac9ffb62bc9a04ddecef76bce953 -2010-01-08T05:59:16.181435Z -17 -kavetski - - - - - - - - - - - - - - - - - - - - - -4213 - -multistate.f90 -file - - - - -2013-06-12T18:10:49.367578Z -9b5e2083a0d71d366357219ebf40ac96 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -3016 - -mod_derivs.f90 -file - - - - -2013-06-12T18:10:49.371578Z -aea755d512d817da00aa61d20c670f92 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -2099 - -selectmodl.f90 -file - - - - -2013-06-12T18:10:49.371578Z -2859c9e8f17af5d496954021767fe8df -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -11652 - -disaggflux.f90 -file - - - - -2013-06-12T18:10:49.371578Z -65a145539800f7c371d9d978de28aa4e -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -9460 - -mean_stats.f90 -file - - - - -2013-06-12T18:10:49.371578Z -ec907f77a90f5e14568db34151848fa1 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -6467 - -qpercolate.f90 -file - - - - -2013-06-12T18:10:49.371578Z -bd44bbf9cef22933a05bf55cff8d6be2 -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -2352 - -model_defnames.f90 -file - - - - -2013-06-12T18:10:49.371578Z -8fb05ab7482888b4319d39d18bc8a9ea -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -4288 - -mean_tipow.f90 -file - - - - -2013-06-12T18:10:49.371578Z -4769bc112f94297b17850df5941d76e0 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -4461 - -init_state.f90 -file - - - - -2013-06-12T18:10:49.371578Z -e905796eb876e03a563d389b6326db0f -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1588 - -putpar_str.f90 -file - - - - -2013-06-12T18:10:49.371578Z -6b51733849aaf4dd3f0e20cd5938f43b -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -2671 - -multistats.f90 -file - - - - -2013-06-12T18:10:49.371578Z -dade483f0f5f5ee3c5202ed0bba609fd -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -2577 - -updatstate.f90 -file - - - - -2013-06-12T18:10:49.371578Z -dcfb8b490f54ca37225cd4ae7318b43c -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -4667 - -xtry_2_str.f90 -file - - - - -2013-06-12T18:10:49.371578Z -ff146506b80ae350cf90046b5325b961 -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -4657 - -par_derive.f90 -file - - - - -2013-06-12T18:10:49.371578Z -2c52ff21c54d3edf3b5c73d2b5d84d65 -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -1723 - -funcv.f90 -file - - - - -2013-06-12T18:10:49.371578Z -06a668a3b64d2c732666116165977f2f -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -3135 - -init_stats.f90 -file - - - - -2013-06-12T18:10:49.371578Z -c0f9eddafe7103d4dd7574b93288c0f3 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1101 - -varextract.f90 -file - - - - -2013-06-12T18:10:49.371578Z -384d6548d6b7e08800289db62027aa05 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -4316 - -qrainerror.f90 -file - - - - -2013-06-12T18:10:49.371578Z -4598ab05a462d83ee13e49bf348fc5e2 -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -1619 - -logismooth.f90 -file - - - - -2013-06-12T18:10:49.371578Z -348102f22c9723dc6ae17cba9c1f8005 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1232 - -multi_flux.f90 -file - - - - -2013-06-12T18:10:49.371578Z -b28526000e06c4bed89137745200ef15 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -3650 - -qinterflow.f90 -file - - - - -2013-06-12T18:10:49.371578Z -cced1421a3197f5cd4a2d2b4aac0d159 -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -1549 - -model_defn.f90 -file - - - - -2013-06-12T18:10:49.371578Z -bfdbe2cccd88a850292bda81fedee2aa -2013-06-05T15:45:44.760997Z -63 -kavetski - - - - - - - - - - - - - - - - - - - - - -3707 - -get_limits.f90 -file - - - - -2013-06-12T18:10:49.371578Z -ddd05d17cd2980c9859352e12c806c55 -2009-10-18T15:43:55.974595Z -9 -kavetski - - - - - - - - - - - - - - - - - - - - - -4101 - -interfaceb.f90 -file - - - - -2013-06-12T18:10:49.371578Z -945795ba8df63a1ff04edcc99acc1a4b -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -5681 - -fuse_sieul.f90 -file - - - - -2013-06-12T18:10:49.371578Z -1f97d58d0fe37f5bb40bde780e66ad60 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -3721 - -par_insert.f90 -file - - - - -2013-06-12T18:10:49.371578Z -afcd46d1f32e82c506704276aa28ef37 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -4630 - -model_numerix.f90 -file - - - - -2013-06-12T18:10:49.371578Z -1c90261708a4ff64d7fe1725f8d156dd -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -4027 - -meanfluxes.f90 -file - - - - -2013-06-12T18:10:49.371578Z -c17ec59ae1abba6185a20efa004300cd -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -3090 - -multiroute.f90 -file - - - - -2013-06-12T18:10:49.371578Z -32b1269a5ad60e10ce0f2ead36034012 -2013-06-05T15:45:44.760997Z -63 -kavetski - - - - - - - - - - - - - - - - - - - - - -601 - -multiforce.f90 -file - - - - -2013-06-12T18:10:49.371578Z -fa4f727a6583b448bca9a722cdb2d10d -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1486 - -multiparam.f90 -file - - - - -2013-06-12T18:10:49.371578Z -3875d8fe373e621e0e2639026d63efd3 -2013-06-05T15:45:44.760997Z -63 -kavetski - - - - - - - - - - - - - - - - - - - - - -11814 - -assign_stt.f90 -file - - - - -2013-06-12T18:10:49.371578Z -7cd3d45d399953649d5d748dc6a0d42d -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -2460 - -str_2_xtry.f90 -file - - - - -2013-06-12T18:10:49.371578Z -be5b1dbf9e6a5d2110f2cc2269004dd1 -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -1765 - -frac_error.f90 -file - - - - -2013-06-12T18:10:49.371578Z -92214a4471e1eb8cbe4e2161e3f67e90 -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -2356 - -getforcing.f90 -file - - - - -2013-06-12T18:10:49.375578Z -4cd657cd7f06dee30f56d80e7ca263f3 -2009-10-18T15:43:55.974595Z -9 -kavetski - - - - - - - - - - - - - - - - - - - - - -6821 - -lnsrch.f90 -file - - - - -2013-06-12T18:10:49.375578Z -e6e12642c24741d5ba791744fdc89b3e -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -2465 - -q_overland.f90 -file - - - - -2013-06-12T18:10:49.375578Z -b608f1dbfdecf290999aa4896eab059e -2013-06-05T15:45:44.760997Z -63 -kavetski - - - - - - - - - - - - - - - - - - - - - -3207 - -initfluxes.f90 -file - - - - -2013-06-12T18:10:49.375578Z -b5b8840efa652b10828e8d0c455c9049 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -2591 - -qtimedelay.f90 -file - - - - -2013-06-12T18:10:49.375578Z -20d420cf7c1eaed9c86a1d1a0b091da3 -2013-06-05T15:45:44.760997Z -63 -kavetski - - - - - - - - - - - - - - - - - - - - - -3785 - -newtoniter.f90 -file - - - - -2013-06-12T18:10:49.375578Z -eef9f55dd5703c7360b5eec181b12460 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -9927 - -fdjac_ode.f90 -file - - - - -2013-06-12T18:10:49.375578Z -e4a275871a5d24015b0eb80c6e57e2e8 -2009-11-20T06:35:05.691690Z -11 -kavetski - - - - - - - - - - - - - - - - - - - - - -2549 - -mstate_eqn.f90 -file - - - - -2013-06-12T18:10:49.375578Z -e17420b9560189d28537d3fd6be2ecb8 -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -4212 - -evap_lower.f90 -file - - - - -2013-06-12T18:10:49.375578Z -b190250b979469c775928ec2b5ec6533 -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -3188 - -fdjac.f90 -file - - - - -2013-06-12T18:10:49.375578Z -3ab9e15dfea568ec198a926ccdcdb1bd -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1180 - -bucketsize.f90 -file - - - - -2013-06-12T18:10:49.375578Z -9ac6e85f24417ac8fae19e9cb9218c81 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1667 - -fix_states.f90 -file - - - - -2013-06-12T18:10:49.375578Z -b1add81b3340ec3840edb11ff095378e -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -16968 - -fuse_solve.f90 -file - - - - -2013-06-12T18:10:49.375578Z -e9cbf273f9d49864fa27ace90942e722 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -14795 - -getpar_str.f90 -file - - - - -2013-06-12T18:10:49.375578Z -e7f6a207e30a094c7446ca338197e56c -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -2811 - -batea_file.f90 -file - - - - -2013-06-12T18:10:49.375578Z -afd76f8e86af8b26ff18d2b4dd925192 -2009-11-20T06:35:05.691690Z -11 -kavetski - - - - - - - - - - - - - - - - - - - - - -11109 - -comp_stats.f90 -file - - - - -2013-06-12T18:10:49.375578Z -ab7aee55c884c94085bff7347cd69058 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1716 - -parextract.f90 -file - - - - -2013-06-12T18:10:49.375578Z -0c853b3e8c211d6348da17e225f33423 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -5820 - diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/adjust_stt.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/adjust_stt.f90.svn-base deleted file mode 100644 index 22cbcd3..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/adjust_stt.f90.svn-base +++ /dev/null @@ -1,56 +0,0 @@ -SUBROUTINE ADJUST_STT() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2008 -! -------- -! Modified by Dmitri Kavetski, 5 June 2013 AD (EAWAG) to replace IF with SELECTCASE -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Ensure that states are consistent with parameter values (needed for the special case of -! stochastic parameters) -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! Model states updated in MODULE multistate -! --------------------------------------------------------------------------------------- -USE model_defn ! model definitions -USE model_defnames -USE multistate ! model states -USE multiparam ! model parameters -IMPLICIT NONE -! internal -INTEGER(I4B) :: ISTT ! loop through model states -! ---------------------------------------------------------------------------------------- -! ---------------------------------------------------------------------------------------- -DO ISTT=1,NSTATE ! NSTATE is in module model_defn - SELECTCASE(CSTATE(ISTT)%iSNAME) - ! --------------------------------------------------------------------------------------- - ! states in the upper layer - ! --------------------------------------------------------------------------------------- - CASE (iopt_TENS1A) ! tension 1a - IF (MSTATE%TENS_1A .GT. DPARAM%MAXTENS_1A) MSTATE%TENS_1A=DPARAM%MAXTENS_1A - CASE (iopt_TENS1B) ! tension 1b - IF (MSTATE%TENS_1B .GT. DPARAM%MAXTENS_1B) MSTATE%TENS_1B=DPARAM%MAXTENS_1B - CASE (iopt_TENS_1) ! tension 1 - IF (MSTATE%TENS_1 .GT. DPARAM%MAXTENS_1) MSTATE%TENS_1 =DPARAM%MAXTENS_1 - CASE (iopt_FREE_1) ! free 1 - IF (MSTATE%FREE_1 .GT. DPARAM%MAXFREE_1) MSTATE%FREE_1 =DPARAM%MAXFREE_1 - CASE (iopt_WATR_1) ! total 1 - IF (MSTATE%WATR_1 .GT. MPARAM%MAXWATR_1) MSTATE%WATR_1 =MPARAM%MAXWATR_1 - ! --------------------------------------------------------------------------------------- - ! states in the lower layer - ! --------------------------------------------------------------------------------------- - CASE (iopt_TENS_2) ! tension 2 - IF (MSTATE%TENS_2 .GT. DPARAM%MAXTENS_2) MSTATE%TENS_2 =DPARAM%MAXTENS_2 - CASE (iopt_FREE2A) ! free 2a - IF (MSTATE%FREE_2A .GT. DPARAM%MAXFREE_2A) MSTATE%FREE_2A=DPARAM%MAXFREE_2A - CASE (iopt_FREE2B) ! free 2b - IF (MSTATE%FREE_2B .GT. DPARAM%MAXFREE_2B) MSTATE%FREE_2B=DPARAM%MAXFREE_2B - CASE (iopt_WATR_2) ! total 2 - IF (MSTATE%WATR_2 .GT. MPARAM%MAXWATR_2) MSTATE%WATR_2 =MPARAM%MAXWATR_2 - END SELECT -END DO ! (loop through model states) -! ---------------------------------------------------------------------------------------- -END SUBROUTINE ADJUST_STT \ No newline at end of file diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/assign_flx.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/assign_flx.f90.svn-base deleted file mode 100644 index 7b9f5f4..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/assign_flx.f90.svn-base +++ /dev/null @@ -1,83 +0,0 @@ -SUBROUTINE ASSIGN_FLX() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Build an array of strings that list model fluxes used for the current model -! configuration -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! Defines list and number of states in MODULE model_defn -! --------------------------------------------------------------------------------------- -USE model_defn ! model definition -USE model_defnames -IMPLICIT NONE -INTEGER(I4B) :: I_FLUX ! just used for testing -LOGICAL(LGT) :: L_TEST ! just used for testing -! --------------------------------------------------------------------------------------- -L_TEST=.FALSE. -N_FLUX=0 -C_FLUX(:)%FNAME = ' ' -! --------------------------------------------------------------------------------------- -! (1) DEFINE STATE VARIABLES IN THE UPPER LAYER -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iARCH1) - CASE(iopt_tension2_1) - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EFF_PPT ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_1A ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_1B ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'RCHR2EXCS ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'TENS2FREE_1' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QPERC_12 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QINTF_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QSURF ' - CASE(iopt_tension1_1) - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EFF_PPT ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'TENS2FREE_1' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QPERC_12 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QINTF_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QSURF ' - CASE(iopt_onestate_1) - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EFF_PPT ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QPERC_12 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QINTF_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QSURF ' - CASE DEFAULT - print *, "MDEFN(IMOD)%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" - STOP -END SELECT -! --------------------------------------------------------------------------------------- -! (2) DEFINE STATE VARIABLES IN THE LOWER LAYER -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iARCH2) - CASE(iopt_tens2pll_2) - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_2 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'TENS2FREE_2' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QBASE_2A ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QBASE_2B ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QBASE_2 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_2A ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_2B ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_2 ' - CASE(iopt_unlimfrc_2,iopt_unlimpow_2,iopt_topmdexp_2,iopt_fixedsiz_2) - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_2 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QBASE_2 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_2 ' - CASE DEFAULT - print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" - print *, " iopt_topmdexp_2, or iopt_fixedsiz_2" - STOP -END SELECT -! --------------------------------------------------------------------------------------- -IF (L_TEST) THEN; DO I_FLUX=1,N_FLUX; WRITE(*,'(A20)') C_FLUX(I_FLUX)%FNAME; END DO; ENDIF -! --------------------------------------------------------------------------------------- -END SUBROUTINE ASSIGN_FLX diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/assign_par.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/assign_par.f90.svn-base deleted file mode 100644 index 289ee78..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/assign_par.f90.svn-base +++ /dev/null @@ -1,183 +0,0 @@ -SUBROUTINE ASSIGN_PAR() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Gets a list of model parameters used for the unique model in the structure SMODL -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multi_flux -- list of model parameters is stored in MODULE multiparam -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition structure -USE model_defnames -USE multiparam, ONLY : lparam, paratt, numpar ! model parameter structures -USE getpar_str_module ! access to SUBROUTINE get_par_str -IMPLICIT NONE -INTEGER(I4B) :: MPAR ! counter for number of parameters -TYPE(PARATT) :: PARAM_LEV1 ! parameter metadata (level 1) -TYPE(PARATT) :: PARAM_LEV2 ! parameter metadata (level 2) -! --------------------------------------------------------------------------------------- -MPAR = 0 ! initialize the number of model parameters -LPARAM(:)%PARNAME = 'PAR_NOUSE' -! --------------------------------------------------------------------------------------- -! (1) RAINFALL ERRORS -! --------------------------------------------------------------------------------------- - -SELECT CASE(SMODL%iRFERR) - CASE(iopt_additive_e) ! additive rainfall error - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'RFERR_ADD' ! additive rainfall error (mm day-1) - CASE(iopt_multiplc_e) ! multiplicative rainfall error - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'RFERR_MLT' ! multiplicative rainfall error (-) - ! check if RFERR_MLT has any prior/hyper-parameters, and, if so, save them - CALL GETPAR_STR('RFERR_MLT',PARAM_LEV1) - IF (PARAM_LEV1%NPRIOR.GT.0) THEN - ! process 1st child - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV1%CHILD1(1:9) ! save 1st child - CALL GETPAR_STR(PARAM_LEV1%CHILD1,PARAM_LEV2) ! get metadata for 1st child - IF (PARAM_LEV2%NPRIOR.GT.0) THEN ! check if 1st child has prior/hyper-param - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV2%CHILD1(1:9) ! save 1st grandchild (from 1st child) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV2%CHILD2(1:9) ! save 2nd grandchild (from 1st child) - ENDIF - ! process 2nd child - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV1%CHILD2(1:9) ! save 2nd child - CALL GETPAR_STR(PARAM_LEV1%CHILD2,PARAM_LEV2) ! get metadata for 1st child - IF (PARAM_LEV2%NPRIOR.GT.0) THEN ! check if 1st child has prior/hyper-param - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV2%CHILD1(1:9) ! save 1st grandchild (from 2nd child) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV2%CHILD2(1:9) ! save 2nd grandchild (from 2nd child) - ENDIF - ENDIF - CASE DEFAULT - print *, "SMODL%RFERR must be 'additive_e' or 'multiplc_e'" - STOP -END SELECT ! (different upper-layer architechure) -! --------------------------------------------------------------------------------------- -! (2) UPPER-LAYER ARCHITECTURE -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iARCH1) - CASE(iopt_tension2_1) ! tension storage sub-divided into recharge and excess - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FRCHZNE ' ! PRMS: frac tension storage in recharge zone (-) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FRACTEN ' ! frac total storage as tension storage (-) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_1' ! maximum total storage in layer1 (mm) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FRACLOWZ ' ! fraction of soil excess to lower zone (-) - CASE(iopt_tension1_1,iopt_onestate_1) ! (need to define tension and free storage -- even if one state) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FRACTEN ' ! frac total storage as tension storage (-) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_1' ! maximum total storage in layer1 (mm) - CASE DEFAULT - print *, "SMODL%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" - STOP -END SELECT ! (different upper-layer architechure) -! --------------------------------------------------------------------------------------- -! (3) LOWER-LAYER ARCHITECTURE / BASEFLOW -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iARCH2) - CASE(iopt_tens2pll_2) ! tension reservoir plus two parallel tanks - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'PERCFRAC ' ! fraction of percolation to tension storage (-) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FPRIMQB ' ! SAC: fraction of baseflow in primary resvr (-) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_2' ! maximum total storage in layer2 (mm) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QBRATE_2A ' ! baseflow depletion rate for primary resvr (day-1) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QBRATE_2B ' ! baseflow depletion rate for secondary resvr (day-1) - CASE(iopt_unlimfrc_2) ! baseflow resvr of unlimited size (0-HUGE), frac rate - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_2' ! maximum total storage in layer2 (mm) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QB_PRMS ' ! baseflow depletion rate (day-1) - CASE(iopt_topmdexp_2,iopt_unlimpow_2) ! topmodel options - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_2' ! maximum total storage in layer2 (mm) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'BASERTE ' ! baseflow rate (mm day-1) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'LOGLAMB ' ! mean value of the log-transformed topographic index (m) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'TISHAPE ' ! shape parameter for the topo index Gamma distribution (-) - ! (add extra paramater for the power-law transmissivity profile) - IF (SMODL%iARCH2.EQ.iopt_unlimpow_2) THEN ! (power-law transmissivity profile) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QB_POWR ' ! baseflow exponent (-) - ENDIF - CASE(iopt_fixedsiz_2) ! power-law relation (no parameters needed for the topo index distribution) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_2' ! maximum total storage in layer2 (mm) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'BASERTE ' ! baseflow rate (mm day-1) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QB_POWR ' ! baseflow exponent (-) - CASE DEFAULT - print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" - print *, " 'topmdexp_2', or 'fixedsiz_2'" - STOP -END SELECT ! different lower-layer architecture / baseflow parameterizations) -! --------------------------------------------------------------------------------------- -! (4) EVAPORATION -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iESOIL) - CASE(iopt_sequential) - ! (no additional parameters for the sequential scheme) - CASE(iopt_rootweight) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'RTFRAC1 ' ! fraction of roots in the upper layer (-) - CASE DEFAULT - print *, "SMODL%iESOIL must be either iopt_sequential or iopt_rootweight'" -END SELECT ! (different evaporation schemes) -! --------------------------------------------------------------------------------------- -! (5) PERCOLATION -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iQPERC) - CASE(iopt_perc_f2sat,iopt_perc_w2sat) ! standard equation k(theta)**c - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'PERCRTE ' ! percolation rate (mm day-1) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'PERCEXP ' ! percolation exponent (-) - CASE(iopt_perc_lower) ! perc defined by moisture content in lower layer (SAC) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'SACPMLT ' ! multiplier in the SAC model for dry lower layer (-) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'SACPEXP ' ! exponent in the SAC model for dry lower layer (-) - CASE DEFAULT ! check for errors - print *, "SMODL%iQPERC must be iopt_perc_f2sat, iopt_perc_w2sat, or iopt_perc_lower" - STOP -END SELECT ! (different percolation options) -! --------------------------------------------------------------------------------------- -! (6) INTERFLOW -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iQINTF) - CASE(iopt_intflwsome) ! interflow - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'IFLWRTE ' ! interflow rate (mm day-1) - CASE(iopt_intflwnone) ! no interflow - ! (no additional parameters for the case of no interflow) - CASE DEFAULT ! check for errors - print *, "SMODL%iQINTF must be either iopt_intflwsome' or iopt_intflwnone'" - STOP -END SELECT ! (different interflow options) -! --------------------------------------------------------------------------------------- -! (7) SURFACE RUNOFF -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iQSURF) - CASE(iopt_arno_x_vic) ! ARNO/Xzang/VIC parameterization (upper zone control) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'AXV_BEXP ' ! ARNO/VIC "b" exponent - CASE(iopt_prms_varnt) ! PRMS variant (fraction of upper tension storage) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'SAREAMAX ' ! maximum saturated area - CASE(iopt_tmdl_param) ! TOPMODEL parameterization - ! need the topographic index if we don't have it for baseflow - IF (SMODL%iARCH2.EQ.iopt_tens2pll_2 .OR. SMODL%iARCH2.EQ.iopt_unlimfrc_2 .OR. & - SMODL%iARCH2.EQ.iopt_fixedsiz_2) THEN - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'LOGLAMB ' ! mean value of the log-transformed topographic index (m) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'TISHAPE ' ! shape parameter for the topo index Gamma distribution (-) - ENDIF - ! need the topmodel power if we don't have it for baseflow - IF (SMODL%iARCH2.EQ.iopt_tens2pll_2 .OR. SMODL%iARCH2.EQ.iopt_unlimfrc_2 .OR. & - SMODL%iARCH2.EQ.iopt_topmdexp_2) THEN - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QB_POWR ' ! baseflow exponent (-), used to modify the topographic index - ENDIF - CASE DEFAULT - print *, "SMODL%iQSURF must be iopt_arno_x_vic, iopt_prms_varnt, or iopt_tmdl_param" - STOP -END SELECT ! (different surface runoff options) -! --------------------------------------------------------------------------------------- -! (8) TIME DELAY IN RUNOFF -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iQ_TDH) - CASE(iopt_rout_gamma) ! use a Gamma distribution with shape parameter = 2.5 - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'TIMEDELAY' ! time delay in runoff - CASE(iopt_no_routing) ! no routing - ! (no additional parameters when there is no time delay in runoff) - CASE DEFAULT ! check for errors - print *, "SMODL%iQ_TDH must be either iopt_rout_gamma or iopt_no_routing" - STOP -END SELECT -! --------------------------------------------------------------------------------------- -NUMPAR = MPAR ! save the number of model parameters used in a given model SMODL -! --------------------------------------------------------------------------------------- -!DO MPAR=1,NUMPAR; WRITE(*,'(A11,1X)') LPARAM(MPAR)%PARNAME; END DO -! --------------------------------------------------------------------------------------- -END SUBROUTINE ASSIGN_PAR diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/assign_stt.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/assign_stt.f90.svn-base deleted file mode 100644 index b500f22..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/assign_stt.f90.svn-base +++ /dev/null @@ -1,60 +0,0 @@ -SUBROUTINE ASSIGN_STT() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Build an array of strings that list model states used for the current model -! configuration -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! Defines list and number of states in MODULE model_defn -! --------------------------------------------------------------------------------------- -USE model_defn ! model definition -USE model_defnames -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -NSTATE=0 -!CSTATE(:)%SNAME(1:6) = 'NO_USE' -! --------------------------------------------------------------------------------------- -! (1) DEFINE STATE VARIABLES IN THE UPPER LAYER -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iARCH1) - CASE(iopt_tension2_1) - CSTATE(NSTATE+1)%iSNAME = iopt_TENS1A - CSTATE(NSTATE+2)%iSNAME = iopt_TENS1B - CSTATE(NSTATE+3)%iSNAME = iopt_FREE_1 - NSTATE = NSTATE+3 - CASE(iopt_tension1_1) - CSTATE(NSTATE+1)%iSNAME = iopt_TENS_1 - CSTATE(NSTATE+2)%iSNAME = iopt_FREE_1 - NSTATE = NSTATE+2 - CASE(iopt_onestate_1) - CSTATE(NSTATE+1)%iSNAME = iopt_WATR_1 - NSTATE = NSTATE+1 - CASE DEFAULT - print *, "MDEFN(IMOD)%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" - STOP -END SELECT -! --------------------------------------------------------------------------------------- -! (2) DEFINE STATE VARIABLES IN THE LOWER LAYER -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iARCH2) - CASE(iopt_tens2pll_2) - CSTATE(NSTATE+1)%iSNAME = iopt_TENS_2 - CSTATE(NSTATE+2)%iSNAME = iopt_FREE2A - CSTATE(NSTATE+3)%iSNAME = iopt_FREE2B - NSTATE = NSTATE+3 - CASE(iopt_unlimfrc_2,iopt_unlimpow_2,iopt_topmdexp_2,iopt_fixedsiz_2) - CSTATE(NSTATE+1)%iSNAME = iopt_WATR_2 - NSTATE = NSTATE+1 - CASE DEFAULT - print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" - print *, " iopt_topmdexp_2, or iopt_fixedsiz_2" - STOP -END SELECT -! --------------------------------------------------------------------------------------- -END SUBROUTINE ASSIGN_STT diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/batea_file.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/batea_file.f90.svn-base deleted file mode 100644 index cbe9d2a..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/batea_file.f90.svn-base +++ /dev/null @@ -1,184 +0,0 @@ -SUBROUTINE BATEA_FILE() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Used to write parameter files in BATEA format -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE fuse_fileManager,only:SETNGS_PATH,BATEA_PARAM ! defines data directory -USE multiparam, ONLY: PARATT, LPARAM, NUMPAR ! parameter attribute structure -USE getpar_str_module ! provide access to SUBROUTINE getpar_str -IMPLICIT NONE -INTEGER(I4B) :: I ! FORALL loop -CHARACTER(LEN=90) :: CNEW ! new parameter delimiter -integer(i4b),parameter::lenPath=1024 !DK211008: allows longer file paths -CHARACTER(LEN=lenPath) :: CFILE ! name of constraints file -INTEGER(I4B) :: IUNIT ! file unit -INTEGER(I4B) :: IPAR ! loop through parameters -INTEGER(I4B) :: IHYP ! loop through hyper-parameters -INTEGER(I4B) :: IPRI ! loop through prior-parameters -INTEGER(I4B) :: NPARFIT ! number of fitted prior/hyper params -CHARACTER(LEN=256) :: PARNAME ! parameter name -TYPE(PARATT) :: PARAM_MODEL ! parameter metadata (model parameters) -TYPE(PARATT) :: PARAM_HYPER ! parameter metadata (hyper-parameters) -TYPE(PARATT) :: PARAM_PRIOR ! parameter metadata (prior-parameters) -! --------------------------------------------------------------------------------------- -! initialize -CNEW(1:1)='!' -FORALL(I=2:LEN(CNEW)) CNEW(I:I)='*' ! define break -FORALL(I=1:LEN(PARNAME)) PARNAME(I:I)=' ' -! open up batea output file -IUNIT = 21 ! file unit -CFILE = TRIM(SETNGS_PATH)//TRIM(BATEA_PARAM) ! file info shared in MODULE ddirectory -OPEN(IUNIT,FILE=CFILE,STATUS='unknown') -! write file header -WRITE(IUNIT,'(A)') 'DMDL_FARAMINEAUX_INFERN_FILE_V2' -WRITE(IUNIT,'(A)') '"Example of a faramineux infern file" ! file comment (not used)' -WRITE(IUNIT,'(A1)') ' ' -WRITE(IUNIT,'(I1,1X,A19,1X,A)') 2, ' ', '! modelID (consult dynamicModelLibrary), 2=FUSE' -WRITE(IUNIT,'(A1)') ' ' -WRITE(IUNIT,'(A90)') CNEW; WRITE(IUNIT,'(A1)') ' ' ! write delimiter plus blank line -! loop through parameters -DO IPAR=1,NUMPAR - ! -------------------------------------------------------------------------------------- - ! get parameter metadata - CALL GETPAR_STR(LPARAM(IPAR)%PARNAME,PARAM_MODEL) ! get parameter metadata - ! write parameter title and parameter index - WRITE(IUNIT,'(A,1X,I2,1X,A1,1X,A)') & - 'NEW_PAR_000 - Parameter', IPAR, '-', '"'//TRIM(LPARAM(IPAR)%PARNAME)//'"' - WRITE(IUNIT,'(I2.2,1X,A18,1X,A)') IPAR, ' ', '! i, index of parameter' - ! write parameter info - CALL WRITE_PARINFO(PARAM_MODEL) ! write parameter info - ! -------------------------------------------------------------------------------------- - ! check for hyper-parameter - IF (PARAM_MODEL%NPRIOR.GT.0) THEN - NPARFIT=0 - DO IHYP=1,PARAM_MODEL%NPRIOR - ! identify name of child parameter - IF (IHYP.EQ.1) PARNAME(1:LEN(PARAM_MODEL%CHILD1))=PARAM_MODEL%CHILD1(1:LEN(PARAM_MODEL%CHILD1)) - IF (IHYP.EQ.2) PARNAME(1:LEN(PARAM_MODEL%CHILD2))=PARAM_MODEL%CHILD2(1:LEN(PARAM_MODEL%CHILD2)) - IF (IHYP.GT.2) STOP ' only anticipate that there will ever by two hyper-parameters ' - ! get parameter metadata - CALL GETPAR_STR(TRIM(PARNAME),PARAM_HYPER) ! get parameter metadata - ! keep track of the number of fitted parameters - IF (PARAM_HYPER%PARFIT) NPARFIT = NPARFIT+1 - ! write parameter header - WRITE(IUNIT,'(A1)') ' ' - FORALL(I=2:LEN(CNEW)) CNEW(I:I)='-' ! define new break - WRITE(IUNIT,'(A90)') CNEW; WRITE(IUNIT,'(A1)') ' ' ! delimiter plus blank line - ! write parameter title and parameter index - WRITE(IUNIT,'(A,1X,I2,1X,A,1X,A1,1X,A)') 'NEW_PAR_000 - Hyper parameter', IHYP, & - ' of "'//TRIM(LPARAM(IPAR)%PARNAME)//'"', '-', '"'//TRIM(PARAM_HYPER%P_NAME)//'"' - WRITE(IUNIT,'(I2.2,1X,A18,1X,A)') IHYP, ' ', '! k, index of parameter' - ! write parameter data - CALL WRITE_PARINFO(PARAM_HYPER) - ! -------------------------------------------------------------------------------------- - ! check for prior-parameter - IF (PARAM_HYPER%NPRIOR.GT.0) THEN - DO IPRI=1,PARAM_HYPER%NPRIOR - ! identify name of child parameter - IF (IPRI.EQ.1) PARNAME(1:LEN(PARAM_HYPER%CHILD1))=PARAM_HYPER%CHILD1(1:LEN(PARAM_HYPER%CHILD1)) - IF (IPRI.EQ.2) PARNAME(1:LEN(PARAM_HYPER%CHILD2))=PARAM_HYPER%CHILD2(1:LEN(PARAM_HYPER%CHILD2)) - IF (IPRI.GT.2) STOP ' only anticipate that there will ever by two prior-parameters ' - ! get parameter metadata - CALL GETPAR_STR(TRIM(PARNAME),PARAM_PRIOR) ! get parameter metadata - ! write parameter header - WRITE(IUNIT,'(A1)') ' ' - WRITE(IUNIT,'(A90)') CNEW; WRITE(IUNIT,'(A1)') ' ' ! delimiter plus blank line - ! write parameter title and parameter index - WRITE(IUNIT,'(A,1X,I2,1X,A,1X,I2,1X,A,1X,A1,1X,A)') 'NEW_PAR_000 - Prior parameter', IPRI, & - ' of Hyper parameter', IHYP, ' of "'//TRIM(LPARAM(IPAR)%PARNAME)//'"', '-', & - '"'//TRIM(PARAM_PRIOR%P_NAME)//'"' - WRITE(IUNIT,'(I2.2,1X,A18,1X,A)') IHYP, ' ', '! k, index of parameter' - ! write parameter data - CALL WRITE_PARINFO(PARAM_PRIOR) - ! write end text for prior parameter - WRITE(IUNIT,'(A)') 'INF_LIST' - WRITE(IUNIT,'(I1,1X,A19,1X,A)') 0, ' ', '! number of fitted prior/hyper-parameters' - WRITE(IUNIT,'(I1,1X,A19,1X,A)') 0, ' ', '! list of fitted prior/hyper-parameters' - WRITE(IUNIT,'(A,1X,I2,1X,A,1X,I2,1X,A,1X,A1,1X,A)') 'END_PAR_000 - Prior parameter', IPRI, & - ' of Hyper parameter', IHYP, ' of "'//TRIM(LPARAM(IPAR)%PARNAME)//'"', '-', & - '"'//TRIM(PARAM_PRIOR%P_NAME)//'"' - END DO ! (loop through prior parameters) - ENDIF ! (if there are prior parameters) - ! write end text for hyper parameter - IF (PARAM_HYPER%NPRIOR.GT.0) THEN - WRITE(IUNIT,'(A1)') ' ' - WRITE(IUNIT,'(A90)') CNEW; WRITE(IUNIT,'(A1)') ' ' ! delimiter plus blank line - ENDIF - WRITE(IUNIT,'(A)') 'INF_LIST' - WRITE(IUNIT,'(I1,1X,A19,1X,A)') 0, ' ', '! number of fitted prior/hyper-parameters' - WRITE(IUNIT,'(I1,1X,A19,1X,A)') 0, ' ', '! list of fitted prior/hyper-parameters' - WRITE(IUNIT,'(A,1X,I2,1X,A,1X,A1,1X,A)') 'END_PAR_000 - Hyper parameter', IHYP, & - ' of "'//TRIM(LPARAM(IPAR)%PARNAME)//'"', '-', '"'//TRIM(PARAM_HYPER%P_NAME)//'"' - END DO ! (loop through hyper parameters) - ! write end text for parameter - WRITE(IUNIT,'(A1)') ' ' - WRITE(IUNIT,'(A90)') CNEW; WRITE(IUNIT,'(A1)') ' ' ! delimiter plus blank line - WRITE(IUNIT,'(A)') 'INF_LIST' - WRITE(IUNIT,'(I1,1X,A19,1X,A)') NPARFIT, ' ', '! number of fitted prior/hyper-parameters' - IF (NPARFIT.EQ.0) WRITE(IUNIT,'(I1,1X,A19,1X,A)') 0, ' ', '! list of fitted prior/hyper-parameters' - IF (NPARFIT.EQ.1) WRITE(IUNIT,'(I1,1X,A19,1X,A)') 1, ' ', '! list of fitted prior/hyper-parameters' - IF (NPARFIT.EQ.2) WRITE(IUNIT,'(I1,A1,I1,A17,1X,A)') 1,',',2, ' ', '! list of fitted prior/hyper-parameters' - ELSE - ! write end text for parameter - WRITE(IUNIT,'(A)') 'INF_LIST' - WRITE(IUNIT,'(I1,1X,A19,1X,A)') 0, ' ', '! number of fitted prior/hyper-parameters' - WRITE(IUNIT,'(I1,1X,A19,1X,A)') 0, ' ', '! list of fitted prior/hyper-parameters' - ENDIF ! (if there are hyper parameters) - ! continue writing end text (same in both cases) - WRITE(IUNIT,'(A,1X,I2,1X,A1,1X,A)') & - 'NEW_PAR_000 - Parameter', IPAR, '-', '"'//TRIM(LPARAM(IPAR)%PARNAME)//'"' - WRITE(IUNIT,'(A1)') ' ' - FORALL(I=2:LEN(CNEW)) CNEW(I:I)='=' ! re-define delimiter - WRITE(IUNIT,'(A90)') CNEW; WRITE(IUNIT,'(A1)') ' ' ! write delimiter plus blank line -END DO ! loop through parameters -! write final delimiter -FORALL(I=2:LEN(CNEW)) CNEW(I:I)='*' ! define break -WRITE(IUNIT,'(A90)') CNEW; WRITE(IUNIT,'(A1)') ' ' ! delimiter plus blank line -CLOSE(IUNIT) -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -CONTAINS - SUBROUTINE WRITE_PARINFO(PARAM_META) - ! define parameter metadata structure - TYPE(PARATT), INTENT(IN) :: PARAM_META ! parameter metadata - REAL(SP) :: PAR_OFFSET ! used to define "reasonable" parameter range - ! write 1st block - WRITE(IUNIT,'(A11, 1X, A9,1X,A)') '"'//TRIM(PARAM_META%P_NAME)//'" ', ' ', '! name of parameter' - WRITE(IUNIT,'(L1, 1X,A19,1X,A)') PARAM_META%PARFIT, ' ', '! fit (T/F) [T=param fitted, F=param fixed at default]' - WRITE(IUNIT,'(I1, 1X,A19,1X,A)') PARAM_META%PARSTK, ' ', '! flag (0=deterministic, 1=stochastic)' - WRITE(IUNIT,'(A1)') ' ' - ! write 2nd block - WRITE(IUNIT,'(E9.3,A1,E9.3,1X,A1,1X,A)') PARAM_META%PARLOW, ',', PARAM_META%PARUPP, ' ', & - '! pLo and pHi: Bounds on parameter' - PAR_OFFSET = PARAM_META%FRSEED * (PARAM_META%PARUPP - PARAM_META%PARLOW) - WRITE(IUNIT,'(E9.3,A1,E9.3,1X,A1,1X,A)') PARAM_META%PARLOW+PAR_OFFSET, ',', PARAM_META%PARUPP-PAR_OFFSET, ' ', & - '! pLoR and pHiR: Reasonable bounds on parameter (seeding multi-sequences)' - WRITE(IUNIT,'(E9.3,1X,A11,1X,A)') PARAM_META%PARSCL, ' ', '! typical scale of parameter' - WRITE(IUNIT,'(E9.3,1X,A11,1X,A)') PARAM_META%PARDEF, ' ', '! initial value of parameter' - WRITE(IUNIT,'(I1, 1X,A19,1X,A)') PARAM_META%PARVTN, ' ', '! ftran_v2z: fitting z-transform [see transformation library' - WRITE(IUNIT,'(A1)') ' ' - ! write 3rd block - WRITE(IUNIT,'(I1, 1X,A19,1X,A)') PARAM_META%PARDIS, ' ', '! prDistID - prior (det) or hyper (stok) [see distribution library]' - WRITE(IUNIT,'(I1, 1X,A19,1X,A)') PARAM_META%PARQTN, ' ', '! ptran_v2q - probModel-transform [see transformation library]' - WRITE(IUNIT,'(A1)') ' ' - ! write 4th block - WRITE(IUNIT,'(I1, 1X,A19,1X,A)') PARAM_META%PARLAT, ' ', '! number of latents (ignored for det, stk: 0=onePerStep, -1=from data' - WRITE(IUNIT,'(I1, 1X,A19,1X,A)') PARAM_META%PARMTH, ' ', '! imeth for all vars FXD_IMETH=0,EXP_IMETH=1,LIN_IMETH=2,FBF_IMETH=4' - WRITE(IUNIT,'(A1)') ' ' - ! write 5th block - WRITE(IUNIT,'(I1, 1X,A19,1X,A)') 0, ' ', '! number of auxiliaries needed' - WRITE(IUNIT,'(I1, 1X,A19,1X,A)') 0, ' ', '! list of auxiliaries needed' - WRITE(IUNIT,'(A1)') ' ' - ! write 6th block - WRITE(IUNIT,'(I1, 1X,A19,1X,A)') PARAM_META%NPRIOR, ' ', '! number of prior/hyper-parameters' - END SUBROUTINE WRITE_PARINFO -END SUBROUTINE BATEA_FILE diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/bucketsize.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/bucketsize.f90.svn-base deleted file mode 100644 index cfcb526..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/bucketsize.f90.svn-base +++ /dev/null @@ -1,31 +0,0 @@ -SUBROUTINE BUCKETSIZE() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Computes the maximum water holding capacity of the different reservoirs -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multiparam -- bucket sizes stored in MODULE multiparam -! --------------------------------------------------------------------------------------- -USE multiparam ! model parameters -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -! derive maximum tension water in each layer -DPARAM%MAXTENS_1 = MPARAM%FRACTEN * MPARAM%MAXWATR_1 -DPARAM%MAXTENS_2 = MPARAM%FRACTEN * MPARAM%MAXWATR_2 -! derive maximum free water in each layer -DPARAM%MAXFREE_1 = (1._sp-MPARAM%FRACTEN) * MPARAM%MAXWATR_1 -DPARAM%MAXFREE_2 = (1._sp-MPARAM%FRACTEN) * MPARAM%MAXWATR_2 -! derive capacities of the recharge and lower zone (ONLY USED if upper tension is divided in two) -DPARAM%MAXTENS_1A = MPARAM%FRCHZNE * DPARAM%MAXTENS_1 -DPARAM%MAXTENS_1B = (1._sp-MPARAM%FRCHZNE) * DPARAM%MAXTENS_1 -! derive capacities of the primary and secondary parallel baseflow reservoirs -DPARAM%MAXFREE_2A = MPARAM%FPRIMQB * DPARAM%MAXFREE_2 -DPARAM%MAXFREE_2B = (1._sp-MPARAM%FPRIMQB) * DPARAM%MAXFREE_2 -! --------------------------------------------------------------------------------------- -END SUBROUTINE BUCKETSIZE diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/comp_stats.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/comp_stats.f90.svn-base deleted file mode 100644 index 4d3347e..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/comp_stats.f90.svn-base +++ /dev/null @@ -1,32 +0,0 @@ -SUBROUTINE COMP_STATS() -! ---------------------------------------------------------------------------------------- -! Creator: -! Martyn Clark, 2009 -! -! ---------------------------------------------------------------------------------------- -! Purpose: -! Used to compute summary statistics of model output -! -! ---------------------------------------------------------------------------------------- -! Future revisions: -! -! (add other summary statistics) -! -! ---------------------------------------------------------------------------------------- -USE nrtype ! variable types (DP, I4B, etc.) -USE multistats -USE model_numerix -IMPLICIT NONE -! ---------------------------------------------------------------------------------------- -! compute numerical stats -MSTATS%NUM_FUNCS = MSTATS%NUM_FUNCS + REAL(NUM_FUNCS, KIND(SP)) ! number of function calls -MSTATS%NUM_JACOBIAN = MSTATS%NUM_JACOBIAN + REAL(NUM_JACOBIAN, KIND(SP)) ! number of times Jacobian is calculated -MSTATS%NUMSUB_ACCEPT = MSTATS%NUMSUB_ACCEPT + REAL(NUMSUB_ACCEPT, KIND(SP)) ! number of sub-steps accepted (taken) -MSTATS%NUMSUB_REJECT = MSTATS%NUMSUB_REJECT + REAL(NUMSUB_REJECT, KIND(SP)) ! number of sub-steps tried but rejected -MSTATS%NUMSUB_NOCONV = MSTATS%NUMSUB_NOCONV + REAL(NUMSUB_NOCONV, KIND(SP)) ! number of sub-steps tried that did not converge -! compute maximum number of iterations -IF (MAXNUM_ITERNS > MSTATS%MAXNUM_ITERNS) MSTATS%MAXNUM_ITERNS = MAXNUM_ITERNS -! compute probability distributions -WHERE(ORD_NSUBS.GE.NUMSUB_ACCEPT) PRB_NSUBS = PRB_NSUBS + 1 -! ---------------------------------------------------------------------------------------- -END SUBROUTINE COMP_STATS diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/disaggflux.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/disaggflux.f90.svn-base deleted file mode 100644 index c67cb63..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/disaggflux.f90.svn-base +++ /dev/null @@ -1,132 +0,0 @@ -MODULE DISAGGFLUX_MODULE -IMPLICIT NONE -CONTAINS -SUBROUTINE DISAGGFLUX(DELS,EFLAG) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Disaggregate fluxes for the semi-implicit Euler method -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! Fluxes in MODULE multi_flux (M_FLUX) -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE nrutil, ONLY : nrerror ! error control -USE model_defn, ONLY: SMODL,& ! identify modelling decisions - C_FLUX,N_FLUX, & ! loop through the fluxes - CSTATE,NSTATE ! loop through the states -USE model_defnames -USE multiforce, ONLY: MFORCE ! model forcing data -USE multi_flux, ONLY: FLUX_0,M_FLUX,FDFLUX ! model fluxes -USE multiparam, ONLY: MPARAM ! model parameters -IMPLICIT NONE -! input/output -REAL(SP), DIMENSION(:), INTENT(IN) :: DELS ! difference in state vector -LOGICAL(LGT), INTENT(OUT) :: EFLAG ! error flag for unusual flux -! internal -INTEGER(I4B) :: IFLUX ! loop thru fluxes -INTEGER(I4B) :: ISTT ! loop through states -REAL(SP), PARAMETER :: ZERO=0._SP ! zero -REAL(SP) :: IN_FLUX ! influx to a given bucket -REAL(SP) :: TOTEVAP ! total evaporation -! --------------------------------------------------------------------------------------- -! make sure that the finite-difference flux structure is allocated -IF (.NOT.ASSOCIATED(FDFLUX)) CALL NRERROR('disaggflux: fdflux is not allocated') -IF (N_FLUX.EQ.0) CALL NRERROR('disaggflux: no fluxes identified') -EFLAG=.FALSE. ! (initialize error flag) -! --------------------------------------------------------------------------------------- -DO IFLUX=1,N_FLUX - ! -------------------------------------------------------------------------------------- - ! (1) DISAGGREGATE FLUXES - ! -------------------------------------------------------------------------------------- - SELECT CASE(TRIM(C_FLUX(IFLUX)%FNAME)) - CASE('EFF_PPT') ; M_FLUX%EFF_PPT = FLUX_0%EFF_PPT + DOT_PRODUCT(FDFLUX(:)%EFF_PPT, DELS(:)) - CASE('EVAP_1A') ; M_FLUX%EVAP_1A = FLUX_0%EVAP_1A + DOT_PRODUCT(FDFLUX(:)%EVAP_1A, DELS(:)) - CASE('EVAP_1B') ; M_FLUX%EVAP_1B = FLUX_0%EVAP_1B + DOT_PRODUCT(FDFLUX(:)%EVAP_1B, DELS(:)) - CASE('EVAP_1') ; M_FLUX%EVAP_1 = FLUX_0%EVAP_1 + DOT_PRODUCT(FDFLUX(:)%EVAP_1, DELS(:)) - CASE('EVAP_2') ; M_FLUX%EVAP_2 = FLUX_0%EVAP_2 + DOT_PRODUCT(FDFLUX(:)%EVAP_2, DELS(:)) - CASE('RCHR2EXCS') ; M_FLUX%RCHR2EXCS = FLUX_0%RCHR2EXCS + DOT_PRODUCT(FDFLUX(:)%RCHR2EXCS, DELS(:)) - CASE('TENS2FREE_1'); M_FLUX%TENS2FREE_1 = FLUX_0%TENS2FREE_1 + DOT_PRODUCT(FDFLUX(:)%TENS2FREE_1,DELS(:)) - CASE('TENS2FREE_2'); M_FLUX%TENS2FREE_2 = FLUX_0%TENS2FREE_2 + DOT_PRODUCT(FDFLUX(:)%TENS2FREE_2,DELS(:)) - CASE('QSURF') ; M_FLUX%QSURF = FLUX_0%QSURF + DOT_PRODUCT(FDFLUX(:)%QSURF, DELS(:)) - CASE('QPERC_12') ; M_FLUX%QPERC_12 = FLUX_0%QPERC_12 + DOT_PRODUCT(FDFLUX(:)%QPERC_12, DELS(:)) - CASE('QINTF_1') ; M_FLUX%QINTF_1 = FLUX_0%QINTF_1 + DOT_PRODUCT(FDFLUX(:)%QINTF_1, DELS(:)) - CASE('QBASE_2') ; M_FLUX%QBASE_2 = FLUX_0%QBASE_2 + DOT_PRODUCT(FDFLUX(:)%QBASE_2, DELS(:)) - CASE('QBASE_2A') ; M_FLUX%QBASE_2A = FLUX_0%QBASE_2A + DOT_PRODUCT(FDFLUX(:)%QBASE_2A, DELS(:)) - CASE('QBASE_2B') ; M_FLUX%QBASE_2B = FLUX_0%QBASE_2B + DOT_PRODUCT(FDFLUX(:)%QBASE_2B, DELS(:)) - CASE('OFLOW_1') ; M_FLUX%OFLOW_1 = FLUX_0%OFLOW_1 + DOT_PRODUCT(FDFLUX(:)%OFLOW_1, DELS(:)) - CASE('OFLOW_2') ; M_FLUX%OFLOW_2 = FLUX_0%OFLOW_2 + DOT_PRODUCT(FDFLUX(:)%OFLOW_2, DELS(:)) - CASE('OFLOW_2A') ; M_FLUX%OFLOW_2A = FLUX_0%OFLOW_2A + DOT_PRODUCT(FDFLUX(:)%OFLOW_2A, DELS(:)) - CASE('OFLOW_2B') ; M_FLUX%OFLOW_2B = FLUX_0%OFLOW_2B + DOT_PRODUCT(FDFLUX(:)%OFLOW_2B, DELS(:)) - CASE DEFAULT ; CALL NRERROR('disaggflux: cannot find desired flux') - END SELECT - ! -------------------------------------------------------------------------------------- - ! (2) ENSURE THAT THE FLUXES ARE REALISTIC - ! -------------------------------------------------------------------------------------- - SELECT CASE(TRIM(C_FLUX(IFLUX)%FNAME)) - CASE('EFF_PPT') ; IF(M_FLUX%EFF_PPT .LT.ZERO) THEN; M_FLUX%EFF_PPT = ZERO; EFLAG=.TRUE.; ENDIF - CASE('EVAP_1A') ; IF(M_FLUX%EVAP_1A .LT.ZERO) THEN; M_FLUX%EVAP_1A = ZERO; EFLAG=.TRUE.; ENDIF - CASE('EVAP_1B') ; IF(M_FLUX%EVAP_1B .LT.ZERO) THEN; M_FLUX%EVAP_1B = ZERO; EFLAG=.TRUE.; ENDIF - CASE('EVAP_1') ; IF(M_FLUX%EVAP_1 .LT.ZERO) THEN; M_FLUX%EVAP_1 = ZERO; EFLAG=.TRUE.; ENDIF - CASE('EVAP_2') ; IF(M_FLUX%EVAP_2 .LT.ZERO) THEN; M_FLUX%EVAP_2 = ZERO; EFLAG=.TRUE.; ENDIF - CASE('RCHR2EXCS') ; IF(M_FLUX%RCHR2EXCS .LT.ZERO) THEN; M_FLUX%RCHR2EXCS = ZERO; EFLAG=.TRUE.; ENDIF - CASE('TENS2FREE_1'); IF(M_FLUX%TENS2FREE_1 .LT.ZERO) THEN; M_FLUX%TENS2FREE_1 = ZERO; EFLAG=.TRUE.; ENDIF - CASE('TENS2FREE_2'); IF(M_FLUX%TENS2FREE_2 .LT.ZERO) THEN; M_FLUX%TENS2FREE_2 = ZERO; EFLAG=.TRUE.; ENDIF - CASE('QSURF') ; IF(M_FLUX%QSURF .LT.ZERO) THEN; M_FLUX%QSURF = ZERO; EFLAG=.TRUE.; ENDIF - CASE('QPERC_12') ; IF(M_FLUX%QPERC_12 .LT.ZERO) THEN; M_FLUX%QPERC_12 = ZERO; EFLAG=.TRUE.; ENDIF - CASE('QINTF_1') ; IF(M_FLUX%QINTF_1 .LT.ZERO) THEN; M_FLUX%QINTF_1 = ZERO; EFLAG=.TRUE.; ENDIF - CASE('QBASE_2') ; IF(M_FLUX%QBASE_2 .LT.ZERO) THEN; M_FLUX%QBASE_2 = ZERO; EFLAG=.TRUE.; ENDIF - CASE('QBASE_2A') ; IF(M_FLUX%QBASE_2A .LT.ZERO) THEN; M_FLUX%QBASE_2A = ZERO; EFLAG=.TRUE.; ENDIF - CASE('QBASE_2B') ; IF(M_FLUX%QBASE_2B .LT.ZERO) THEN; M_FLUX%QBASE_2B = ZERO; EFLAG=.TRUE.; ENDIF - CASE('OFLOW_1') ; IF(M_FLUX%OFLOW_1 .LT.ZERO) THEN; M_FLUX%OFLOW_1 = ZERO; EFLAG=.TRUE.; ENDIF - CASE('OFLOW_2') ; IF(M_FLUX%OFLOW_2 .LT.ZERO) THEN; M_FLUX%OFLOW_2 = ZERO; EFLAG=.TRUE.; ENDIF - CASE('OFLOW_2A') ; IF(M_FLUX%OFLOW_2A .LT.ZERO) THEN; M_FLUX%OFLOW_2A = ZERO; EFLAG=.TRUE.; ENDIF - CASE('OFLOW_2B') ; IF(M_FLUX%OFLOW_2B .LT.ZERO) THEN; M_FLUX%OFLOW_2B = ZERO; EFLAG=.TRUE.; ENDIF - CASE DEFAULT ; CALL NRERROR('disaggflux: cannot find desired flux') - END SELECT -END DO ! (loop through fluxes) -! deal with surface runoff -IF(M_FLUX%QSURF.GT.M_FLUX%EFF_PPT) THEN; M_FLUX%QSURF = M_FLUX%EFF_PPT; EFLAG=.TRUE.; ENDIF -! deal with evaporation -TOTEVAP = M_FLUX%EVAP_1+M_FLUX%EVAP_2 -IF (TOTEVAP.GT.MFORCE%PET) THEN - M_FLUX%EVAP_1 = (M_FLUX%EVAP_1/TOTEVAP) * MFORCE%PET - M_FLUX%EVAP_2 = (M_FLUX%EVAP_2/TOTEVAP) * MFORCE%PET - EFLAG=.TRUE. -ENDIF -! --------------------------------------------------------------------------------------- -! (2) ENSURE THAT THE bucket overflow fluxes are less than the bucket INFLUX -! --------------------------------------------------------------------------------------- -DO ISTT=1,NSTATE - SELECT CASE(CSTATE(ISTT)%iSNAME) - CASE (iopt_TENS1A); IN_FLUX = M_FLUX%EFF_PPT - M_FLUX%QSURF - IF (M_FLUX%RCHR2EXCS .GT.IN_FLUX) THEN; M_FLUX%RCHR2EXCS =IN_FLUX; EFLAG=.TRUE.; ENDIF - CASE (iopt_TENS1B); IN_FLUX = M_FLUX%RCHR2EXCS - IF (M_FLUX%TENS2FREE_1.GT.IN_FLUX) THEN; M_FLUX%TENS2FREE_1=IN_FLUX; EFLAG=.TRUE.; ENDIF - CASE (iopt_TENS_1); IN_FLUX = M_FLUX%EFF_PPT - M_FLUX%QSURF - IF (M_FLUX%TENS2FREE_1.GT.IN_FLUX) THEN; M_FLUX%TENS2FREE_1=IN_FLUX; EFLAG=.TRUE.; ENDIF - CASE (iopt_FREE_1); IN_FLUX = M_FLUX%TENS2FREE_1 - IF (M_FLUX%OFLOW_1 .GT.IN_FLUX) THEN; M_FLUX%OFLOW_1 =IN_FLUX; EFLAG=.TRUE.; ENDIF - CASE (iopt_WATR_1); IN_FLUX = M_FLUX%EFF_PPT - M_FLUX%QSURF - IF (M_FLUX%OFLOW_1 .GT.IN_FLUX) THEN; M_FLUX%OFLOW_1 =IN_FLUX; EFLAG=.TRUE.; ENDIF - CASE (iopt_TENS_2); IN_FLUX = M_FLUX%QPERC_12*(1._SP-MPARAM%PERCFRAC) - IF (M_FLUX%TENS2FREE_2.GT.IN_FLUX) THEN; M_FLUX%TENS2FREE_2=IN_FLUX; EFLAG=.TRUE.; ENDIF - CASE (iopt_FREE2A); IN_FLUX = M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) - IF (M_FLUX%OFLOW_2A .GT.IN_FLUX) THEN; M_FLUX%OFLOW_2A =IN_FLUX; EFLAG=.TRUE.; ENDIF - CASE (iopt_FREE2B); IN_FLUX = M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) - IF (M_FLUX%OFLOW_2B .GT.IN_FLUX) THEN; M_FLUX%OFLOW_2B =IN_FLUX; EFLAG=.TRUE.; ENDIF - CASE (iopt_WATR_2); IN_FLUX = M_FLUX%QPERC_12 - IF (M_FLUX%OFLOW_2 .GT.IN_FLUX) THEN; M_FLUX%OFLOW_2 =IN_FLUX; EFLAG=.TRUE.; ENDIF - END SELECT -END DO -! --------------------------------------------------------------------------------------- -! compute total overflow from the lower zone -IF (SMODL%iARCH1.EQ.iopt_tension2_1) M_FLUX%OFLOW_2 = M_FLUX%OFLOW_2A + M_FLUX%OFLOW_2B -! --------------------------------------------------------------------------------------- -END SUBROUTINE DISAGGFLUX -END MODULE DISAGGFLUX_MODULE diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/evap_lower.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/evap_lower.f90.svn-base deleted file mode 100644 index 71eddab..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/evap_lower.f90.svn-base +++ /dev/null @@ -1,60 +0,0 @@ -SUBROUTINE EVAP_LOWER() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Computes evaporation from the lower soil layer -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multi_flux -- evaporation stored in MODULE multi_flux -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition structure -USE model_defnames -USE multiparam ! model parameters -USE multiforce ! model forcing -USE multistate ! model states -USE multi_flux ! model fluxes -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -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 SUBROUTINE EVAP_LOWER diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/evap_upper.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/evap_upper.f90.svn-base deleted file mode 100644 index b62b6a3..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/evap_upper.f90.svn-base +++ /dev/null @@ -1,66 +0,0 @@ -SUBROUTINE EVAP_UPPER() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Computes evaporation from the upper soil layer -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multi_flux -- evaporation stored in MODULE multi_flux -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition structure -USE model_defnames -USE multiparam ! model parameters -USE multiforce ! model forcing -USE multistate ! model states -USE multi_flux ! model fluxes -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iARCH1) ! upper layer architecture - ! -------------------------------------------------------------------------------------- - CASE(iopt_tension2_1) ! tension storage sub-divided into recharge and excess - ! -------------------------------------------------------------------------------------- - ! use different evaporation schemes for the upper layer - ! ----------------------------------------------------- - SELECT CASE(SMODL%iESOIL) - CASE(iopt_sequential) - M_FLUX%EVAP_1A = MFORCE%PET * TSTATE%TENS_1A/DPARAM%MAXTENS_1A - M_FLUX%EVAP_1B = (MFORCE%PET - M_FLUX%EVAP_1A) * TSTATE%TENS_1B/DPARAM%MAXTENS_1B - M_FLUX%EVAP_1 = M_FLUX%EVAP_1A + M_FLUX%EVAP_1B - CASE(iopt_rootweight) - M_FLUX%EVAP_1A = MFORCE%PET * MPARAM%RTFRAC1 * TSTATE%TENS_1A/DPARAM%MAXTENS_1A - M_FLUX%EVAP_1B = MFORCE%PET * DPARAM%RTFRAC2 * TSTATE%TENS_1B/DPARAM%MAXTENS_1B - M_FLUX%EVAP_1 = M_FLUX%EVAP_1A + M_FLUX%EVAP_1B - CASE DEFAULT - print *, "SMODL%iESOIL must be either iopt_sequential or iopt_rootweight" - STOP - END SELECT - ! -------------------------------------------------------------------------------------- - CASE(iopt_tension1_1,iopt_onestate_1) ! single tension store or single state - ! -------------------------------------------------------------------------------------- - ! use different evaporation schemes for the upper layer - ! ----------------------------------------------------- - SELECT CASE(SMODL%iESOIL) - CASE(iopt_sequential) - M_FLUX%EVAP_1A = 0._sp - M_FLUX%EVAP_1B = 0._sp - M_FLUX%EVAP_1 = MFORCE%PET * TSTATE%TENS_1/DPARAM%MAXTENS_1 - CASE(iopt_rootweight) - M_FLUX%EVAP_1A = 0._sp - M_FLUX%EVAP_1B = 0._sp - M_FLUX%EVAP_1 = MFORCE%PET * MPARAM%RTFRAC1 * TSTATE%TENS_1/DPARAM%MAXTENS_1 - CASE DEFAULT - print *, "SMODL%iESOIL must be either iopt_sequential or iopt_rootweight" - END SELECT ! (evaporation schemes) - ! -------------------------------------------------------------------------------------- - CASE DEFAULT - print *, "SMODL%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" - STOP - ! -------------------------------------------------------------------------------------- -END SELECT ! (upper-layer architechure) -END SUBROUTINE EVAP_UPPER diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fdjac.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fdjac.f90.svn-base deleted file mode 100644 index d764c91..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fdjac.f90.svn-base +++ /dev/null @@ -1,40 +0,0 @@ -SUBROUTINE fdjac(x,fvec,df) -USE nrtype; USE nrutil, ONLY : assert_eq -use funcv_mod -use model_numerix, ONLY : num_jacobian -IMPLICIT NONE -REAL(SP), DIMENSION(:), INTENT(IN) :: fvec -REAL(SP), DIMENSION(:), INTENT(INOUT) :: x -REAL(SP), DIMENSION(:,:), INTENT(OUT) :: df -!INTERFACE -! FUNCTION funcv(xtry) -! USE nrtype -! IMPLICIT NONE -! REAL(SP), DIMENSION(:), INTENT(IN) :: xtry -! REAL(SP), DIMENSION(size(xtry)) :: funcv -! END FUNCTION funcv -!END INTERFACE -REAL(SP), PARAMETER :: EPS=-1.0e-4_sp ! NOTE force h to be negative -INTEGER(I4B) :: j,n -REAL(SP), DIMENSION(size(x)) :: xsav,xph,h -REAL(SP), DIMENSION(size(df,1)) :: vv -n=assert_eq(size(x),size(fvec),size(df,1),size(df,2),'fdjac') -xsav=x -h=EPS*abs(xsav) -where (h == 0.0) h=EPS -xph=xsav+h -h=xph-xsav -do j=1,n - x(j)=xph(j) - df(:,j)=(funcv(x)-fvec(:))/h(j) - x(j)=xsav(j) -end do -! MPC check for zero derivative -vv=maxval(abs(df),dim=2) -if (any(vv == 0.0)) then - do j=1,n; write(*,'(10(e12.5,1x))') df(:,j); end do - stop ' fatal error: zero derivative in Jacobian ' -endif -! keep track of the number of times computing the Jacobian -num_jacobian = num_jacobian + 1 ! num_jacobian shared in module model_numerix -END SUBROUTINE fdjac diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fdjac_ode.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fdjac_ode.f90.svn-base deleted file mode 100644 index 6aacb0d..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fdjac_ode.f90.svn-base +++ /dev/null @@ -1,47 +0,0 @@ -MODULE fdjac_ode_module -IMPLICIT NONE -CONTAINS -SUBROUTINE fdjac_ode(x,dsdt,df,simeth) -USE nrtype; USE nrutil, ONLY : assert_eq -USE model_numerix, ONLY : num_jacobian -USE fuse_deriv_module -! Used to compute Jacobian of the ODE, based on the NR routine fdjac -IMPLICIT NONE -! input/output -REAL(SP), DIMENSION(:), INTENT(IN) :: dsdt ! state derivative -REAL(SP), DIMENSION(:), INTENT(INOUT) :: x ! trial state vector -REAL(SP), DIMENSION(:,:), INTENT(OUT) :: df ! Jacobian -LOGICAL(LGT), INTENT(IN), OPTIONAL :: simeth ! flag for semi-implicit Euler method -! internal -LOGICAL(LGT) :: fdflux ! flag to compute flux derivatives -REAL(SP), PARAMETER :: EPS=-1.0e-4_sp ! relative state change, NOTE force h to be negative -INTEGER(I4B) :: j,n ! loop through statesm number of states -REAL(SP) :: dx ! relative change in state -REAL(SP), DIMENSION(size(x)) :: xsav,xph,h ! perturbed states and change in states -! check size of input argumets -n=assert_eq(size(x),size(dsdt),size(df,1),size(df,2),'fdjac') -! if semi-implicit Euler method, then compute flux derivatives -fdflux=.false.; if (present(simeth)) fdflux=.true. -! save input x value -xsav=x -! compute step size -dx = EPS ! relative state change -!DK: dx-determination can be improved using the characteristic scale of state variables. -! current approach ok for the moment. -h = dx*abs(xsav) ! state change -where (h == 0.0) h=dx ! force state change to be non-zero -xph= xsav+h ! perturbed state -h = xph-xsav ! size of perturbation (trick to avoid rounding errors) -! compute Jacobian (and, if desired, compute the derivatives of the fluxes) -do j=1,n - x(j)=xph(j) ! perturb state - !print *, 'computing jacobian, j, x = '; write(*,'(i3,1x,10(e20.8,1x))') j, x - df(:,j)=(fuse_deriv(x)-dsdt(:))/h(j) ! compute row of the Jacobian - !print *, 'jac result '; write(*,'(10(e20.8,1x))') df(:,j) - if (fdflux) call flux_deriv(j,h(j)) ! compute flux derivatives for state j - x(j)=xsav(j) ! set state back to original value -end do -! keep track of the number of times computing the Jacobian -num_jacobian = num_jacobian + 1 ! num_jacobian shared in module model_numerix -END SUBROUTINE fdjac_ode -END MODULE fdjac_ode_module diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fix_states.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fix_states.f90.svn-base deleted file mode 100644 index 01a3bb2..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fix_states.f90.svn-base +++ /dev/null @@ -1,283 +0,0 @@ -SUBROUTINE FIX_STATES(DT,ERROR_FLAG) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Ensure states are within bounds, and disaggregate fluxes if necessary -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multistate -- populates the MODULE multistate with derivatives DY_DT%(*) -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition structure -USE model_defnames -USE multiparam ! model parameters -USE multiforce ! model forcing data -USE multistate ! model states -USE multi_flux ! model fluxes -USE model_numerix ! model numerix -IMPLICIT NONE -! input/output -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) -! --------------------------------------------------------------------------------------- -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_1)/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%FREE_2B.GT.DPARAM%MAXFREE_2B) 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 SUBROUTINE FIX_STATES diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/flux_deriv.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/flux_deriv.f90.svn-base deleted file mode 100644 index 1e70744..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/flux_deriv.f90.svn-base +++ /dev/null @@ -1,60 +0,0 @@ -SUBROUTINE FLUX_DERIV(J,DS) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Compute the flux derivatives, used in calculating time-step average fluxes in the -! semi-implicit Euler scheme -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! Finite-difference fluxes in MODULE multi_flux -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE nrutil, ONLY : nrerror ! error control -USE model_defn, ONLY: NSTATE,N_FLUX,C_FLUX ! number of state variables -USE multi_flux, ONLY: FLUX_0,M_FLUX,FDFLUX ! model fluxes -IMPLICIT NONE -! input -INTEGER(I4B), INTENT(IN) :: J ! index of state variable -REAL(SP), INTENT(IN) :: DS ! difference in state variable -! internal -INTEGER(I4B) :: IFLUX ! loop thru fluxes -INTEGER(I4B) :: IERR ! error code for the allocate statement -! --------------------------------------------------------------------------------------- -! make sure that the finite-difference flux structure is allocated -IF (.NOT.ASSOCIATED(FDFLUX)) THEN - ALLOCATE(FDFLUX(NSTATE), STAT=IERR ) ! NSTATE in structure model_defn - IF (IERR.NE.0) CALL NRERROR('flux_deriv: problem allocating fdflux') -ENDIF -! make sure that there are some fluxes -IF (N_FLUX.EQ.0) CALL NRERROR('flux_deriv: number of fluxes is zero') -! --------------------------------------------------------------------------------------- -DO IFLUX=1,N_FLUX - SELECT CASE(TRIM(C_FLUX(IFLUX)%FNAME)) - CASE('EFF_PPT') ; FDFLUX(J)%EFF_PPT = (M_FLUX%EFF_PPT - FLUX_0%EFF_PPT) / DS - CASE('EVAP_1A') ; FDFLUX(J)%EVAP_1A = (M_FLUX%EVAP_1A - FLUX_0%EVAP_1A) / DS - CASE('EVAP_1B') ; FDFLUX(J)%EVAP_1B = (M_FLUX%EVAP_1B - FLUX_0%EVAP_1B) / DS - CASE('EVAP_1') ; FDFLUX(J)%EVAP_1 = (M_FLUX%EVAP_1 - FLUX_0%EVAP_1) / DS - CASE('EVAP_2') ; FDFLUX(J)%EVAP_2 = (M_FLUX%EVAP_2 - FLUX_0%EVAP_2) / DS - CASE('RCHR2EXCS') ; FDFLUX(J)%RCHR2EXCS = (M_FLUX%RCHR2EXCS - FLUX_0%RCHR2EXCS) / DS - CASE('TENS2FREE_1'); FDFLUX(J)%TENS2FREE_1 = (M_FLUX%TENS2FREE_1 - FLUX_0%TENS2FREE_1) / DS - CASE('TENS2FREE_2'); FDFLUX(J)%TENS2FREE_2 = (M_FLUX%TENS2FREE_2 - FLUX_0%TENS2FREE_2) / DS - CASE('QSURF') ; FDFLUX(J)%QSURF = (M_FLUX%QSURF - FLUX_0%QSURF) / DS - CASE('QPERC_12') ; FDFLUX(J)%QPERC_12 = (M_FLUX%QPERC_12 - FLUX_0%QPERC_12) / DS - CASE('QINTF_1') ; FDFLUX(J)%QINTF_1 = (M_FLUX%QINTF_1 - FLUX_0%QINTF_1) / DS - CASE('QBASE_2') ; FDFLUX(J)%QBASE_2 = (M_FLUX%QBASE_2 - FLUX_0%QBASE_2) / DS - CASE('QBASE_2A') ; FDFLUX(J)%QBASE_2A = (M_FLUX%QBASE_2A - FLUX_0%QBASE_2A) / DS - CASE('QBASE_2B') ; FDFLUX(J)%QBASE_2B = (M_FLUX%QBASE_2B - FLUX_0%QBASE_2B) / DS - CASE('OFLOW_1') ; FDFLUX(J)%OFLOW_1 = (M_FLUX%OFLOW_1 - FLUX_0%OFLOW_1) / DS - CASE('OFLOW_2') ; FDFLUX(J)%OFLOW_2 = (M_FLUX%OFLOW_2 - FLUX_0%OFLOW_2) / DS - CASE('OFLOW_2A') ; FDFLUX(J)%OFLOW_2A = (M_FLUX%OFLOW_2A - FLUX_0%OFLOW_2A) / DS - CASE('OFLOW_2B') ; FDFLUX(J)%OFLOW_2B = (M_FLUX%OFLOW_2B - FLUX_0%OFLOW_2B) / DS - CASE DEFAULT ; CALL NRERROR('flux_deriv: cannot find desired state') - END SELECT -END DO ! (loop through fluxes) -! --------------------------------------------------------------------------------------- -END SUBROUTINE FLUX_DERIV diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fmin.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fmin.f90.svn-base deleted file mode 100644 index ecdce20..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fmin.f90.svn-base +++ /dev/null @@ -1,32 +0,0 @@ -MODULE fminln - USE nrtype; USE nrutil, ONLY : nrerror - REAL(SP), POINTER :: fmin_dtp ! time step - REAL(SP), POINTER :: fmin_dt2p ! half time step - REAL(SP), DIMENSION(:), POINTER :: fmin_x0p ! initial state - REAL(SP), DIMENSION(:), POINTER :: fmin_dseep ! change in state by explicit euler - REAL(SP), DIMENSION(:), POINTER :: fmin_dsdtp ! state derivatives - REAL(SP), DIMENSION(:), POINTER :: fmin_fvecp ! residuals of the discrete system -CONTAINS -!BL - FUNCTION fmin(x) - USE model_numerix ! provide access to the model numerix decisions - USE fuse_deriv_module ! provide access to the function to compute model derivatives - IMPLICIT NONE - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP) :: fmin - if (.not.associated(fmin_x0p) .or. .not.associated(fmin_dtp) .or. & - .not.associated(fmin_dt2p) .or. .not.associated(fmin_dseep) .or. & - .not.associated(fmin_dsdtp) .or. .not.associated(fmin_fvecp) ) & - call nrerror('fmin: problem with pointer for returned values') - fmin_dsdtp = fuse_deriv(x) ! calculate derivatives - SELECT CASE(SOLUTION_METHOD) - CASE(IMPLICIT_EULER); fmin_fvecp = x - (fmin_x0p + fmin_dtp*fmin_dsdtp) - !print *, 'in fmin, x = ', x - !print *, 'in fmin, x0 + dt * dsdt = ', fmin_x0p + fmin_dtp*fmin_dsdtp - !print *, 'in fmin, fvec = ', fmin_fvecp - CASE(IMPLICIT_HEUN); fmin_fvecp = x - (fmin_x0p + fmin_dt2p*fmin_dsdtp + fmin_dseep) - CASE DEFAULT; call nrerror('fmin: solution method must be either implicit euler or implicit heun') - END SELECT - fmin=0.5_sp*dot_product(fmin_fvecp,fmin_fvecp) - END FUNCTION fmin -END MODULE fminln diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/frac_error.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/frac_error.f90.svn-base deleted file mode 100644 index b6faf2e..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/frac_error.f90.svn-base +++ /dev/null @@ -1,40 +0,0 @@ -module frac_error_mod -implicit none -contains -FUNCTION FRAC_ERROR(X_END1,X_END2) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Calculates the fractional error in each state (relative to state capacity) -! for one-step and two step implicit solutions -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definitions -USE model_defnames -USE multiparam ! model parameters -IMPLICIT NONE -! input/output -REAL(SP), DIMENSION(:), INTENT(IN) :: X_END1 ! one-step solution -REAL(SP), DIMENSION(:), INTENT(IN) :: X_END2 ! two-step solution -REAL(SP), DIMENSION(SIZE(X_END1)) :: FRAC_ERROR ! fractional error -! internal -INTEGER(I4B) :: ISTT ! loop through model states -! --------------------------------------------------------------------------------------- -DO ISTT=1,NSTATE - IF (CSTATE(ISTT)%iSNAME.EQ.iopt_TENS1A) FRAC_ERROR(ISTT) = ABS(X_END1(ISTT)-X_END2(ISTT))/DPARAM%MAXTENS_1A - IF (CSTATE(ISTT)%iSNAME.EQ.iopt_TENS1B) FRAC_ERROR(ISTT) = ABS(X_END1(ISTT)-X_END2(ISTT))/DPARAM%MAXTENS_1B - IF (CSTATE(ISTT)%iSNAME.EQ.iopt_TENS_1) FRAC_ERROR(ISTT) = ABS(X_END1(ISTT)-X_END2(ISTT))/DPARAM%MAXTENS_1 - IF (CSTATE(ISTT)%iSNAME.EQ.iopt_FREE_1) FRAC_ERROR(ISTT) = ABS(X_END1(ISTT)-X_END2(ISTT))/DPARAM%MAXFREE_1 - IF (CSTATE(ISTT)%iSNAME.EQ.iopt_WATR_1) FRAC_ERROR(ISTT) = ABS(X_END1(ISTT)-X_END2(ISTT))/MPARAM%MAXWATR_1 - IF (CSTATE(ISTT)%iSNAME.EQ.iopt_TENS_2) FRAC_ERROR(ISTT) = ABS(X_END1(ISTT)-X_END2(ISTT))/DPARAM%MAXTENS_2 - IF (CSTATE(ISTT)%iSNAME.EQ.iopt_FREE2A) FRAC_ERROR(ISTT) = ABS(X_END1(ISTT)-X_END2(ISTT))/DPARAM%MAXFREE_2A - IF (CSTATE(ISTT)%iSNAME.EQ.iopt_FREE2B) FRAC_ERROR(ISTT) = ABS(X_END1(ISTT)-X_END2(ISTT))/DPARAM%MAXFREE_2B - IF (CSTATE(ISTT)%iSNAME.EQ.iopt_WATR_2) FRAC_ERROR(ISTT) = ABS(X_END1(ISTT)-X_END2(ISTT))/MPARAM%MAXWATR_2 -END DO -! --------------------------------------------------------------------------------------- -END FUNCTION FRAC_ERROR -endmodule frac_error_mod diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/funcv.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/funcv.f90.svn-base deleted file mode 100644 index 69f4f4d..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/funcv.f90.svn-base +++ /dev/null @@ -1,63 +0,0 @@ -module funcv_mod -implicit none -contains -FUNCTION FUNCV(X_TRY) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Returns a vector of errors from the state equations, evaluated at X_TRY -! -! That is, -! X_NEW(1) = X_OLD(1) + DYDX( X_TRY(1) ) * delT -! X_NEW(2) = X_OLD(2) + DYDX( X_TRY(2) ) * delT -! ... -! X_NEW(N) = X_OLD(N) + DYDX( X_TRY(N) ) * delT -! -! So... -! FUNCV(1) = X_NEW(1) - X_TRY(1) -! FUNCV(2) = X_NEW(2) - X_TRY(2) -! -! FUNCV(N) = X_NEW(N) - X_TRY(N) -! -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn, ONLY:CSTATE,NSTATE ! model definition structures -USE model_defnames -USE multistate, ONLY:TSTATE,MSTATE,DY_DT,HSTATE ! model states -USE xtry_2_str_module ! puts state vector into structure in multistate -IMPLICIT NONE -! input/output -REAL(SP), DIMENSION(:), INTENT(IN) :: X_TRY ! vector of model states -REAL(SP), DIMENSION(SIZE(X_TRY)) :: FUNCV ! function evaluations -! internal -INTEGER(I4B) :: ISTT ! loop through model states -! --------------------------------------------------------------------------------------- -! (1) COMPUTE MODEL DERIVATIVES -! --------------------------------------------------------------------------------------- -CALL XTRY_2_STR(X_TRY,TSTATE) ! populate state structure TSTATE with values of X -CALL MOD_DERIVS() ! evaluate dxdt for state vector X_TRY -! --------------------------------------------------------------------------------------- -! (2) COMPUTE FUNCTION VALUES -! --------------------------------------------------------------------------------------- -DO ISTT=1,NSTATE - SELECT CASE(CSTATE(ISTT)%iSNAME) - CASE (iopt_TENS1A); FUNCV(ISTT) = MSTATE%TENS_1A + DY_DT%TENS_1A*HSTATE%STEP - X_TRY(ISTT) - CASE (iopt_TENS1B); FUNCV(ISTT) = MSTATE%TENS_1B + DY_DT%TENS_1B*HSTATE%STEP - X_TRY(ISTT) - CASE (iopt_TENS_1); FUNCV(ISTT) = MSTATE%TENS_1 + DY_DT%TENS_1 *HSTATE%STEP - X_TRY(ISTT) - CASE (iopt_FREE_1); FUNCV(ISTT) = MSTATE%FREE_1 + DY_DT%FREE_1 *HSTATE%STEP - X_TRY(ISTT) - CASE (iopt_WATR_1); FUNCV(ISTT) = MSTATE%WATR_1 + DY_DT%WATR_1 *HSTATE%STEP - X_TRY(ISTT) - CASE (iopt_TENS_2); FUNCV(ISTT) = MSTATE%TENS_2 + DY_DT%TENS_2 *HSTATE%STEP - X_TRY(ISTT) - CASE (iopt_FREE2A); FUNCV(ISTT) = MSTATE%FREE_2A + DY_DT%FREE_2A*HSTATE%STEP - X_TRY(ISTT) - CASE (iopt_FREE2B); FUNCV(ISTT) = MSTATE%FREE_2B + DY_DT%FREE_2B*HSTATE%STEP - X_TRY(ISTT) - CASE (iopt_WATR_2); FUNCV(ISTT) = MSTATE%WATR_2 + DY_DT%WATR_2 *HSTATE%STEP - X_TRY(ISTT) - CASE DEFAULT; STOP 'fatal error: cannot identify the state variable' - END SELECT - print *, desc_int2str(CSTATE(ISTT)%iSNAME), FUNCV(ISTT), HSTATE%STEP -END DO -! --------------------------------------------------------------------------------------- -END FUNCTION FUNCV -endmodule funcv_mod diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fuse_deriv.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fuse_deriv.f90.svn-base deleted file mode 100644 index c21c86f..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fuse_deriv.f90.svn-base +++ /dev/null @@ -1,30 +0,0 @@ -MODULE FUSE_DERIV_MODULE -IMPLICIT NONE -CONTAINS -! --------------------------------------------------------------------------------------- -FUNCTION FUSE_DERIV(S) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Used to calculate derivatives from a specified FUSE model, includes -! (1) Put state vector in model data structures -! (2) Compute fluxes and derivatives -! (3) Extract derivatives from model structure -! --------------------------------------------------------------------------------------- -USE nrtype ! numerical recipes data types -USE multistate, ONLY:TSTATE,DY_DT ! model data structures -USE str_2_xtry_module ! provide access to str_2_xtry -USE xtry_2_str_module ! provide access to xtry_2_str -IMPLICIT NONE -REAL(SP), DIMENSION(:), INTENT(IN) :: S ! storage -REAL(SP), DIMENSION(SIZE(S)) :: FUSE_DERIV ! FUNCTION name -CALL XTRY_2_STR(S,TSTATE) ! (1) Put state vector in model data structures -CALL MOD_DERIVS() ! (2) Compute fluxes and derivatives -CALL STR_2_XTRY(DY_DT,FUSE_DERIV) ! (3) Extract derivatives from model structure -END FUNCTION FUSE_DERIV -! --------------------------------------------------------------------------------------- -END MODULE FUSE_DERIV_MODULE diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fuse_sieul.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fuse_sieul.f90.svn-base deleted file mode 100644 index ec6cae7..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fuse_sieul.f90.svn-base +++ /dev/null @@ -1,62 +0,0 @@ -MODULE FUSE_SIEUL_MODULE -IMPLICIT NONE -CONTAINS -! --------------------------------------------------------------------------------------- -SUBROUTINE FUSE_SIEUL(SINI,DSDT0,DT,IERR,MESSAGE) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! A FUSE-specific routine for the temporal integration of ordinary differential equations -! using the semi-implicit Euler method -! --------------------------------------------------------------------------------------- -! Modules Modified: -! -------- -! Populates M_FLUX in module multi_flux (in the routine disaggflux) -! --------------------------------------------------------------------------------------- -USE nrtype ! data types -USE nrutil, ONLY: diagadd ! utility to add identity matrix -USE nr, ONLY: ludcmp,lubksb ! provide access to the LU solver -USE fdjac_ode_module ! provide access to fdjac_ode -USE disaggflux_module ! provide access to disaggflux -IMPLICIT NONE -! input -REAL(SP), DIMENSION(:), INTENT(IN) :: SINI ! initial state vector -REAL(SP), DIMENSION(:), INTENT(IN) :: DSDT0 ! initial state derivatives -REAL(SP), INTENT(IN) :: DT ! time step -! internal -INTEGER(I4B) :: ISTT ! looping through states -REAL(SP), DIMENSION(SIZE(SINI)) :: STRY ! trial state vector, used in FDJAC_ODE -REAL(SP), DIMENSION(SIZE(SINI),SIZE(SINI)) :: JAC_ODE ! Jacobian of the ODE -REAL(SP), DIMENSION(SIZE(SINI),SIZE(SINI)) :: FJAC ! Jacobian matrix -INTEGER(I4B), DIMENSION(SIZE(SINI)) :: INDX ! Row permutations from partial pivoting (LUDCMP) -REAL(SP) :: D ! Denotes the number of row interchanges (LUDCMP) -REAL(SP), DIMENSION(SIZE(SINI)) :: DELS ! Change in state variables -LOGICAL(LGT) :: EFLAG ! Error flag -! output -- note: derivatives stored in the FUSE data structures) -INTEGER(I4B), INTENT(OUT) :: IERR ! error code -CHARACTER(*), INTENT(OUT) :: MESSAGE ! error message -! --------------------------------------------------------------------------------------- -! initialize errors -IERR=0; MESSAGE='fuse_sieul: just started' -! calculate Jacobian at S(n) -- and also calculate flux derivatives (SIMETH=.true.) -STRY=SINI ! need to calculate Jacobian at S(n), but want to preserve SINI -CALL FDJAC_ODE(STRY,DSDT0,JAC_ODE,SIMETH=.TRUE.) ! calculate Jacobian of the ODE -FJAC=-DT*JAC_ODE; CALL DIAGADD(FJAC,1._SP) ! compute (I - DT dg/dS) -! preliminaries before solving linear system -DELS=DT*DSDT0 ! set up RHS of the linear system -! solve linear system delS = Jac**-1 dt*dSdt -CALL LUDCMP(FJAC,INDX,D) ! decompose Jacobian -CALL LUBKSB(FJAC,INDX,DELS) ! solve for delS -! disaggregate fluxes -CALL DISAGGFLUX(DELS,EFLAG) ! disaggregate fluxes (store in structure M_FLUX) -! process warning (negative error code) -IF (EFLAG) THEN; IERR=-20; MESSAGE='fuse_sieul: unusual flux calculation; truncated'; ENDIF -! re-compute derivatives (use structure M_FLUX populated in disaggflux) -CALL MSTATE_EQN() -! --------------------------------------------------------------------------------------- -END SUBROUTINE FUSE_SIEUL -END MODULE FUSE_SIEUL_MODULE diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fuse_solve.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fuse_solve.f90.svn-base deleted file mode 100644 index dd4ec5b..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/fuse_solve.f90.svn-base +++ /dev/null @@ -1,251 +0,0 @@ -SUBROUTINE FUSE_SOLVE(CALCDSDT,IE_SOLVE,SI_SOLVE,B_IMPOSE,AVG_FLUX,ADD_FLUX,NEWSTATE, & ! define functionality of the routine - DT,S0,S1,DSDT,NEWSTEP,CONVCHECK,NITER,SOLUTION,HBOUND, & ! input/output - IERR,MESSAGE) ! error control -! Used to -! (1) calculate dS/dt for the input vector S0 -! (2) solve for S using the implicit Euler method -! (3) solve for S using the semi-implicit Euler method -! (4) average fluxes from the start and end of the sub-step -! (5) impose bounds on model states (and disaggregate fluxes) -! (6) add fluxes from accepted sub-steps to the total timestep flux -! (7) estimate state at end of a full step, based on sum of fluxes -USE nrtype ! variable definitions, etc. -USE multi_flux, ONLY: M_FLUX,FLUX_0,FLUX_1,W_FLUX,& ! model fluxes - CURRENT_DT ! model fluxes (continued) -USE multistate, ONLY: FSTATE,MSTATE,BSTATE,ESTATE,& ! model states - DY_DT,DYDT_0,DYDT_1,HSTATE ! model states (continued) -USE fminln, ONLY: fmin_x0p,fmin_dtp,fmin_dt2p,fmin_dseep ! variables used for residual vector in IE -USE xtry_2_str_module ! provide access to xtry_2_str -USE str_2_xtry_module ! provide access to str_2_xtry -USE fuse_deriv_module ! provide access to derivatives -USE fuse_sieul_module ! provide access to the semi-implicit Euler function -USE newtoniter_mod ! provide access to newtoniter -IMPLICIT NONE -! input/output variables -LOGICAL(LGT), INTENT(IN),OPTIONAL :: CALCDSDT ! FLAG to calculate derivatives at S0 -LOGICAL(LGT), INTENT(IN),OPTIONAL :: IE_SOLVE ! FLAG to compute the implicit Euler solution -LOGICAL(LGT), INTENT(IN),OPTIONAL :: SI_SOLVE ! FLAG to compute the semi-implicit Euler solution -LOGICAL(LGT), INTENT(IN),OPTIONAL :: B_IMPOSE ! FLAG to impose bounds on model state -LOGICAL(LGT), INTENT(IN),OPTIONAL :: AVG_FLUX ! FLAG to average fluxes from start & end states -LOGICAL(LGT), INTENT(IN),OPTIONAL :: ADD_FLUX ! FLAG to add accepted fluxes to the total flux -LOGICAL(LGT), INTENT(IN),OPTIONAL :: NEWSTATE ! FLAG to use weighted fluxes to compute end state -REAL(SP), INTENT(IN), OPTIONAL :: DT ! length of the sub-step -REAL(SP), DIMENSION(:),INTENT(IN), OPTIONAL :: S0 ! input state vector -REAL(SP), DIMENSION(:), INTENT(OUT),OPTIONAL :: S1 ! state vector from the implicit euler solution -REAL(SP), DIMENSION(:),INTENT(INOUT),OPTIONAL :: DSDT ! state derivatives -LOGICAL(LGT), INTENT(IN),OPTIONAL :: NEWSTEP ! FLAG to denote a new model time step -LOGICAL(LGT), INTENT(OUT),OPTIONAL :: CONVCHECK ! FLAG to check for convergence of the implicit scheme -INTEGER(I4B), INTENT(OUT), OPTIONAL :: NITER ! number of iterations -INTEGER(I4B), INTENT(IN), OPTIONAL :: SOLUTION ! solution is at start (0) or end (1) of sub-step -LOGICAL(LGT), INTENT(OUT),OPTIONAL :: HBOUND ! FLAG to denote if the states were out of bounds -INTEGER(I4B), INTENT(OUT) :: IERR ! error code -CHARACTER(LEN=*), INTENT(OUT) :: MESSAGE ! error message -! internal variables -REAL(SP), PARAMETER :: XACC=1.E-10 ! accuracy of implicit estimate -LOGICAL(LGT) :: ERROR_FLAG ! FLAG to denote if violated constraints -REAL(SP), TARGET :: DT1 ! full time step -REAL(SP), TARGET :: DT2 ! half time step -REAL(SP), DIMENSION(:), ALLOCATABLE, TARGET :: XI ! initial state vector -REAL(SP), DIMENSION(:), ALLOCATABLE, TARGET :: DSEE ! change in state by explicit euler -REAL(SP), DIMENSION(:), ALLOCATABLE :: DSDT0 ! state derivative at start of step -REAL(SP), DIMENSION(:), ALLOCATABLE :: DSDT_SIE ! state derivative for semi-implicit euler -! --------------------------------------------------------------------------------------- -IERR=0; MESSAGE='fuse_solve, just started' -! --------------------------------------------------------------------------------------- -! (1) CALCULATE DERIVATIVES -! --------------------------------------------------------------------------------------- -IF (PRESENT(CALCDSDT)) THEN - IF (CALCDSDT) THEN - ! check that we have passed what we need - IF (.NOT.PRESENT(S0) .OR. .NOT.PRESENT(DT) .OR. .NOT.PRESENT(DSDT) .OR. .NOT.PRESENT(SOLUTION) ) THEN - IF (.NOT.PRESENT(S0)) MESSAGE='need S0 to calculate model derivatives' - IF (.NOT.PRESENT(DT)) MESSAGE='need DT to calculate model derivatives' - IF (.NOT.PRESENT(DSDT)) MESSAGE='need DSDT to calculate model derivatives' - IF (.NOT.PRESENT(SOLUTION)) MESSAGE='need SOLUTION to calculate model derivatives' - IERR=20; RETURN - ENDIF - ! put DT into model flux structures - CURRENT_DT = DT - ! calculate derivatives - DSDT = FUSE_DERIV(S0) ! calculate derivatives - ! save information in model structures - SELECT CASE(SOLUTION) - CASE(0) - FLUX_0 = M_FLUX ! save fluxes at the start of the sub-step - DYDT_0 = DY_DT ! save derivatives at the start of the sub-step - CASE(1) - FLUX_1 = M_FLUX ! save fluxes at the end of the sub-step - DYDT_1 = DY_DT ! save derivatives at the start of the sub-step - END SELECT - ELSE - ! check that we have passed what we need - IF (.NOT.PRESENT(SOLUTION)) THEN - MESSAGE='need SOLUTION to calculate model derivatives'; IERR=20; RETURN - ENDIF - ! extract information from model structures - SELECT CASE(SOLUTION) - CASE(0) - M_FLUX = FLUX_0 ! extract fluxes from the start of the sub-step - DY_DT = DYDT_0 ! extract derivatives from the start of the sub-step - CASE(1) - M_FLUX = FLUX_1 ! extract fluxes from the end of the sub-step - DY_DT = DYDT_1 ! extract derivatives from the start of the sub-step - END SELECT - ENDIF -ENDIF -! --------------------------------------------------------------------------------------- -! (2) ESTIMATE NEW VECTOR OF STATES USING THE IMPLICIT EULER/HEUN METHOD -! --------------------------------------------------------------------------------------- -IF (PRESENT(IE_SOLVE)) THEN - IF (IE_SOLVE) THEN - ! check that we have passed what we need - IF (.NOT.PRESENT(S0) .OR. .NOT.PRESENT(S1) .OR. .NOT.PRESENT(DSDT) .OR. .NOT.PRESENT(DT) .OR. & - .NOT.PRESENT(NEWSTEP) .OR. .NOT.PRESENT(CONVCHECK) .OR. .NOT.PRESENT(NITER)) THEN - IF (.NOT.PRESENT(S0)) MESSAGE='need S0 for the implicit euler solution' - IF (.NOT.PRESENT(S1)) MESSAGE='need S1 for the implicit euler solution' - IF (.NOT.PRESENT(DT)) MESSAGE='need DT for the implicit euler solution' - IF (.NOT.PRESENT(DSDT)) MESSAGE='need DYDT for the implicit euler solution' - IF (.NOT.PRESENT(NEWSTEP)) MESSAGE='need NEWSTEP for the implicit euler solution' - IF (.NOT.PRESENT(CONVCHECK)) MESSAGE='need CONVCHECK for the implicit euler solution' - IF (.NOT.PRESENT(NITER)) MESSAGE='need NITER for the implicit euler solution' - IERR=20; RETURN - ENDIF - ! alolocate space for pointer targets - allocate(xi(size(s0)),dsee(size(s0)),dsdt0(size(s0)), stat=ierr) - if (ierr.ne.0) then; ierr=20; message='fuse_solve: problem allocating space'; endif - ! make pointer assignments for initial state and time steps (used in fminln for calc residual vector) - fmin_x0p =>xi ! provide access to the initial state used in fmin - fmin_dtp =>dt1 ! provide access to the time step used in fmin - fmin_dt2p =>dt2 ! provide access to the half time step used in fmin - fmin_dseep=>dsee ! provide access to the vector of change in state by explicit euler - ! put DT into model flux structures - CURRENT_DT = DT - ! populate targets - DT1=DT ! full sub-step - DT2=DT/2._SP ! half sub-step - CALL STR_2_XTRY(MSTATE,XI) ! retrieve state at the start of the sub-step - CALL STR_2_XTRY(DYDT_0,DSDT0) ! retrieve derivatives at the start of the sub-step - DSEE = DSDT0*DT2 ! calculate explicit euler component of Heun solution - ! compute the IE solution - S1 = S0 ! S1 over-written on output - CALL NEWTONITER(S1,NEWSTEP,CONVCHECK,NITER) ! try different values of X until converge - FLUX_1 = M_FLUX ! save fluxes at end of sub-step (save in model structure) - DYDT_1 = DY_DT ! save derivs at end of sub-step (save in model structure) - CALL STR_2_XTRY(DY_DT,DSDT) ! extract derivatives from model structure, and return to ODE_INT - ! deallocate space for pointer targets - deallocate(xi,dsee,dsdt0, stat=ierr) - if (ierr.ne.0) then; ierr=20; message='fuse_solve: problem deallocating space'; endif - ENDIF -ENDIF -! --------------------------------------------------------------------------------------- -! (3) ESTIMATE NEW VECTOR OF STATES USING THE SEMI-IMPLICIT EULER METHOD -! --------------------------------------------------------------------------------------- -IF (PRESENT(SI_SOLVE)) THEN - IF (SI_SOLVE) THEN - ! check that we have passed what we need - IF (.NOT.PRESENT(S0) .OR. .NOT.PRESENT(S1) .OR. .NOT.PRESENT(DSDT) .OR. .NOT.PRESENT(DT)) THEN - IF (.NOT.PRESENT(S0)) MESSAGE='need S0 for the semi-implicit euler solution' - IF (.NOT.PRESENT(S1)) MESSAGE='need S1 for the semi-implicit euler solution' - IF (.NOT.PRESENT(DSDT)) MESSAGE='need DSDT for the semi-implicit euler solution' - IF (.NOT.PRESENT(DT)) MESSAGE='need DT for the semi-implicit euler solution' - IERR=20; RETURN - ENDIF - ! allocate space - ALLOCATE(DSDT_SIE(SIZE(S0)), STAT=IERR) - IF (IERR.NE.0) THEN; IERR=20; MESSAGE='fuse_solve: problem allocating space'; ENDIF - ! put DT into model flux structures - CURRENT_DT = DT - ! estimate new derivatives using the semi-implicit method - CALL FUSE_SIEUL(S0,DSDT,DT,IERR,MESSAGE) ! somewhat FUSE-specific - CALL STR_2_XTRY(DY_DT,DSDT_SIE) ! extract derivatives from the FUSE data structures - ! compute new state - S1 = S0 + DSDT_SIE*DT - ! deallocate space - DEALLOCATE(DSDT_SIE, STAT=IERR) - IF (IERR.NE.0) THEN; IERR=20; MESSAGE='fuse_solve: problem deallocating space'; ENDIF - ENDIF -ENDIF -! --------------------------------------------------------------------------------------- -! (4) AVERAGE FLUXES FROM START & END OF STEP (NECESSARY IF ACCEPT HIGHER ORDER SOLUTION) -! --------------------------------------------------------------------------------------- -IF (PRESENT(AVG_FLUX)) THEN - IF (AVG_FLUX) THEN ! Case 1: Higher-order solution accepted - ! average fluxes and derivatives from the start and end of the step - CALL MEANFLUXES() - ELSE ! Case 2: Lower-order solution accepted - ! check that the solution argument is present - IF (.NOT.PRESENT(SOLUTION)) THEN - MESSAGE='need SOLUTION to assign fluxes and derivatives'; IERR=20; RETURN - ENDIF - ! assign fluxes from the appropriate solution - SELECT CASE(SOLUTION) - CASE(0) ! explicit euler: save fluxes and derivatives at start of sub-step - M_FLUX = FLUX_0 - DY_DT = DYDT_0 - CASE(1) ! implicit euler: save fluxes and derivatives at end of sub-step - M_FLUX = FLUX_1 - DY_DT = DYDT_1 - END SELECT - ENDIF -ENDIF -! --------------------------------------------------------------------------------------- -! (5) IMPOSE BOUNDS ON MODEL STATES (AND DISAGGREGATE FLUXES) -! --------------------------------------------------------------------------------------- -IF (PRESENT(B_IMPOSE)) THEN - IF (B_IMPOSE) THEN - ! check that we have passed what we need - IF (.NOT.PRESENT(S0) .OR. .NOT.PRESENT(S1) .OR. .NOT.PRESENT(DT) .OR. & - .NOT.PRESENT(HBOUND)) THEN - IF (.NOT.PRESENT(S0)) MESSAGE='need S0 to impose bounds on model states' - IF (.NOT.PRESENT(S1)) MESSAGE='need S1 to impose bounds on model states' - IF (.NOT.PRESENT(DT)) MESSAGE='need DT to impose bounds on model states' - IF (.NOT.PRESENT(HBOUND)) MESSAGE='need HBOUND to impose bounds on model states' - IERR=20; RETURN - ENDIF - ! put the model states in the appropriate structures - BSTATE = MSTATE ! state at the start of the sub-step - CALL XTRY_2_STR(S0,ESTATE) ! extrapolated state at the end of the sub-step - ! constrain bounds - CALL FIX_STATES(DT,ERROR_FLAG) ! ERROR_FLAG is a logical flag to denote if hit bound - HBOUND=ERROR_FLAG - ! extract states from the model structure - CALL STR_2_XTRY(ESTATE,S1) ! corrected state at the end of the sub-step - ENDIF -ENDIF -! --------------------------------------------------------------------------------------- -! (6) ADD FLUXES FROM ACCEPTED SUB-STEPS TO THE TOTAL TIMESTEP FLUX -! --------------------------------------------------------------------------------------- -IF (PRESENT(ADD_FLUX)) THEN - IF (ADD_FLUX) THEN - ! check that S1 and DT are present - IF (.NOT.PRESENT(S1) .OR. .NOT.PRESENT(DT)) THEN - IF (.NOT.PRESENT(S1)) MESSAGE='need S1 to aggregate fluxes and save states' - IF (.NOT.PRESENT(DT)) MESSAGE='need DT to aggregate fluxes and save states' - IERR=20; RETURN - ENDIF - ! aggregate fluxes and save states - HSTATE%STEP = DT ! insert the time interval into the data structures - CALL WGT_FLUXES() ! compute the contribution of the flux over the time interval DT - CALL XTRY_2_STR(S1,MSTATE) ! update MSTATE - ENDIF -ENDIF -! --------------------------------------------------------------------------------------- -! (7) COMPUTE STATE AT THE END OF THE TIME INTERVAL -! --------------------------------------------------------------------------------------- -IF (PRESENT(NEWSTATE)) THEN - ! check that S1 and DT are present - IF (.NOT.PRESENT(S1) .OR. .NOT.PRESENT(DT)) THEN - IF (.NOT.PRESENT(S1)) MESSAGE='need S1 to aggregate fluxes and save states' - IF (.NOT.PRESENT(DT)) MESSAGE='need DT to aggregate fluxes and save states' - IERR=20; RETURN - ENDIF - ! update state - IF (NEWSTATE) THEN - M_FLUX = W_FLUX; CALL MSTATE_EQN() ! compute model derivatives using aggregated fluxes - CALL UPDATSTATE(DT) ! compute new value of FSTATE - MSTATE = FSTATE ! update MSTATE - CALL STR_2_XTRY(FSTATE,S1) ! extract state vector - ENDIF -ENDIF -! --------------------------------------------------------------------------------------- -END SUBROUTINE FUSE_SOLVE diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/get_limits.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/get_limits.f90.svn-base deleted file mode 100644 index a12bd82..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/get_limits.f90.svn-base +++ /dev/null @@ -1,76 +0,0 @@ -SUBROUTINE GET_LIMITS() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007; revised 2008 to make use of parameter names; -! revised 2009 to include extra information for BATEA -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Reads parameter constraints -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multiparam -- model parameters stored in MODULE multiparam -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE fuse_fileManager,only:SETNGS_PATH,CONSTRAINTS ! defines data directory -USE multiparam, ONLY: PARATT ! parameter attribute structure -USE putpar_str_module ! provide access to SUBROUTINE putpar_str -IMPLICIT NONE -INTEGER(I4B) :: IUNIT ! file unit -integer(i4b),parameter::lenPath=1024 !DK211008: allows longer file paths -INTEGER(I4B) :: IERR ! error code for read statement\ -REAL(SP) :: XVAR ! argument for SUBROUTINE putpar_str -CHARACTER(LEN=lenPath) :: CFILE ! name of constraints file -LOGICAL(LGT) :: LEXIST ! .TRUE. if file exists -CHARACTER(LEN=256) :: KEY ! format code -TYPE(PARATT) :: PARAM_META ! parameter metadata -INTEGER(I4B) :: IPOS,JPOS ! indices of string -INTEGER(I4B) :: ICH ! looping variable (forall loop) -! --------------------------------------------------------------------------------------- -print *, 'in get_limits' -! read in control file -IUNIT = 21 ! file unit -CFILE = TRIM(SETNGS_PATH)//TRIM(CONSTRAINTS) ! control file info shared in MODULE ddirectory -INQUIRE(FILE=CFILE,EXIST=LEXIST) ! check that control file exists -IF (LEXIST) THEN - ! initialize parameter strings - FORALL(ICH=1:LEN(PARAM_META%P_NAME)) PARAM_META%P_NAME(ICH:ICH)=' ' - FORALL(ICH=1:LEN(PARAM_META%CHILD1)) PARAM_META%CHILD1(ICH:ICH)=' ' - FORALL(ICH=1:LEN(PARAM_META%CHILD2)) PARAM_META%CHILD2(ICH:ICH)=' ' - ! open up model decisions file - OPEN(IUNIT,FILE=CFILE,STATUS='old') - ! read format key (and strip out descriptive text) - READ(IUNIT,'(a256)') KEY - IPOS = INDEX(KEY,'!'); FORALL(JPOS=IPOS:LEN(KEY)) KEY(JPOS:JPOS)=' ' - PRINT *, TRIM(KEY), len_trim(key) - DO - ! read parameter constraints - READ(IUNIT,TRIM(KEY), IOSTAT=IERR) & - PARAM_META%PARFIT, & ! 'fit' (T/F) [T=parameter is fitted, F=parameter is fixed at the default value) - PARAM_META%PARSTK, & ! flag (0=deterministic, 1=stochastic) - PARAM_META%PARDEF, & ! default parameter set - PARAM_META%PARLOW, & ! lower limit of each parameter - PARAM_META%PARUPP, & ! upper limit of each parameter - PARAM_META%FRSEED, & ! fraction param space for "reasonable" bounds - PARAM_META%PARSCL, & ! typical scale of parameter - PARAM_META%PARVTN, & ! method used for variable transformation - PARAM_META%PARDIS, & ! parametric form of prob dist used for prior/hyper - PARAM_META%PARQTN, & ! transformation applied before use of prob dist - PARAM_META%PARLAT, & ! number of latent variables (0=onePerStep, -1=from data) - PARAM_META%PARMTH, & ! imeth for all variables ???what is this??? - PARAM_META%NPRIOR, & ! number of prior/hyper-parameters - PARAM_META%P_NAME, & ! parameter name - PARAM_META%CHILD1, & ! name of 1st parameter child - PARAM_META%CHILD2 ! name of 2nd parameter child - IF (IERR.NE.0) EXIT - WRITE(*,TRIM(KEY)) PARAM_META - ! put parameters in data structures - CALL PUTPAR_STR(PARAM_META, PARAM_META%P_NAME) - END DO - CLOSE(IUNIT) -ELSE - STOP ' parameter constraints file does not exist ' -ENDIF -END SUBROUTINE GET_LIMITS diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/getforcing.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/getforcing.f90.svn-base deleted file mode 100644 index 1689495..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/getforcing.f90.svn-base +++ /dev/null @@ -1,130 +0,0 @@ -SUBROUTINE GETFORCING(INFERN_START,NTIM) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Read ASCII model forcing data in BATEA format -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multiforce -- populate structure AFORCE(*)%(*) -! --------------------------------------------------------------------------------------- -USE fuse_fileManager,only:SETNGS_PATH,FORCINGINFO ! defines data directory -USE multiforce ! model forcing structures -USE multiroute ! model routing structure -IMPLICIT NONE -! internal -integer(i4b),parameter::lenPath=1024 ! DK211008: allows longer file paths -INTEGER(I4B) :: I ! looping -INTEGER(I4B),DIMENSION(10) :: IERR ! error codes -INTEGER(I4B) :: IUNIT ! input file unit -CHARACTER(LEN=lenPath) :: CFILE ! name of control file -CHARACTER(LEN=lenPath) :: FFILE ! name of forcing file -LOGICAL(LGT) :: LEXIST ! .TRUE. if control file exists -CHARACTER(LEN=lenPath) :: FNAME_INPUT ! name of input file -INTEGER(I4B) :: NCOL ! number of columns -INTEGER(I4B) :: IX_PPT ! column number for precipitation -INTEGER(I4B) :: IX_PET ! column number for potential ET -INTEGER(I4B) :: IX_OBSQ ! column number for observed streamflow -INTEGER(I4B) :: NHEAD ! number of header rows -INTEGER(I4B) :: WARM_START ! index of start of warm-up period -INTEGER(I4B) :: INFERN_END ! index of start of inference period -INTEGER(I4B) :: NSTEPS ! number of time steps desired -INTEGER(I4B) :: IPOS ! position of descriptive text in control file -INTEGER(I4B) :: IHEAD ! header index -CHARACTER(LEN=lenPath) :: TMPTXT ! descriptive text -INTEGER(I4B) :: ITIME ! time index (input data) -INTEGER(I4B) :: JTIME ! time index (internal data structure) -REAL(SP),DIMENSION(:),ALLOCATABLE :: TMPDAT ! one line of data -! output -INTEGER(I4B), INTENT(OUT) :: INFERN_START ! index of start of inference period -INTEGER(I4B), INTENT(OUT) :: NTIM ! index of start of inference period -! --------------------------------------------------------------------------------------- -! read in control file -CFILE = TRIM(SETNGS_PATH)//TRIM(FORCINGINFO) ! control file info shared in MODULE ddirectory -INQUIRE(FILE=CFILE,EXIST=LEXIST) ! check that control file exists -IF (LEXIST) THEN - ! read in parameters of the control file - IUNIT = 21 ! file unit - OPEN(IUNIT,FILE=CFILE,STATUS='old') - READ(IUNIT,'(A256)') FNAME_INPUT ! get input filename - READ(IUNIT,*) NCOL,IX_PPT,IX_PET,IX_OBSQ ! number of columns and column numbers - READ(IUNIT,*) NHEAD,WARM_START,INFERN_START,INFERN_END ! n header, start warm-up, start inference, end inference - CLOSE(IUNIT) - ! subtract the header lines from the data indices - WARM_START = WARM_START - NHEAD - INFERN_START = INFERN_START - NHEAD - INFERN_END = INFERN_END - NHEAD - ! fill extra characters in filename with white space - IPOS = SCAN(FNAME_INPUT,'!') - IF (IPOS.GT.0) FORALL(I=IPOS:LEN(FNAME_INPUT)) FNAME_INPUT(I:I) = ' ' -ELSE - print *, TRIM(CFILE); STOP ' control file for forcing data does not exist ' -ENDIF -! --------------------------------------------------------------------------------------- -! allocate space for data structures -IERR = 0 -NSTEPS = (INFERN_END-WARM_START)+1 -!print *, NHEAD,WARM_START,INFERN_START,INFERN_END,NSTEPS -IF (WARM_START.GT.INFERN_START) STOP ' start of inference is greater than the start of warm-up ' -IF (INFERN_START.GT.INFERN_END) STOP ' start of inference is greater than the end of inference ' -ALLOCATE(TMPDAT(NCOL),STAT=IERR(1)) ! (only used in this routine -- deallocate later) -ALLOCATE(AFORCE(NSTEPS),STAT=IERR(2)) ! (shared in module multiforce) -ALLOCATE(AROUTE(NSTEPS),STAT=IERR(3)) ! (shared in module multiroute) -IF (ANY(IERR.NE.0)) STOP ' problem allocating space for data structures ' -! initialize the Q_ACCURATE vector -AROUTE(1:NSTEPS)%Q_ACCURATE = -9999._SP -! --------------------------------------------------------------------------------------- -! read data -IUNIT = 21 ! (file unit) -JTIME = 0 -FFILE = TRIM(SETNGS_PATH)//TRIM(FNAME_INPUT) -INQUIRE(FILE=FFILE,EXIST=LEXIST) ! check that control file exists -IF (.NOT.LEXIST) THEN - print *, TRIM(FFILE); STOP ' forcing data file does not exist ' -ENDIF -OPEN(IUNIT,FILE=FFILE,STATUS='old') - ! read header - DO IHEAD=1,NHEAD - IF (IHEAD.EQ.2) THEN - READ(IUNIT,*) DELTIM ! time interval of the data (shared in module multiforce) - ELSE - READ(IUNIT,*) TMPTXT ! descriptive text - ENDIF - END DO - ! read data - DO ITIME=1,INFERN_END - READ(IUNIT,*) TMPDAT - !WRITE(*,'(2(I6,1X),F5.0,1X,3(F3.0,1X)') ITIME,WARM_START,TMPDAT(1:4) - IF (ITIME.GE.WARM_START) THEN - JTIME = JTIME+1 - AFORCE(JTIME)%IY = INT(TMPDAT(1)) - AFORCE(JTIME)%IM = INT(TMPDAT(2)) - AFORCE(JTIME)%ID = INT(TMPDAT(3)) - AFORCE(JTIME)%IH = INT(TMPDAT(4)) - AFORCE(JTIME)%IMIN = 0 - AFORCE(JTIME)%DSEC = 0._SP - AFORCE(JTIME)%DTIME = 0._SP - AFORCE(JTIME)%PPT = TMPDAT(IX_PPT) - AFORCE(JTIME)%PET = TMPDAT(IX_PET) - AFORCE(JTIME)%OBSQ = TMPDAT(IX_OBSQ) - !WRITE(*,'(2(I6,1X),F5.0,1X,3(F3.0,1X),3(F12.4,1X))') ITIME, JTIME, TMPDAT(1:4), & - ! AFORCE(JTIME)%PPT, AFORCE(JTIME)%PET, AFORCE(JTIME)%OBSQ - ENDIF - END DO -CLOSE(IUNIT) -! correct the index for start of inference -INFERN_START = (INFERN_START-WARM_START)+1 -ISTART = INFERN_START ! (shared in MODULE multiforce) -!WRITE(*,'(I6,1X,I4,1X,3(I2,1X),3(F12.4,1X))') ISTART, & -! AFORCE(ISTART)%IY, AFORCE(ISTART)%IM, AFORCE(ISTART)%ID, AFORCE(ISTART)%IH, & -! AFORCE(ISTART)%PPT, AFORCE(ISTART)%PET, AFORCE(ISTART)%OBSQ -! save the number of time steps -NTIM = NSTEPS ! number of time steps (returned to main program) -NUMTIM = NSTEPS ! number of time steps (shared in MODULE multiforce) -IERR(1)= 0; DEALLOCATE(TMPDAT, STAT=IERR(1)); IF (IERR(1).NE.0) STOP ' problem deallocating TMPDAT ' -! --------------------------------------------------------------------------------------- -END SUBROUTINE GETFORCING diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/getnumerix.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/getnumerix.f90.svn-base deleted file mode 100644 index 278dd21..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/getnumerix.f90.svn-base +++ /dev/null @@ -1,61 +0,0 @@ -SUBROUTINE GETNUMERIX(err,message) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Reads decisions/parameters that defines the numerical scheme -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE model_numerix -- model parameters stored in MODULE multiparam -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE fuse_fileManager,only:SETNGS_PATH,MOD_NUMERIX ! defines data directory -USE model_numerix ! defines numerix decisions -IMPLICIT NONE -! dummies -integer(I4B),intent(out)::err -character(*),intent(out)::message -! locals -INTEGER(I4B) :: IUNIT ! file unit -integer(i4b),parameter::lenPath=1024 !DK211008: allows longer file paths -CHARACTER(LEN=lenPath) :: CFILE ! name of constraints file -LOGICAL(LGT) :: LEXIST ! .TRUE. if file exists -! --------------------------------------------------------------------------------------- -! read in control file -err=0; message="GETNUMERIX/ok" -IUNIT = 21 ! file unit -CFILE = TRIM(SETNGS_PATH)//TRIM(MOD_NUMERIX) ! control file info shared in MODULE ddirectory -INQUIRE(FILE=CFILE,EXIST=LEXIST) ! check that control file exists -IF (LEXIST) THEN - ! open up model numerix file - OPEN(IUNIT,FILE=CFILE,STATUS='old') - READ(IUNIT,*) SOLUTION_METHOD ! Method used to solve state equations (explicit vs implicit) - READ(IUNIT,*) TEMPORAL_ERROR_CONTROL ! Method used for temporal error control (adaptive time steps) - READ(IUNIT,*) INITIAL_NEWTON ! Method used to estimate the initial conditions for the Newton scheme - READ(IUNIT,*) JAC_RECOMPUTE ! Jacobian re-evaluation strategy - READ(IUNIT,*) CHECK_OVERSHOOT ! Method used to trap/fix errors in Newton - READ(IUNIT,*) SMALL_ENDSTEP ! Method used to process the small time interval at the end of a time step - READ(IUNIT,*) ERR_TRUNC_ABS ! Absolute temporal truncation error tolerance - READ(IUNIT,*) ERR_TRUNC_REL ! Relative temporal truncation error tolerance - READ(IUNIT,*) ERR_ITER_FUNC ! Iteration convergence tolerance for function values - READ(IUNIT,*) ERR_ITER_DX ! Iteration convergence tolerance for dx - READ(IUNIT,*) THRESH_FRZE ! Threshold for freezing the Jacobian - READ(IUNIT,*) FRACSTATE_MIN ! Fractional minimum value of state (used so that derivatives are non-zero) - READ(IUNIT,*) SAFETY ! Safety factor in step-size equation - READ(IUNIT,*) RMIN ! Minimum step size multiplier - READ(IUNIT,*) RMAX ! Maximum step size multiplier - READ(IUNIT,*) NITER_TOTAL ! Total number of iterations used in the implicit scheme - READ(IUNIT,*) MIN_TSTEP ! Minimum time step length (minutes) - READ(IUNIT,*) MAX_TSTEP ! Maximum time step length (minutes) - CLOSE(IUNIT) - MIN_TSTEP = MIN_TSTEP/(24._SP*60._SP) ! Convert from minutes to days - MAX_TSTEP = MAX_TSTEP/(24._SP*60._SP) ! Convert from minutes to days -ELSE - message="f-GETNUMERIX/model numerix file '"//trim(CFILE)//"' does not exist" - err=100; return -ENDIF -END SUBROUTINE GETNUMERIX diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/getpar_str.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/getpar_str.f90.svn-base deleted file mode 100644 index 47a6c7b..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/getpar_str.f90.svn-base +++ /dev/null @@ -1,62 +0,0 @@ -MODULE GETPAR_STR_MODULE -IMPLICIT NONE -CONTAINS -SUBROUTINE GETPAR_STR(PARNAME,METADAT) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Inserts parameter metadata into data structures -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE multiparam, ONLY : PARATT, PARMETA ! derived type for parameter metadata -IMPLICIT NONE -! input -CHARACTER(*), INTENT(IN) :: PARNAME ! parameter name -TYPE(PARATT), INTENT(OUT) :: METADAT ! parameter metadata -! --------------------------------------------------------------------------------------- -! model parameters -SELECTCASE(TRIM(PARNAME)) -CASE('RFERR_ADD'); METADAT = PARMETA%RFERR_ADD -CASE('RFERR_MLT'); METADAT = PARMETA%RFERR_MLT -CASE('RFH1_MEAN'); METADAT = PARMETA%RFH1_MEAN -CASE('RFH2_SDEV'); METADAT = PARMETA%RFH2_SDEV -CASE('RH1P_MEAN'); METADAT = PARMETA%RH1P_MEAN -CASE('RH1P_SDEV'); METADAT = PARMETA%RH1P_SDEV -CASE('RH2P_MEAN'); METADAT = PARMETA%RH2P_MEAN -CASE('RH2P_SDEV'); METADAT = PARMETA%RH2P_SDEV -CASE('MAXWATR_1'); METADAT = PARMETA%MAXWATR_1 -CASE('MAXWATR_2'); METADAT = PARMETA%MAXWATR_2 -CASE('FRACTEN'); METADAT = PARMETA%FRACTEN -CASE('FRCHZNE'); METADAT = PARMETA%FRCHZNE -CASE('FPRIMQB'); METADAT = PARMETA%FPRIMQB -CASE('RTFRAC1'); METADAT = PARMETA%RTFRAC1 -CASE('PERCRTE'); METADAT = PARMETA%PERCRTE -CASE('PERCEXP'); METADAT = PARMETA%PERCEXP -CASE('SACPMLT'); METADAT = PARMETA%SACPMLT -CASE('SACPEXP'); METADAT = PARMETA%SACPEXP -CASE('PERCFRAC'); METADAT = PARMETA%PERCFRAC -CASE('FRACLOWZ'); METADAT = PARMETA%FRACLOWZ -CASE('IFLWRTE'); METADAT = PARMETA%IFLWRTE -CASE('BASERTE'); METADAT = PARMETA%BASERTE -CASE('QB_POWR'); METADAT = PARMETA%QB_POWR -CASE('QB_PRMS'); METADAT = PARMETA%QB_PRMS -CASE('QBRATE_2A'); METADAT = PARMETA%QBRATE_2A -CASE('QBRATE_2B'); METADAT = PARMETA%QBRATE_2B -CASE('SAREAMAX'); METADAT = PARMETA%SAREAMAX -CASE('AXV_BEXP'); METADAT = PARMETA%AXV_BEXP -CASE('LOGLAMB'); METADAT = PARMETA%LOGLAMB -CASE('TISHAPE'); METADAT = PARMETA%TISHAPE -CASE('TIMEDELAY'); METADAT = PARMETA%TIMEDELAY -CASE DEFAULT - print *, 'parameter name (', TRIM(PARNAME), ') does not exist ' - IF (TRIM(PARNAME).EQ.'NO_CHILD1' .OR. TRIM(PARNAME).EQ.'NO_CHILD2') & - print *, ' * check the number of prior/hyper parameters specified ' - STOP -ENDSELECT -! --------------------------------------------------------------------------------------- -END SUBROUTINE GETPAR_STR -END MODULE GETPAR_STR_MODULE diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/getparmeta.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/getparmeta.f90.svn-base deleted file mode 100644 index cb66730..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/getparmeta.f90.svn-base +++ /dev/null @@ -1,81 +0,0 @@ -SUBROUTINE GETPARMETA(err,message) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Reads parameter metadata -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multiparam -- model parameters stored in MODULE multiparam -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE fuse_fileManager,only:SETNGS_PATH,CONSTRAINTS ! defines data directory -USE multiparam, ONLY: PARATT ! parameter attribute structure -USE putpar_str_module ! provide access to SUBROUTINE putpar_str -USE par_insert_module ! provide access to SUBROUTINE par_insert -IMPLICIT NONE -! dummies -integer(i4b),intent(out)::err -character(*),intent(out)::message -! locals -INTEGER(I4B) :: IUNIT ! file unit -integer(i4b),parameter::lenPath=1024 !DK211008: allows longer file paths -INTEGER(I4B) :: IERR ! error code for read statement\ -CHARACTER(LEN=lenPath) :: CFILE ! name of constraints file -LOGICAL(LGT) :: LEXIST ! .TRUE. if file exists -CHARACTER(LEN=256) :: KEY ! format code -TYPE(PARATT) :: PARAM_META ! parameter metadata -INTEGER(I4B) :: IPOS,JPOS ! indices of string -INTEGER(I4B) :: ICH ! looping variable (do loop) -! --------------------------------------------------------------------------------------- -! read in control file -err=0 -IUNIT = 21 ! file unit -CFILE = TRIM(SETNGS_PATH)//TRIM(CONSTRAINTS) ! control file info shared in MODULE ddirectory -INQUIRE(FILE=CFILE,EXIST=LEXIST) ! check that control file exists -IF (.not.LEXIST) THEN - message="f-GETPARMETA/parameter constraints file '"//trim(CFILE)//"' does not exist " - err=100; return -ENDIF -! initialize parameter strings -DO ICH=1,LEN(PARAM_META%P_NAME); PARAM_META%P_NAME(ICH:ICH)=' '; END DO -DO ICH=1,LEN(PARAM_META%CHILD1); PARAM_META%CHILD1(ICH:ICH)=' '; END DO -DO ICH=1,LEN(PARAM_META%CHILD2); PARAM_META%CHILD2(ICH:ICH)=' '; END DO -! open up parameter metadata file -OPEN(IUNIT,FILE=CFILE,STATUS='old') -! read format key (and strip out descriptive text) -READ(IUNIT,'(a256)') KEY -IPOS = INDEX(KEY,'!'); DO JPOS=IPOS,LEN(KEY); KEY(JPOS:JPOS)=' '; END DO -!PRINT *, TRIM(KEY), len_trim(key) -DO - ! read parameter constraints - READ(IUNIT,TRIM(KEY), IOSTAT=IERR) & - PARAM_META%PARFIT, & ! 'fit' (T/F) [T=parameter is fitted, F=parameter is fixed at the default value) - PARAM_META%PARSTK, & ! flag (0=deterministic, 1=stochastic) - PARAM_META%PARDEF, & ! default parameter set - PARAM_META%PARLOW, & ! lower limit of each parameter - PARAM_META%PARUPP, & ! upper limit of each parameter - PARAM_META%FRSEED, & ! fraction param space used as offset for "reasonable" bounds - PARAM_META%PARSCL, & ! typical scale of parameter - PARAM_META%PARVTN, & ! method used for variable transformation - PARAM_META%PARDIS, & ! parametric form of prob dist used for prior/hyper - PARAM_META%PARQTN, & ! transformation applied before use of prob dist - PARAM_META%PARLAT, & ! number of latent variables (0=onePerStep, -1=from data) - PARAM_META%PARMTH, & ! imeth for all variables ???what is this??? - PARAM_META%NPRIOR, & ! number of prior/hyper-parameters - PARAM_META%P_NAME, & ! parameter name - PARAM_META%CHILD1, & ! name of 1st parameter child - PARAM_META%CHILD2 ! name of 2nd parameter child - IF (IERR.NE.0) EXIT - !WRITE(*,TRIM(KEY)) PARAM_META - ! put parameters in data structures - CALL PUTPAR_STR(PARAM_META, PARAM_META%P_NAME) - ! populate the model parameter structure with default values - CALL PAR_INSERT(PARAM_META%PARDEF,PARAM_META%P_NAME) -END DO -CLOSE(IUNIT) -END SUBROUTINE GETPARMETA diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/init_state.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/init_state.f90.svn-base deleted file mode 100644 index 711b017..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/init_state.f90.svn-base +++ /dev/null @@ -1,36 +0,0 @@ -SUBROUTINE INIT_STATE(FRAC) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Initialize model states at fraction (FRAC) of capacity -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! Model states in MODULE multistate -! --------------------------------------------------------------------------------------- -USE multiparam ! model parameters -USE multistate ! model states -USE multiroute ! routed runoff -IMPLICIT NONE -REAL(SP), INTENT(IN) :: FRAC ! fraction of capacity -! --------------------------------------------------------------------------------------- -! (upper layer) -FSTATE%TENS_1A = DPARAM%MAXTENS_1A * FRAC -FSTATE%TENS_1B = DPARAM%MAXTENS_1B * FRAC -FSTATE%TENS_1 = DPARAM%MAXTENS_1 * FRAC -FSTATE%FREE_1 = DPARAM%MAXFREE_1 * FRAC -FSTATE%WATR_1 = MPARAM%MAXWATR_1 * FRAC -! (lower layer) -FSTATE%TENS_2 = DPARAM%MAXTENS_2 * FRAC -FSTATE%FREE_2 = DPARAM%MAXFREE_2 * FRAC -FSTATE%FREE_2A = DPARAM%MAXFREE_2A * FRAC -FSTATE%FREE_2B = DPARAM%MAXFREE_2B * FRAC -FSTATE%WATR_2 = MPARAM%MAXWATR_2 * FRAC -! (routed runoff) -FUTURE = 0._sp -! --------------------------------------------------------------------------------------- -END SUBROUTINE INIT_STATE diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/init_stats.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/init_stats.f90.svn-base deleted file mode 100644 index 6f81b52..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/init_stats.f90.svn-base +++ /dev/null @@ -1,30 +0,0 @@ -SUBROUTINE INIT_STATS() -! ---------------------------------------------------------------------------------------- -! Creator: -! Martyn Clark, 2009 -! -! ---------------------------------------------------------------------------------------- -! Purpose: -! Used to initialize summary statistics -! -! ---------------------------------------------------------------------------------------- -! Future revisions: -! -! (add other summary statistics) -! -! ---------------------------------------------------------------------------------------- -USE nrtype ! variable types (DP, I4B, etc.) -USE multistats -USE model_numerix -IMPLICIT NONE -! ---------------------------------------------------------------------------------------- -! initialize numerical statistics -MSTATS%NUM_FUNCS = 0 -MSTATS%NUM_JACOBIAN = 0 -MSTATS%NUMSUB_ACCEPT = 0 -MSTATS%NUMSUB_REJECT = 0 -MSTATS%NUMSUB_NOCONV = 0 -! initialize probability distributions -PRB_NSUBS(:) = 0 -! ---------------------------------------------------------------------------------------- -END SUBROUTINE INIT_STATS diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/initfluxes.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/initfluxes.f90.svn-base deleted file mode 100644 index 66dbff0..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/initfluxes.f90.svn-base +++ /dev/null @@ -1,50 +0,0 @@ -SUBROUTINE INITFLUXES() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Set all fluxes to zero at the start of each time step -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! Fluxes in MODULE multi_flux -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE multi_flux ! model fluxes -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -M_FLUX%EFF_PPT = 0._sp; W_FLUX%EFF_PPT = 0._sp -M_FLUX%SATAREA = 0._sp; W_FLUX%SATAREA = 0._sp -M_FLUX%QSURF = 0._sp; W_FLUX%QSURF = 0._sp -M_FLUX%EVAP_1A = 0._sp; W_FLUX%EVAP_1A = 0._sp -M_FLUX%EVAP_1B = 0._sp; W_FLUX%EVAP_1B = 0._sp -M_FLUX%EVAP_1 = 0._sp; W_FLUX%EVAP_1 = 0._sp -M_FLUX%EVAP_2 = 0._sp; W_FLUX%EVAP_2 = 0._sp -M_FLUX%RCHR2EXCS = 0._sp; W_FLUX%RCHR2EXCS = 0._sp -M_FLUX%TENS2FREE_1 = 0._sp; W_FLUX%TENS2FREE_1 = 0._sp -M_FLUX%TENS2FREE_2 = 0._sp; W_FLUX%TENS2FREE_2 = 0._sp -M_FLUX%QINTF_1 = 0._sp; W_FLUX%QINTF_1 = 0._sp -M_FLUX%QPERC_12 = 0._sp; W_FLUX%QPERC_12 = 0._sp -M_FLUX%QBASE_2 = 0._sp; W_FLUX%QBASE_2 = 0._sp -M_FLUX%QBASE_2A = 0._sp; W_FLUX%QBASE_2A = 0._sp -M_FLUX%QBASE_2B = 0._sp; W_FLUX%QBASE_2B = 0._sp -M_FLUX%OFLOW_1 = 0._sp; W_FLUX%OFLOW_1 = 0._sp -M_FLUX%OFLOW_2 = 0._sp; W_FLUX%OFLOW_2 = 0._sp -M_FLUX%OFLOW_2A = 0._sp; W_FLUX%OFLOW_2A = 0._sp -M_FLUX%OFLOW_2B = 0._sp; W_FLUX%OFLOW_2B = 0._sp -M_FLUX%ERR_WATR_1 = 0._sp; W_FLUX%ERR_WATR_1 = 0._sp -M_FLUX%ERR_TENS_1 = 0._sp; W_FLUX%ERR_TENS_1 = 0._sp -M_FLUX%ERR_FREE_1 = 0._sp; W_FLUX%ERR_FREE_1 = 0._sp -M_FLUX%ERR_TENS_1A = 0._sp; W_FLUX%ERR_TENS_1A = 0._sp -M_FLUX%ERR_TENS_1B = 0._sp; W_FLUX%ERR_TENS_1B = 0._sp -M_FLUX%ERR_WATR_2 = 0._sp; W_FLUX%ERR_WATR_2 = 0._sp -M_FLUX%ERR_TENS_2 = 0._sp; W_FLUX%ERR_TENS_2 = 0._sp -M_FLUX%ERR_FREE_2 = 0._sp; W_FLUX%ERR_FREE_2 = 0._sp -M_FLUX%ERR_FREE_2A = 0._sp; W_FLUX%ERR_FREE_2A = 0._sp -M_FLUX%ERR_FREE_2B = 0._sp; W_FLUX%ERR_FREE_2B = 0._sp -M_FLUX%CHK_TIME = 0._sp; W_FLUX%CHK_TIME = 0._sp -! --------------------------------------------------------------------------------------- -END SUBROUTINE INITFLUXES diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/interfaceb.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/interfaceb.f90.svn-base deleted file mode 100644 index f04f113..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/interfaceb.f90.svn-base +++ /dev/null @@ -1,69 +0,0 @@ -MODULE INTERFACEB -! ------------------------------------------------------------------------------------------------- -INTERFACE - SUBROUTINE ODE_INT(MODL_SOLVE,STATE_START,STATE_END,DT_SUB,DT_FULL,IERR,MESSAGE) - USE nrtype ! variable definitions, etc. - IMPLICIT NONE - REAL(SP), DIMENSION(:), INTENT(IN) :: STATE_START ! state vector at the start of the full step - REAL(SP), DIMENSION(:), INTENT(OUT) :: STATE_END ! state vector at the end of the full step - REAL(SP), INTENT(INOUT) :: DT_SUB ! length of the sub-step - REAL(SP), INTENT(IN) :: DT_FULL ! length of the full step - INTEGER(I4B), INTENT(OUT) :: IERR ! error code - CHARACTER(LEN=*), INTENT(OUT) :: MESSAGE ! error message - INTERFACE - SUBROUTINE MODL_SOLVE(CALCDSDT,IE_SOLVE,SI_SOLVE,B_IMPOSE,AVG_FLUX,ADD_FLUX,NEWSTATE, & ! define functionality of the routine - DT,S0,S1,DSDT,NEWSTEP,CONVCHECK,NITER,SOLUTION,HBOUND, & ! input/output - IERR,MESSAGE) ! error control - USE nrtype ! variable definitions, etc. - IMPLICIT NONE - LOGICAL(LGT), INTENT(IN),OPTIONAL :: CALCDSDT ! FLAG to calculate derivatives at S0 - LOGICAL(LGT), INTENT(IN),OPTIONAL :: IE_SOLVE ! FLAG to compute the implicit Euler solution - LOGICAL(LGT), INTENT(IN),OPTIONAL :: SI_SOLVE ! FLAG to compute the semi-implicit Euler solution - LOGICAL(LGT), INTENT(IN),OPTIONAL :: B_IMPOSE ! FLAG to impose bounds on model states - LOGICAL(LGT), INTENT(IN),OPTIONAL :: AVG_FLUX ! FLAG to average fluxes from start & end states - LOGICAL(LGT), INTENT(IN),OPTIONAL :: ADD_FLUX ! FLAG to add accepted fluxes to the total flux - LOGICAL(LGT), INTENT(IN),OPTIONAL :: NEWSTATE ! FLAG to use weighted fluxes to compute end state - REAL(SP), INTENT(IN), OPTIONAL :: DT ! length of the sub-step - REAL(SP), DIMENSION(:),INTENT(IN), OPTIONAL :: S0 ! input state vector - REAL(SP), DIMENSION(:), INTENT(OUT),OPTIONAL :: S1 ! state vector from the implicit euler solution - REAL(SP), DIMENSION(:),INTENT(INOUT),OPTIONAL :: DSDT ! state derivatives - LOGICAL(LGT), INTENT(IN),OPTIONAL :: NEWSTEP ! FLAG to denote a new model time step - LOGICAL(LGT), INTENT(IN),OPTIONAL :: CONVCHECK ! FLAG to check for convergence of the implicit scheme - INTEGER(I4B), INTENT(OUT), OPTIONAL :: NITER ! number of iterations - INTEGER(I4B), INTENT(IN), OPTIONAL :: SOLUTION ! solution is at start (0) or end (1) of sub-step - LOGICAL(LGT), INTENT(OUT),OPTIONAL :: HBOUND ! FLAG to denote if the states were out of bounds - INTEGER(I4B), INTENT(OUT) :: IERR ! error code - CHARACTER(LEN=*), INTENT(OUT) :: MESSAGE ! error message - END SUBROUTINE MODL_SOLVE - END INTERFACE - END SUBROUTINE ODE_INT -END INTERFACE -! ------------------------------------------------------------------------------------------------- -INTERFACE - SUBROUTINE FUSE_SOLVE(CALCDSDT,IE_SOLVE,SI_SOLVE,B_IMPOSE,AVG_FLUX,ADD_FLUX,NEWSTATE, & ! define functionality of the routine - DT,S0,S1,DSDT,NEWSTEP,CONVCHECK,NITER,SOLUTION,HBOUND, & ! input/output - IERR,MESSAGE) ! error control - USE nrtype ! variable definitions, etc. - IMPLICIT NONE - LOGICAL(LGT), INTENT(IN),OPTIONAL :: CALCDSDT ! FLAG to calculate derivatives at S0 - LOGICAL(LGT), INTENT(IN),OPTIONAL :: IE_SOLVE ! FLAG to compute the implicit Euler solution - LOGICAL(LGT), INTENT(IN),OPTIONAL :: SI_SOLVE ! FLAG to compute the semi-implicit Euler solution - LOGICAL(LGT), INTENT(IN),OPTIONAL :: B_IMPOSE ! FLAG to impose bounds on model states - LOGICAL(LGT), INTENT(IN),OPTIONAL :: AVG_FLUX ! FLAG to average fluxes from start & end states - LOGICAL(LGT), INTENT(IN),OPTIONAL :: ADD_FLUX ! FLAG to add accepted fluxes to the total flux - LOGICAL(LGT), INTENT(IN),OPTIONAL :: NEWSTATE ! FLAG to use weighted fluxes to compute end state - REAL(SP), INTENT(IN), OPTIONAL :: DT ! length of the sub-step - REAL(SP), DIMENSION(:),INTENT(IN), OPTIONAL :: S0 ! input state vector - REAL(SP), DIMENSION(:), INTENT(OUT),OPTIONAL :: S1 ! state vector from the implicit euler solution - REAL(SP), DIMENSION(:),INTENT(INOUT),OPTIONAL :: DSDT ! state derivatives - LOGICAL(LGT), INTENT(IN),OPTIONAL :: NEWSTEP ! FLAG to denote a new model time step - LOGICAL(LGT), INTENT(IN),OPTIONAL :: CONVCHECK ! FLAG to check for convergence of the implicit scheme - INTEGER(I4B), INTENT(OUT), OPTIONAL :: NITER ! number of iterations - INTEGER(I4B), INTENT(IN), OPTIONAL :: SOLUTION ! solution is at start (0) or end (1) of sub-step - LOGICAL(LGT), INTENT(OUT),OPTIONAL :: HBOUND ! FLAG to denote if the states were out of bounds - INTEGER(I4B), INTENT(OUT) :: IERR ! error code - CHARACTER(LEN=*), INTENT(OUT) :: MESSAGE ! error message - END SUBROUTINE FUSE_SOLVE -END INTERFACE -! ------------------------------------------------------------------------------------------------- -END MODULE INTERFACEB diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/limit_xtry.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/limit_xtry.f90.svn-base deleted file mode 100644 index 0739c82..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/limit_xtry.f90.svn-base +++ /dev/null @@ -1,79 +0,0 @@ -MODULE LIMIT_XTRY_MODULE -IMPLICIT NONE -CONTAINS -SUBROUTINE LIMIT_XTRY(X_TRY) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Imposes constraints on the vector of model states -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition structures -USE model_defnames -USE multiparam ! model parameters -USE multistate ! model states (USE NSTATE) -USE model_numerix ! model numerix -IMPLICIT NONE -! input/output -REAL(SP), DIMENSION(:), INTENT(INOUT) :: X_TRY ! vector of model states -! internal -REAL(SP) :: XMIN ! very small number -INTEGER(I4B) :: ISTT ! loop through model states -! --------------------------------------------------------------------------------------- -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) - IF(X_TRY(ISTT).LT.XMIN*DPARAM%MAXTENS_1A) X_TRY(ISTT) = XMIN*DPARAM%MAXTENS_1A - IF(X_TRY(ISTT).GT. DPARAM%MAXTENS_1A) X_TRY(ISTT) = DPARAM%MAXTENS_1A - CASE (iopt_TENS1B) - IF(X_TRY(ISTT).LT.XMIN*DPARAM%MAXTENS_1B) X_TRY(ISTT) = XMIN*DPARAM%MAXTENS_1B - IF(X_TRY(ISTT).GT. DPARAM%MAXTENS_1B) X_TRY(ISTT) = DPARAM%MAXTENS_1B - CASE (iopt_TENS_1) - IF(X_TRY(ISTT).LT.XMIN*DPARAM%MAXTENS_1) X_TRY(ISTT) = XMIN*DPARAM%MAXTENS_1 - IF(X_TRY(ISTT).GT. DPARAM%MAXTENS_1) X_TRY(ISTT) = DPARAM%MAXTENS_1 - CASE (iopt_FREE_1) - IF(X_TRY(ISTT).LT.XMIN*DPARAM%MAXFREE_1) X_TRY(ISTT) = XMIN*DPARAM%MAXFREE_1 - IF(X_TRY(ISTT).GT. DPARAM%MAXFREE_1) X_TRY(ISTT) = DPARAM%MAXFREE_1 - CASE (iopt_WATR_1) - IF(X_TRY(ISTT).LT.XMIN*MPARAM%MAXWATR_1) X_TRY(ISTT) = XMIN*MPARAM%MAXWATR_1 - IF(X_TRY(ISTT).GT. MPARAM%MAXWATR_1) X_TRY(ISTT) = MPARAM%MAXWATR_1 - ! lower tanks - CASE (iopt_TENS_2) - IF(X_TRY(ISTT).LT.XMIN*DPARAM%MAXTENS_2) X_TRY(ISTT) = XMIN*DPARAM%MAXTENS_2 - IF(X_TRY(ISTT).GT. DPARAM%MAXTENS_2) X_TRY(ISTT) = DPARAM%MAXTENS_2 - CASE (iopt_FREE2A) - IF(X_TRY(ISTT).LT.XMIN*DPARAM%MAXFREE_2A) X_TRY(ISTT) = XMIN*DPARAM%MAXFREE_2A - IF(X_TRY(ISTT).GT. DPARAM%MAXFREE_2A) X_TRY(ISTT) = DPARAM%MAXFREE_2A - CASE (iopt_FREE2B) - IF(X_TRY(ISTT).LT.XMIN*DPARAM%MAXFREE_2B) X_TRY(ISTT) = XMIN*DPARAM%MAXFREE_2B - IF(X_TRY(ISTT).GT. DPARAM%MAXFREE_2B) X_TRY(ISTT) = DPARAM%MAXFREE_2B - CASE (iopt_WATR_2) - ! *** SET LOWER LIMITS *** - IF (SMODL%iARCH2.NE.iopt_topmdexp_2) THEN - ! enforce lower limit - IF (X_TRY(ISTT).LT.XMIN*MPARAM%MAXWATR_2) X_TRY(ISTT) = XMIN*MPARAM%MAXWATR_2 - ELSE - ! MPARAM%MAXWATR_2 is just a scaling parameter, but don't allow stupid values - IF (X_TRY(ISTT).LT.-MPARAM%MAXWATR_2*10._sp) X_TRY(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 - IF (X_TRY(ISTT).GT.MPARAM%MAXWATR_2) X_TRY(ISTT) = MPARAM%MAXWATR_2 - ELSE - ! unlimited storage, but make sure the values are still sensible - !IF (X_TRY(ISTT).GT.MPARAM%MAXWATR_2*100._sp) X_TRY(ISTT) = MPARAM%MAXWATR_2*100._sp - ENDIF - END SELECT -END DO ! (loop through states) -! --------------------------------------------------------------------------------------- -END SUBROUTINE LIMIT_XTRY -END MODULE LIMIT_XTRY_MODULE diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/lnsrch.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/lnsrch.f90.svn-base deleted file mode 100644 index ae5a2d6..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/lnsrch.f90.svn-base +++ /dev/null @@ -1,76 +0,0 @@ - SUBROUTINE lnsrch(xold,fold,g,p,x,f,stpmax,check,func) - USE nrtype; USE nrutil, ONLY : assert_eq,nrerror,vabs - USE model_numerix, ONLY : ERR_ITER_DX,NUM_FUNCS ! convergence criterion on dx - USE limit_xtry_module ! provide access to limit_xtry - IMPLICIT NONE - REAL(SP), DIMENSION(:), INTENT(IN) :: xold,g - REAL(SP), DIMENSION(:), INTENT(INOUT) :: p - REAL(SP), INTENT(IN) :: fold,stpmax - REAL(SP), DIMENSION(:), INTENT(OUT) :: x - REAL(SP), INTENT(OUT) :: f - LOGICAL(LGT), INTENT(OUT) :: check - INTERFACE - FUNCTION func(x) - USE nrtype - IMPLICIT NONE - REAL(SP) :: func - REAL(SP), DIMENSION(:), INTENT(IN) :: x - END FUNCTION func - END INTERFACE - REAL(SP), PARAMETER :: ALF=1.0e-4_sp - INTEGER(I4B) :: ndum - REAL(SP) :: a,alam,alam2,alamin,b,disc,f2,fold2,pabs,rhs1,rhs2,slope,& - tmplam - ndum=assert_eq(size(g),size(p),size(x),size(xold),'lnsrch') - check=.false. - pabs=vabs(p(:)) - if (pabs > stpmax) p(:)=p(:)*stpmax/pabs - slope=dot_product(g,p) - alamin=ERR_ITER_DX/maxval(abs(p(:))/max(abs(xold(:)),1.0_sp)) - alam=1.0 - do - x(:)=xold(:)+alam*p(:) - !print *, 'alam = ', alam, alamin - !print *, 'in lnsrch, x raw = ', x - call limit_xtry(x) ! ensure that the value of x is physically reasonable - f=func(x) ! compute function evaluation (populate FVEC and DSDT) - !print *, 'in lnsrch, x new = ', x, f - !write(*,'(i4,1x20(f20.10,1x))') num_funcs, x - if (alam < alamin) then - x(:)=xold(:) - check=.true. - RETURN - else if (f <= fold+ALF*alam*slope) then - RETURN - else - if (alam == 1.0) then - tmplam=-slope/(2.0_sp*(f-fold-slope)) - else - rhs1=f-fold-alam*slope - rhs2=f2-fold2-alam2*slope - a=(rhs1/alam**2-rhs2/alam2**2)/(alam-alam2) - b=(-alam2*rhs1/alam**2+alam*rhs2/alam2**2)/& - (alam-alam2) - if (a == 0.0) then - tmplam=-slope/(2.0_sp*b) - else - disc=b*b-3.0_sp*a*slope - !if (disc < 0.0) call nrerror('roundoff problem in lnsrch') - ! MPC change -- this should only happen for small alam - if (disc < 0.0) then - x(:)=xold(:) - check=.true. - RETURN - endif - ! end MPC change - tmplam=(-b+sqrt(disc))/(3.0_sp*a) - end if - if (tmplam > 0.5_sp*alam) tmplam=0.5_sp*alam - end if - end if - alam2=alam - f2=f - fold2=fold - alam=max(tmplam,0.1_sp*alam) - end do - END SUBROUTINE lnsrch diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/logismooth.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/logismooth.f90.svn-base deleted file mode 100644 index b149654..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/logismooth.f90.svn-base +++ /dev/null @@ -1,22 +0,0 @@ -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) :: ASMOOTH ! actual smoothing -REAL(SP) :: LOGISMOOTH ! FUNCTION name -! --------------------------------------------------------------------------------------- -ASMOOTH = PSMOOTH*STATE_MAX ! actual smoothing -LOGISMOOTH = 1._SP / ( 1._SP + EXP(-(STATE - (STATE_MAX - ASMOOTH*5._SP) ) / ASMOOTH) ) -! --------------------------------------------------------------------------------------- -END FUNCTION LOGISMOOTH diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/mean_stats.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/mean_stats.f90.svn-base deleted file mode 100644 index 42713f4..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/mean_stats.f90.svn-base +++ /dev/null @@ -1,105 +0,0 @@ -SUBROUTINE MEAN_STATS() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Computes summary statistics from model simulations -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multistats -- summary statistics stored in MODULE multistats -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -! FUSE modules -USE multiforce ! model forcing data (obs streamflow) -USE multiroute ! routed runoff -USE multistats ! summary statistics -USE model_numerix ! model numerix parameters and data -IMPLICIT NONE -! internal -INTEGER(I4B) :: I ! looping -INTEGER(I4B) :: NS ! number of samples -INTEGER(I4B) :: IERR ! error code for allocate/deallocate statements -REAL(SP), DIMENSION(:), ALLOCATABLE :: QOBS ! observed runoff -REAL(SP), DIMENSION(:), ALLOCATABLE :: QSIM ! simulated runoff -REAL(SP), DIMENSION(:), ALLOCATABLE :: DOBS ! observed runoff anomalies -REAL(SP), DIMENSION(:), ALLOCATABLE :: DSIM ! simulated runoff anomalies -REAL(SP), DIMENSION(:), ALLOCATABLE :: RAWD ! observed-simulated differences in flow -REAL(SP), DIMENSION(:), ALLOCATABLE :: LOGD ! observed-simulated differences in LOG flow -REAL(SP) :: XB_OBS ! mean observed runoff -REAL(SP) :: XB_SIM ! mean simulated runoff -REAL(SP) :: SS_OBS ! sum of squared observed runoff anomalies -REAL(SP) :: SS_SIM ! sum of squared simulated runoff anomalies -REAL(SP) :: SS_LOBS ! sum of squared lagged differences in observed runoff -REAL(SP) :: SS_LSIM ! sum of squared lagged differences in simulated runoff -REAL(SP) :: SS_RAW ! sum of squared differences in observed - simulated -REAL(SP) :: SS_LOG ! sum of squared differences in LOG observed - LOG simulated -REAL(SP), PARAMETER :: NO_ZERO=1.E-20 ! avoid divide by zero -! --------------------------------------------------------------------------------------- -! (1) PRELIMINARIES -! --------------------------------------------------------------------------------------- -! define sample size -NS = (NUMTIM-ISTART) + 1 ! (ISTART is shared in MODULE multiforce) -! allocate space for observed and simulated runoff -ALLOCATE(QOBS(NS),QSIM(NS),DOBS(NS),DSIM(NS),RAWD(NS),LOGD(NS),STAT=IERR) -IF (IERR.NE.0) STOP ' PROBLEM ALLOCATING SPACE IN MEAN_STATS.F90 ' -! extract vectors from data structures -QOBS = AFORCE(ISTART:NUMTIM)%OBSQ -QSIM = AROUTE(ISTART:NUMTIM)%Q_ROUTED -! compute mean -XB_OBS = SUM(QOBS(:)) / REAL(NS, KIND(SP)) -XB_SIM = SUM(QSIM(:)) / REAL(NS, KIND(SP)) -! compute the sum of squares of simulated and observed vectors -DOBS(:) = QOBS(:) - XB_OBS -DSIM(:) = QSIM(:) - XB_SIM -SS_OBS = DOT_PRODUCT(DOBS,DOBS) ! = SUM( DOBS(:)*DOBS(:) ) -SS_SIM = DOT_PRODUCT(DSIM,DSIM) ! = SUM( DSIM(:)*DSIM(:) ) -! compute the sum of squares of lagged differences -SS_LOBS = DOT_PRODUCT(DOBS(2:NS),DOBS(1:NS-1)) -SS_LSIM = DOT_PRODUCT(DSIM(2:NS),DSIM(1:NS-1)) -! compute sum of squared differences between model and observations -RAWD(:) = QSIM(:) - QOBS(:) -LOGD(:) = LOG(QSIM(:)) - LOG(QOBS(:)) -SS_RAW = DOT_PRODUCT(RAWD,RAWD) ! = SUM( RAWD(:)*RAWD(:) ) -SS_LOG = DOT_PRODUCT(LOGD,LOGD) ! = SUM( LOGD(:)*LOGD(:) ) -! --------------------------------------------------------------------------------------- -! (2) COMPUTE ERROR STATISTICS -! --------------------------------------------------------------------------------------- -! compute the mean -MSTATS%QOBS_MEAN = XB_OBS -MSTATS%QSIM_MEAN = XB_SIM -! compute the coefficient of variation -MSTATS%QOBS_CVAR = SQRT( SS_OBS / REAL(NS-1, KIND(SP)) ) / (XB_OBS+NO_ZERO) -MSTATS%QSIM_CVAR = SQRT( SS_SIM / REAL(NS-1, KIND(SP)) ) / (XB_SIM+NO_ZERO) -! compute the lag-1 correlation coefficient -MSTATS%QOBS_LAG1 = SS_LOBS / (SQRT(SS_OBS*SS_OBS)+NO_ZERO) -MSTATS%QSIM_LAG1 = SS_LSIM / (SQRT(SS_SIM*SS_SIM)+NO_ZERO) -! compute the root-mean-squared-error of flow -MSTATS%RAW_RMSE = SQRT( SS_RAW / REAL(NS, KIND(SP)) ) -! compute the root-mean-squared-error of LOG flow -MSTATS%LOG_RMSE = SQRT( SS_LOG / REAL(NS, KIND(SP)) ) -! compute the Nash-Sutcliffe score -MSTATS%NASH_SUTT = 1. - SS_RAW/(SS_OBS+NO_ZERO) -! --------------------------------------------------------------------------------------- -! (4) COMPUTE STATISTICS ON NUMERICAL ACCURACY AND EFFICIENCY -! --------------------------------------------------------------------------------------- -! compute RMSE between "more accurate" and "less accurate" solutions -QOBS = AROUTE(ISTART:NUMTIM)%Q_ACCURATE -RAWD(:) = QSIM(:) - QOBS(:); SS_RAW = DOT_PRODUCT(RAWD,RAWD) ! = SUM( RAWD(:)*RAWD(:) ) -MSTATS%NUM_RMSE = SQRT( SS_RAW / REAL(NS, KIND(SP)) ) -! compute summary statistics for efficiency -MSTATS%NUM_FUNCS = MSTATS%NUM_FUNCS / REAL(NUMTIM, KIND(SP)) ! number of function calls -MSTATS%NUM_JACOBIAN = MSTATS%NUM_JACOBIAN / REAL(NUMTIM, KIND(SP)) ! number of times Jacobian is calculated -MSTATS%NUMSUB_ACCEPT = MSTATS%NUMSUB_ACCEPT / REAL(NUMTIM, KIND(SP)) ! number of sub-steps accepted (taken) -MSTATS%NUMSUB_REJECT = MSTATS%NUMSUB_REJECT / REAL(NUMTIM, KIND(SP)) ! number of sub-steps tried but rejected -MSTATS%NUMSUB_NOCONV = MSTATS%NUMSUB_NOCONV / REAL(NUMTIM, KIND(SP)) ! number of sub-steps tried that did not converge -! compute cumulative probability distributions -MSTATS%NUMSUB_PROB = REAL(PRB_NSUBS(:), KIND(SP)) / REAL(NUMTIM, KIND(SP)) -! --------------------------------------------------------------------------------------- -DEALLOCATE(QOBS,QSIM,DOBS,DSIM,RAWD,LOGD,STAT=IERR) -IF (IERR.NE.0) STOP ' PROBLEM DEALLOCATING SPACE IN MEAN_STATS.F90 ' -! --------------------------------------------------------------------------------------- -END SUBROUTINE MEAN_STATS diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/mean_tipow.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/mean_tipow.f90.svn-base deleted file mode 100644 index c1e88f8..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/mean_tipow.f90.svn-base +++ /dev/null @@ -1,71 +0,0 @@ -SUBROUTINE MEAN_TIPOW() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Computes the mean of the power-transformed topographic index -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multiparam -- mean topographic index stored in MODULE multiparam -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE nr, ONLY : gammp ! interface for the incomplete gamma function -USE multiparam ! model parameters -IMPLICIT NONE -! internal variables -INTEGER(I4B) :: IBIN ! loop through bins -INTEGER(I4B), PARAMETER :: NBINS=2000 ! number of bins in PDF of topo index -REAL(SP), PARAMETER :: TI_MAX=50._SP ! maximum possible log-transformed index -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) :: LOWERV ! lower value of frequency bin -REAL(SP) :: UPPERV ! upper value of frequency bin -REAL(SP) :: LOWERP ! cumulative probability of the lower value -REAL(SP) :: UPPERP ! cumulative probability of the upper value -REAL(SP) :: GMARG2 ! 2nd argument to the incomplete Gamma function -REAL(SP) :: PROBIN ! probability of the current bin -REAL(SP) :: LOGVAL ! log-transformed index for the current bin -REAL(SP) :: POWVAL ! power-transformed index for the current bin -!REAL(SP) :: AVELOG ! average log-transformed index (testing) -REAL(SP) :: AVEPOW ! average power-transformed index -! --------------------------------------------------------------------------------------- -! preliminaries -- get parameters of the Gamma distribution (save typing) -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) -! values for testing (Sivapalan et al., WRR, December 1987) -!TI_OFF = 3.82_SP ! TI_OFF = 2.92_SP -!TI_SHP = 2.48_SP ! TI_SHP = 3.52_SP -!TI_CHI = 1.00_SP ! TI_CHI = 0.742_SP -! loop through the frequency distribution -LOWERV = 0._SP -LOWERP = 0._SP -!AVELOG = 0._SP -AVEPOW = 0._SP -DO IBIN=1,NBINS - ! get probability for the current bin - UPPERV = (REAL(IBIN)/REAL(NBINS)) * TI_MAX ! upper value in frequency bin - GMARG2 = MAX(0._SP, UPPERV - TI_OFF) / TI_CHI ! 2nd argument to the Gamma function - UPPERP = GAMMP(TI_SHP, GMARG2) ! GAMMP is the incomplete Gamma function - PROBIN = UPPERP-LOWERP ! probability of the current bin - ! get the scaled topographic index value - LOGVAL = 0.5_SP*(LOWERV+UPPERV) ! log-transformed index for the current bin - POWVAL = (EXP(LOGVAL))**(1._SP/MPARAM%QB_POWR) ! power-transformed index for the current bin - !AVELOG = AVELOG + LOGVAL*PROBIN ! average log-transformed index (testing) - AVEPOW = AVEPOW + POWVAL*PROBIN ! average power-transformed index - !write(*,'(7(f9.3,1x))') lowerv, upperv, logval, powval, avelog, avepow - ! save the lower value and probability - LOWERV = UPPERV ! lower value for the next bin - LOWERP = UPPERP ! cumulative probability for the next bin -END DO ! (looping through bins) -DPARAM%MAXPOW = POWVAL -DPARAM%POWLAMB = AVEPOW -!print *, DPARAM%POWLAMB, MPARAM%QB_POWR -!pause -! --------------------------------------------------------------------------------------- -END SUBROUTINE MEAN_TIPOW diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/meanfluxes.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/meanfluxes.f90.svn-base deleted file mode 100644 index f23db91..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/meanfluxes.f90.svn-base +++ /dev/null @@ -1,50 +0,0 @@ -SUBROUTINE MEANFLUXES() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Compute 0.5*(FLUX_0 + FLUX_1) -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! Fluxes in MODULE multi_flux -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE multi_flux ! model fluxes -USE multistate ! model states (use time step) -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -M_FLUX%EFF_PPT = 0.5_sp * (FLUX_0%EFF_PPT + FLUX_1%EFF_PPT ) -M_FLUX%SATAREA = 0.5_sp * (FLUX_0%SATAREA + FLUX_1%SATAREA ) -M_FLUX%QSURF = 0.5_sp * (FLUX_0%QSURF + FLUX_1%QSURF ) -M_FLUX%EVAP_1A = 0.5_sp * (FLUX_0%EVAP_1A + FLUX_1%EVAP_1A ) -M_FLUX%EVAP_1B = 0.5_sp * (FLUX_0%EVAP_1B + FLUX_1%EVAP_1B ) -M_FLUX%EVAP_1 = 0.5_sp * (FLUX_0%EVAP_1 + FLUX_1%EVAP_1 ) -M_FLUX%EVAP_2 = 0.5_sp * (FLUX_0%EVAP_2 + FLUX_1%EVAP_2 ) -M_FLUX%RCHR2EXCS = 0.5_sp * (FLUX_0%RCHR2EXCS + FLUX_1%RCHR2EXCS ) -M_FLUX%TENS2FREE_1 = 0.5_sp * (FLUX_0%TENS2FREE_1 + FLUX_1%TENS2FREE_1) -M_FLUX%TENS2FREE_2 = 0.5_sp * (FLUX_0%TENS2FREE_2 + FLUX_1%TENS2FREE_2) -M_FLUX%QINTF_1 = 0.5_sp * (FLUX_0%QINTF_1 + FLUX_1%QINTF_1 ) -M_FLUX%QPERC_12 = 0.5_sp * (FLUX_0%QPERC_12 + FLUX_1%QPERC_12 ) -M_FLUX%QBASE_2 = 0.5_sp * (FLUX_0%QBASE_2 + FLUX_1%QBASE_2 ) -M_FLUX%QBASE_2A = 0.5_sp * (FLUX_0%QBASE_2A + FLUX_1%QBASE_2A ) -M_FLUX%QBASE_2B = 0.5_sp * (FLUX_0%QBASE_2B + FLUX_1%QBASE_2B ) -M_FLUX%OFLOW_1 = 0.5_sp * (FLUX_0%OFLOW_1 + FLUX_1%OFLOW_1 ) -M_FLUX%OFLOW_2 = 0.5_sp * (FLUX_0%OFLOW_2 + FLUX_1%OFLOW_2 ) -M_FLUX%OFLOW_2A = 0.5_sp * (FLUX_0%OFLOW_2A + FLUX_1%OFLOW_2A ) -M_FLUX%OFLOW_2B = 0.5_sp * (FLUX_0%OFLOW_2B + FLUX_1%OFLOW_2B ) -M_FLUX%ERR_WATR_1 = 0.5_sp * (FLUX_0%ERR_WATR_1 + FLUX_1%ERR_WATR_1 ) -M_FLUX%ERR_TENS_1 = 0.5_sp * (FLUX_0%ERR_TENS_1 + FLUX_1%ERR_TENS_1 ) -M_FLUX%ERR_FREE_1 = 0.5_sp * (FLUX_0%ERR_FREE_1 + FLUX_1%ERR_FREE_1 ) -M_FLUX%ERR_TENS_1A = 0.5_sp * (FLUX_0%ERR_TENS_1A + FLUX_1%ERR_TENS_1A) -M_FLUX%ERR_TENS_1B = 0.5_sp * (FLUX_0%ERR_TENS_1B + FLUX_1%ERR_TENS_1B) -M_FLUX%ERR_WATR_2 = 0.5_sp * (FLUX_0%ERR_WATR_2 + FLUX_1%ERR_WATR_2 ) -M_FLUX%ERR_TENS_2 = 0.5_sp * (FLUX_0%ERR_TENS_2 + FLUX_1%ERR_TENS_2 ) -M_FLUX%ERR_FREE_2 = 0.5_sp * (FLUX_0%ERR_FREE_2 + FLUX_1%ERR_FREE_2 ) -M_FLUX%ERR_FREE_2A = 0.5_sp * (FLUX_0%ERR_FREE_2A + FLUX_1%ERR_FREE_2A) -M_FLUX%ERR_FREE_2B = 0.5_sp * (FLUX_0%ERR_FREE_2B + FLUX_1%ERR_FREE_2B) -! --------------------------------------------------------------------------------------- -END SUBROUTINE MEANFLUXES diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/meta_stats.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/meta_stats.f90.svn-base deleted file mode 100644 index 6afadb0..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/meta_stats.f90.svn-base +++ /dev/null @@ -1,47 +0,0 @@ -MODULE meta_stats -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Describe all summary statistics (used to define NetCDF output files, etc.) -! --------------------------------------------------------------------------------------- -! variable definitions -USE nrtype -IMPLICIT NONE -CHARACTER(LEN=11), DIMENSION(100) :: XNAME ! variable names -CHARACTER(LEN=52), DIMENSION(100) :: XDESC ! variable long names (descrition of variable) -CHARACTER(LEN=13), DIMENSION(100) :: XUNIT ! variable units -INTEGER(I4B) :: I ! loop through variables -INTEGER(I4B) :: NSUMVAR ! number of summary variables -CONTAINS -! --------------------------------------------------------------------------------------- -SUBROUTINE SUMDESCRIBE() -I=0 ! initialize counter -! DMSL diagnostix -I=I+1; XNAME(I)='var_residul'; XDESC(I)='variance of the model residuals, used in MCMC '; XUNIT(I)='mm**2 ' -I=I+1; XNAME(I)='logp_simuln'; XDESC(I)='log density of the simulation '; XUNIT(I)='problem_depnt' -I=I+1; XNAME(I)='jump_taken '; XDESC(I)='MCMC jump diagnostix; 0 = no jump; 1 = jumping '; XUNIT(I)='- ' -! comparisons between model output and observations -I=I+1; XNAME(I)='qobs_mean '; XDESC(I)='mean observed runoff '; XUNIT(I)='mm timestep-1' -I=I+1; XNAME(I)='qsim_mean '; XDESC(I)='mean simulated runoff '; XUNIT(I)='mm timestep-1' -I=I+1; XNAME(I)='qobs_cvar '; XDESC(I)='coefficient of variation of observed runoff '; XUNIT(I)='- ' -I=I+1; XNAME(I)='qsim_cvar '; XDESC(I)='coefficient of variation of simulated runoff '; XUNIT(I)='- ' -I=I+1; XNAME(I)='qobs_lag1 '; XDESC(I)='lag-1 correlation of observed runoff '; XUNIT(I)='- ' -I=I+1; XNAME(I)='qsim_lag1 '; XDESC(I)='lag-1 correlation of simulated runoff '; XUNIT(I)='- ' -I=I+1; XNAME(I)='raw_rmse '; XDESC(I)='root-mean-squared-error of flow '; XUNIT(I)='mm timestep-1' -I=I+1; XNAME(I)='log_rmse '; XDESC(I)='root-mean-squared-error of LOG flow '; XUNIT(I)='mm timestep-1' -I=I+1; XNAME(I)='nash_sutt '; XDESC(I)='Nash-Sutcliffe score '; XUNIT(I)='- ' -! attributes of model output -I=I+1; XNAME(I)='numerx_rmse'; XDESC(I)='RMSE between exact and approximate solution '; XUNIT(I)='mm timestep-1' -I=I+1; XNAME(I)='mean_nfuncs'; XDESC(I)='mean number function evaluations '; XUNIT(I)='- ' -I=I+1; XNAME(I)='mean_njacob'; XDESC(I)='mean number jacobian evaluations '; XUNIT(I)='- ' -I=I+1; XNAME(I)='mean_accept'; XDESC(I)='mean number sub-steps accepted (taken) '; XUNIT(I)='- ' -I=I+1; XNAME(I)='mean_reject'; XDESC(I)='mean number sub-steps tried but rejected '; XUNIT(I)='- ' -I=I+1; XNAME(I)='mean_noconv'; XDESC(I)='mean number sub-steps tried that did not converge '; XUNIT(I)='- ' -I=I+1; XNAME(I)='maxnum_iter'; XDESC(I)='maximum number of iterations in the implicit scheme'; XUNIT(I)='- ' -NSUMVAR=I -END SUBROUTINE SUMDESCRIBE -END MODULE meta_stats diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/metaoutput.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/metaoutput.f90.svn-base deleted file mode 100644 index a643fdd..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/metaoutput.f90.svn-base +++ /dev/null @@ -1,84 +0,0 @@ -MODULE metaoutput -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Describe all variables used in the model (used to define NetCDF output files, etc.) -! --------------------------------------------------------------------------------------- -! variable definitions -USE nrtype -IMPLICIT NONE -LOGICAL(LGT) :: Q_ONLY=.FALSE. ! .TRUE. = restrict attention to simulated runoff -CHARACTER(LEN=11), DIMENSION(100) :: VNAME ! variable names -CHARACTER(LEN=52), DIMENSION(100) :: LNAME ! variable long names (descrition of variable) -CHARACTER(LEN=13), DIMENSION(100) :: VUNIT ! variable units -INTEGER(I4B) :: I ! loop through variables -INTEGER(I4B) :: NOUTVAR ! number of output variables -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)='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 ' -! 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' -NOUTVAR=I -END SUBROUTINE VARDESCRIBE -END MODULE metaoutput diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/metaparams.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/metaparams.f90.svn-base deleted file mode 100644 index 70b6df1..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/metaparams.f90.svn-base +++ /dev/null @@ -1,85 +0,0 @@ -MODULE metaparams -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Describe all parameters used in the model (used to define NetCDF output files, etc.) -! --------------------------------------------------------------------------------------- -! variable definitions -USE nrtype -IMPLICIT NONE -CHARACTER(LEN=11), DIMENSION(100) :: PNAME ! parameter names -CHARACTER(LEN=52), DIMENSION(100) :: PDESC ! parameter long names (description of variable) -CHARACTER(LEN= 8), DIMENSION(100) :: PUNIT ! paramerter units -INTEGER(I4B) :: I ! loop through parameter sets -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 ' -! 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)' -! 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 -END MODULE metaparams diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/mod_derivs.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/mod_derivs.f90.svn-base deleted file mode 100644 index dd5c28c..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/mod_derivs.f90.svn-base +++ /dev/null @@ -1,36 +0,0 @@ -SUBROUTINE MOD_DERIVS() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! compute the derivative (dydx) of all model states (y) at time (x) -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multi_flux -- populate structure M_FLUX%(*) -! MODULE multistate -- populate structure DY_DT%(*) -USE model_numerix, ONLY: NUM_FUNCS ! (number of function evaluations) -! --------------------------------------------------------------------------------------- -! (1) COMPUTE FLUXES -! --------------------------------------------------------------------------------------- -CALL QRAINERROR() ! compute the "effective" rainfall, following a prescribed error model -CALL QSATEXCESS() ! compute the saturated area and surface runoff -CALL EVAP_UPPER() ! compute evaporation from the upper layer -CALL EVAP_LOWER() ! compute evaporation from the lower layer -CALL QINTERFLOW() ! compute interflow from free water in the upper layer -CALL QPERCOLATE() ! compute percolation from the upper to lower soil layers -CALL Q_BASEFLOW() ! compute baseflow from the lower soil layer -CALL Q_MISSCELL() ! compute miscellaneous fluxes (NOTE: need sat area, evap, and perc) -! --------------------------------------------------------------------------------------- -! (2) COMPUTE DERIVATIVES FOR EACH OF THE MODEL STATES -! --------------------------------------------------------------------------------------- -CALL MSTATE_EQN() -! --------------------------------------------------------------------------------------- -! (3) KEEP TRACK OF THE NUMBER OF FUNCTION CALLS -! --------------------------------------------------------------------------------------- -NUM_FUNCS = NUM_FUNCS + 1 ! NUM_FUNCS is shared in module model_numerix -! --------------------------------------------------------------------------------------- -END SUBROUTINE MOD_DERIVS diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/model_defn.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/model_defn.f90.svn-base deleted file mode 100644 index c9be589..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/model_defn.f90.svn-base +++ /dev/null @@ -1,63 +0,0 @@ -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 - TYPE DESC - CHARACTER(LEN=10) :: MCOMPONENT ! description of model compopnent - 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 - ! structure that holds (x) unique combinations - TYPE UMODEL - INTEGER(I4B) :: MODIX ! model index - CHARACTER(LEN=256) :: MNAME ! model name -! CHARACTER(LEN=10) :: RFERR ! rainfall error - INTEGER(I4B) :: iRFERR -! CHARACTER(LEN=10) :: ARCH1 ! upper-layer architecture - INTEGER(I4B) :: iARCH1 -! CHARACTER(LEN=10) :: ARCH2 ! lower-layer architecture - INTEGER(I4B) :: iARCH2 -! CHARACTER(LEN=10) :: QSURF ! surface runoff - INTEGER(I4B) :: iQSURF -! CHARACTER(LEN=10) :: QPERC ! percolation - INTEGER(I4B) :: iQPERC -! CHARACTER(LEN=10) :: ESOIL ! evaporation - INTEGER(I4B) :: iESOIL -! CHARACTER(LEN=10) :: QINTF ! interflow - INTEGER(I4B) :: iQINTF -! CHARACTER(LEN=10) :: Q_TDH ! time delay in runoff - INTEGER(I4B) :: iQ_TDH - END TYPE UMODEL - ! structure to hold model state names - TYPE SNAMES -! CHARACTER(LEN=6) :: SNAME ! state name - INTEGER(I4B) :: iSNAME ! integer value of state name - END TYPE SNAMES - ! structure to hold model flux names - TYPE FNAMES - CHARACTER(LEN=11) :: FNAME ! state name - END TYPE FNAMES -! max steps in routing function - INTEGER(I4B),PARAMETER::NTDH_MAX=500 -! model definitions - CHARACTER(LEN=256) :: FNAME_NETCDF ! NETCDF output filename - 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 - INTEGER(I4B),PARAMETER :: OUTFILE_UNIT=21 ! unit for output file - TYPE(UMODEL),DIMENSION(5000) :: AMODL ! (model definition -- all) - TYPE(UMODEL) :: SMODL ! (model definition -- single model) - TYPE(SNAMES),DIMENSION(6) :: 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/FUSE_ENGINE/.svn/text-base/model_defnames.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/model_defnames.f90.svn-base deleted file mode 100644 index 5a19b35..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/model_defnames.f90.svn-base +++ /dev/null @@ -1,105 +0,0 @@ -module model_defnames -! Purpose: Contains routines for alternating between char <-> int names -! Programmers: David McInerney and Dmitri Kavetski (University of Adelaide) -USE nrtype -implicit none -! parameterised descriptions -integer(I4B), parameter :: iopt_additive_e = 1001, & - iopt_multiplc_e = 1002, & - iopt_tension1_1 = 2001, & - iopt_tension2_1 = 2002, & - iopt_onestate_1 = 2003, & - iopt_tens2pll_2 = 3001, & - iopt_unlimfrc_2 = 3002, & - iopt_unlimpow_2 = 3003, & - iopt_fixedsiz_2 = 3004, & - iopt_topmdexp_2 = 3005, & - iopt_arno_x_vic = 4001, & - iopt_prms_varnt = 4002, & - iopt_tmdl_param = 4003, & - iopt_perc_f2sat = 5001, & - iopt_perc_w2sat = 5002, & - iopt_perc_lower = 5003, & - iopt_sequential = 6001, & - iopt_rootweight = 6002, & - iopt_intflwnone = 7001, & - iopt_intflwsome = 7002, & - iopt_rout_gamma = 8001, & - iopt_no_routing = 8002 -! --- -integer(I4B), parameter :: iopt_TENS1A = 9001, & - iopt_TENS1B = 9002, & - iopt_TENS_1 = 9003, & - iopt_FREE_1 = 9004, & - iopt_WATR_1 = 9005, & - iopt_TENS_2 = 9006, & - iopt_FREE2A = 9007, & - iopt_FREE2B = 9008, & - iopt_WATR_2 = 9009 -! ------------------------------------------ -contains -! ------------------------------------------ -elemental function desc_str2int(name)result(res) -! Purpose: Converts a string description into its corresponding integer value. -implicit none -! dummies -character(*), intent(in) :: name -integer(I4B) :: res -! Start procedure here -selectcase(name) -case("additive_e"); res = iopt_additive_e -case("multiplc_e"); res = iopt_multiplc_e -case("tension1_1"); res = iopt_tension1_1 -case("tension2_1"); res = iopt_tension2_1 -case("onestate_1"); res = iopt_onestate_1 -case("tens2pll_2"); res = iopt_tens2pll_2 -case("unlimfrc_2"); res = iopt_unlimfrc_2 -case("unlimpow_2"); res = iopt_unlimpow_2 -case("fixedsiz_2"); res = iopt_fixedsiz_2 -case("arno_x_vic"); res = iopt_arno_x_vic -case("prms_varnt"); res = iopt_prms_varnt -case("tmdl_param"); res = iopt_tmdl_param -case("perc_f2sat"); res = iopt_perc_f2sat -case("perc_w2sat"); res = iopt_perc_w2sat -case("perc_lower"); res = iopt_perc_lower -case("sequential"); res = iopt_sequential -case("rootweight"); res = iopt_rootweight -case("intflwnone"); res = iopt_intflwnone -case("intflwsome"); res = iopt_intflwsome -case("rout_gamma"); res = iopt_rout_gamma -case("no_routing"); res = iopt_no_routing -case("TENS1B"); res = iopt_TENS1B -case("TENS_1"); res = iopt_TENS_1 -case("FREE_1"); res = iopt_FREE_1 -case("WATR_1"); res = iopt_WATR_1 -case("TENS_2"); res = iopt_TENS_2 -case("FREE2A"); res = iopt_FREE2A -case("FREE2B"); res = iopt_FREE2B -case("WATR_2"); res = iopt_WATR_2 -case default; res = -999 -endselect -! End procedure here -endfunction desc_str2int -! ------------------------------------------ -elemental function desc_int2str(intVal)result(res) -! Purpose: Converts an integer description into corresponding string value -implicit none -! dummies -integer(I4B), intent(in) :: intVal -character(10) :: res -! Start procedure here -selectcase(intVal) -case(iopt_TENS1B); res = "TENS1B" -case(iopt_TENS_1); res = "TENS_1" -case(iopt_FREE_1); res = "FREE_1" -case(iopt_WATR_1); res = "WATR_1" -case(iopt_TENS_2); res = "TENS_2" -case(iopt_FREE2A); res = "FREE2A" -case(iopt_FREE2B); res = "FREE2B" -case(iopt_WATR_2); res = "WATR_2" -case default; res = "UNDFND" -endselect -! End procedure here -endfunction desc_int2str -! ------------------------------------------ -endmodule model_defnames diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/model_numerix.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/model_numerix.f90.svn-base deleted file mode 100644 index 8aefa42..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/model_numerix.f90.svn-base +++ /dev/null @@ -1,61 +0,0 @@ -!****************************************************************** -MODULE model_numerix -! Purpose: To define method/parameters used for numerical solution -! Programmer: Dmitri Kavetski and Martyn Clark -! Last modified: -! Comments: -USE nrtype -implicit none -! --------------------------------------------------------------------------------------- -! (A) METHODS -! --------------------------------------------------------------------------------------- -! 1. Solution technique -INTEGER(I4B), PARAMETER :: EXPLICIT_EULER=0, EXPLICIT_HEUN=1, IMPLICIT_EULER=2, & - IMPLICIT_HEUN=3, SEMI_IMPLICIT=4 -INTEGER(I4B) :: SOLUTION_METHOD -! 2. Temporal error control -INTEGER(I4B), PARAMETER :: TS_FIXED=0, TS_ADAPT=1 -INTEGER(I4B) :: TEMPORAL_ERROR_CONTROL -! 3. Method used to estimate the initial conditions for the Newton scheme -INTEGER(I4B), PARAMETER :: STATE_OLD=0, EXPLICIT_MID=1, EXPLICIT_FULL=2 -INTEGER(I4B) :: INITIAL_NEWTON -! 4. Jacobian re-evaluation strategy -INTEGER(I4B), PARAMETER :: FULLYVARIABLE=0, CONST_SUBSTEP=1, CONSTFULLSTEP=2, PERIOD_FREEZE=3, & - SMALL_F_RATIO=4 -INTEGER(I4B) :: JAC_RECOMPUTE -REAL(SP), ALLOCATABLE :: fjacDCMP(:,:), fjacCOPY(:,:), fjacINDX(:) ! (temporary arrays) -! 5. Method used to trap/fix errors in Newton -INTEGER(I4B), PARAMETER :: FULL_NEWTON=0, LINE_SEARCH=1 -INTEGER(I4B) :: CHECK_OVERSHOOT -! 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 -! --------------------------------------------------------------------------------------- -! (B) PARAMETERS -! --------------------------------------------------------------------------------------- -REAL(SP) :: ERR_TRUNC_ABS ! Absolute temporal truncation error tolerance -REAL(SP) :: ERR_TRUNC_REL ! Relative temporal truncation error tolerance -REAL(SP) :: ERR_ITER_FUNC ! Iteration convergence tolerance for function values -REAL(SP) :: ERR_ITER_DX ! Iteration convergence tolerance for dx -REAL(SP) :: THRESH_FRZE ! Threshold for freezing the Jacobian -REAL(SP) :: FRACSTATE_MIN ! Fractional minimum value of state (for non-zero derivatives) -REAL(SP) :: SAFETY ! Safety factor in step-size equation -REAL(SP) :: RMIN ! Minimum step size multiplier -REAL(SP) :: RMAX ! Maximum step size multiplier -INTEGER(I4B) :: NITER_TOTAL ! Total number of iterations used in the implicit scheme -REAL(SP) :: MIN_TSTEP ! Minimum time step length -REAL(SP) :: MAX_TSTEP ! Maximum time step length -! --------------------------------------------------------------------------------------- -! (C) DIAGNOSTIX -! --------------------------------------------------------------------------------------- -INTEGER(I4B) :: NUM_FUNCS ! number of function calls -INTEGER(I4B) :: NUM_JACOBIAN ! number of times Jacobian is calculated -INTEGER(I4B) :: NUMSUB_ACCEPT ! number of sub-steps accepted (taken) -INTEGER(I4B) :: NUMSUB_REJECT ! number of sub-steps tried but rejected -INTEGER(I4B) :: NUMSUB_NOCONV ! number of sub-steps tried that did not converge -INTEGER(I4B) :: MAXNUM_ITERNS ! maximum number of iterations in the implicit scheme -INTEGER(I4B),DIMENSION(20) :: ORD_NSUBS = (/ 1, 2, 5, 10, 20, 30, 50, 75, 100, 200, & - 300,500,750,1000,2000,5000,10000,20000,50000,100000/) -INTEGER(I4B),DIMENSION(20) :: PRB_NSUBS ! cumulative probability for number of substeps taken -! --------------------------------------------------------------------------------------- -END MODULE MODEL_NUMERIX diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/mstate_eqn.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/mstate_eqn.f90.svn-base deleted file mode 100644 index 45b371f..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/mstate_eqn.f90.svn-base +++ /dev/null @@ -1,66 +0,0 @@ -SUBROUTINE MSTATE_EQN() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Computes derivatives of all states for all model combinations -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multistate -- populates the MODULE multistate with derivatives DY_DT%(*) -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition structure -USE model_defnames -USE multiparam ! model parameters -USE multiforce ! model forcing data -USE multistate ! model states -USE multi_flux ! model fluxes -! --------------------------------------------------------------------------------------- -! (1) COMPUTE DERIVATIVES FOR STATES IN THE UPPER LAYER -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iARCH1) - CASE(iopt_tension2_1) ! tension storage sub-divided into recharge and excess - DY_DT%TENS_1A = M_FLUX%EFF_PPT - M_FLUX%QSURF - M_FLUX%EVAP_1A - M_FLUX%RCHR2EXCS - DY_DT%TENS_1B = M_FLUX%RCHR2EXCS - M_FLUX%EVAP_1B - M_FLUX%TENS2FREE_1 - DY_DT%FREE_1 = M_FLUX%TENS2FREE_1 - M_FLUX%QPERC_12 - M_FLUX%QINTF_1 - M_FLUX%OFLOW_1 - !print *, M_FLUX%EFF_PPT, M_FLUX%QSURF, M_FLUX%EVAP_1A, M_FLUX%RCHR2EXCS - CASE(iopt_tension1_1) ! upper layer broken up into tension and free storage - DY_DT%TENS_1 = M_FLUX%EFF_PPT - M_FLUX%QSURF - M_FLUX%EVAP_1 - M_FLUX%TENS2FREE_1 - DY_DT%FREE_1 = M_FLUX%TENS2FREE_1 - M_FLUX%QPERC_12 - M_FLUX%QINTF_1 - M_FLUX%OFLOW_1 - !print *, 'in mstate_eqn, layer1 ', DY_DT%TENS_1, DY_DT%FREE_1, M_FLUX%EFF_PPT, M_FLUX%QSURF, M_FLUX%EVAP_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 - DY_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 - !print *, 'in mstate_eqn, layer1 ', DY_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 architechure) -! --------------------------------------------------------------------------------------- -! (2) COMPUTE DERIVATIVES FOR STATES IN THE LOWER LAYER -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iARCH2) - CASE(iopt_tens2pll_2) ! tension reservoir plus two parallel tanks - DY_DT%TENS_2 = M_FLUX%QPERC_12*(1._SP-MPARAM%PERCFRAC) - M_FLUX%EVAP_2 - M_FLUX%TENS2FREE_2 - DY_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 - DY_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 - !print *, 'in mstate_eqn, layer2 ', M_FLUX%QPERC_12, M_FLUX%EVAP_2, M_FLUX%TENS2FREE_2, M_FLUX%QBASE_2A, M_FLUX%QBASE_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') - DY_DT%WATR_2 = M_FLUX%QPERC_12 - M_FLUX%EVAP_2 - M_FLUX%QBASE_2 - M_FLUX%OFLOW_2 - !print *, 'in mstate_eqn, layer2 ', M_FLUX%EVAP_2, M_FLUX%QBASE_2, M_FLUX%OFLOW_2 - CASE DEFAULT - print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" - print *, " iopt_topmdexp_2, or iopt_fixedsiz_2" - STOP -END SELECT -! --------------------------------------------------------------------------------------- -END SUBROUTINE MSTATE_EQN diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multi_flux.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multi_flux.f90.svn-base deleted file mode 100644 index 9fbe26a..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multi_flux.f90.svn-base +++ /dev/null @@ -1,41 +0,0 @@ -MODULE multi_flux - USE nrtype - TYPE FLUXES - REAL(SP) :: EFF_PPT ! effective precipitation (mm day-1) - REAL(SP) :: SATAREA ! saturated area (-) - REAL(SP) :: QSURF ! surface runoff (mm day-1) - REAL(SP) :: EVAP_1A ! evaporation from soil excess zone (mm day-1) - REAL(SP) :: EVAP_1B ! evaporation from soil recharge zone (mm day-1) - REAL(SP) :: EVAP_1 ! evaporation from upper soil layer (mm day-1) - REAL(SP) :: EVAP_2 ! evaporation from lower soil layer (mm day-1) - REAL(SP) :: RCHR2EXCS ! flow from recharge to excess (mm day-1) - REAL(SP) :: TENS2FREE_1 ! flow from tension storage to free storage (mm day-1) - REAL(SP) :: TENS2FREE_2 ! flow from tension storage to free storage (mm day-1) - REAL(SP) :: QINTF_1 ! interflow from free water (mm day-1) - REAL(SP) :: QPERC_12 ! percolation from upper to lower soil layers (mm day-1) - REAL(SP) :: QBASE_2 ! baseflow (mm day-1) - REAL(SP) :: QBASE_2A ! baseflow from primary linear resvr (mm day-1) - REAL(SP) :: QBASE_2B ! baseflow from secondary linear resvr (mm day-1) - REAL(SP) :: OFLOW_1 ! bucket overflow (mm day-1) - REAL(SP) :: OFLOW_2 ! bucket overflow (mm day-1) - REAL(SP) :: OFLOW_2A ! bucket overflow (mm day-1) - REAL(SP) :: OFLOW_2B ! bucket overflow (mm day-1) - REAL(SP) :: ERR_WATR_1 ! excessive extrapolation: total storage in layer1 (mm day-1) - REAL(SP) :: ERR_TENS_1 ! excessive extrapolation: tension storage in layer1 (mm day-1) - REAL(SP) :: ERR_FREE_1 ! excessive extrapolation: free storage in layer 1 (mm day-1) - REAL(SP) :: ERR_TENS_1A ! excessive extrapolation: storage in the recharge zone (mm day-1) - REAL(SP) :: ERR_TENS_1B ! excessive extrapolation: storage in the lower zone (mm day-1) - REAL(SP) :: ERR_WATR_2 ! excessive extrapolation: total storage in layer2 (mm day-1) - REAL(SP) :: ERR_TENS_2 ! excessive extrapolation: tension storage in layer2 (mm day-1) - REAL(SP) :: ERR_FREE_2 ! excessive extrapolation: free storage in layer2 (mm day-1) - REAL(SP) :: ERR_FREE_2A ! excessive extrapolation: storage in the primary resvr (mm day-1) - 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 - REAL(SP) :: CURRENT_DT ! current time step (days) -END MODULE multi_flux diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multiforce.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multiforce.f90.svn-base deleted file mode 100644 index 1cd1750..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multiforce.f90.svn-base +++ /dev/null @@ -1,23 +0,0 @@ -MODULE multiforce - USE nrtype - TYPE FDATA - 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 - REAL(SP) :: PPT ! water input: rain + melt (mm day-1) - REAL(SP) :: PET ! energy input: potential ET (mm day-1) - REAL(SP) :: OBSQ ! observed runoff (mm day-1) - ENDTYPE FDATA - ! -------------------------------------------------------------------------------------- - 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 - INTEGER(I4B) :: ISTART ! index for start of the inference period - INTEGER(I4B) :: NUMTIM ! number of time steps - REAL(SP) :: DELTIM ! length of time step (days) - ! -------------------------------------------------------------------------------------- -END MODULE multiforce diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multiparam.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multiparam.f90.svn-base deleted file mode 100644 index 8ba83cf..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multiparam.f90.svn-base +++ /dev/null @@ -1,154 +0,0 @@ -MODULE multiparam - USE nrtype - USE model_defn,ONLY:NTDH_MAX - ! -------------------------------------------------------------------------------------- - ! (1) PARAMETER METADATA - ! -------------------------------------------------------------------------------------- - ! data structure to hold metadata for adjustable model parameters - TYPE PARATT - LOGICAL(LGT) :: PARFIT ! flag to determine if parameter is fitted - INTEGER(I4B) :: PARSTK ! flag (0=deterministic, 1=stochastic) - REAL(SP) :: PARDEF ! default parameter set - REAL(SP) :: PARLOW ! lower limit of each parameter - REAL(SP) :: PARUPP ! upper limit of each parameter - REAL(SP) :: FRSEED ! fraction param space for "reasonable" bounds - REAL(SP) :: PARSCL ! typical scale of parameter - INTEGER(I4B) :: PARVTN ! method used for variable transformation - INTEGER(I4B) :: PARDIS ! parametric form of prob dist used for prior/hyper - INTEGER(I4B) :: PARQTN ! transformation applied before use of prob dist - INTEGER(I4B) :: PARLAT ! number of latent variables (0=onePerStep, -1=from data) - INTEGER(I4B) :: PARMTH ! imeth for all variables ???what is this??? - INTEGER(I4B) :: NPRIOR ! number of prior/hyper-parameters - CHARACTER(LEN=256) :: P_NAME ! parameter name - 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) - TYPE(PARATT) :: RFERR_ADD ! additive rainfall error (mm day-1) - TYPE(PARATT) :: RFERR_MLT ! multiplicative rainfall error (-) - TYPE(PARATT) :: RFH1_MEAN ! hyper parameter1: mean rainfall multiplier (-) - TYPE(PARATT) :: RFH2_SDEV ! hyper parameter2: sdev rainfall multiplier (-) - TYPE(PARATT) :: RH1P_MEAN ! prior param1 of hyper param1: prior mean of hypermean - TYPE(PARATT) :: RH1P_SDEV ! prior param2 of hyper param1: prior sdev of hypermean - TYPE(PARATT) :: RH2P_MEAN ! prior param1 of hyper param2: lower bound of hypersdev - TYPE(PARATT) :: RH2P_SDEV ! prior param2 of hyper param2: upper bound of hypersdev - ! bucket sizes (adjustable) - TYPE(PARATT) :: MAXWATR_1 ! maximum total storage in layer1 (mm) - TYPE(PARATT) :: MAXWATR_2 ! maximum total storage in layer2 (mm) - TYPE(PARATT) :: FRACTEN ! frac total storage as tension storage (-) - TYPE(PARATT) :: FRCHZNE ! PRMS: frac tension storage in recharge zone (-) - TYPE(PARATT) :: FPRIMQB ! SAC: fraction of baseflow in primary resvr (-) - ! evaporation (adjustable) - TYPE(PARATT) :: RTFRAC1 ! fraction of roots in the upper layer (-) - ! percolation (adjustable) - TYPE(PARATT) :: PERCRTE ! percolation rate (mm day-1) - TYPE(PARATT) :: PERCEXP ! percolation exponent (-) - TYPE(PARATT) :: SACPMLT ! multiplier in the SAC model for dry lower layer (-) - TYPE(PARATT) :: SACPEXP ! exponent in the SAC model for dry lower layer (-) - TYPE(PARATT) :: PERCFRAC ! fraction of percolation to tension storage (-) - TYPE(PARATT) :: FRACLOWZ ! fraction of soil excess to lower zone (-) - ! interflow (adjustable) - TYPE(PARATT) :: IFLWRTE ! interflow rate (mm day-1) - ! baseflow (adjustable) - TYPE(PARATT) :: BASERTE ! baseflow rate (mm day-1) - TYPE(PARATT) :: QB_POWR ! baseflow exponent (-) - TYPE(PARATT) :: QB_PRMS ! baseflow depletion rate (day-1) - TYPE(PARATT) :: QBRATE_2A ! baseflow depletion rate for primary resvr (day-1) - TYPE(PARATT) :: QBRATE_2B ! baseflow depletion rate for secondary resvr (day-1) - ! surface runoff (adjustable) - TYPE(PARATT) :: SAREAMAX ! maximum saturated area - TYPE(PARATT) :: AXV_BEXP ! ARNO/VIC "b" exponent - TYPE(PARATT) :: LOGLAMB ! mean value of the log-transformed topographic index (m) - TYPE(PARATT) :: TISHAPE ! shape parameter for the topo index Gamma distribution (-) - ! time delay in runoff - TYPE(PARATT) :: TIMEDELAY ! time delay in runoff (days) - ENDTYPE PARINFO - ! -------------------------------------------------------------------------------------- - ! (2) ADJUSTABLE PARAMETERS - ! -------------------------------------------------------------------------------------- - TYPE PARADJ - ! rainfall error parameters (adjustable) - REAL(SP) :: RFERR_ADD ! additive rainfall error (mm day-1) - REAL(SP) :: RFERR_MLT ! multiplicative rainfall error (-) - REAL(SP) :: RFH1_MEAN ! hyper parameter1: mean rainfall multiplier (-) - REAL(SP) :: RFH2_SDEV ! hyper parameter2: sdev rainfall multiplier (-) - REAL(SP) :: RH1P_MEAN ! prior param1 of hyper param1: prior mean of hypermean - REAL(SP) :: RH1P_SDEV ! prior param2 of hyper param1: prior sdev of hypermean - REAL(SP) :: RH2P_MEAN ! prior param1 of hyper param2: lower bound of hypersdev - REAL(SP) :: RH2P_SDEV ! prior param2 of hyper param2: upper bound of hypersdev - ! bucket sizes (adjustable) - REAL(SP) :: MAXWATR_1 ! maximum total storage in layer1 (mm) - REAL(SP) :: MAXWATR_2 ! maximum total storage in layer2 (mm) - REAL(SP) :: FRACTEN ! frac total storage as tension storage (-) - REAL(SP) :: FRCHZNE ! PRMS: frac tension storage in recharge zone (-) - REAL(SP) :: FPRIMQB ! SAC: fraction of baseflow in primary resvr (-) - ! evaporation (adjustable) - REAL(SP) :: RTFRAC1 ! fraction of roots in the upper layer (-) - ! percolation (adjustable) - REAL(SP) :: PERCRTE ! percolation rate (mm day-1) - REAL(SP) :: PERCEXP ! percolation exponent (-) - REAL(SP) :: SACPMLT ! multiplier in the SAC model for dry lower layer (-) - REAL(SP) :: SACPEXP ! exponent in the SAC model for dry lower layer (-) - REAL(SP) :: PERCFRAC ! fraction of percolation to tension storage (-) - REAL(SP) :: FRACLOWZ ! fraction of soil excess to lower zone (-) - ! interflow (adjustable) - REAL(SP) :: IFLWRTE ! interflow rate (mm day-1) - ! baseflow (adjustable) - REAL(SP) :: BASERTE ! baseflow rate (mm day-1) - REAL(SP) :: QB_POWR ! baseflow exponent (-) - REAL(SP) :: QB_PRMS ! baseflow depletion rate (day-1) - REAL(SP) :: QBRATE_2A ! baseflow depletion rate for primary resvr (day-1) - REAL(SP) :: QBRATE_2B ! baseflow depletion rate for secondary resvr (day-1) - ! surface runoff (adjustable) - REAL(SP) :: SAREAMAX ! maximum saturated area - REAL(SP) :: AXV_BEXP ! ARNO/VIC "b" exponent - REAL(SP) :: LOGLAMB ! mean value of the log-transformed topographic index (m) - REAL(SP) :: TISHAPE ! shape parameter for the topo index Gamma distribution (-) - ! time delay in runoff - REAL(SP) :: TIMEDELAY ! time delay in runoff (days) - END TYPE PARADJ - ! -------------------------------------------------------------------------------------- - ! (3) DERIVED PARAMETERS - ! -------------------------------------------------------------------------------------- - TYPE PARDVD - ! bucket sizes (derived) - REAL(SP) :: MAXTENS_1 ! maximum tension storage in layer1 (mm) - REAL(SP) :: MAXTENS_2 ! maximum tension storage in layer2 (mm) - REAL(SP) :: MAXFREE_1 ! maximum free storage in layer 1 (mm) - REAL(SP) :: MAXFREE_2 ! maximum free storage in layer2 (mm) - REAL(SP) :: MAXTENS_1A ! maximum storage in the recharge zone (mm) - REAL(SP) :: MAXTENS_1B ! maximum storage in the lower zone (mm) - REAL(SP) :: MAXFREE_2A ! maximum storage in the primary resvr (mm) - REAL(SP) :: MAXFREE_2B ! maximum storage in the secondary resvr (mm) - ! evaporation - REAL(SP) :: RTFRAC2 ! fraction of roots in the lower layer (-) - ! percolation/baseflow - REAL(SP) :: QBSAT ! baseflow at saturation - ! surface runoff - REAL(SP) :: POWLAMB ! mean value of the power-transformed topographic index (m**(1/n)) - REAL(SP) :: MAXPOW ! max value of the power-transformed topographic index (m**(1/n)) - ! routing - 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; DK211008: 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 diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multiroute.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multiroute.f90.svn-base deleted file mode 100644 index 747cc71..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multiroute.f90.svn-base +++ /dev/null @@ -1,12 +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) :: MROUTE ! runoff for one time step -END MODULE multiroute diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multistate.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multistate.f90.svn-base deleted file mode 100644 index bcdff98..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multistate.f90.svn-base +++ /dev/null @@ -1,46 +0,0 @@ -MODULE multistate - USE nrtype - ! -------------------------------------------------------------------------------------- - ! model state structure - ! -------------------------------------------------------------------------------------- - TYPE STATEV - ! 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) :: 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) - ! -------------------------------------------------------------------------------------- - -! initial store fraction (initialization) -real(sp),parameter::fracState0=0.25_sp - -END MODULE multistate diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multistats.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multistats.f90.svn-base deleted file mode 100644 index 74096ca..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multistats.f90.svn-base +++ /dev/null @@ -1,35 +0,0 @@ -MODULE multistats - USE nrtype - TYPE SUMMARY - ! 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) - REAL(SP) :: QOBS_CVAR ! coefficient of variation of observed runoff (-) - REAL(SP) :: QSIM_CVAR ! coefficient of variation of simulated runoff (-) - REAL(SP) :: QOBS_LAG1 ! lag-1 correlation of observed runoff (-) - REAL(SP) :: QSIM_LAG1 ! lag-1 correlation of simulated runoff (-) - REAL(SP) :: RAW_RMSE ! root-mean-squared-error of flow (mm day-1) - REAL(SP) :: LOG_RMSE ! root-mean-squared-error of LOG flow (mm day-1) - REAL(SP) :: NASH_SUTT ! Nash-Sutcliffe score - ! attributes of model output - REAL(SP) :: NUM_RMSE ! error of the approximate solution - REAL(SP) :: NUM_FUNCS ! number of function calls - REAL(SP) :: NUM_JACOBIAN ! number of times Jacobian is calculated - REAL(SP) :: NUMSUB_ACCEPT ! number of sub-steps taken - REAL(SP) :: NUMSUB_REJECT ! number of sub-steps taken - 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 diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/newtoniter.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/newtoniter.f90.svn-base deleted file mode 100644 index 951f5be..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/newtoniter.f90.svn-base +++ /dev/null @@ -1,199 +0,0 @@ -MODULE newtoniter_mod -IMPLICIT NONE -CONTAINS - ! --------------------------------------------------------------------------------------- - SUBROUTINE newtoniter(X,newJacIn,check,niter) - USE nrtype; USE nrutil, ONLY : nrerror,diagadd,vabs - USE nr, ONLY : fdjac,lnsrch,lubksb,ludcmp - USE fminln, ONLY : fmin,fmin_dsdtp,fmin_fvecp,fmin_dtp,fmin_dt2p - USE limit_xtry_module - USE fdjac_ode_module - USE model_numerix - ! Purpose: finds the state vector "X_NEW", so that - ! X_NEW(:) = X_OLD(:) + DYDX(:) * HSTATE%STEP, with DYDX(:) evaluated at X_NEW(:) - ! (based loosely on the Numerical Recipes routine newt.f90) - ! Programmers: Dmitri Kavetski and Martyn Clark - IMPLICIT NONE - ! dummies - REAL(SP), DIMENSION(:), INTENT(INOUT) :: x ! state vector - LOGICAL(LGT), INTENT(IN) :: newJacIn ! .TRUE. if new Jacobian required - LOGICAL(LGT), INTENT(OUT) :: check ! .TRUE. if spurious minimum - INTEGER(I4B), INTENT(OUT) :: niter ! number of iterations - ! 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 - ! locals - INTEGER(I4B) :: i,j,k ! looping (test) - INTEGER(I4B) :: its ! iteration counter - INTEGER(I4B), DIMENSION(size(x)) :: indx ! used in ludcmp - REAL(SP) :: d ! used in ludcmp - REAL(SP) :: f,fold ! function values - REAL(SP) :: absf_old ! absolute value of the residual vector (last iter) - REAL(SP) :: absf_new ! absolute value of the residual vector (current iter) - REAL(SP) :: stpmax ! step size for lnsrch - REAL(SP), DIMENSION(size(x)) :: g ! gradient used in lnsrch - REAL(SP), DIMENSION(size(x)) :: p,dx ! p = newton step, dx = actual step - REAL(SP), DIMENSION(size(x)) :: xold ! old state vector - REAL(SP), DIMENSION(size(x)), TARGET :: dsdt ! model derivatives - REAL(SP), DIMENSION(size(x)), TARGET :: fvec ! model residuals - REAL(SP), DIMENSION(size(x),size(x)) :: jac_ode,fjac,fjacSave ! Jacobian matrices - LOGICAL(LGT) :: newjac ! .TRUE. if calculate a new Jacobian matrix - - ! --------------------------------------------------------------------------------------- - ! (0) INITIALIZATION - ! --------------------------------------------------------------------------------------- - NITER=0 ! initialize number of iterations (intent=out) - CHECK=.FALSE. ! initialize check on convergence (intent=out) - fmin_dsdtp=>dsdt ! provide access to the vector of derivatives used in fmin - fmin_fvecp=>fvec ! provide access to the vector of residuals used in fmin - - ! --------------------------------------------------------------------------------------- - ! (1) TEST FOR THE INITIAL GUESS BEING A ROOT (MORE STRINGENT TEST THAN SIMPLY ERR_ITER_DX) - ! --------------------------------------------------------------------------------------- - CALL LIMIT_XTRY(X) ! ensure that the values of X are physically reasonable - F=FMIN(X) ! compute function evaluation (populates vectors DSDT and FVEC) - !write(*,'(10(f20.10,1x))') x - ABSF_OLD=MAXVAL(ABS(FVEC)) ! initial norm of the residual vector - IF (ABSF_OLD < 0.01_SP*ERR_ITER_DX) THEN - CHECK=.FALSE. - RETURN - ENDIF - - ! --------------------------------------------------------------------------------------- - ! (2) ITERATE TO EITHER NITER_TOTAL OR CONVERGENCE - ! --------------------------------------------------------------------------------------- - ! compute maximum step size used in line searches - IF (CHECK_OVERSHOOT.EQ.LINE_SEARCH) STPMAX = STPMX*MAX(VABS(X),REAL(SIZE(X),SP)) - DO ITS=1,NITER_TOTAL - NITER = ITS - - !print *, '***** new iteration *****', its, check, ABSF_OLD - ! --------------------------------------------------------------------------------------- - ! (2A) CHECK IF WE NEED A NEW JACOBIAN, AND, IF SO, COMPUTE IT - ! --------------------------------------------------------------------------------------- - SELECT CASE(JAC_RECOMPUTE) - CASE(FULLYVARIABLE) - NEWJAC=.TRUE. ! always re-compute Jacobian - CASE(CONST_SUBSTEP) - NEWJAC=(ITS==1) ! only recompute Jacobian on the first iteration - CASE(CONSTFULLSTEP,PERIOD_FREEZE,SMALL_F_RATIO) - IF (JAC_RECOMPUTE==CONSTFULLSTEP) THEN - NEWJAC=newJacIn ! only recompute Jacobian at start of full step (defined by input flag) - IF (ITS>1) NEWJAC=.FALSE. - ENDIF - IF (JAC_RECOMPUTE==PERIOD_FREEZE) THEN - NEWJAC=(MAXVAL(ABS(FVEC)) > THRESH_FRZE) - IF (ITS==1) NEWJAC=newJacIn ! always recompute Jacobian at start of full step (defined by input flag) - ENDIF - IF (JAC_RECOMPUTE==SMALL_F_RATIO) THEN - IF (ITS==1) THEN - NEWJAC=.TRUE. - ELSE - NEWJAC=(ABSF_NEW/ABSF_OLD > THRESH_FRZE) - ABSF_OLD=ABSF_NEW - ENDIF - ENDIF - IF (.NOT.NEWJAC) THEN - if (.not.allocated(fjacCOPY) .or. .not.allocated(fjacDCMP) .or. .not.allocated(fjacINDX)) & - stop ' constant Jacobian copies not allocated ' - fjacSave=fjacCOPY ! (used to compute the gradient, for use in lnsrch) - FJAC=fjacDCMP ! (used to compute p=dx in lubksb) - INDX=fjacINDX ! (used to compute p=dx in lubksb) - ENDIF - END SELECT - !print *, 'newjac = ', newjac - !print *, 'X = ', X - IF (NEWJAC) THEN - ! compute new jacobian matrix - CALL FDJAC_ODE(X,DSDT,JAC_ODE) ! calculate Jacobian of the ODE - SELECT CASE(SOLUTION_METHOD) - CASE(IMPLICIT_EULER); FJAC=-fmin_dtp*JAC_ODE ! working towards (I - DT dg/dS), identity matrix added later - CASE(IMPLICIT_HEUN); FJAC=-fmin_dt2p*JAC_ODE ! working towards (I - DT2 dg/dS), identity matrix added later - CASE DEFAULT; STOP ' solution method muct be either implicit_euler or implicit heun ' - END SELECT - CALL DIAGADD(FJAC,1._SP) ! add identify matrix - !print *, 'fjac = '; DO I=1,SIZE(X); WRITE(*,'(10(E12.5,1X))') FJAC(:,I); END DO - !print *, 'fvec = '; WRITE(*,'(10(E12.5,1X))') FVEC(:) - IF (CHECK_OVERSHOOT==LINE_SEARCH) fjacSave=FJAC ! need because FJAC overwritten in LUDCMP - IF (JAC_RECOMPUTE==CONSTFULLSTEP .OR. JAC_RECOMPUTE==PERIOD_FREEZE .OR. JAC_RECOMPUTE==SMALL_F_RATIO) THEN - IF (.NOT.ALLOCATED(fjacCOPY)) STOP ' constant Jacobian copies not allocated ' - fjacCOPY=FJAC ! stored in MODULE model_numerix and re-used - ENDIF - ENDIF - IF (CHECK_OVERSHOOT==LINE_SEARCH) THEN - G=MATMUL(FVEC,fjacSave) - ENDIF - - ! --------------------------------------------------------------------------------------- - ! (2B) DECOMPOSE THE JACOBIAN MATRIX AND ESTIMATE DX (DX=P) - ! --------------------------------------------------------------------------------------- - XOLD=X - FOLD=F - IF (NEWJAC) THEN - CALL LUDCMP(FJAC,INDX,D) - IF (JAC_RECOMPUTE==CONSTFULLSTEP .OR. JAC_RECOMPUTE==PERIOD_FREEZE .OR. JAC_RECOMPUTE==SMALL_F_RATIO) THEN - if (.not.allocated(fjacDCMP) .or. .not.allocated(fjacINDX)) & - stop ' constant Jacobian copies not allocated ' - fjacDCMP=FJAC - fjacINDX=INDX - ENDIF - ENDIF - P=-FVEC - CALL LUBKSB(FJAC,INDX,P) - !print *, 'p = ', p - - ! --------------------------------------------------------------------------------------- - ! (2C) CHECK FOR OVERSHOOT AND FIX - ! --------------------------------------------------------------------------------------- - IF (CHECK_OVERSHOOT.EQ.LINE_SEARCH) THEN - ! undertake line search - CALL LNSRCH(XOLD,FOLD,G,P,X,F,STPMAX,CHECK,FMIN) - ABSF_NEW = MAXVAL(ABS(FVEC)) - !print *, 'fvec = ', fvec, absf_new, check - IF (ABSF_NEW < ERR_ITER_FUNC) THEN ! test for convergence on function values - CHECK=.FALSE. - EXIT - ENDIF - IF (CHECK) THEN ! test for a gradient of f zero (i.e., spurious convergence) - CHECK=(MAXVAL( ABS(G)*MAX(ABS(X),1.0_SP) / MAX(F,0.5_SP*SIZE(X)) ) < TOLMIN) - !print *, 'in check ', MAXVAL( ABS(G)*MAX(ABS(X),1.0_SP) / MAX(F,0.5_SP*SIZE(X)) ), check - EXIT - ENDIF - DX = X-XOLD ! done to account for constraints in LIMIT_XTRY (i.e., dx ne newton step) - ELSE - ! take full newton step - X = XOLD + P - CALL LIMIT_XTRY(X) ! ensure that the values of X are physically reasonable - F = FMIN(X) ! compute function evaluation (also populates DSDT and FVEC) - ! test for convergence on function values - ABSF_NEW = MAXVAL(ABS(FVEC)) - IF (ABSF_NEW < ERR_ITER_FUNC) THEN - CHECK=.FALSE. - EXIT - ENDIF - ! test that the function decreased - IF (F.GE.FOLD) THEN - X=XOLD - CHECK=.TRUE. - EXIT - ENDIF - DX = X-XOLD ! done to account for constraints in LIMIT_XTRY (i.e., dx ne newton step) - ENDIF - !WRITE(*,'(I4,1X,10(E15.8,1X))') NITER, F, X - !WRITE(*,'(I4,1X,10(E15.8,1X))') NITER, F, DX - !WRITE(*,'(I4,1X,10(E15.8,1X))') NITER, F, ABS(FVEC) - ! --------------------------------------------------------------------------------------- - ! (2D) CHECK FOR CONVERGENCE - ! --------------------------------------------------------------------------------------- - ! check for convergence on dx - IF (MAXVAL( ABS(DX) / MAX(ABS(X),1.0_SP) ) < ERR_ITER_DX) THEN - CHECK=.FALSE. - EXIT - ENDIF - ! check for non-convergence - IF (ITS.EQ.NITER_TOTAL) CHECK=.TRUE. - ! --------------------------------------------------------------------------------------- - END DO ! iteration loop - ! ---------------------------------------------------------------------------------------- - END SUBROUTINE newtoniter -END MODULE newtoniter_mod diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/ode_int.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/ode_int.f90.svn-base deleted file mode 100644 index 0c20d74..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/ode_int.f90.svn-base +++ /dev/null @@ -1,360 +0,0 @@ -SUBROUTINE ODE_INT(MODL_SOLVE,STATE_START,STATE_END,DT_SUB,DT_FULL,IERR,MESSAGE) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! -! Used for the temporal integration of ordinary differential equations, using different -! numerical methods -! -! Based on the FUSE "sub-stepper" routine, but all FUSE-specific data structures have -! been stripped out to call a simple test function -! -! --------------------------------------------------------------------------------------- -USE nrtype ! variable definitions, etc. -USE model_numerix ! define method/parameters used for numerical solution -IMPLICIT NONE -! input/output variables -REAL(SP), DIMENSION(:), INTENT(IN) :: STATE_START ! state vector at the start of the full step -REAL(SP), DIMENSION(:), INTENT(OUT) :: STATE_END ! state vector at the end of the full step -REAL(SP), INTENT(INOUT) :: DT_SUB ! length of the sub-step -REAL(SP), INTENT(IN) :: DT_FULL ! length of the full step -INTEGER(I4B), INTENT(OUT) :: IERR ! error code -CHARACTER(LEN=*), INTENT(OUT) :: MESSAGE ! error message -! internal variables -REAL(SP) :: STEP ! new step size -REAL(SP) :: ETIME ! part of the time step completed -REAL(SP) :: PREVSTEP ! save pen-ultimate step size so small steps not carried over -LOGICAL(LGT) :: NEWSTEP ! .TRUE. if new step (determine if a new Jacobian is needed) -LOGICAL(LGT) :: NEW_SUBSTEP ! .TRUE. if new sub-step (determine if need to calculate derivatives) -LOGICAL(LGT) :: STEP_INCREASE ! FLAG to determine if the end time step has been increased -REAL(SP), DIMENSION(SIZE(STATE_START)) :: STATE0 ! state vector at the start of the sub-step -REAL(SP), DIMENSION(SIZE(STATE_START)) :: STATE1_LO ! state vector at the end of the sub-step (lower-order solution) -REAL(SP), DIMENSION(SIZE(STATE_START)) :: STATE1_HI ! state vector at the end of the sub-step (higher-order solution) -REAL(SP), DIMENSION(SIZE(STATE_START)) :: STATE1_LO_S ! safeguarded explicit Euler solution, also used in explicit Heun -REAL(SP), DIMENSION(SIZE(STATE_START)) :: STATE1_HI_S ! safeguarded explicit Heun and implicit Heun solutions -REAL(SP), DIMENSION(SIZE(STATE_START)) :: STATE1_INIT ! initial state vector used in the implicit solution -REAL(SP), DIMENSION(SIZE(STATE_START)) :: STATE1_RETAIN ! states retained at the end of the sub-step -REAL(SP), DIMENSION(SIZE(STATE_START)) :: DYDT_0 ! model derivatives at the start of the sub-step -REAL(SP), DIMENSION(SIZE(STATE_START)) :: DYDT_1 ! model derivatives at the end of the sub-step -REAL(SP), DIMENSION(SIZE(STATE_START)) :: EVEC ! error estimate for each state -REAL(SP), DIMENSION(SIZE(STATE_START)) :: TVEC ! error threshold for each state -REAL(SP) :: MULT ! multiplier for new step size -REAL(SP), PARAMETER :: EPS=1.E-10_SP ! machine constant to prevent floating point errors -INTEGER(I4B), DIMENSION(1) :: IMAX ! index of maximum error -INTEGER(I4B) :: NITER ! number of iterations in newtoniter -LOGICAL(LGT) :: CHECK ! convergence check in SUBROUTINE newtoniter -LOGICAL(LGT) :: FEXCESS ! FLAG to denote if states are corrected for excessive extrapolation -REAL(SP) :: TEMPSTEP ! suggested new time step, for case of non-convergence -! ------------------------------------------------------------------------------------------------- -INTERFACE - SUBROUTINE MODL_SOLVE(CALCDSDT,IE_SOLVE,SI_SOLVE,B_IMPOSE,AVG_FLUX,ADD_FLUX,NEWSTATE, & ! define functionality of the routine - DT,S0,S1,DSDT,NEWSTEP,CONVCHECK,NITER,SOLUTION,HBOUND, & ! input/output - IERR,MESSAGE) ! error control - USE nrtype ! variable definitions, etc. - IMPLICIT NONE - LOGICAL(LGT), INTENT(IN),OPTIONAL :: CALCDSDT ! FLAG to calculate derivatives at S0 - LOGICAL(LGT), INTENT(IN),OPTIONAL :: IE_SOLVE ! FLAG to compute the implicit Euler solution - LOGICAL(LGT), INTENT(IN),OPTIONAL :: SI_SOLVE ! FLAG to compute the semi-implicit Euler solution - LOGICAL(LGT), INTENT(IN),OPTIONAL :: B_IMPOSE ! FLAG to impose bounds on model states - LOGICAL(LGT), INTENT(IN),OPTIONAL :: AVG_FLUX ! FLAG to average fluxes from start & end states - LOGICAL(LGT), INTENT(IN),OPTIONAL :: ADD_FLUX ! FLAG to add accepted fluxes to the total flux - LOGICAL(LGT), INTENT(IN),OPTIONAL :: NEWSTATE ! FLAG to use weighted fluxes to compute end state - REAL(SP), INTENT(IN), OPTIONAL :: DT ! length of the sub-step - REAL(SP), DIMENSION(:),INTENT(IN), OPTIONAL :: S0 ! input state vector - REAL(SP), DIMENSION(:), INTENT(OUT),OPTIONAL :: S1 ! state vector from the implicit euler solution - REAL(SP), DIMENSION(:),INTENT(INOUT),OPTIONAL :: DSDT ! state derivatives - LOGICAL(LGT), INTENT(IN),OPTIONAL :: NEWSTEP ! FLAG to denote a new model time step - LOGICAL(LGT), INTENT(IN),OPTIONAL :: CONVCHECK ! FLAG to check for convergence of the implicit scheme - INTEGER(I4B), INTENT(OUT), OPTIONAL :: NITER ! number of iterations - INTEGER(I4B), INTENT(IN), OPTIONAL :: SOLUTION ! solution is at start (0) or end (1) of sub-step - LOGICAL(LGT), INTENT(IN),OPTIONAL :: HBOUND ! FLAG to denote if the states were out of bounds - INTEGER(I4B), INTENT(OUT) :: IERR ! error code - CHARACTER(LEN=*), INTENT(OUT) :: MESSAGE ! error message - END SUBROUTINE MODL_SOLVE -END INTERFACE -! --------------------------------------------------------------------------------------- -! (0) INITIALIZATION -! --------------------------------------------------------------------------------------- -! intilize states and counters -ETIME = 0._sp ! part of the time step completed -CHECK = .FALSE. -STATE0 = STATE_START ! save model states at the start of the full step -STATE1_RETAIN = STATE_START ! initial state (needed for rejected steps) -newStep = .true. ! initialize newstep (force re-calculation of Jacobian) -NEW_SUBSTEP = .TRUE. ! initialize new sub-step (check if need new derivatives) -! initialize diagnostix -NUM_FUNCS = 0 ! number of function calls -NUM_JACOBIAN = 0 ! number of times Jacobian is calculated -NUMSUB_ACCEPT = 0 ! number of sub-steps accepted (taken) -NUMSUB_REJECT = 0 ! number of sub-steps tried but rejected -NUMSUB_NOCONV = 0 ! number of sub-steps tried that did not converge -MAXNUM_ITERNS = 0 ! maximum number of iterations taken in the newton method -! --------------------------------------------------------------------------------------- -! DT_SUB (sub-step length) is carried over from previous step; ensure that it is in bounds -DT_SUB = MIN( MAX(MIN_TSTEP,DT_SUB), MAX_TSTEP) ! (MIN_TSTEP < stepsize < MAX_TSTEP) -PREVSTEP = DT_SUB ! initialize the previous time step (tracked to avoid using small interval at end of step) -STEP_INCREASE = .FALSE. ! used to check if the final sub-step has been increased - -SUBSTEPS: DO ! continuous (recursive) loop over sub-steps - - ! --------------------------------------------------------------------------------------- - ! (0) SAVE VECTOR OF STATES AND DERIVATIVES AT THE START OF THE SUB-STEP - ! --------------------------------------------------------------------------------------- - - ! refresh model states at the start of the sub-step - IF (NEW_SUBSTEP .AND. .NOT.newStep) STATE0 = STATE1_RETAIN - - ! calculate new derivatives - IF (NEW_SUBSTEP) THEN - CALL MODL_SOLVE(CALCDSDT=.TRUE.,S0=STATE0,DT=DT_SUB,DSDT=DYDT_0,SOLUTION=0,IERR=IERR,MESSAGE=MESSAGE) - IF (IERR.NE.0) THEN; PRINT *, IERR, MESSAGE; STOP; ENDIF - ELSE - CALL MODL_SOLVE(CALCDSDT=.FALSE.,SOLUTION=0,IERR=IERR,MESSAGE=MESSAGE) - IF (IERR.NE.0) THEN; PRINT *, IERR, MESSAGE; STOP; ENDIF - ENDIF - - ! select solution method - SELECT CASE(SOLUTION_METHOD) - - ! --------------------------------------------------------------------------------------- - ! (1) CALCULATE EXPLICIT EULER SOLUTION -- NOTE, NO ERROR CONTROL - ! --------------------------------------------------------------------------------------- - CASE (EXPLICIT_EULER) - ! calculate explicit Euler solution - STATE1_HI = STATE0 + DYDT_0*DT_SUB ! explicit solution (can be out of range, but OK for error control) - ! get a safegaurded solution to account for excessive extrapolation (includes flux disaggregation) - CALL MODL_SOLVE(B_IMPOSE=.TRUE.,S0=STATE1_HI,S1=STATE1_HI_S,DT=DT_SUB,HBOUND=FEXCESS,& - IERR=IERR,MESSAGE=MESSAGE) - IF (IERR.NE.0) THEN; PRINT *, IERR, MESSAGE; STOP; ENDIF - newStep=.false. - - ! -------------------------------------------------------------------------------------- - ! (2) CALCULATE IMPLICIT EULER SOLUTION -- NOTE, NO ERROR CONTROL - ! -------------------------------------------------------------------------------------- - CASE (IMPLICIT_EULER) - ! estimate the initial conditions used in the Newton scheme - SELECT CASE (INITIAL_NEWTON) - CASE (STATE_OLD); STATE1_INIT = STATE0 - CASE (EXPLICIT_MID); STATE1_INIT = STATE0 + DYDT_0*DT_SUB/2.0_SP ! estimate at mid-point - CASE (EXPLICIT_FULL); STATE1_INIT = STATE0 + DYDT_0*DT_SUB ! estimate at end - END SELECT - ! estimate state vector at end of time step - CALL MODL_SOLVE(IE_SOLVE=.TRUE.,S0=STATE1_INIT,S1=STATE1_HI,DSDT=DYDT_1,DT=DT_SUB,& - NEWSTEP=newStep,CONVCHECK=CHECK,NITER=NITER,& - IERR=IERR,MESSAGE=MESSAGE) - IF (IERR.NE.0) THEN; PRINT *, IERR, TRIM(MESSAGE); STOP; ENDIF - IF (NITER > MAXNUM_ITERNS) MAXNUM_ITERNS=NITER - newStep=.false. - ! re-compute state vector at the end of the sub-step (needed for non-convergence) - STATE1_HI_S = STATE0 + DYDT_1*DT_SUB - - ! --------------------------------------------------------------------------------------- - ! (3) CALCULATE EXPLICIT HEUN SOLUTION - ! --------------------------------------------------------------------------------------- - CASE (EXPLICIT_HEUN) - ! calculate explicit Euler solution - STATE1_LO = STATE0 + DYDT_0*DT_SUB ! explicit solution (can be out of range, but OK for error control) - ! get a safegaurded solution to account for excessive extrapolation (includes flux disaggregation) - CALL MODL_SOLVE(B_IMPOSE=.TRUE.,S0=STATE1_LO,S1=STATE1_LO_S,DT=DT_SUB,HBOUND=FEXCESS,& - IERR=IERR,MESSAGE=MESSAGE) - IF (IERR.NE.0) THEN; PRINT *, IERR, TRIM(MESSAGE); STOP; ENDIF - newStep=.false. - ! calculate explicit Heun solution (NOTE: using safeguarded states) - CALL MODL_SOLVE(CALCDSDT=.TRUE.,S0=STATE1_LO_S,DT=DT_SUB,DSDT=DYDT_1,SOLUTION=1,IERR=IERR,MESSAGE=MESSAGE) - IF (IERR.NE.0) THEN; PRINT *, IERR, MESSAGE; STOP; ENDIF - STATE1_HI = STATE0 + 0.5_SP*(DYDT_0+DYDT_1)*DT_SUB - ! average fluxes (average fluxes before imposing bounds) - CALL MODL_SOLVE(AVG_FLUX=.TRUE.,IERR=IERR,MESSAGE=MESSAGE) - IF (IERR.NE.0) THEN; PRINT *, IERR, TRIM(MESSAGE); STOP; ENDIF - ! get a safegaurded solution to account for excessive extrapolation (includes flux disaggregation) - CALL MODL_SOLVE(B_IMPOSE=.TRUE.,S0=STATE1_HI,S1=STATE1_HI_S,DT=DT_SUB,HBOUND=FEXCESS,& - IERR=IERR,MESSAGE=MESSAGE) - IF (IERR.NE.0) THEN; PRINT *, IERR, TRIM(MESSAGE); STOP; ENDIF - - ! -------------------------------------------------------------------------------------- - ! (4) CALCULATE IMPLICIT HEUN SOLUTION - ! -------------------------------------------------------------------------------------- - CASE (IMPLICIT_HEUN) - ! estimate the initial conditions used in the Newton scheme - SELECT CASE (INITIAL_NEWTON) - CASE (STATE_OLD); STATE1_INIT = STATE0 - CASE (EXPLICIT_MID); STATE1_INIT = STATE0 + DYDT_0*DT_SUB/2.0_SP ! estimate at mid-point - CASE (EXPLICIT_FULL); STATE1_INIT = STATE0 + DYDT_0*DT_SUB ! estimate at end - END SELECT - ! estimate state vector at end of sub-step - CALL MODL_SOLVE(IE_SOLVE=.TRUE.,S0=STATE1_INIT,S1=STATE1_HI,DSDT=DYDT_1,DT=DT_SUB,& - NEWSTEP=newStep,CONVCHECK=CHECK,NITER=NITER,& - IERR=IERR,MESSAGE=MESSAGE) - IF (IERR.NE.0) THEN; PRINT *, IERR, TRIM(MESSAGE); STOP; ENDIF - IF (NITER > MAXNUM_ITERNS) MAXNUM_ITERNS=NITER - newStep=.false. - ! re-compute state vector at the end of the sub-step (needed for non-convergence) - STATE1_HI = STATE0 + 0.5_SP*(DYDT_0+DYDT_1)*DT_SUB - ! average fluxes (average fluxes before imposing bounds) - CALL MODL_SOLVE(AVG_FLUX=.TRUE.,IERR=IERR,MESSAGE=MESSAGE) - IF (IERR.NE.0) THEN; PRINT *, IERR, TRIM(MESSAGE); STOP; ENDIF - ! get a safegaurded solution to account for excessive extrapolation (includes flux disaggregation) - CALL MODL_SOLVE(B_IMPOSE=.TRUE.,S0=STATE1_HI,S1=STATE1_HI_S,DT=DT_SUB,HBOUND=FEXCESS,& - IERR=IERR,MESSAGE=MESSAGE) - IF (IERR.NE.0) THEN; PRINT *, IERR, TRIM(MESSAGE); STOP; ENDIF - ! check for non-convergence - IF (TEMPORAL_ERROR_CONTROL.EQ.TS_ADAPT) THEN - IF (CHECK) THEN - NUMSUB_NOCONV = NUMSUB_NOCONV + 1 - STEP = MAX(MIN_TSTEP, DT_SUB*RMIN) ! (avoid stepsize < MIN_TSTEP) - TEMPSTEP = REVISE_STEP() ! avoid small steps at the end of a time interval - IF (TEMPSTEP.NE.STEP) THEN; PREVSTEP=STEP; ELSE; PREVSTEP=TEMPSTEP; ENDIF - ! avoid the case of a continuous do loop where TEMPSTEP is at a minimum - IF (TEMPSTEP.LT.DT_SUB) THEN ! TEMPSTEP may equal DT_SUB (MIN_TSTEP, or end of interval) - newStep = .true. - DT_SUB = TEMPSTEP - CYCLE SUBSTEPS - ENDIF - IERR=10; MESSAGE='newton did not converge, and unable to make steps small enough'; RETURN - ENDIF - ENDIF - ! compute auxillary lower-order solution - STATE1_LO = STATE0 + DYDT_1*DT_SUB - - ! -------------------------------------------------------------------------------------- - ! (5) CALCULATE SEMI-IMPLICIT EULER SOLUTION - ! -------------------------------------------------------------------------------------- - CASE (SEMI_IMPLICIT) - ! use explicit Euler for lower-order solution - STATE1_LO = STATE0 + DYDT_0*DT_SUB - ! estimate state vector at end of time step - CALL MODL_SOLVE(SI_SOLVE=.TRUE.,S0=STATE0,S1=STATE1_HI,DSDT=DYDT_0,DT=DT_SUB,& - IERR=IERR,MESSAGE=MESSAGE) - IF (IERR.LT.0) PRINT *, IERR, TRIM(MESSAGE) - IF (IERR.GT.0) THEN; PRINT *, IERR, TRIM(MESSAGE); STOP; ENDIF - newStep=.false. - ! get a safegaurded solution to account for excessive extrapolation (includes flux disaggregation) - CALL MODL_SOLVE(B_IMPOSE=.TRUE.,S0=STATE1_HI,S1=STATE1_HI_S,DT=DT_SUB,HBOUND=FEXCESS,& - IERR=IERR,MESSAGE=MESSAGE) - - - ! check that the solution method is OK - CASE DEFAULT - IERR=20; MESSAGE='ode_int: unknown solution method'; RETURN - - END SELECT - - ! -------------------------------------------------------------------------------------- - ! (3) CALCULATE ERROR, CHECK IF ACCEPT/REJECT THE CURRENT STEP, AND NEW STEP SIZE - ! -------------------------------------------------------------------------------------- - ! calculate the maximum error over all states - NEW_SUBSTEP = .FALSE. - IF (TEMPORAL_ERROR_CONTROL.EQ.TS_ADAPT) THEN - EVEC = ABS(STATE1_HI_S - STATE1_LO) ! error estimate - TVEC = ERR_TRUNC_REL*ABS(STATE1_HI_S) + ERR_TRUNC_ABS ! error thresholds - IMAX = MAXLOC(EVEC - TVEC) ! index of maximum error - IF (EVEC(IMAX(1)) < TVEC(IMAX(1)) .OR. & ! (accept if error is less than critical threshold) - DT_SUB <= MIN_TSTEP) THEN - NEW_SUBSTEP = .TRUE. - ENDIF - ELSE - EVEC = 0._SP; TVEC = 0._SP; IMAX = 0 - NEW_SUBSTEP = .TRUE. ! (accept if fixed time steps) - ENDIF - ! -------------------------------------------------------------------------------------- - IF (NEW_SUBSTEP) THEN ! (accept if time step is already minimum allowable) - !WRITE(*,'(I1,1X,2(F8.5,1X),I1,1X,20(F8.3,1X))') 0, ETIME, DT_SUB, IMAX, STATE1_HI_S, EVEC, TVEC - ! accept step -- calculate new (increased) step size - ! NOTE: step size not necessarily increased because of the safety factor - IF (TEMPORAL_ERROR_CONTROL.EQ.TS_ADAPT) THEN - MULT = SAFETY * SQRT( TVEC(IMAX(1)) / MAX(EVEC(IMAX(1)),EPS) ) - STEP = MIN( MAX(MIN_TSTEP, DT_SUB * MIN(MULT,RMAX) ), MAX_TSTEP) ! (MIN_TSTEP < stepsize < MAX_TSTEP) - ELSE - STEP = MAX_TSTEP - ENDIF - ! add contribution of sub-step flux to the timestep-average flux - CALL MODL_SOLVE(ADD_FLUX=.TRUE.,S1=STATE1_HI_S,DT=DT_SUB,IERR=IERR,MESSAGE=MESSAGE) - IF (IERR.NE.0) THEN; PRINT *, IERR, TRIM(MESSAGE); STOP; ENDIF - STATE1_RETAIN = STATE1_HI_S - - NUMSUB_ACCEPT = NUMSUB_ACCEPT + 1 - ! compute fraction of big step that is finished, and check for exit criteria - ETIME = ETIME + DT_SUB ! identify position within the time step - IF (ETIME.GE.DT_FULL) THEN - EXIT SUBSTEPS ! exit the substeps loop - ENDIF - ! revise the length of time steps to avoid small steps at the end of a time interval - DT_SUB = REVISE_STEP() ! avoid small steps at the end of a time interval - IF (DT_SUB.NE.STEP) THEN; PREVSTEP=STEP; ELSE; PREVSTEP=DT_SUB; ENDIF - ! -------------------------------------------------------------------------------------- - ELSE ! REJECT STEP AND DECREASE STEP SIZE - NEW_SUBSTEP = .FALSE. - !WRITE(*,'(I1,1X,2(F8.5,1X),I1,1X,20(F8.3,1X))') 1, ETIME, DT_SUB, IMAX, STATE1_HI_S, EVEC, TVEC - ! calculate new (decreased) step size - NUMSUB_REJECT = NUMSUB_REJECT + 1 - MULT = SAFETY * SQRT( TVEC(IMAX(1)) / MAX(EVEC(IMAX(1)),EPS) ) - STEP = MAX(MIN_TSTEP, DT_SUB * MAX(MULT,RMIN) ) ! (avoid stepsize < MIN_TSTEP) - DT_SUB = REVISE_STEP() ! avoid small steps at the end of a time interval - IF (DT_SUB.NE.STEP) THEN; PREVSTEP=STEP; ELSE; PREVSTEP=DT_SUB; ENDIF - ENDIF - - ! (keep looping) -END DO SUBSTEPS ! continuous (recursive) do loop -!print *, 'num_funcs = ', num_funcs - -! --------------------------------------------------------------------------------------- -! (9) RE-COMPUTE STATES AT THE END OF THE FULL STEP -! --------------------------------------------------------------------------------------- -! The implicit solution is not exact. To conserve mass, we uses the weighted average of -! model fluxes throughout the time step to re-compute states at the end of the time step -! --------------------------------------------------------------------------------------- -! update model states (note use of DT_FULL) -CALL MODL_SOLVE(NEWSTATE=.TRUE.,S1=STATE_END,DT=DT_FULL,IERR=IERR,MESSAGE=MESSAGE) -IF (IERR.NE.0) THEN; PRINT *, IERR, TRIM(MESSAGE); STOP; ENDIF -! NOTE: may need to modify diagnostic variables that do not have time units, e.g., satarea = satarea/dt_full -DT_SUB=PREVSTEP ! ensure stepsize is not equal to the small remainder - -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -CONTAINS - FUNCTION REVISE_STEP() - REAL(SP) :: REVISE_STEP - REAL(SP) :: T_MGN - SELECT CASE(SMALL_ENDSTEP) - ! ------------------------------------------------------------------------------------- - CASE(STEP_TRUNC) ! truncate the time step if near the end - IF (ETIME + STEP .GE. DT_FULL) REVISE_STEP = DT_FULL - ETIME - IF (ETIME + STEP .LT. DT_FULL) REVISE_STEP = STEP - ! ------------------------------------------------------------------------------------- - CASE(LOOK_AHEAD) ! the look-ahead method of Shampine (1994) - IF (ETIME + STEP .GE. DT_FULL) THEN - REVISE_STEP = DT_FULL - ETIME - ELSE - IF (ETIME + STEP*2._SP .GE. DT_FULL) THEN - REVISE_STEP = (DT_FULL - ETIME)/2._SP - ELSE - REVISE_STEP = STEP - ENDIF - ENDIF - ! ------------------------------------------------------------------------------------- - CASE(STEP_ABSORB) ! the step-absorption method - IF (STEP_INCREASE) THEN ! only try and increase step size once - IF (ETIME + STEP .GE. DT_FULL) REVISE_STEP = DT_FULL - ETIME - IF (ETIME + STEP .LT. DT_FULL) REVISE_STEP = STEP - ELSE - T_MGN = STEP/SAFETY - STEP ! margin of error - IF (ETIME + STEP + T_MGN .GE. DT_FULL) THEN - REVISE_STEP = DT_FULL - ETIME - STEP_INCREASE = .TRUE. - ELSE - IF (ETIME + STEP + T_MGN*2._SP .GE. DT_FULL) THEN - REVISE_STEP = STEP + T_MGN*(T_MGN/(DT_FULL-(ETIME+STEP))) - STEP_INCREASE = .TRUE. - ELSE - REVISE_STEP = STEP - ENDIF - ENDIF - ENDIF - CASE DEFAULT; STOP ' must use the STEP_TRUNC, LOOK_AHEAD, or STEP_ABSORB methods ' - END SELECT - END FUNCTION REVISE_STEP -END SUBROUTINE ODE_INT diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/par_derive.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/par_derive.f90.svn-base deleted file mode 100644 index 8a1b699..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/par_derive.f90.svn-base +++ /dev/null @@ -1,35 +0,0 @@ -SUBROUTINE PAR_DERIVE(err,message) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Computes derived model parameters (bucket sizes, etc.) -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multiparam -- model parameters stored in MODULE multiparam -! --------------------------------------------------------------------------------------- -USE nrtype ! define data types -USE model_defn, ONLY: SMODL ! model definition structures -USE model_defnames -USE multiparam, ONLY: MPARAM,DPARAM ! model parameter structures -IMPLICIT NONE -! dummies -integer(i4b),intent(out)::err -character(*),intent(out)::message -! --------------------------------------------------------------------------------------- -err=0 -CALL BUCKETSIZE() ! compute bucket size -CALL MEAN_TIPOW() ! mean of the power-transformed topo index -CALL QBSATURATN() ! compute baseflow at saturation (used in the SAC percolation model) -CALL QTIMEDELAY(err,message) ! compute fraction of runoff in future time steps -if(err/=0)then - err=10; message="f-PAR_DERIVE/&"//trim(message); return -endif -! --------------------------------------------------------------------------------------- -IF (SMODL%iESOIL.EQ.iopt_rootweight) DPARAM%RTFRAC2 = 1._SP - MPARAM%RTFRAC1 -! --------------------------------------------------------------------------------------- -END SUBROUTINE PAR_DERIVE diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/par_insert.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/par_insert.f90.svn-base deleted file mode 100644 index 053edee..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/par_insert.f90.svn-base +++ /dev/null @@ -1,100 +0,0 @@ -MODULE PAR_INSERT_MODULE -IMPLICIT NONE -CONTAINS -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -SUBROUTINE PUT_PARSET(PARSET) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2008 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Inserts an entire parameter set into a data structure, using the list of parameters -! in LPARAM -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE multiparam ! model parameters -IMPLICIT NONE -! input -REAL(SP), INTENT(IN), DIMENSION(:) :: PARSET ! parameter set -! local -INTEGER(I4B) :: IPAR ! looping -! --------------------------------------------------------------------------------------- -DO IPAR=1,NUMPAR ! NUMPAR is stored in module multiparam - CALL PAR_INSERT(PARSET(IPAR),LPARAM(IPAR)%PARNAME) -END DO -! --------------------------------------------------------------------------------------- -END SUBROUTINE PUT_PARSET -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -SUBROUTINE PAR_INSERT(XVAR,PARNAME) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Inserts parameter value into data structurs -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE multiparam ! model parameters -IMPLICIT NONE -! input -REAL(SP), INTENT(IN) :: XVAR ! parameter value -CHARACTER(*), INTENT(IN) :: PARNAME ! parameter name -! --------------------------------------------------------------------------------------- -! model parameters -SELECTCASE(TRIM(PARNAME)) -CASE('RFERR_ADD'); MPARAM%RFERR_ADD = XVAR -CASE('RFERR_MLT'); MPARAM%RFERR_MLT = XVAR -CASE('RFH1_MEAN'); MPARAM%RFH1_MEAN = XVAR -CASE('RFH2_SDEV'); MPARAM%RFH2_SDEV = XVAR -CASE('RH1P_MEAN'); MPARAM%RH1P_MEAN = XVAR -CASE('RH1P_SDEV'); MPARAM%RH1P_SDEV = XVAR -CASE('RH2P_MEAN'); MPARAM%RH2P_MEAN = XVAR -CASE('RH2P_SDEV'); MPARAM%RH2P_SDEV = XVAR -CASE('MAXWATR_1'); MPARAM%MAXWATR_1 = XVAR -CASE('MAXWATR_2'); MPARAM%MAXWATR_2 = XVAR -CASE('FRACTEN'); MPARAM%FRACTEN = XVAR -CASE('FRCHZNE'); MPARAM%FRCHZNE = XVAR -CASE('FPRIMQB'); MPARAM%FPRIMQB = XVAR -CASE('RTFRAC1'); MPARAM%RTFRAC1 = XVAR -CASE('PERCRTE'); MPARAM%PERCRTE = XVAR -CASE('PERCEXP'); MPARAM%PERCEXP = XVAR -CASE('SACPMLT'); MPARAM%SACPMLT = XVAR -CASE('SACPEXP'); MPARAM%SACPEXP = XVAR -CASE('PERCFRAC'); MPARAM%PERCFRAC = XVAR -CASE('FRACLOWZ'); MPARAM%FRACLOWZ = XVAR -CASE('IFLWRTE'); MPARAM%IFLWRTE = XVAR -CASE('BASERTE'); MPARAM%BASERTE = XVAR -CASE('QB_POWR'); MPARAM%QB_POWR = XVAR -CASE('QB_PRMS'); MPARAM%QB_PRMS = XVAR -CASE('QBRATE_2A'); MPARAM%QBRATE_2A = XVAR -CASE('QBRATE_2B'); MPARAM%QBRATE_2B = XVAR -CASE('SAREAMAX'); MPARAM%SAREAMAX = XVAR -CASE('AXV_BEXP'); MPARAM%AXV_BEXP = XVAR -CASE('LOGLAMB'); MPARAM%LOGLAMB = XVAR -CASE('TISHAPE'); MPARAM%TISHAPE = XVAR -CASE('TIMEDELAY'); MPARAM%TIMEDELAY = XVAR -! derived parameters -CASE('MAXTENS_1'); DPARAM%MAXTENS_1 = XVAR -CASE('MAXTENS_1A'); DPARAM%MAXTENS_1A = XVAR -CASE('MAXTENS_1B'); DPARAM%MAXTENS_1B = XVAR -CASE('MAXFREE_1'); DPARAM%MAXFREE_1 = XVAR -CASE('MAXTENS_2'); DPARAM%MAXTENS_2 = XVAR -CASE('MAXFREE_2'); DPARAM%MAXFREE_2 = XVAR -CASE('MAXFREE_2A'); DPARAM%MAXFREE_2A = XVAR -CASE('MAXFREE_2B'); DPARAM%MAXFREE_2B = XVAR -CASE('QBSAT'); DPARAM%QBSAT = XVAR -CASE('RTFRAC2'); DPARAM%RTFRAC2 = XVAR -CASE('POWLAMB'); DPARAM%POWLAMB = XVAR -CASE('MAXPOW'); DPARAM%MAXPOW = XVAR -CASE DEFAULT; STOP ' parameter name does not exist ' -ENDSELECT -! --------------------------------------------------------------------------------------- -END SUBROUTINE PAR_INSERT -END MODULE PAR_INSERT_MODULE diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/parextract.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/parextract.f90.svn-base deleted file mode 100644 index a08452b..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/parextract.f90.svn-base +++ /dev/null @@ -1,126 +0,0 @@ -MODULE PAREXTRACT_MODULE -IMPLICIT NONE -CONTAINS -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -SUBROUTINE GET_PARSET(PARSET) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2008 -! --------------------------------------------------------------------------------------- -! 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 -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 - ! 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 - ! 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 -END MODULE PAREXTRACT_MODULE diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/putpar_str.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/putpar_str.f90.svn-base deleted file mode 100644 index 8058622..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/putpar_str.f90.svn-base +++ /dev/null @@ -1,59 +0,0 @@ -MODULE PUTPAR_STR_MODULE -IMPLICIT NONE -CONTAINS -SUBROUTINE PUTPAR_STR(METADAT,PARNAME) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Inserts parameter metadata into data structures -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE multiparam, ONLY : PARATT, PARMETA ! derived type for parameter metadata -IMPLICIT NONE -! input -TYPE(PARATT), INTENT(IN) :: METADAT ! parameter metadata -CHARACTER(*), INTENT(IN) :: PARNAME ! parameter name -! --------------------------------------------------------------------------------------- -! model parameters -SELECTCASE(TRIM(PARNAME)) -CASE('RFERR_ADD'); PARMETA%RFERR_ADD = METADAT -CASE('RFERR_MLT'); PARMETA%RFERR_MLT = METADAT -CASE('RFH1_MEAN'); PARMETA%RFH1_MEAN = METADAT -CASE('RFH2_SDEV'); PARMETA%RFH2_SDEV = METADAT -CASE('RH1P_MEAN'); PARMETA%RH1P_MEAN = METADAT -CASE('RH1P_SDEV'); PARMETA%RH1P_SDEV = METADAT -CASE('RH2P_MEAN'); PARMETA%RH2P_MEAN = METADAT -CASE('RH2P_SDEV'); PARMETA%RH2P_SDEV = METADAT -CASE('MAXWATR_1'); PARMETA%MAXWATR_1 = METADAT -CASE('MAXWATR_2'); PARMETA%MAXWATR_2 = METADAT -CASE('FRACTEN'); PARMETA%FRACTEN = METADAT -CASE('FRCHZNE'); PARMETA%FRCHZNE = METADAT -CASE('FPRIMQB'); PARMETA%FPRIMQB = METADAT -CASE('RTFRAC1'); PARMETA%RTFRAC1 = METADAT -CASE('PERCRTE'); PARMETA%PERCRTE = METADAT -CASE('PERCEXP'); PARMETA%PERCEXP = METADAT -CASE('SACPMLT'); PARMETA%SACPMLT = METADAT -CASE('SACPEXP'); PARMETA%SACPEXP = METADAT -CASE('PERCFRAC'); PARMETA%PERCFRAC = METADAT -CASE('FRACLOWZ'); PARMETA%FRACLOWZ = METADAT -CASE('IFLWRTE'); PARMETA%IFLWRTE = METADAT -CASE('BASERTE'); PARMETA%BASERTE = METADAT -CASE('QB_POWR'); PARMETA%QB_POWR = METADAT -CASE('QB_PRMS'); PARMETA%QB_PRMS = METADAT -CASE('QBRATE_2A'); PARMETA%QBRATE_2A = METADAT -CASE('QBRATE_2B'); PARMETA%QBRATE_2B = METADAT -CASE('SAREAMAX'); PARMETA%SAREAMAX = METADAT -CASE('AXV_BEXP'); PARMETA%AXV_BEXP = METADAT -CASE('LOGLAMB'); PARMETA%LOGLAMB = METADAT -CASE('TISHAPE'); PARMETA%TISHAPE = METADAT -CASE('TIMEDELAY'); PARMETA%TIMEDELAY = METADAT -CASE DEFAULT - print *, 'parameter name (', TRIM(PARNAME), ') does not exist'; STOP -ENDSELECT -! --------------------------------------------------------------------------------------- -END SUBROUTINE PUTPAR_STR -END MODULE PUTPAR_STR_MODULE diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/q_baseflow.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/q_baseflow.f90.svn-base deleted file mode 100644 index d13da29..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/q_baseflow.f90.svn-base +++ /dev/null @@ -1,51 +0,0 @@ -SUBROUTINE Q_BASEFLOW() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Computes the baseflow from the lower soil layer -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multi_flux -- baseflow stored in MODULE multi_flux -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition structure -USE model_defnames -USE multiparam ! model parameters -USE multistate ! model states -USE multi_flux ! model fluxes -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -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 - !WRITE(*,'(3(F9.3,1X))') MPARAM%QBRATE_2A, TSTATE%FREE_2A, M_FLUX%QBASE_2A - !WRITE(*,'(4(F9.3,1X))') MPARAM%QBRATE_2B, TSTATE%FREE_2B, M_FLUX%QBASE_2B, M_FLUX%QBASE_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) - ! -------------------------------------------------------------------------------------- - CASE(iopt_unlimpow_2) ! baseflow resvr of unlimited size (0-HUGE), power recession - M_FLUX%QBASE_2 = DPARAM%QBSAT * (TSTATE%WATR_2/MPARAM%MAXWATR_2)**MPARAM%QB_POWR - ! -------------------------------------------------------------------------------------- - CASE(iopt_topmdexp_2) ! topmodel exponential reservoir (-HUGE to HUGE) - M_FLUX%QBASE_2 = DPARAM%QBSAT * EXP( -(1. - TSTATE%WATR_2/MPARAM%MAXWATR_2) ) - ! -------------------------------------------------------------------------------------- - CASE(iopt_fixedsiz_2) ! baseflow reservoir of fixed size - M_FLUX%QBASE_2 = MPARAM%BASERTE * (TSTATE%WATR_2/MPARAM%MAXWATR_2)**MPARAM%QB_POWR - ! -------------------------------------------------------------------------------------- - CASE DEFAULT - print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" - print *, " iopt_topmdexp_2, or iopt_fixedsiz_2" - STOP - ! -------------------------------------------------------------------------------------- -END SELECT -! --------------------------------------------------------------------------------------- -END SUBROUTINE Q_BASEFLOW diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/q_misscell.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/q_misscell.f90.svn-base deleted file mode 100644 index b40328a..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/q_misscell.f90.svn-base +++ /dev/null @@ -1,171 +0,0 @@ -SUBROUTINE Q_MISSCELL() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 (revised 2009 to include a residual method) -! --------------------------------------------------------------------------------------- -! 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) -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multi_flux -- baseflow stored in MODULE multi_flux -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition structure -USE model_defnames -USE multiparam, ONLY: MPARAM,DPARAM ! model parameters -USE multistate, ONLY: MSTATE,TSTATE ! model states -USE multi_flux, ONLY: M_FLUX,CURRENT_DT ! model fluxes -USE model_numerix ! access model numerix decisions -IMPLICIT NONE -REAL(SP) :: LOGISMOOTH ! FUNCTION logistic smoothing -REAL(SP), PARAMETER :: PSMOOTH=0.01_SP ! smoothing parameter -REAL(SP) :: W_FUNC ! result from LOGISMOOTH -REAL(SP) :: DT ! current time step -INTEGER(I4B), PARAMETER :: POP_CASE=9 ! just a temporary fix so the case statement is populated -! --------------------------------------------------------------------------------------- -SELECT CASE(SOLUTION_METHOD) - CASE (EXPLICIT_EULER,IMPLICIT_EULER,EXPLICIT_HEUN,IMPLICIT_HEUN,SEMI_IMPLICIT) - ! --------------------------------------------------------------------------------------- - ! (1) OVERFLOW FLUXES AS A FRACTION OF INFLUXES - ! --------------------------------------------------------------------------------------- - 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 = LOGISMOOTH(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 = LOGISMOOTH(TSTATE%TENS_1B,DPARAM%MAXTENS_1B,PSMOOTH) - M_FLUX%TENS2FREE_1 = W_FUNC * M_FLUX%RCHR2EXCS - ! compute over-flow of free water - W_FUNC = LOGISMOOTH(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 = LOGISMOOTH(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 = LOGISMOOTH(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 - W_FUNC = LOGISMOOTH(TSTATE%WATR_1,MPARAM%MAXWATR_1,PSMOOTH) - M_FLUX%OFLOW_1 = W_FUNC * (M_FLUX%EFF_PPT - M_FLUX%QSURF) - 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 = LOGISMOOTH(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 = LOGISMOOTH(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 = LOGISMOOTH(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 = LOGISMOOTH(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 - ! --------------------------------------------------------------------------------------- - CASE (POP_CASE) - ! --------------------------------------------------------------------------------------- - ! (2) OVERFLOW FLUXES COMPUTED AS A RESIDUAL OF AVAILABLE STORAGE - ! --------------------------------------------------------------------------------------- - DT = CURRENT_DT - ! --------------------------------------------------------------------------------------- - 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) - M_FLUX%RCHR2EXCS = MAX(0._SP, (M_FLUX%EFF_PPT - M_FLUX%QSURF) - (DPARAM%MAXTENS_1A - MSTATE%TENS_1A)/DT) - ! compute flow from tension storage to free storage (mm s-1) - M_FLUX%TENS2FREE_1 = MAX(0._SP, M_FLUX%RCHR2EXCS - (DPARAM%MAXTENS_1B - MSTATE%TENS_1B)/DT) - ! compute over-flow of free water - M_FLUX%OFLOW_1 = MAX(0._SP, M_FLUX%TENS2FREE_1 - (DPARAM%MAXFREE_1 - MSTATE%FREE_1) /DT) - 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) - M_FLUX%TENS2FREE_1 = MAX(0._SP, (M_FLUX%EFF_PPT - M_FLUX%QSURF) - (DPARAM%MAXTENS_1 - MSTATE%TENS_1)/DT) - ! compute over-flow of free water - M_FLUX%OFLOW_1 = MAX(0._SP, M_FLUX%TENS2FREE_1 - (DPARAM%MAXFREE_1 - MSTATE%FREE_1)/DT) - 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 - M_FLUX%OFLOW_1 = MAX(0._SP, (M_FLUX%EFF_PPT - M_FLUX%QSURF) - (MPARAM%MAXWATR_1 - MSTATE%WATR_1)/DT) - 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) - M_FLUX%TENS2FREE_2 = MAX(0._SP, M_FLUX%QPERC_12*(1._SP-MPARAM%PERCFRAC) - (DPARAM%MAXTENS_2 - MSTATE%TENS_2 )/DT) - ! compute over-flow of free water in the primary reservoir - M_FLUX%OFLOW_2A = MAX(0._SP, (M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) + M_FLUX%TENS2FREE_2/2._SP) & - - (DPARAM%MAXFREE_2A - MSTATE%FREE_2A)/DT) - ! compute over-flow of free water in the secondary reservoir - M_FLUX%OFLOW_2B = MAX(0._SP, (M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) + M_FLUX%TENS2FREE_2/2._SP) & - - (DPARAM%MAXFREE_2B - MSTATE%FREE_2B)/DT) - ! 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 - M_FLUX%OFLOW_2 = MAX(0._SP, M_FLUX%QPERC_12 - (MPARAM%MAXWATR_2 - MSTATE%WATR_2)/DT) - 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 - ! --------------------------------------------------------------------------------------- - CASE DEFAULT - PRINT *, 'fatal error in q_misscell: unknown solution method; solution method must equal '//& - '0 (explicit_euler), 1 (explicit heun), 2 (implicit_euler), 3 (implicit_heun), or '//& - '4 (semi_implicit)' - STOP -END SELECT -END SUBROUTINE Q_MISSCELL diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/q_overland.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/q_overland.f90.svn-base deleted file mode 100644 index a66b31a..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/q_overland.f90.svn-base +++ /dev/null @@ -1,53 +0,0 @@ -SUBROUTINE Q_OVERLAND() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! -------- -! History -! 5 June 2013 AD: Modified by David McInerney to merge array loop operations -! 5 June 2013 AD: Modified by Dmitri Kavetski to avoid zero-element operations -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Computes the time delay in runoff in a basin (places runoff in future time steps) -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multiroute -- places runoff in array FUTURE(:)RUNOFF -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition structure -USE model_defnames -USE multiparam ! model parameters -USE multi_flux ! model fluxes -USE multiroute ! routed runoff -IMPLICIT NONE -INTEGER(I4B) :: NTDH ! maximum number of future time steps -INTEGER(I4B) :: JTIM ! (loop through future time steps) -REAL(SP), PARAMETER :: SNEG=-1.e-5 ! small negative number, used for checking -LOGICAL, PARAMETER :: USE_NTDH_NEED=.TRUE. ! flag to use NTDH_NEED to reduce array operations (loop length) -! --------------------------------------------------------------------------------------- -! compute total runoff (sum of surface runoff, overflow, interflow, and baseflow -MROUTE%Q_INSTNT = W_FLUX%QSURF + W_FLUX%OFLOW_1 + W_FLUX%QINTF_1 + W_FLUX%OFLOW_2 + W_FLUX%QBASE_2 -!print *, 'in q_overland ', & -! MROUTE%Q_INSTNT, W_FLUX%QSURF, W_FLUX%OFLOW_1, W_FLUX%QINTF_1, W_FLUX%OFLOW_2, W_FLUX%QBASE_2 -if (W_FLUX%QSURF.lt.SNEG .or. W_FLUX%OFLOW_1.lt.SNEG .or. W_FLUX%QINTF_1.lt.SNEG .or. & - W_FLUX%OFLOW_2.lt.SNEG .or. W_FLUX%QBASE_2.lt.SNEG) stop 'negative flux in q_overland' -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iQ_TDH) - CASE(iopt_rout_gamma) ! use a Gamma distribution with shape parameter = 2.5 - NTDH = SIZE(DPARAM%FRAC_FUTURE) ! maximum number of future time steps - MROUTE%Q_ROUTED = FUTURE(1) + MROUTE%Q_INSTNT * DPARAM%FRAC_FUTURE(1) - DO JTIM=2,MERGE(DPARAM%NTDH_NEED,NTDH,USE_NTDH_NEED) ! update and move array of states within the routing convolution - FUTURE(JTIM-1) = FUTURE(JTIM) + MROUTE%Q_INSTNT * DPARAM%FRAC_FUTURE(JTIM) - END DO - FUTURE(JTIM-1) = 0._sp ! last element (just in case) - the rest are never accessed (treated as 0) - CASE(iopt_no_routing) ! no routing - MROUTE%Q_ROUTED = MROUTE%Q_INSTNT - CASE DEFAULT ! check for errors - print *, "SMODL%iQ_TDH must be either iopt_rout_gamma or iopt_no_routing" - STOP -END SELECT -! --------------------------------------------------------------------------------------- -END SUBROUTINE Q_OVERLAND diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qbsaturatn.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qbsaturatn.f90.svn-base deleted file mode 100644 index 629668c..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qbsaturatn.f90.svn-base +++ /dev/null @@ -1,54 +0,0 @@ -SUBROUTINE QBSATURATN() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Computes baseflow at saturation (used in the SAC percolation model) -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multiparam -- baseflow at saturation stored in MODULE multiparam -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition structures -USE model_defnames -USE multiparam ! model parameters -IMPLICIT NONE -REAL(SP) :: TOPMDM ! TOPMODEL "m" parameter -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iARCH2) - ! -------------------------------------------------------------------------------------- - CASE(iopt_tens2pll_2) ! tension reservoir plus two parallel tanks - DPARAM%QBSAT = MPARAM%QBRATE_2A*DPARAM%MAXFREE_2A + MPARAM%QBRATE_2B*DPARAM%MAXFREE_2B - ! -------------------------------------------------------------------------------------- - CASE(iopt_unlimfrc_2) ! baseflow resvr of unlimited size - DPARAM%QBSAT = MPARAM%QB_PRMS * MPARAM%MAXWATR_2 - ! -------------------------------------------------------------------------------------- - CASE(iopt_unlimpow_2) ! topmodel power-law transmissivity profile - ! This is a bit tricky. The capacity of the aquifer is m*n, where m is a scaling - ! parameter. We have the capacity, i.e., MPARAM%MAXWATR_2/1000., and need the - ! TOPMODEL "m" parameter - TOPMDM = (MPARAM%MAXWATR_2/1000._sp) / MPARAM%QB_POWR ! NOTE: mm --> m - ! ...and, compute baseflow - DPARAM%QBSAT = MPARAM%BASERTE * ( TOPMDM / (DPARAM%POWLAMB**MPARAM%QB_POWR) ) - ! -------------------------------------------------------------------------------------- - CASE(iopt_topmdexp_2) ! topmodel exponential transmissivity profile (NOTE: mm --> m) - ! for simplicity we use the CAPACITY as the TOPMODEL scaling parameter - TOPMDM = MPARAM%MAXWATR_2/1000._sp ! NOTE: mm --> m - ! ..., and compute baseflow - DPARAM%QBSAT = MPARAM%BASERTE * TOPMDM * EXP(-MPARAM%LOGLAMB) - ! -------------------------------------------------------------------------------------- - CASE(iopt_fixedsiz_2) ! baseflow reservoir of fixed size - DPARAM%QBSAT = MPARAM%BASERTE - ! -------------------------------------------------------------------------------------- - CASE DEFAULT - print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" - print *, " iopt_topmdexp_2, or iopt_fixedsiz_2" - STOP - ! -------------------------------------------------------------------------------------- -END SELECT -! --------------------------------------------------------------------------------------- -END SUBROUTINE QBSATURATN diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qinterflow.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qinterflow.f90.svn-base deleted file mode 100644 index 406723e..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qinterflow.f90.svn-base +++ /dev/null @@ -1,33 +0,0 @@ -SUBROUTINE QINTERFLOW() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Computes the interflow from free water in the upper soil layer -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multi_flux -- interflow stored in MODULE multi_flux -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition structure -USE model_defnames -USE multiparam ! model parameters -USE multistate ! model states -USE multi_flux ! model fluxes -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -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 SUBROUTINE QINTERFLOW diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qpercolate.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qpercolate.f90.svn-base deleted file mode 100644 index 22b8e30..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qpercolate.f90.svn-base +++ /dev/null @@ -1,40 +0,0 @@ -SUBROUTINE QPERCOLATE() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Computes the percolation from the upper soil layer to the lower soil layer -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multi_flux -- percolation stored in MODULE multi_flux -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition structure -USE model_defnames -USE multiparam ! model parameters -USE multistate ! model states -USE multi_flux ! model fluxes -IMPLICIT NONE -REAL(SP) :: LZ_PD ! lower zone percolation demand -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iQPERC) - CASE(iopt_perc_f2sat) ! water from (field cap to sat) avail for percolation - M_FLUX%QPERC_12 = MPARAM%PERCRTE * (TSTATE%FREE_1/DPARAM%MAXFREE_1)**MPARAM%PERCEXP - CASE(iopt_perc_w2sat) ! water from (wilt pt to sat) avail for percolation - M_FLUX%QPERC_12 = MPARAM%PERCRTE * (TSTATE%WATR_1/MPARAM%MAXWATR_1)**MPARAM%PERCEXP - CASE(iopt_perc_lower) ! perc defined by moisture content in lower layer (SAC) - ! (compute lower-zone percolation demand -- multiplier on maximum percolation, then percolation) - 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) - !print *, 'lz_pd = ', LZ_PD, MPARAM%SACPMLT, TSTATE%WATR_2/MPARAM%MAXWATR_2, MPARAM%SACPEXP - !print *, 'qperc_12 = ', M_FLUX%QPERC_12, DPARAM%QBSAT, LZ_PD, TSTATE%FREE_1/DPARAM%MAXFREE_1 - CASE DEFAULT ! check for errors - print *, "SMODL%iQPERC must be iopt_perc_f2sat, iopt_perc_w2sat, or iopt_perc_lower" - STOP -END SELECT -! --------------------------------------------------------------------------------------- -END SUBROUTINE QPERCOLATE diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qrainerror.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qrainerror.f90.svn-base deleted file mode 100644 index b22104d..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qrainerror.f90.svn-base +++ /dev/null @@ -1,33 +0,0 @@ -SUBROUTINE QRAINERROR() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2008 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Computes the "effective" rainfall, following an error model -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multi_flux -- "effective" rainfall (eff_ppt) stored in MODULE multi_flux -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition structure -USE model_defnames -USE multiforce ! model forcing -USE multiparam ! model parameters -USE multi_flux ! model fluxes -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iRFERR) - CASE(iopt_additive_e) ! additive rainfall error - M_FLUX%EFF_PPT = MAX(0.0_sp, MFORCE%PPT + MPARAM%RFERR_ADD) - CASE(iopt_multiplc_e) ! multiplicative rainfall error - M_FLUX%EFF_PPT = MFORCE%PPT * MPARAM%RFERR_MLT - CASE DEFAULT ! check for errors - print *, "SMODL%iRFERR must be either iopt_additive_e or iopt_multiplc_e" - STOP -END SELECT -! --------------------------------------------------------------------------------------- -END SUBROUTINE QRAINERROR diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qsatexcess.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qsatexcess.f90.svn-base deleted file mode 100644 index 68eb47c..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qsatexcess.f90.svn-base +++ /dev/null @@ -1,69 +0,0 @@ -SUBROUTINE QSATEXCESS() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Computes the saturated area and surface runoff -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multi_flux -- saturated area and surface runoff stored in MODULE multi_flux -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE nr, ONLY : gammp ! interface for the incomplete gamma function -USE model_defn ! model definition structure -USE model_defnames -USE multiparam ! model parameters -USE multiforce ! model forcing -USE multistate ! model states -USE multi_flux ! model fluxes -IMPLICIT NONE -! internal variables -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 -! --------------------------------------------------------------------------------------- -! saturated area method -SELECT CASE(SMODL%iQSURF) - CASE(iopt_arno_x_vic) ! ARNO/Xzang/VIC parameterization (upper zone control) - M_FLUX%SATAREA = 1._sp - ( 1._sp - MIN(TSTATE%WATR_1/MPARAM%MAXWATR_1, 1._sp) )**MPARAM%AXV_BEXP - CASE(iopt_prms_varnt) ! PRMS variant (fraction of upper tension storage) - M_FLUX%SATAREA = MIN(TSTATE%TENS_1/DPARAM%MAXTENS_1, 1._sp) * MPARAM%SAREAMAX - CASE(iopt_tmdl_param) ! TOPMODEL parameterization (only valid for TOPMODEL qb) - - ! 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 - - ! 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 SUBROUTINE QSATEXCESS diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qtimedelay.f90.svn-base b/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qtimedelay.f90.svn-base deleted file mode 100644 index dd6bb09..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/qtimedelay.f90.svn-base +++ /dev/null @@ -1,69 +0,0 @@ -SUBROUTINE QTIMEDELAY(err,message) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Computes the fraction of runoff in future time steps -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multiparam -- runoff fractions stored in DPARAM%FRAC_FUTURE(:) -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE nr, ONLY : gammp ! interface for the incomplete gamma function -USE model_defn ! model definition structure -USE model_defnames -USE multiforce ! model forcing (need DELTIM) -USE multiparam ! model parameters -IMPLICIT NONE -! dummies -integer(i4b),intent(out)::err -character(*),intent(out)::message -! locals -INTEGER(I4B) :: NTDH ! maximum number of future time steps -REAL(SP) :: ALPHA ! shape parameter -REAL(SP) :: ALAMB ! scale parameter -INTEGER(I4B) :: JTIM ! (loop through future time steps) -REAL(SP) :: TFUTURE ! future time (units of days) -REAL(SP) :: CUMPROB ! cumulative probability at JTIM -REAL(SP) :: PSAVE ! cumulative probability at JTIM-1 -! --------------------------------------------------------------------------------------- -err=0 -SELECT CASE(SMODL%iQ_TDH) - CASE(iopt_rout_gamma) ! use a Gamma distribution with shape parameter = 2.5 - ALPHA = 2.5_SP ! shape parameter - ALAMB = ALPHA/MPARAM%TIMEDELAY ! scale parameter - PSAVE = 0._SP ! cumulative probability at JTIM-1 - NTDH = SIZE(DPARAM%FRAC_FUTURE) ! maximum number of future time steps - ! loop through time steps and compute the fraction of runoff in future time steps - DO JTIM=1,NTDH - TFUTURE = REAL(JTIM,SP)*DELTIM ! future time (units of days) - CUMPROB = GAMMP(ALPHA,ALAMB*TFUTURE) ! cumulative probability at JTIM - DPARAM%FRAC_FUTURE(JTIM) = MAX(0._SP, CUMPROB-PSAVE) ! probability between JTIM-1 and JTIM - PSAVE = CUMPROB ! cumulative probability at JTIM-1 - !WRITE(*,'(3(F11.5))') TFUTURE, DPARAM%FRAC_FUTURE(JTIM), CUMPROB - IF(DPARAM%FRAC_FUTURE(JTIM)0 -if(haveFMG)haveFMG=len_trim(fuseFileManagerIn)>0 ! check for zero-string -if(haveMUS.and.haveFMG)then - message="f-"//procnam//"/mustSpecifyEither(notBoth)& - &[fuseMusterDirektor.or.fuseFileManager]" - err=10; return -elseif(haveFMG)then - fuseFileManager=fuseFileManagerIn - i=scan(fuseFileManager,pathDelim,back=.true.) - if(i>0)defpath=fuseFileManager(:i-1)//pathDelim(1:1) -elseif(haveMUS)then - fuseMusterDirektor=fuseMusterDirektorIn - i=scan(fuseMusterDirektor,pathDelim,back=.true.) - if(i>0)defpath=fuseMusterDirektor(:i-1)//pathDelim(1:1) -else - message="f-"//procnam//"/mustSpecifyEither& - &[fuseMusterDirektor.or.fuseFileManager]" - err=20; return -endif -if(.not.haveFMG)then ! grab it from the muster-direktor -! 2. Open muster-direktor and read it - open(unt,file=fuseMusterDirektor,status="old",action="read",iostat=err) - if(err/=0)then - message="f-"//procnam//"/musterDirektorFileOpenError['"//trim(fuseMusterDirektor)//"']" - err=10; return - endif - read(unt,*)temp - if(temp/=fuseMusterDirektorHeader)then - message="f-"//procnam//"/unknownHeader&[file='"//trim(fuseMusterDirektor)//"']&& - &[header='"//trim(temp)//"']" - err=20; return - endif - read(unt,*)fuseFileManager - close(unt) -endif -! open file manager file -open(unt,file=fuseFileManager,status="old",action="read",iostat=err) -if(err/=0)then - message="f-"//procnam//"/fileManagerOpenError['"//trim(fuseFileManager)//"']" - err=10; return -endif -read(unt,*)temp -if(temp/=fuseFileManagerHeader)then - message="f-"//procnam//"/unknownHeader&[file='"//trim(fuseFileManager)//"']&& - &[header="//trim(temp)//"]" - err=20; return -endif -read(unt,'(a)')temp -read(unt,'(a)')temp -read(unt,*)SETNGS_PATH -read(unt,*)INPUT_PATH -read(unt,*)OUTPUT_PATH -read(unt,'(a)')temp -read(unt,*)FORCINGINFO -read(unt,*)M_DECISIONS -read(unt,*)CONSTRAINTS -read(unt,*)MOD_NUMERIX -read(unt,*)BATEA_PARAM -close(unt) -! process paths a bit -if(SETNGS_PATH(1:1)==defpathSymb)SETNGS_PATH=trim(defpath)//SETNGS_PATH(2:) -if( INPUT_PATH(1:1)==defpathSymb) INPUT_PATH=trim(defpath)//INPUT_PATH (2:) -if(OUTPUT_PATH(1:1)==defpathSymb)OUTPUT_PATH=trim(defpath)//OUTPUT_PATH(2:) -! End procedure here -endsubroutine fuse_SetDirsUndPhiles -!---------------------------------------------------- -END MODULE fuse_filemanager diff --git a/build/FUSE_SRC/FUSE_HOOK/.svn/text-base/fuse_stdDmdl_dmsl_mod.f90.svn-base b/build/FUSE_SRC/FUSE_HOOK/.svn/text-base/fuse_stdDmdl_dmsl_mod.f90.svn-base deleted file mode 100644 index 134890f..0000000 --- a/build/FUSE_SRC/FUSE_HOOK/.svn/text-base/fuse_stdDmdl_dmsl_mod.f90.svn-base +++ /dev/null @@ -1,432 +0,0 @@ -!****************************************************************** -! (C) Copyright 2009-2010 --- Dmitri Kavetski and Martyn Clark --- All rights reserved -!****************************************************************** -module fuse_stdDmdl_dmsl_mod -! Purpose: Standard dynamic model template for FUSE. -use kinds_dmsl_kit_FUSE -use model_defn,only:FUSE_version,FUSE_enabled -implicit none -!---------------------------------------------------- -private -public::FUSE_version,FUSE_enabled -public::FUSE_setModel,FUSE_getModelInfo,FUSE_cebarModel,FUSE_controlModel -public::FUSE_runModel,FUSE_runAllModel -!---------------------------------------------------- -! * Basic properties: numbers of parameters and states -character(*),parameter::modelNameFUSE="FUSE_" -character(*),parameter::indxNameFUSE="time" -integer(mik),parameter::nInputFUSE=2,nOutputFUSE=1 -integer(mik),parameter::parTranDefFUSE=0 ! default parameter transformations !DK: needs to be read from file -!---------------------------------------------------- -contains -!----------------------------------------------------------------------------------------- -! ***** SET MODEL ****************************************************************** -!----------------------------------------------------------------------------------------- -subroutine FUSE_setModel(modelID,setupCmd,chvarLibDef,err,message) -! Purpose: get setup information for the FUSE model -! At this stage, model parameters or even their number are not known by BATEA. -! This routine obtains the FUSE configuration from file. -USE model_defn,only:nstateFUSE=>nstate ! defines the set of FUSE models -USE metaoutput,only:vardescribe ! defines output for the FUSE models -! informational modules -use fuse_fileManager,only:fuse_SetDirsUndPhiles -USE selectmodl_module,only:selectmodl ! identify the model using a control file -use model_numerix,only:JAC_RECOMPUTE,CONSTFULLSTEP,FJACCOPY,FJACDCMP,FJACINDX -! Purpose: get setup information for the FUSE model -implicit none -! dummies -integer(mik),intent(in)::modelID(:) -character(*),intent(in)::setupCmd -character(*),intent(in),optional::chvarLibDef(:,:) -integer(mik),intent(out)::err -character(*),intent(out)::message -! local variables -integer(mik)::nmod -character(5)::jchar -integer(mik)::lenJCH=len(jchar) -! Start procedure here -err=0; message="ok" -! check that the file exists -if(setupCmd/=" ")then - jchar=setupCmd(:lenJCH) ! determine if musterfile or filemanager supplied - selectcase(jchar) - case("[fmf]","[FMF]") ! file manager file supplied - call fuse_SetDirsUndPhiles(fuseFileManagerIn=setupCmd(lenJCH+1:),err=err,message=message) - case("[mdf]","[MDF]") ! muster direktor file supplied - call fuse_SetDirsUndPhiles(fuseMusterDirektorIn=setupCmd(lenJCH+1:),err=err,message=message) - case default - call fuse_SetDirsUndPhiles(fuseFileManagerIn=setupCmd,err=err,message=message) - endselect -else - call fuse_SetDirsUndPhiles(err=err,message=message) -endif -if(err>0)then ! somethign actually went wrong - message="f-FUSE_setModel/&"//trim(message) - err=100; return -else ! just use default file (not a problem) - err=0 -endif -! Define model attributes (valid for all models) -call uniquemodl(nmod,err,message) ! get nmod unique models -if(err/=0)then - message="f-FUSE_setModel/&"//trim(message) - err=100; return -endif -call vardescribe() ! model variable descriptions (store in module metaoutput) -call getnumerix(err,message) ! decisions/parameters that define the numerical scheme -if(err/=0)then - message="f-FUSE_setModel/&"//trim(message) - err=100; return -endif -call getparmeta(err,message) ! read parameter metadata (parameter bounds, etc.) -if(err/=0)then - message="f-FUSE_setModel/&"//trim(message) - err=100; return -endif -! Identify a single model (read control file) -call selectmodl(istatus=err,message=message) -if(err/=0)then - message="f-FUSE_setModel/&"//trim(message) - err=200; return -endif -!write(*,*) LEN_TRIM(SMODL%MNAME), ' - ', TRIM(SMODL%MNAME) -! determine number of states -call assign_stt() ! state definitions stored in module model_defn [nstateFUSE] -! determine number of parameters -call assign_par() ! parameter defintions stored in module multiparam [nparFUSE] -! Allocate Jacobian if necessary -IF (JAC_RECOMPUTE.EQ.CONSTFULLSTEP) THEN - ALLOCATE(fjacCOPY(nstateFUSE,nstateFUSE),fjacDCMP(nstateFUSE,nstateFUSE),fjacINDX(nstateFUSE)) -ENDIF -! End procedure here -endsubroutine FUSE_setModel -!----------------------------------------------------------------------------------------- -! ***** GET MODEL INFO ******************************************************************* -!----------------------------------------------------------------------------------------- -subroutine FUSE_getModelInfo(modelID,infoCmd,& - modelName,ninput,nstate,npar,& - indxName,inputName,stateName,parName,& - stateLo,stateHi,parLo,parHi,inScal,stateScal,parScal,& - stateDef,parDef,parSD,parTranDef,parFitDef,& - err,message) -! Purpose: Returns basic properties of the FUSE model -! data modules -USE model_defn,only:SMODL,CSTATE,nstateFUSE=>nstate ! defines the set of FUSE models -USE model_defnames,only:desc_int2str -USE multiparam,only:paratt,lparam,numpar ! parameter attribute structure -USE multistate,only:fstate,dstate,fracstate0 ! defines the states for the FUSE models -USE multiforce,only:DELTIM ! model time step (days) -USE metaoutput,only:VNAME,NOUTVAR ! defines output for the FUSE models -! informational modules -USE str_2_xtry_module,only:str_2_xtry ! gets state vector from structure in multistate -USE getpar_str_module,only:getpar_str ! gets parameter metadata structure -USE par_insert_module,only:par_insert ! puts specific parameter into structure in multiparam -USE parextract_module,only:get_parset ! gets specific parameter from structure in multiparam -implicit none -! dummies -integer(mik),intent(in)::modelID(:) -character(*),intent(in)::infoCmd -character(*),intent(out),optional::modelName -integer(mik),intent(out),optional::ninput,nstate,npar -character(*),intent(out),optional::indxName ! this variable appeared in BATEAU v 502 -character(*),intent(out),dimension(:),optional::inputName,stateName,parName -real(mrk),intent(out),dimension(:),optional::stateLo,stateHi,parLo,parHi,& - inScal,stateScal,parScal,stateDef,parDef,parSD -integer(mik),intent(out),optional::parTranDef(:) -logical(mlk),intent(out),optional::parFitDef(:) -integer(mik),intent(out)::err -character(*),intent(out)::message -! local variables -! character(len=2) :: cnum ! model number as text -! integer(mik) :: nmod ! number of unique models -integer(mik) :: i !,j,k ! looping variables -integer(mik) :: istart ! start index of variable list (to define output) -real(mrk) :: frac ! fraction of capacity to initialize states -type(paratt) :: param_meta ! parameter metadata -real(mrk)::dt !DK_BOTCH: hardcode 'dt' -! Start procedure here -err=0; message="ok"; dt=1._mrk -! Define model data step -DELTIM = dt -! Define model name -if(present(modelName)) modelName = smodl%mname ! smodl is in module model_defn -! define model inputs (assume inputs are the ***first*** nInputs in varlist) -if(present(ninput)) nInput=nInputFUSE -if(present(indxName)) indxName=indxNameFUSE -if(present(inputName))forall(i=1:nInputFUSE) inputName(i) = vname(i) -! define model states -if(present(nstate))then - nstate=nstateFUSE+nOutputFUSE ! +nOutputFUSE to include model outputs in "state" list -endif -! define model outputs (assume outputs are the ***last*** nOutputs in varlist) -if(present(stateName))then - istart = (noutvar-nOutputFUSE)+1 - stateName(1:nOutputFUSE) = vname(istart:noutvar) - stateName(nOutputFUSE+1:nOutputFUSE+nstateFUSE) = desc_int2str(cstate%isname) -endif -! define model parameters -if(present(npar))then - npar=numpar ! numpar from module multiparam -endif -if(present(parName)) forall(i=1:numpar) parName(i) = lparam(i)%parname -! define parameter ranges and default transformations -if(present(parLo) .and. present(parHi).and.present(parTranDef)) then - do i=1,numpar - call getpar_str(lparam(i)%parname,param_meta) - parLo(i) = param_meta%parlow - parHi(i) = param_meta%parupp - parTranDef = param_meta%parvtn - end do -endif -! define state ranges -if(present(stateLo) .and. present(stateHi)) then - stateLo = 0._mrk ! set minimum states to zero - ! (use the default parameter values to set bucket sizes) - do i=1,numpar - call getpar_str(lparam(i)%parname,param_meta) ! extract full metadata structure - call par_insert(param_meta%pardef,lparam(i)%parname) ! insert the default param to model param structure - end do - call par_derive(err,message) ! identify the derived parameters associated with mparam - if(err/=0)then - message="f-FUSE_getModelInfo/&"//trim(message); return - endif - frac = 1._mrk; call init_state(frac) ! initialize states at fraction (frac) of capacity - call str_2_xtry(fstate,stateHi) ! extract a vector of states at the maximum value -endif -! define scaling factors -if(present(inScal)) inScal(1:nInputFUSE) = 10._mrk -if(present(stateScal))stateScal(1:nstateFUSE) = 10._mrk -if(present(parScal)) parScal(1:numpar) = 10._mrk -! define default parameter values -if(present(stateDef)) then - ! (use the default parameter values to set default states) - do i=1,numpar - call getpar_str(lparam(i)%parname,param_meta) ! extract full metadata structure - call par_insert(param_meta%pardef,lparam(i)%parname) ! insert the default param to model param structure - end do - call par_derive(err,message) ! identify the derived parameters associated with mparam - if(err/=0)then - message="f-FUSE_getModelInfo/&"//trim(message); return - endif - call init_state(fracState0) ! initialize states at fraction (frac) of capacity - call str_2_xtry(fstate,stateDef) ! extract a vector of states at the value tstate - dstate=fstate ! save default states in module multistate -endif -if(present(parDef)) then - do i=1,numpar - call getpar_str(lparam(i)%parname,param_meta) ! extract full metadata structure - parDef(i)=param_meta%pardef ! set default param to value from structure - end do -endif -if(present(parSD))parSD=undefRN -if(present(parFitDef))parFitDef=.true. -! End procedure here -endsubroutine FUSE_getModelInfo -!----------------------------------------------------------------------------------------- -! ***** PRIME MODEL WITH INPUT FILES, ETC ****************************************************************** -!----------------------------------------------------------------------------------------- -subroutine FUSE_cebarModel(modelID,cebarCmd,dataXY,dataProps,err,message) -! Purpose: This routine is used to prime the model for execution. -implicit none -! dummies -integer(mik),intent(in)::modelID(:) -character(*),intent(in)::cebarCmd -real(mrk),intent(in)::dataXY(:,:) -real(mrk),intent(in)::dataProps(:) -integer(mik),intent(out)::err -character(*),intent(out)::message -! local variables -! Start procedure here -err=0; message="ok" -! check that the file exists -if(cebarCmd/=" ")then - message="w-FUSE_cebarModel/doesntUseFiles/&"//"[file'"//trim(cebarCmd)//"'notUsed]" - err=100; return -endif -! End procedure here -endsubroutine FUSE_cebarModel -!----------------------------------------------------------------------------------------- -! ***** GET MODEL CONTROL **************************************************************** -!----------------------------------------------------------------------------------------- -subroutine FUSE_controlModel(modelID,inittCmd,dataXY,dataProps,parIn,dquanIn,& - parOut,flexSin,setS0in,stateIn,stateOut,feas,err,message) -! Purpose: Sets/Gets model states and parameters. -! Usage: -! - if(setS0in) then will set all states to default values -! this is convenient when initialising the model without calibrating S0. -! - if(flexSin) then will adjust states to be compatible with parameter values, -! eg, if state S exceeds its maximum value Smax, will reset S to Smax. -! data modules -USE multistate,only:fstate,mstate,fracstate0,hstate ! defines the states for the FUSE models -use multiforce,only:deltim -use multiparam,only:lparam -use multiroute,only:mroute -USE metaoutput,only:VNAME,NOUTVAR ! defines output for the FUSE models -! informational modules -USE par_insert_module,only:par_insert,put_parset ! puts specific parameter into structure in multiparam -USE parextract_module,only:get_parset ! gets specific parameter from structure in multiparam -USE xtry_2_str_module,only:xtry_2_str ! puts state vector into structure in multistate -USE str_2_xtry_module,only:str_2_xtry ! gets state vector from structure in multistate -! DMSL -!use utilities_dmsl_kit,only:quickif -implicit none -! dummies -integer(mik),intent(in)::modelID(:) -character(*),intent(in),optional::inittCmd -real(mrk),intent(in),optional::dataXY(:,:),dataProps(:) -real(mrk),intent(in),optional::parIn(:),dquanIn(:),stateIn(:) -logical(mlk),intent(in),optional::flexSin,setS0in -real(mrk),intent(out),optional::parOut(:),stateOut(:) -logical(mlk),intent(out),optional::feas -integer(mik),intent(out)::err -character(*),intent(out)::message -! locals -logical(mlk)::haveSin,newRun !flexS,setS0,checkFeas -logical(mlk),parameter::flexSdef=.false.,setS0def=.false. -character(200)::parName1 -integer(mik)::i,istart -real(mrk)::dt -! Start procedure here -! (a) Set FUSE parameters -err=0; message="FUSE_controlModel/ok"; if(present(feas))feas=.true.; haveSin=present(stateIn) -if(present(dataProps))then; dt=dataProps(1) -else; dt=undefRN; endif -newRun=.false.;if(present(setS0in))newRun=setS0in -! newRun=quickif(setS0in,.false.) ! flag to avoid recomputing derived parameters: -!DK_NB: This is not a general fix, because prevents stochastic parameters other than rMult -! (b) Put/Get parameters into and out of the model structure -if (present(parIn)) then - if(newRun)then ! this happens at beginning of each new run - call put_parset(parIn) ! base parameters - call par_derive(err,message) ! corresponding derived parameters - if(err/=0)then - message="f-FUSE_controlModel/&"//trim(message); return - endif - else ! this does stochastic parameters. currently only rain-error can be stochastic - parName1=lparam(1)%parname - select case (trim(parName1)) - case('RFERR_ADD','RFERR_MLT') - call par_insert(parIn(1),parName1) - case default - err=100; message="f-FUSE_controlModel/unsupportedStochPar["//trim(parName1)//"]" - return - endselect - endif -endif -if (present(parOut)) call get_parset(parOut) -! (c) Put/Get states into and out of the model structure -if (present(stateIn)) then - call xtry_2_str(stateIn,fstate) ! populates fstate - mstate = fstate ! initialize the model state -endif -if (present(stateOut))then - istart = (noutvar-nOutputFUSE)+1 - do i=istart,noutvar ! noutvar is in module metaoutput - if (trim(vname(i))=='q_routed')stateOut((i-istart)+1) = mroute%q_routed - enddo - call str_2_xtry(fstate,stateOut(nOutputFUSE+1:)) -endif -! (d) Adjust states to be compatible w/ param values -if (present(flexSin)) then ! (needed for the case of stochastic parameters) - if (flexSin) call adjust_stt() -endif -! (e) re-initialize states to default values -if (present(setS0in)) then ! (convenient when initialising w/o calibrating S0) - if (setS0in)then - call init_state(fracState0) ! initialize states at fraction (frac) of capacity - !dstate=fstate ! save the initial state as the default state (not needed) MPC 2009/10/09 - mstate=fstate ! save the initial state as the model state 2009/10/09 - hstate%step = dt ! deltim is shared in module multiforce. -!DK: NB: dt should NOT change between controlModel and runModel, must equal deltime. -! hstate%step is reduced/increased by error control. dont reset it between time steps. - endif -endif -! (f) check parameter set obeys constraints -! no constrains currently -! End procedure here -endsubroutine FUSE_controlModel -!----------------------------------------------------------------------------------------- -! ***** RUN MODEL ************************************************************************ -!----------------------------------------------------------------------------------------- -subroutine FUSE_runModel(modelID,runitCmd,iT,dataProps,input,state,feas,err,message) -! Purpose: Performs single step of FUSE model. -USE model_defn,only:nstate -USE metaoutput,only:vname,noutvar ! defines output for the FUSE models -USE multiforce,only:mforce,deltim ! forcing structure -USE multiroute,only:mroute ! routing structure -USE multistate,only:hstate,fstate -USE interfaceb,only:ode_int,fuse_solve -USE str_2_xtry_module,only:STR_2_XTRY ! gets state vector from structure in multistate -implicit none -! dummies -integer(mik),intent(in)::modelID(:) -character(*),intent(in)::runitCmd -integer(mik),intent(in)::iT -real(mrk),intent(in)::dataProps(:) -real(mrk),intent(in)::input(:) -real(mrk),intent(out)::state(:) -logical(mlk),intent(out)::feas -integer(mik),intent(out)::err -character(*),intent(out)::message -! local -integer(mik)::i -real(mrk)::dt_sub,dt_full -real(mrk),dimension(nstate)::state0,state1 -! Start procedure here -err=0; message="ok"; feas=.true.; state=undefRN -!DK_NB: hstate%step is reduced/increased by error control. dont reset it between time steps. -! get model inputs and put them in the structure -do i=1,nInputFUSE ! (assume the first in the variable name list) - if (trim(vname(i))=='ppt') mforce%ppt = input(i) - if (trim(vname(i))=='pet') mforce%pet = input(i) -end do ! (loop thru inputs) -DT_FULL = DELTIM -DT_SUB = HSTATE%STEP -CALL STR_2_XTRY(FSTATE,STATE0) ! get the vector of states from the FSTATE structure -CALL INITFLUXES() ! set weighted sum of fluxes to zero -! temporally integrate the ordinary differential equations -CALL ODE_INT(FUSE_SOLVE,STATE0,STATE1,DT_SUB,DT_FULL,ERR,MESSAGE) -IF (ERR/=0) THEN - message="f-FUSE_runModel/&"//TRIM(MESSAGE); return -ENDIF -HSTATE%STEP = DT_SUB -! perform overland flow routing -CALL Q_OVERLAND() -! get model outputs (assume the last in the variable name list) -call FUSE_controlModel(modelID,stateOut=state,err=err,message=message) -! compute summary statistics -CALL COMP_STATS() -! End procedure here -endsubroutine FUSE_runModel -!----------------------------------------------------------------------------------------- -! ***** RUNALL MODEL ************************************************************************ -!----------------------------------------------------------------------------------------- -subroutine FUSE_runAllModel(modelID,runallCmd,dataProps,input,state,feas,err,message) -! Purpose: Performs all steps of FUSE model. -implicit none -! dummies -integer(mik),intent(in)::modelID(:) -character(*),intent(in)::runallCmd -real(mrk),intent(in)::dataProps(:) -real(mrk),intent(in)::input(:,:) -real(mrk),intent(out)::state(:,:) -logical(mlk),intent(out)::feas -integer(mik),intent(out)::err -character(*),intent(out)::message -! local -integer(mik)::nT,iT -! Start procedure here -nT=size(input,1) -do iT=1,nT - call FUSE_runModel(modelID,runallCmd,iT,dataProps,& - input(iT,:),state(iT,:),feas,err,message) - if(err/=0)then - write(message,'(a,i0,a)')"f-FUSE_runAllModel/[iT=",iT,"]/&"//trim(message) - err=20; return - endif -enddo -! End procedure here -endsubroutine FUSE_runAllModel -!---------------------------------------------------- -endmodule fuse_stdDmdl_dmsl_mod -!****************************************************************** diff --git a/build/FUSE_SRC/FUSE_HOOK/.svn/text-base/kinds_dmsl_kit_FUSE.f90.svn-base b/build/FUSE_SRC/FUSE_HOOK/.svn/text-base/kinds_dmsl_kit_FUSE.f90.svn-base deleted file mode 100644 index 7c495da..0000000 --- a/build/FUSE_SRC/FUSE_HOOK/.svn/text-base/kinds_dmsl_kit_FUSE.f90.svn-base +++ /dev/null @@ -1,120 +0,0 @@ -!****************************************************************** -! (C) Copyright 2000-2010 --- Dmitri Kavetski --- All rights reserved -! NB: CUSTOMIZED VERSION FOR FUSE SUITE OF MARTYN CLARK -!****************************************************************** -module kinds_dmsl_kit_FUSE -! Purpose: a. Defines global numeric kinds for DMSL; -! b. Contains machine precision information; -! c. Contains global information for DMSL library support. -! This module is typically made globally available. -! --- -! Programmer: Dmitri Kavetski. -! 2000 - 2004 -! Civil, Environmental Engineering and Surveying -! University of Newcastle, Callaghan, NSW 2308, Australia. -! 2004 - 2007 -! Department of Civil and Environmental Engineering -! Princeton University, Princeton, NJ 08544, USA. -! 2007 - current -! Civil, Environmental Engineering and Surveying -! University of Newcastle, Callaghan, NSW 2308, Australia. -! --- -! Comments: -! 1. The log[] function (2b) may not compile on some compilers. -! 2. The complex constants may not compile on some compilers. -! 3. If the compiler prevents the direct definitions below, hardcode them -! with at least 40 significant digits of precision. -implicit none -public -! --- -! (1) Parameterised numeric data types -! (a) Available precision (CVF reals: 4=single, 8=double, 16=quad; CVF integers: 4=short, 8=long) -integer, parameter::srk=selected_real_kind(p=4) ! single precision -integer, parameter::drk=selected_real_kind(p=8) ! double precision -integer, parameter::qrk=selected_real_kind(p=16) ! quadruple precision -integer, parameter::sik=selected_int_kind(r=4) ! short integer -integer, parameter::lik=selected_int_kind(r=8) ! long integer (NB: NR-90 uses r=9) -! (b) Selected global precision in all DMSL units -integer, parameter::mrk=drk ! global real kind -integer, parameter::mik=lik ! global integer kind -real(mrk), parameter::protoRe=1._mrk ! prototype of real(mrk) number -integer(mik),parameter::protoInt=1_mik ! prototype of integer(mik) number -integer, parameter::mck=kind((1._mrk,1._mrk)) ! global complex kind -integer, parameter::mlk=kind(.true.) ! global logical kind -complex(mck),parameter::protoCmx=((1._mrk,1._mrk)) ! prototype of complex(mck) number -logical(mlk),parameter::protoLog=.true. ! prototype of logical(mlk) number -! (c) Compiler-specific info [best kept up to date, I guess ...] -integer(mik),parameter::mrkBy=mrk ! number of bytes to store protoRe -integer(mik),parameter::mikBy=mik ! number of bytes to store protoInt -integer(mik),parameter::mckBy=2*mrk ! number of bytes to store protoCmx -integer(mik),parameter::mlkBy=4 ! number of bytes to store protoLog -! NB: -! On CVF compiler: mrk and mik also denote the number of bytes used to store the value, -! mlk requires 4 bytes storage -! single precision = 32-bit (4 bytes) -! double precision = 64-bit (8 bytes) -! quadruple precisison = 128-bits (16 bytes) -! --- -! (2) Machine precision information -! (a) Intrinsix -real(mrk), parameter::tinyRe=tiny(protoRe) ! smallest real on machine -real(mrk), parameter::epsRe= epsilon(protoRe) ! normalised machine accuracy -real(mrk), parameter::hugeRe=huge(protoRe) ! largest real on machine -integer(mik),parameter::hugeInt= huge(protoInt) ! largest integer on machine -real(mrk), parameter::hugeIntR=real(hugeInt,mrk) ! largest integer (real format) -! real(mrk), parameter::hugeIntR=2.14748364700000E+009_mrk ! Salford Software FTN95 -! complex(mck),parameter::tinyC=(tinyRe,tinyRe) ! smallest complex on machine -! complex(mck),parameter::epsC= (epsRe,epsRe) ! complex machine precision -! complex(mck),parameter::hugeC=(hugeRe,hugeRe) ! largest complex on machine -! (b) Functions of machine precision -integer(mik),parameter::minExpRei=minexponent(protoRe) ! min exponent (int) in machine base (usually radix=2) -real(mrk), parameter::minExpRer=real(minExpRei,mrk) ! min exponent (real) in machine base (usually radix=2) -! real(mrk), parameter::minExpRer=-1.02100000000000E+003_mrk ! Salford Software FTN95 -integer(mik),parameter::maxExpRei=maxexponent(protoRe) ! max exponent (int) in machine base (usually radix=2) -real(mrk), parameter::maxExpRer=real(maxExpRei,mrk) ! max exponent (real) in machine base (usually radix=2) -! real(mrk), parameter::maxExpRer=+1.02400000000000E+003_mrk ! Salford Software FTN95 -real(mrk), parameter::radixRer=real(radix(protoRe),mrk) ! radix expressed as real -! real(mrk), parameter::radixRer=2.00000000000000E+000_mrk ! Salford Software FTN95 -! real(mrk), parameter::nDecDigitsRe=-log10(epsRe) ! number of decimal digits -!real(mrk), parameter::nDecDigitsRe=-log(epsRe)/log(10._mrk) ! number of decimal digits -! real(mrk), parameter::nDecDigitsRe=1.56535597745270E+001_mrk ! Salford Software FTN95 -!real(mrk), parameter::lnEpsRe=log(epsRe) ! ln[] of machine precision -real(mrk), parameter::lnEpsRe=3.60436533891172E+001_mrk ! Salford Software FTN95 -!real(mrk), parameter::lunflw=minExpRer*log(radixRer) ! =log(tinyRe) ! ln[] of smallest real -! real(mrk), parameter::lunflw=-7.07703271351704E+002_mrk ! Salford Software FTN95 -!real(mrk), parameter::lovflw=(1._mrk-epsRe)*maxExpRer*log(radixRer) ! =log(hugeRe) ! ln[] of largest real, safe to exponentiate -! real(mrk), parameter::lovflw=+7.09782712893384E+002_mrk ! Salford Software FTN95 -! --- -! (3) Parameterised machine settings -integer(mik),parameter::keyboardUnit=5 ! keyboard unit (default input) -integer(mik),parameter::screenUnit=6 ! screen unit (default output) -! --- -! (4) Library support features -integer(mik),parameter::DMSL_vernum=417 -character(*),parameter::DMSL_authorName="Dmitri Kavetski" -character(*),parameter::DMSL_authorEmail="dmitri.kavetski@newcastle.edu.au" -! --- -! (5) Special DMSL values, conventionally used to flag un-initialised variables -real(mrk), parameter::undefRN=-999999999._mrk ! flag for undefined real numbers -real(mrk), parameter::undefRNH=-0.5_mrk*hugeRe ! huge flag for undefined real numbers -integer(mik),parameter::undefIN=-999999999 ! flag for undefined integer numbers -integer(mik),parameter::undefINH=-hugeInt/2 ! huge flag for undefined integer numbers -logical(mlk),parameter::undefLG=.false. ! flag for undefined logicals -! complex(mck),parameter::undefCZ=(undefRN,undefRN) ! flag for undefined complex numbers -complex(mck),parameter::undefCZ=(-999999999._mrk,-999999999._mrk) ! flag for undefined complex numbers -! complex(mck),parameter::undefCZH=(undefRNH,undefRNH) ! huge flag for undefined complex numbers -! complex(mck),parameter::undefCZH=cmplx(undefRNH,undefRNH,kind=mck) ! huge flag for undefined complex numbers -character(*),parameter::undefCH="undefined" ! flag for undefined character strings -! --- -! (6) DMSL-wide registered settings -integer(mik),parameter::iyes=1,ino=0 ! integer flags for true/false -! --- -endmodule kinds_dmsl_kit_FUSE -!****************************************************************** -! module makeKinds_dmsl_kit -! implicit none -! contains -! !---------------------------------------------------- -! !---------------------------------------------------- -! endmodule makeKinds_dmsl_kit -!****************************************************************** diff --git a/build/FUSE_SRC/FUSE_HOOK/.svn/text-base/make_batea_parfiles.f90.svn-base b/build/FUSE_SRC/FUSE_HOOK/.svn/text-base/make_batea_parfiles.f90.svn-base deleted file mode 100644 index eb030a9..0000000 --- a/build/FUSE_SRC/FUSE_HOOK/.svn/text-base/make_batea_parfiles.f90.svn-base +++ /dev/null @@ -1,23 +0,0 @@ -program make_batea_parfiles -! Martyn Clark, 2009 -! used to make parameter files for BATEA -use nrtype ! variable types -use selectmodl_module ! access to SUBROUTINE selectmodl -implicit none -integer(i4b) :: nmod ! number of possible models -integer(i4b) :: ierr ! error code -integer(i1b) :: ipar ! looping -character(len=256) :: message ! error message -! ---------------------------------------------------------------------------------------- -! get parameter metadata for all possible models -call getparmeta() -! identify the model used -call uniquemodl(nmod) ! get nmod unique models -call selectmodl(ierr,message) ! identify single model (read control file m_decisions.txt) -if (ierr.ne.0) then; print *, trim(message); stop; endif -! identify the parameters used in the model selected -call assign_par() ! parameters used are stored in module multiparam -! write parameter file for batea -call batea_file() -stop -end program make_batea_parfiles diff --git a/build/FUSE_SRC/FUSE_MAIN/.svn/all-wcprops b/build/FUSE_SRC/FUSE_MAIN/.svn/all-wcprops deleted file mode 100644 index dc52589..0000000 --- a/build/FUSE_SRC/FUSE_MAIN/.svn/all-wcprops +++ /dev/null @@ -1,41 +0,0 @@ -K 25 -svn:wc:ra_dav:version-url -V 60 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_MAIN -END -fmodel_run_ascii.f90 -K 25 -svn:wc:ra_dav:version-url -V 81 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_MAIN/fmodel_run_ascii.f90 -END -driver_ascii.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_MAIN/driver_ascii.f90 -END -batea_test.f90 -K 25 -svn:wc:ra_dav:version-url -V 75 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_MAIN/batea_test.f90 -END -fmodel_run_netcdf.f90 -K 25 -svn:wc:ra_dav:version-url -V 82 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_MAIN/fmodel_run_netcdf.f90 -END -driver_netcdf.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_MAIN/driver_netcdf.f90 -END -sobol.f90 -K 25 -svn:wc:ra_dav:version-url -V 70 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_MAIN/sobol.f90 -END diff --git a/build/FUSE_SRC/FUSE_MAIN/.svn/entries b/build/FUSE_SRC/FUSE_MAIN/.svn/entries deleted file mode 100644 index bed7ba0..0000000 --- a/build/FUSE_SRC/FUSE_MAIN/.svn/entries +++ /dev/null @@ -1,232 +0,0 @@ -10 - -dir -63 -https://venture1.projectlocker.com/UoNEnvEngGroup/FUSE/svn/trunk/FUSE_SRC/FUSE_MAIN -https://venture1.projectlocker.com/UoNEnvEngGroup/FUSE/svn - - - -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - -7fd0be38-6417-4f01-9cbe-fd474d0c6e94 - -fmodel_run_ascii.f90 -file - - - - -2013-06-12T18:10:48.771575Z -bb285f70954809e366c5e60a44dcf03c -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -2770 - -driver_ascii.f90 -file - - - - -2013-06-12T18:10:48.771575Z -09a4704764d99f74c5bdcac00b9c21b4 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -6854 - -batea_test.f90 -file - - - - -2013-06-12T18:10:48.771575Z -64c295e0cd22b858fc09dfcf9fe0f6ab -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -9421 - -fmodel_run_netcdf.f90 -file - - - - -2013-06-12T18:10:48.771575Z -4a488815415f3606309031d100b0b1b5 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -2870 - -driver_netcdf.f90 -file - - - - -2013-06-12T18:10:48.775575Z -33a2a889dc5f76d8cafd67dea697fed7 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -6928 - -sobol.f90 -file - - - - -2013-06-12T18:10:48.775575Z -0be2419af7c817a5ec0c7e618616af44 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -159630 - diff --git a/build/FUSE_SRC/FUSE_MAIN/.svn/text-base/batea_test.f90.svn-base b/build/FUSE_SRC/FUSE_MAIN/.svn/text-base/batea_test.f90.svn-base deleted file mode 100644 index 06a5152..0000000 --- a/build/FUSE_SRC/FUSE_MAIN/.svn/text-base/batea_test.f90.svn-base +++ /dev/null @@ -1,183 +0,0 @@ -program batea_test -! BATEA modules -use ddirectory ! define directory that holds data -use kinds_dmsl_kit_FUSE ! define data types -use fuse_stdDmdl_dmsl_mod ! linking routines for FUSE -! FUSE data modules -use multiforce ! defines model forcing data -use multistate ! defines the states for the FUSE models -USE multiparam, only:paratt,lparam ! parameter attribute structure -! FUSE informational modules -use str_2_xtry_module ! gets state vector from structure in multistate -USE getpar_str_module ! gets parameter metadata structure -USE par_insert_module ! puts specific parameter into structure in multiparam -use parextract_module ! gets specific parameter from structure in multiparam -implicit none -! general variables -integer(mik) :: modelID -integer(mik) :: err -character(len=256) :: message -! model info -character(len=256) :: modelName -integer(mik) :: ninputs,noutputs,nstate,npar,ninfo -character(len=256),dimension(:),allocatable :: inputName,outputName,stateName,parName,infoStateName -real(mrk),dimension(:),allocatable :: parLo,parHi,stateLo,stateHi,& ! ranges - parScal,stateScal,inScal,outScal,& ! scaling factors - parDef,stateDef ! defaults -integer(mik),dimension(:),allocatable :: parTranDef ! param transform code -type(paratt) :: param_meta ! parameter metadata -! model control -integer(mik) :: iparset ! case for type of parameter set -integer(mik), parameter :: irandom=0 ! random parameter set -integer(mik), parameter :: idefault=1 ! default parameter set -real(mrk),dimension(:),allocatable :: parIn,parOut,stateIn,stateOut -logical(mlk) :: feas,setS0in,flexSin -real(mrk) :: frac ! used to provide an example state vector -! model run -character(len=8) :: cbasid ! basin ID -integer(mik) :: itim,ntim ! loop through time -real(mrk),dimension(:),allocatable :: input,output,infoState -! local variables -integer(mik) :: i !,j,k ! looping variables -integer(mik) :: ierr(10) !,icheck ! status codes for allocate statement -! real(mrk) :: frac -real(mrk) :: tA,tB -! --------------------------------------------------------------------------------------- -! (0) DEFINE PATH NAMES AND READ FORCING DATA -! --------------------------------------------------------------------------------------- -! Read data from the "BATEA-compliant" ASCII files -call getforcing(ntim) -! --------------------------------------------------------------------------------------- -! (1) SETUP AND MODEL INFO -! --------------------------------------------------------------------------------------- -modelID=-9999 -! (a) get configuration and dimensions -call FUSE_getModelInfo(modelID,& - modelName,ninputs,noutputs,nstate,npar,ninfo,& - err=err,message=message) -! --------------------------------------------------------------------------------------- -! (b) allocate space -allocate(inputName(ninputs),outputName(noutputs),stateName(nstate),parName(npar),& - infoStateName(ninfo), stat=ierr(1)) -allocate(parLo(npar),parHi(npar), stat=ierr(2)) -allocate(stateLo(nstate),stateHi(nstate), stat=ierr(3)) -allocate(parScal(npar),stateScal(npar),inScal(npar),outScal(npar), stat=ierr(4)) -allocate(parDef(npar),stateDef(nstate),parTranDef(npar), stat=ierr(5)) -if (any(ierr(1:4).ne.0)) stop ' problem allocating space for model info ' -write(*,*) len(modelName),len_trim(modelName),modelName(1:len_trim(modelName)) -write(*,*) ninputs,noutputs,nstate,npar,ninfo -! (c) get model info -call FUSE_getModelInfo(modelID,& - modelName,ninputs,noutputs,nstate,npar,ninfo,& - inputName,outputName,stateName,parName,infoStateName,& - parLo,parHi,stateLo,stateHi,& - parScal,stateScal,inScal,outScal,& - parDef,stateDef,parTranDef,& - err=err,message=message) -write(*,*) 'after FUSE_getModelInfo' -!---------------------------------------------------------------------------------------- -! (2) PRIME THE MODEL (TOPO DATA, ETC) -call FUSE_CebarModel(modelID,deltim,err=err,message=message) -if (err.ne.0) then - write(*,*) trim(message) - stop -endif -write(*,*) ' after FUSE_GetModelSetup ' -! --------------------------------------------------------------------------------------- -! (3) GET MODEL CONTROL -! --------------------------------------------------------------------------------------- -! (a) allocate space -allocate(parIn(npar),parOut(npar),stateIn(nstate),stateOut(nstate), stat=ierr(1)) -if (ierr(1).ne.0) stop ' problem allocating space for model control ' -! (b) get an example model parameter set -! switch between random parameter set -!iparset = 1 ! irandom = 0; idefault = 1 -!select case(iparset) -! random parameter set -!case(irandom) - !call get_params(1) ! fill structure APARAM with just one parameter set - !mparam=aparam(1) ! set current parameter set to the parameter set just extracted - !do i=1,npar; parIn(i) = parextract(parName(i)); end do ! (extract parameters from mparam) -! default parameter set -!case(idefault) - ! (use the default parameter values to set default states) - do i=1,npar - call getpar_str(lparam(i)%parname,param_meta) ! extract full metadata structure - call par_insert(param_meta%pardef,lparam(i)%parname) ! insert the default param to model param structure - parIn(i) = param_meta%pardef - end do -!case default -! write(*,*) 'case iparset must be either ', irandom, ' or ', idefault -! stop -!end select -! (c) get an example set of model states for that parameter set -call par_derive() ! identify the derived parameters associated with mparam -frac = 0.5_mrk ! define the fraction of capacity to initialize states -call init_state(frac) ! initialize states at fraction (frac) of capacity -tstate=fstate ! set current state to the first state -call str_2_xtry(stateIn) ! extract a vector of states at the value tstate -! (d) define input flags -flexSin = .true. ! (.true. = adjust states to be compatible w/ param values) -! setS0in = .false. ! (.true. = states are re-initialized to default values) -setS0in = .true. ! (.true. = states are re-initialized to default values) -! (e) call model control -call FUSE_controlModel(modelID,deltim,parIn,parOut,flexSin,setS0in,stateIn,stateOut,feas,& - err,message) -do i=1,ninputs - write(*,*) i, trim(inputName(i)) -end do -write(*,*) '----------' -do i=1,noutputs - write(*,*) i, trim(outputName(i)) -end do -write(*,*) '----------' -do i=1,nstate - write(*,'(i2,1x,a9,1x,3(f9.3,1x))') i, stateName(i), stateDef(i), stateLo(i), stateHi(i) -end do -write(*,*) '----------' -do i=1,npar - write(*,'(i2,1x,a9,1x,3(f9.3,1x))') i, parName(i), parIn(i), parLo(i), parHi(i) -end do -write(*,*) '----------' -do i=1,ninfo - write(*,*) i, len(infoStateName(i)), len_trim(infoStateName(i)), trim(infoStateName(i)) -end do -write(*,*) '----------' -pause -! --------------------------------------------------------------------------------------- -! (4) RUN MODEL -! --------------------------------------------------------------------------------------- -open(21,file=ModelName(1:8)//'.out',status='unknown') -! (a) allocate space for model inputs and outputs -allocate(input(ninputs),output(noutputs),infoState(ninfo), stat=ierr(1)) -if (ierr(1).ne.0) stop ' problem allocating space for model control ' -! (b) loop through time -! initialize sub-step length to the length of the time step -! hstate%step = deltim ! deltim is shared in module multiforce -call cpu_time(tA) -do itim=1,ntim - ! (c) assign model forcing data - do i=1,ninputs - if (trim(inputName(i)).eq.'ppt') input(i) = aforce(itim)%ppt - if (trim(inputName(i)).eq.'pet') input(i) = aforce(itim)%pet - end do - ! (d) run model - call FUSE_runModel(modelID,deltim,input,output,infoState,err,message) - ! (e) write output - WRITE( *,'(I10,1X,I4,1X,4(I2,1X),F9.3,1X,F15.1,1X,4(ES12.4,1X))') ITIM, AFORCE(ITIM),OUTPUT - WRITE(21,'(I10,1X,I4,1X,4(I2,1X),F9.3,1X,F15.1,1X,4(ES12.4,1X))') ITIM, AFORCE(ITIM),OUTPUT -end do ! (looping through time) -call cpu_time(tB) -write(*,*)"CPU time, sec",tB-tA -close(21) -! --------------------------------------------------------------------------------------- -! deallocate space -deallocate(inputName,outputName,stateName,parName,infoStateName, stat=ierr(1)) -deallocate(parLo,parHi,stateLo,stateHi, stat=ierr(2)) -deallocate(parScal,stateScal,inScal,outScal, stat=ierr(3)) -deallocate(parDef,stateDef, stat=ierr(4)) -deallocate(parIn,parOut,stateIn,stateOut, stat=ierr(5)) -deallocate(input,output,infoState, stat=ierr(6)) -if (any(ierr(1:6).ne.0)) stop ' problem deallocating space ' -stop -end program batea_test diff --git a/build/FUSE_SRC/FUSE_MAIN/.svn/text-base/driver_ascii.f90.svn-base b/build/FUSE_SRC/FUSE_MAIN/.svn/text-base/driver_ascii.f90.svn-base deleted file mode 100644 index 93d84e0..0000000 --- a/build/FUSE_SRC/FUSE_MAIN/.svn/text-base/driver_ascii.f90.svn-base +++ /dev/null @@ -1,124 +0,0 @@ -PROGRAM DRIVER_ASCII -! --------------------------------------------------------------------------------------- -! Creator: -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! Simple driver program for FUSE (output ASCII files) -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE ddirectory ! directory for data files -! data modules -USE model_defn,nstateFUSE=>nstate ! model definition structures -USE multiforce, ONLY: DELTIM ! data interval = maximum model time step -USE multiparam, ONLY: LPARAM, PARATT, NUMPAR ! parameter metadata structures -USE multiroute ! model routing structures -USE multistats ! model statistics structures -! informational modules -USE selectmodl_module ! reads model control file -USE getpar_str_module ! extracts parameter metadata -USE par_insert_module ! inserts model parameters -! model numerix -USE model_numerix -IMPLICIT NONE -! get command-line arguments -CHARACTER(LEN=11) :: PAR_IDX ! start index of parameter set -CHARACTER(LEN=11) :: PAR_JDX ! end index of parameter set -INTEGER(I4B) :: IPAR1 ! start index of parameter set -INTEGER(I4B) :: IPAR2 ! end index of parameter set -! get forcing data -INTEGER(I4B) :: NTIM ! number of time steps -INTEGER(I4B) :: INFERN_START ! start of inference period -! get model setup -INTEGER(I4B) :: I,J,K ! looping -INTEGER(I4B) :: NMOD ! number of models -INTEGER(I4B) :: ERR ! error code -CHARACTER(LEN=256) :: MESSAGE ! error message -! define output files -INTEGER(I4B) :: ONEMOD ! index for defining output file (one file per model) -LOGICAL(LGT) :: OUTPUT_FLAG ! .TRUE. if desire time series output -LOGICAL(LGT) :: SSTATS_FLAG ! .TRUE. if desire summary statistics -! generate a new parameter set -INTEGER(I4B) :: IPAR ! loop through model parameters -INTEGER(I4B) :: JPAR ! loop through model parameters -TYPE(PARATT) :: PARAM_META ! parameter metadata (model parameters) -REAL(SP), DIMENSION(:), ALLOCATABLE :: BL ! vector of lower parameter bounds -REAL(SP), DIMENSION(:), ALLOCATABLE :: BU ! vector of upper parameter bounds -REAL(SP), DIMENSION(:), ALLOCATABLE :: APAR ! model parameter set -INTEGER(KIND=4) :: ISEED ! seed for the random sequence -REAL(KIND=4),DIMENSION(:), ALLOCATABLE :: URAND ! vector of quasi-random numbers U[0,1] -! --------------------------------------------------------------------------------------- -! (0) RETRIEVE COMMAND-LINE ARGUMENTS -! --------------------------------------------------------------------------------------- -! get start index for parameter set -CALL GETARG(1,PAR_IDX) -IF (LEN_TRIM(PAR_IDX).EQ.0) STOP ' need start index for parameter set as 1st command-line argument ' -READ(PAR_IDX,*) IPAR1 ! convert index to an integer -! get end index for parameter set -CALL GETARG(2,PAR_JDX) -IF (LEN_TRIM(PAR_JDX).EQ.0) STOP ' need end index for parameter set as 2nd command-line argument ' -READ(PAR_JDX,*) IPAR2 ! convert index to an integer -! --------------------------------------------------------------------------------------- -! (1) GET MODEL FORCING DATA AND STORE IN MEMORY -! --------------------------------------------------------------------------------------- -! Read data from the "BATEA-compliant" ASCII files -CALL GETFORCING(INFERN_START,NTIM) -! --------------------------------------------------------------------------------------- -! (2) GET MODEL SETUP -- MODEL DEFINITION, AND PARAMETER AND VARIABLE INFO FOR ALL MODELS -! --------------------------------------------------------------------------------------- -! Define model attributes (valid for all models) -CALL UNIQUEMODL(NMOD) ! get nmod unique models -CALL GETNUMERIX() ! defines method/parameters used for numerical solution -CALL GETPARMETA() ! read parameter metadata (parameter bounds etc.) -! Identify a single model (read control file ../DataFiles/m_decisions.txt) -CALL SELECTMODL(ERR,MESSAGE) -IF (ERR.NE.0) THEN - PRINT *, TRIM(MESSAGE); STOP -ENDIF -! Define list of states and parameters for the current model -CALL ASSIGN_STT() ! state definitions are stored in module model_defn -CALL ASSIGN_PAR() ! parameter defintions are stored in module multiparam -! compute derived model parameters (bucket sizes, etc.) -CALL PAR_DERIVE() -! -------------------------------------------------------------------------------------- -! (3) DEFINE NETCDF OUTPUT FILES -! -------------------------------------------------------------------------------------- -! Define output file names (shared in MODULE model_defn) -FNAME_NETCDF = TRIM(OUTPUT_PATH)//TRIM(SMODL%MNAME)//'_'//TRIM(PAR_IDX)//'.nc' -FNAME_ASCII = TRIM(OUTPUT_PATH)//TRIM(SMODL%MNAME)//'_'//TRIM(PAR_IDX)//'.dat' -! Define indices and flags for model output -ONEMOD=1 ! one file per model (i.e., model dimension = 1) -PCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) -OUTPUT_FLAG = .FALSE. ! .TRUE. if desire NetCDF time series output -SSTATS_FLAG = .FALSE. ! .TRUE. if desire NETCDF summary statistics -! open output file -OPEN(UNIT=OUTFILE_UNIT,NAME=TRIM(FNAME_ASCII),STATUS='unknown') -! -------------------------------------------------------------------------------------- -! (4) RUN MODEL -! -------------------------------------------------------------------------------------- -! allocate space for parameter vectors -ALLOCATE(APAR(NUMPAR),BL(NUMPAR),BU(NUMPAR),URAND(NUMPAR)) -! get parameter bounds -DO IPAR=1,NUMPAR - CALL GETPAR_STR(LPARAM(IPAR)%PARNAME,PARAM_META) - BL(IPAR) = PARAM_META%PARLOW - BU(IPAR) = PARAM_META%PARUPP -END DO -! loop through parameter sets -DO IPAR=IPAR1,IPAR2 - ISEED=IPAR - ! get new parameter sets - CALL I4_SOBOL(NUMPAR,ISEED,URAND) - WRITE(*,'(I4,1X,12(E10.2,1X))') ISEED-1, URAND - APAR = BL + URAND*(BU-BL) - CALL PUT_PARSET(APAR) - ! write parameter set to the file - WRITE(OUTFILE_UNIT,'(20(A9,1X))') (TRIM(LPARAM(JPAR)%PARNAME),JPAR=1,NUMPAR) - WRITE(OUTFILE_UNIT,'(20(F9.3,1X))') (APAR(JPAR),JPAR=1,NUMPAR) - ! run zee model - CALL FMODEL_RUN_ASCII() -END DO -! close the output file -CLOSE(OUTFILE_UNIT) -STOP -END PROGRAM DRIVER_ASCII diff --git a/build/FUSE_SRC/FUSE_MAIN/.svn/text-base/driver_netcdf.f90.svn-base b/build/FUSE_SRC/FUSE_MAIN/.svn/text-base/driver_netcdf.f90.svn-base deleted file mode 100644 index f07d5f7..0000000 --- a/build/FUSE_SRC/FUSE_MAIN/.svn/text-base/driver_netcdf.f90.svn-base +++ /dev/null @@ -1,124 +0,0 @@ -PROGRAM DRIVER_NETCDF -! --------------------------------------------------------------------------------------- -! Creator: -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! Simple driver program for FUSE (output NetCDF files) -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE ddirectory ! directory for data files -! data modules -USE model_defn,nstateFUSE=>nstate ! model definition structures -USE multiforce, ONLY: DELTIM ! data interval = maximum model time step -USE multiparam, ONLY: LPARAM, PARATT, NUMPAR ! parameter metadata structures -USE multiroute ! model routing structures -USE multistats ! model statistics structures -! informational modules -USE selectmodl_module ! reads model control file -USE getpar_str_module ! extracts parameter metadata -USE par_insert_module ! inserts model parameters -! model numerix -USE model_numerix -IMPLICIT NONE -! get command-line arguments -CHARACTER(LEN=11) :: PAR_IDX ! start index of parameter set -CHARACTER(LEN=11) :: PAR_JDX ! end index of parameter set -INTEGER(I4B) :: IPAR1 ! start index of parameter set -INTEGER(I4B) :: IPAR2 ! end index of parameter set -! get forcing data -INTEGER(I4B) :: NTIM ! number of time steps -INTEGER(I4B) :: INFERN_START ! start of inference period -! get model setup -INTEGER(I4B) :: I,J,K ! looping -INTEGER(I4B) :: NMOD ! number of models -INTEGER(I4B) :: ERR ! error code -CHARACTER(LEN=256) :: MESSAGE ! error message -! define output files -CHARACTER(LEN=256) :: FNAME_ASCII ! ascii output file name -INTEGER(I4B) :: ONEMOD ! index for defining output file (one file per model) -LOGICAL(LGT) :: OUTPUT_FLAG ! .TRUE. if desire time series output -LOGICAL(LGT) :: SSTATS_FLAG ! .TRUE. if desire summary statistics -! generate a new parameter set -INTEGER(I4B) :: IPAR ! loop through model parameters -TYPE(PARATT) :: PARAM_META ! parameter metadata (model parameters) -REAL(SP), DIMENSION(:), ALLOCATABLE :: BL ! vector of lower parameter bounds -REAL(SP), DIMENSION(:), ALLOCATABLE :: BU ! vector of upper parameter bounds -REAL(SP), DIMENSION(:), ALLOCATABLE :: APAR ! model parameter set -INTEGER(KIND=4) :: ISEED ! seed for the random sequence -REAL(KIND=4),DIMENSION(:), ALLOCATABLE :: URAND ! vector of quasi-random numbers U[0,1] -! --------------------------------------------------------------------------------------- -! (0) RETRIEVE COMMAND-LINE ARGUMENTS -! --------------------------------------------------------------------------------------- -! get start index for parameter set -CALL GETARG(1,PAR_IDX) -IF (LEN_TRIM(PAR_IDX).EQ.0) STOP ' need start index for parameter set as 1st command-line argument ' -READ(PAR_IDX,*) IPAR1 ! convert index to an integer -! get end index for parameter set -CALL GETARG(2,PAR_JDX) -IF (LEN_TRIM(PAR_JDX).EQ.0) STOP ' need end index for parameter set as 2nd command-line argument ' -READ(PAR_JDX,*) IPAR2 ! convert index to an integer -! --------------------------------------------------------------------------------------- -! (1) GET MODEL FORCING DATA AND STORE IN MEMORY -! --------------------------------------------------------------------------------------- -! Read data from the "BATEA-compliant" ASCII files -CALL GETFORCING(INFERN_START,NTIM) -! --------------------------------------------------------------------------------------- -! (2) GET MODEL SETUP -- MODEL DEFINITION, AND PARAMETER AND VARIABLE INFO FOR ALL MODELS -! --------------------------------------------------------------------------------------- -! Define model attributes (valid for all models) -CALL UNIQUEMODL(NMOD) ! get nmod unique models -CALL GETNUMERIX() ! defines method/parameters used for numerical solution -CALL GETPARMETA() ! read parameter metadata (parameter bounds etc.) -! Identify a single model (read control file ../DataFiles/m_decisions.txt) -CALL SELECTMODL(ERR,MESSAGE) -IF (ERR.NE.0) THEN - PRINT *, TRIM(MESSAGE); STOP -ENDIF -! Define list of states and parameters for the current model -CALL ASSIGN_STT() ! state definitions are stored in module model_defn -CALL ASSIGN_PAR() ! parameter defintions are stored in module multiparam -! compute derived model parameters (bucket sizes, etc.) -CALL PAR_DERIVE() -! -------------------------------------------------------------------------------------- -! (3) DEFINE NETCDF OUTPUT FILES -! -------------------------------------------------------------------------------------- -! Define output file names (shared in MODULE model_defn) -FNAME_NETCDF = TRIM(OUTPUT_PATH)//TRIM(SMODL%MNAME)//'_'//TRIM(PAR_IDX)//'.nc' -! Define NetCDF output files (only write parameters and summary statistics) -ONEMOD=1 ! one file per model (i.e., model dimension = 1) -PCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) -CALL DEF_PARAMS(ONEMOD) ! define model parameters (initial CREATE) -OUTPUT_FLAG = .TRUE. ! .TRUE. if desire time series output -SSTATS_FLAG = .TRUE. ! .TRUE. if desire summary statistics -IF (OUTPUT_FLAG) CALL DEF_OUTPUT(NTIM) ! define model output (REDEF) -IF (SSTATS_FLAG) CALL DEF_SSTATS() ! define summary statistics (REDEF) -! -------------------------------------------------------------------------------------- -! (4) RUN MODEL -! -------------------------------------------------------------------------------------- -! allocate space for parameter vectors -ALLOCATE(APAR(NUMPAR),BL(NUMPAR),BU(NUMPAR),URAND(NUMPAR)) -! get parameter bounds -DO IPAR=1,NUMPAR - CALL GETPAR_STR(LPARAM(IPAR)%PARNAME,PARAM_META) - BL(IPAR) = PARAM_META%PARLOW - BU(IPAR) = PARAM_META%PARUPP -END DO -! loop through parameter sets -DO IPAR=IPAR1,IPAR2 - ISEED=IPAR - ! get new parameter sets - CALL I4_SOBOL(NUMPAR,ISEED,URAND) - WRITE(*,'(I4,1X,12(E10.2,1X))') ISEED-1, URAND - APAR = BL + URAND*(BU-BL) - CALL PUT_PARSET(APAR) - ! run zee model - CALL FMODEL_RUN(OUTPUT_FLAG,SSTATS_FLAG) - ! compute and write summary statistics - IF (SSTATS_FLAG) THEN - CALL MEAN_STATS() ! compute summary statistics - CALL PUT_SSTATS(PCOUNT,1) ! 1 = just one model for numerix test - ENDIF -END DO -STOP -END PROGRAM DRIVER_NETCDF diff --git a/build/FUSE_SRC/FUSE_MAIN/.svn/text-base/fmodel_run_ascii.f90.svn-base b/build/FUSE_SRC/FUSE_MAIN/.svn/text-base/fmodel_run_ascii.f90.svn-base deleted file mode 100644 index 5f79256..0000000 --- a/build/FUSE_SRC/FUSE_MAIN/.svn/text-base/fmodel_run_ascii.f90.svn-base +++ /dev/null @@ -1,53 +0,0 @@ -SUBROUTINE FMODEL_RUN_ASCII() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Run a single model with one parameter set (ASCII output) -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -! data modules -USE model_defn, ONLY: OUTFILE_UNIT ! file unit for ASCII output -USE multiforce ! model forcing data -USE multiparam ! model parameters -USE multi_flux ! model fluxes -USE multistate ! model states -USE multiroute ! routed runoff -USE multistats ! summary statistics -! informational modules -USE par_insert_module ! insert parameters into data structures -IMPLICIT NONE -! internal -INTEGER(I4B) :: ITIM ! loop through time series -! --------------------------------------------------------------------------------------- -! increment parameter counter -PCOUNT = PCOUNT + 1 -! initialize model states and model time step -CALL INIT_STATE(fracState0) ! fracState0 is shared in MODULE multistate -HSTATE%STEP = DELTIM ! deltim is shared in module multiforce. -! write header for time series output -WRITE(OUTFILE_UNIT,'(A4,1X,3(A2,1X),8(A12,1X))') & - 'YEAR','MM','DD','HH','PPT','EFF_PPT','PET','WATR_1','WATR_2','Q_INSTNT','Q_ROUTED','OBSQ' -! loop through time -DO ITIM=1,NUMTIM ! (NUMTIM is shared in MODULE multiforce) - ! run model for one time step - MFORCE = AFORCE(ITIM) ! assign model forcing data - CALL INITFLUXES() ! set weighted sum of fluxes to zero - CALL SUBSTEPPER() ! run model for one time step using implicit solution with variable sub-steps - CALL Q_OVERLAND() ! overland flow routing - ! save instantaneous and routed runoff - AROUTE(ITIM)%Q_INSTNT = MROUTE%Q_INSTNT ! save instantaneous runoff - AROUTE(ITIM)%Q_ROUTED = MROUTE%Q_ROUTED ! save routed runoff - ! write model output to ASCII output file - WRITE(OUTFILE_UNIT,'(I4,1X,3(I2,1X),8(ES12.5,1X))') & - MFORCE%IY,MFORCE%IM,MFORCE%ID,MFORCE%IH, & - MFORCE%PPT,W_FLUX%EFF_PPT,MFORCE%PET, & - FSTATE%WATR_1,FSTATE%WATR_2, & - MROUTE%Q_INSTNT,MROUTE%Q_ROUTED, & - MFORCE%OBSQ -END DO ! (itim) -! --------------------------------------------------------------------------------------- -END SUBROUTINE FMODEL_RUN_ASCII diff --git a/build/FUSE_SRC/FUSE_MAIN/.svn/text-base/fmodel_run_netcdf.f90.svn-base b/build/FUSE_SRC/FUSE_MAIN/.svn/text-base/fmodel_run_netcdf.f90.svn-base deleted file mode 100644 index 667f153..0000000 --- a/build/FUSE_SRC/FUSE_MAIN/.svn/text-base/fmodel_run_netcdf.f90.svn-base +++ /dev/null @@ -1,56 +0,0 @@ -SUBROUTINE FMODEL_RUN_NETCDF(OUTPUT_FLAG,SSTATS_FLAG) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Run a single model with one parameter set (NetCDF output) -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -! data modules -USE multiforce ! model forcing data -USE multiparam ! model parameters -USE multistate ! model states -USE multiroute ! routed runoff -USE multistats ! summary statistics -! informational modules -USE par_insert_module ! insert parameters into data structures -IMPLICIT NONE -! input -LOGICAL(LGT), INTENT(IN) :: OUTPUT_FLAG ! .TRUE. if desire time series output -LOGICAL(LGT), INTENT(IN) :: SSTATS_FLAG ! .TRUE. if desire time series output -! internal -INTEGER(I4B) :: ITIM ! loop through time series -! --------------------------------------------------------------------------------------- -! increment parameter counter -PCOUNT = PCOUNT + 1 -! write parameters to the NetCDF file -CALL PUT_PARAMS(PCOUNT,1) ! PCOUNT = index for parameter set, 1 = just one model for numerix test -! initialize summary statistics -IF (SSTATS_FLAG) CALL INIT_STATS() -! initialize model states and model time step -CALL INIT_STATE(fracState0) ! fracState0 is shared in MODULE multistate -HSTATE%STEP = DELTIM ! deltim is shared in module multiforce. -! loop through time -DO ITIM=1,NUMTIM ! (NUMTIM is shared in MODULE multiforce) - ! run model for one time step - MFORCE = AFORCE(ITIM) ! assign model forcing data - CALL INITFLUXES() ! set weighted sum of fluxes to zero - CALL SUBSTEPPER() ! run model for one time step using implicit solution with variable sub-steps - CALL Q_OVERLAND() ! overland flow routing - ! save instantaneous and routed runoff - AROUTE(ITIM)%Q_INSTNT = MROUTE%Q_INSTNT ! save instantaneous runoff - AROUTE(ITIM)%Q_ROUTED = MROUTE%Q_ROUTED ! save routed runoff - ! compute summary statistics - IF (SSTATS_FLAG) CALL COMP_STATS() - ! write output - IF (OUTPUT_FLAG) THEN - CALL PUT_OUTPUT(PCOUNT,1,ITIM) - !WRITE(*,'(I10,1X,I4,1X,4(I2,1X),F9.3,1X,F20.1,1X,4(F11.3,1X))') ITIM, AFORCE(ITIM), AROUTE(ITIM)%Q_ROUTED - ENDIF - !if (itim.ge.355) pause -END DO ! (itim) -! --------------------------------------------------------------------------------------- -END SUBROUTINE FMODEL_RUN_NETCDF diff --git a/build/FUSE_SRC/FUSE_MAIN/.svn/text-base/sobol.f90.svn-base b/build/FUSE_SRC/FUSE_MAIN/.svn/text-base/sobol.f90.svn-base deleted file mode 100644 index b1f8844..0000000 --- a/build/FUSE_SRC/FUSE_MAIN/.svn/text-base/sobol.f90.svn-base +++ /dev/null @@ -1,3649 +0,0 @@ -subroutine get_unit ( iunit ) - -!*****************************************************************************80 -! -!! GET_UNIT returns a free FORTRAN unit number. -! -! Discussion: -! -! A "free" FORTRAN unit number is an integer between 1 and 99 which -! is not currently associated with an I/O device. A free FORTRAN unit -! number is needed in order to open a file with the OPEN command. -! -! If IUNIT = 0, then no free FORTRAN unit could be found, although -! all 99 units were checked (except for units 5, 6 and 9, which -! are commonly reserved for console I/O). -! -! Otherwise, IUNIT is an integer between 1 and 99, representing a -! free FORTRAN unit. Note that GET_UNIT assumes that units 5 and 6 -! are special, and will never return those values. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 18 September 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, integer IUNIT, the free unit number. -! - implicit none - - integer i - integer ios - integer iunit - logical lopen - - iunit = 0 - - do i = 1, 99 - - if ( i /= 5 .and. i /= 6 .and. i /= 9 ) then - - inquire ( unit = i, opened = lopen, iostat = ios ) - - if ( ios == 0 ) then - if ( .not. lopen ) then - iunit = i - return - end if - end if - - end if - - end do - - return -end -function i4_bit_hi1 ( n ) - -!*****************************************************************************80 -! -!! I4_BIT_HI1 returns the position of the high 1 bit base 2 in an integer. -! -! Discussion: -! -! This routine uses the default integer precision, which is -! presumed to correspond to a KIND of 4. -! -! Example: -! -! N Binary Hi 1 -! ---- -------- ---- -! 0 0 0 -! 1 1 1 -! 2 10 2 -! 3 11 2 -! 4 100 3 -! 5 101 3 -! 6 110 3 -! 7 111 3 -! 8 1000 4 -! 9 1001 4 -! 10 1010 4 -! 11 1011 4 -! 12 1100 4 -! 13 1101 4 -! 14 1110 4 -! 15 1111 4 -! 16 10000 5 -! 17 10001 5 -! 1023 1111111111 10 -! 1024 10000000000 11 -! 1025 10000000001 11 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 May 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the integer to be measured. -! N should be nonnegative. If N is nonpositive, I4_BIT_HI1 -! will always be 0. -! -! Output, integer ( kind = 4 ) I4_BIT_HI1, the number of bits base 2. -! - implicit none - - integer ( kind = 4 ) bit - integer ( kind = 4 ) i4_bit_hi1 - integer ( kind = 4 ) i - integer ( kind = 4 ) n - - i = n - bit = 0 - - do - - if ( i <= 0 ) then - exit - end if - - bit = bit + 1 - i = i / 2 - - end do - - i4_bit_hi1 = bit - - return -end -function i4_bit_lo0 ( n ) - -!*****************************************************************************80 -! -!! I4_BIT_LO0 returns the position of the low 0 bit base 2 in an integer. -! -! Discussion: -! -! This routine uses the default integer precision, which is -! presumed to correspond to a KIND of 4. -! -! Example: -! -! N Binary Lo 0 -! ---- -------- ---- -! 0 0 1 -! 1 1 2 -! 2 10 1 -! 3 11 3 -! 4 100 1 -! 5 101 2 -! 6 110 1 -! 7 111 4 -! 8 1000 1 -! 9 1001 2 -! 10 1010 1 -! 11 1011 3 -! 12 1100 1 -! 13 1101 2 -! 14 1110 1 -! 15 1111 5 -! 16 10000 1 -! 17 10001 2 -! 1023 1111111111 1 -! 1024 10000000000 1 -! 1025 10000000001 1 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 May 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the integer to be measured. -! N should be nonnegative. -! -! Output, integer ( kind = 4 ) I4_BIT_LO0, the position of the low 1 bit. -! - implicit none - - integer ( kind = 4 ) bit - integer ( kind = 4 ) i - integer ( kind = 4 ) i2 - integer ( kind = 4 ) i4_bit_lo0 - integer ( kind = 4 ) n - - bit = 0 - i = n - - do - - bit = bit + 1 - i2 = i / 2 - - if ( i == 2 * i2 ) then - exit - end if - - i = i2 - - end do - - i4_bit_lo0 = bit - - return -end -subroutine i4_sobol ( dim_num, seed, quasi ) - -!*****************************************************************************80 -! -!! I4_SOBOL generates a new quasirandom Sobol vector with each call. -! -! Discussion: -! -! The routine adapts the ideas of Antonov and Saleev. -! -! This routine uses the default integer precision, which is -! presumed to correspond to a KIND of 4. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 25 June 2008 -! -! Author: -! -! FORTRAN77 original version by Bennett Fox. -! FORTRAN90 version by John Burkardt -! -! Reference: -! -! IA Antonov, VM Saleev, -! An Economic Method of Computing LP Tau-Sequences, -! USSR Computational Mathematics and Mathematical Physics, -! Volume 19, 1980, pages 252-256. -! -! Paul Bratley, Bennett Fox, -! Algorithm 659: -! Implementing Sobol's Quasirandom Sequence Generator, -! ACM Transactions on Mathematical Software, -! Volume 14, Number 1, March 1988, pages 88-100 -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, December 1986, pages 362-376. -! -! Stephen Joe, Frances Kuo, -! Remark on Algorithm 659: -! Implementing Sobol's Quasirandom Sequence Generator, -! ACM Transactions on Mathematical Software, -! Volume 29, Number 1, March 2003, pages 49-57. -! -! Ilya Sobol, -! Uniformly Distributed Sequences with an Additional Uniform Property, -! USSR Computational Mathematics and Mathematical Physics, -! Volume 16, 1977, pages 236-242. -! -! Ilya Sobol, YL Levitan, -! The Production of Points Uniformly Distributed in a Multidimensional -! Cube (in Russian), -! Preprint IPM Akademii Nauk SSSR, -! Number 40, Moscow 1976. -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the number of spatial dimensions. -! DIM_NUM must satisfy 2 <= DIM_NUM <= 1111. -! -! Input/output, integer ( kind = 4 ) SEED, the "seed" for the sequence. -! This is essentially the index in the sequence of the quasirandom -! value to be generated. On output, SEED has been set to the -! appropriate next value, usually simply SEED+1. -! If SEED is less than 0 on input, it is treated as though it were 0. -! An input value of 0 requests the first (0-th) element of the sequence. -! -! Output, real ( kind = 4 ) QUASI(DIM_NUM), the next quasirandom vector. -! - implicit none - - integer ( kind = 4 ) dim_num - integer ( kind = 4 ), parameter :: dim_max = 1111 - integer ( kind = 4 ), parameter :: log_max = 30 - - integer ( kind = 4 ) atmost - integer ( kind = 4 ), save :: dim_num_save = 0 - integer ( kind = 4 ) i - integer ( kind = 4 ) i4_bit_hi1 - integer ( kind = 4 ) i4_bit_lo0 - integer ( kind = 4 ) inc - logical includ(log_max) - logical, save :: initialized = .false. - integer ( kind = 4 ) j - integer ( kind = 4 ) j2 - integer ( kind = 4 ) k - integer ( kind = 4 ) l - integer ( kind = 4 ), save, dimension(dim_max) :: lastq - integer ( kind = 4 ) m - integer ( kind = 4 ), save :: maxcol - integer ( kind = 4 ) newv - integer ( kind = 4 ), save, dimension(1:dim_max) :: poly - real ( kind = 4 ) quasi(dim_num) - real ( kind = 4 ), save :: recipd - integer ( kind = 4 ) seed - integer ( kind = 4 ), save :: seed_save = - 1 - integer ( kind = 4 ) seed_temp - integer ( kind = 4 ), save, dimension(1:dim_max,1:log_max) :: v - - if ( .not. initialized .or. dim_num /= dim_num_save ) then - - initialized = .true. - - v(1:dim_max,1:log_max) = 0 -! -! Initialize (part of) V. -! - v(2:1111,1) = 1 - v(3:401,2) = (/ & - 1,3,1,3,1,3,3,1,3,1,3,1,3,1,1,3,1,3,1,3, & - 1,3,3,1,1,1,3,1,3,1,3,3,1,3,1,1,1,3,1,3,1,1,1,3,3,1,3,3,1,1, & - 3,3,1,3,3,3,1,3,1,3,1,1,3,3,1,1,1,1,3,1,1,3,1,1,1,3,3,1,3,3, & - 1,3,3,3,1,3,3,3,1,3,3,1,3,3,3,1,3,1,3,1,1,3,3,1,3,3,1,1,1,3, & - 3,1,3,3,1,3,1,1,3,3,3,1,1,1,3,1,1,3,1,1,3,3,1,3,1,3,3,3,3,1, & - 1,1,3,3,1,1,3,1,1,1,1,1,1,3,1,3,1,1,1,3,1,3,1,3,3,3,1,1,3,3, & - 1,3,1,3,1,1,3,1,3,1,3,1,3,1,1,1,3,3,1,3,3,1,3,1,1,1,3,1,3,1, & - 1,3,1,1,3,3,1,1,3,3,3,1,3,3,3,1,3,1,3,1,1,1,3,1,1,1,3,1,1,1, & - 1,1,3,3,3,1,1,1,1,3,3,3,1,3,3,1,1,1,1,3,1,1,3,1,3,3,1,1,3,3, & - 1,1,1,1,3,1,3,3,1,3,3,1,1,1,3,3,3,1,3,3,1,3,3,1,3,1,3,3,3,1, & - 3,1,1,3,1,3,1,1,1,3,3,3,1,1,3,1,3,1,1,1,1,1,1,3,1,1,3,1,3,3, & - 1,1,1,1,3,1,3,1,3,1,1,1,1,3,3,1,1,1,1,1,3,3,3,1,1,3,3,3,3,3, & - 1,3,3,1,3,3,3,3,1,1,1,1,1,1,3,1,1,3,1,1,1,3,1,1,1,3,3,3,1,3, & - 1,1,3,3,3,1,3,3,1,3,1,3,3,1,3,3,3,1,1/) - v(402:800,2) = (/ & - 3,3,1,3,1,3,1,1,1,3,3,3,3,1,3,1,1,3,1, & - 3,1,1,1,3,1,3,1,3,1,3,3,3,3,3,3,3,3,1,3,3,3,3,3,1,3,1,3,3,3, & - 1,3,1,3,1,3,3,1,3,3,3,3,3,3,3,3,3,1,1,1,1,1,1,3,3,1,1,3,3,1, & - 1,1,3,3,1,1,3,3,3,3,1,1,3,1,3,3,1,3,3,1,1,1,3,3,3,1,1,3,3,3, & - 3,3,1,1,1,3,1,3,3,1,3,3,3,3,1,1,3,1,1,3,1,3,1,3,1,3,3,1,1,3, & - 3,1,3,3,1,3,3,1,1,3,1,3,3,1,1,3,1,3,1,3,1,1,3,3,1,1,1,3,3,1, & - 3,1,1,3,3,1,1,3,1,3,1,1,1,1,1,3,1,1,1,1,3,1,3,1,1,3,3,1,1,3, & - 1,3,1,3,3,3,1,3,3,3,1,1,3,3,3,1,1,1,1,3,1,3,1,3,1,1,3,3,1,1, & - 1,3,3,1,3,1,3,1,1,1,1,1,1,3,1,3,3,1,3,3,3,1,3,1,1,3,3,1,1,3, & - 3,1,1,1,3,1,3,3,1,1,3,1,1,3,1,3,1,1,1,3,3,3,3,1,1,3,3,1,1,1, & - 1,3,1,1,3,3,3,1,1,3,3,1,3,3,1,1,3,3,3,3,3,3,3,1,3,3,1,3,1,3, & - 1,1,3,3,1,1,1,3,1,3,3,1,3,3,1,3,1,1,3,3,3,1,1,1,3,1,1,1,3,3, & - 3,1,3,3,1,3,1,1,3,3,3,1,3,3,1,1,1,3,1,3,3,3,3,3,3,3,3,1,3,3, & - 1,3,1,1,3,3,3,1,3,3,3,3,3,1,3,3,3,1,1,1/) - v(801:1111,2) = (/ & - 3,3,1,3,3,1,3,1,3,1,3,1,3,3,3,3,3,3, & - 1,1,3,1,3,1,1,1,1,1,3,1,1,1,3,1,3,1,1,3,3,3,1,3,1,3,1,1,3,1, & - 3,3,1,3,1,3,3,1,3,3,1,3,3,3,3,3,3,1,3,1,1,3,3,3,1,1,3,3,3,3, & - 3,3,3,1,3,3,3,3,1,3,1,3,3,3,1,3,1,3,1,1,1,3,3,1,3,1,1,3,3,1, & - 3,1,1,1,1,3,1,3,1,1,3,1,3,1,3,3,3,3,3,3,1,3,3,3,3,1,3,3,1,3, & - 3,3,3,3,1,1,1,1,3,3,3,1,3,3,1,1,3,3,1,1,3,3,1,3,1,1,3,1,3,3, & - 3,3,3,1,3,1,1,3,3,3,3,1,3,1,1,3,3,3,3,3,3,1,1,3,1,3,1,1,3,1, & - 1,1,1,3,3,1,1,3,1,1,1,3,1,3,1,1,3,3,1,3,1,1,3,3,3,3,3,1,3,1, & - 1,1,3,1,1,1,3,1,1,3,1,3,3,3,3,3,1,1,1,3,3,3,3,1,3,3,3,3,1,1, & - 3,3,3,1,3,1,1,3,3,1,3,3,1,1,1,1,1,3,1,1,3,3,1,1,1,3,1,1,3,3, & - 1,3,3,3,3,3,3,3,3,1,1,3,3,1,1,3,1,3,3,3,3,3,1/) - v(4:402,3) = (/ & - 7,5,1,3,3,7,5,5,7,7,1,3,3,7,5,1,1,5,3,7, & - 1,7,5,1,3,7,7,1,1,1,5,7,7,5,1,3,3,7,5,5,5,3,3,3,1,1,5,1,1,5, & - 3,3,3,3,1,3,7,5,7,3,7,1,3,3,5,1,3,5,5,7,7,7,1,1,3,3,1,1,5,1, & - 5,7,5,1,7,5,3,3,1,5,7,1,7,5,1,7,3,1,7,1,7,3,3,5,7,3,3,5,1,3, & - 3,1,3,5,1,3,3,3,7,1,1,7,3,1,3,7,5,5,7,5,5,3,1,3,3,3,1,3,3,7, & - 3,3,1,7,5,1,7,7,5,7,5,1,3,1,7,3,7,3,5,7,3,1,3,3,3,1,5,7,3,3, & - 7,7,7,5,3,1,7,1,3,7,5,3,3,3,7,1,1,3,1,5,7,1,3,5,3,5,3,3,7,5, & - 5,3,3,1,3,7,7,7,1,5,7,1,3,1,1,7,1,3,1,7,1,5,3,5,3,1,1,5,5,3, & - 3,5,7,1,5,3,7,7,3,5,3,3,1,7,3,1,3,5,7,1,3,7,1,5,1,3,1,5,3,1, & - 7,1,5,5,5,3,7,1,1,7,3,1,1,7,5,7,5,7,7,3,7,1,3,7,7,3,5,1,1,7, & - 1,5,5,5,1,5,1,7,5,5,7,1,1,7,1,7,7,1,1,3,3,3,7,7,5,3,7,3,1,3, & - 7,5,3,3,5,7,1,1,5,5,7,7,1,1,1,1,5,5,5,7,5,7,1,1,3,5,1,3,3,7, & - 3,7,5,3,5,3,1,7,1,7,7,1,1,7,7,7,5,5,1,1,7,5,5,7,5,1,1,5,5,5, & - 5,5,5,1,3,1,5,7,3,3,5,7,3,7,1,7,7,1,3/) - v(403:801,3) = (/ & - 5,1,5,5,3,7,3,7,7,5,7,5,7,1,1,5,3,5,1, & - 5,3,7,1,5,7,7,3,5,1,3,5,1,5,3,3,3,7,3,5,1,3,7,7,3,7,5,3,3,1, & - 7,5,1,1,3,7,1,7,1,7,3,7,3,5,7,3,5,3,1,1,1,5,7,7,3,3,1,1,1,5, & - 5,7,3,1,1,3,3,7,3,3,5,1,3,7,3,3,7,3,5,7,5,7,7,3,3,5,1,3,5,3, & - 1,3,5,1,1,3,7,7,1,5,1,3,7,3,7,3,5,1,7,1,1,3,5,3,7,1,5,5,1,1, & - 3,1,3,3,7,1,7,3,1,7,3,1,7,3,5,3,5,7,3,3,3,5,1,7,7,1,3,1,3,7, & - 7,1,3,7,3,1,5,3,1,1,1,5,3,3,7,1,5,3,5,1,3,1,3,1,5,7,7,1,1,5, & - 3,1,5,1,1,7,7,3,5,5,1,7,1,5,1,1,3,1,5,7,5,7,7,1,5,1,1,3,5,1, & - 5,5,3,1,3,1,5,5,3,3,3,3,1,1,3,1,3,5,5,7,5,5,7,5,7,1,3,7,7,3, & - 5,5,7,5,5,3,3,3,1,7,1,5,5,5,3,3,5,1,3,1,3,3,3,7,1,7,7,3,7,1, & - 1,5,7,1,7,1,7,7,1,3,7,5,1,3,5,5,5,1,1,7,1,7,1,7,7,3,1,1,5,1, & - 5,1,5,3,5,5,5,5,5,3,3,7,3,3,5,5,3,7,1,5,7,5,1,5,5,3,5,5,7,5, & - 3,5,5,5,1,5,5,5,5,1,3,5,3,1,7,5,5,7,1,5,3,3,1,5,3,7,1,7,5,1, & - 1,3,1,1,7,1,5,5,3,7,3,7,5,3,1,1,3,1,3,5/) - v(802:1111,3) = (/ & - 5,7,5,3,7,7,7,3,7,3,7,1,3,1,7,7,1,7, & - 3,7,3,7,3,7,3,5,1,1,7,3,1,5,5,7,1,5,5,5,7,1,5,5,1,5,5,3,1,3, & - 1,7,3,1,3,5,7,7,7,1,1,7,3,1,5,5,5,1,1,1,1,1,5,3,5,1,3,5,3,1, & - 1,1,1,3,7,3,7,5,7,1,5,5,7,5,3,3,7,5,3,1,1,3,1,3,1,1,3,7,1,7, & - 1,1,5,1,7,5,3,7,3,5,3,1,1,5,5,1,7,7,3,7,3,7,1,5,1,5,3,7,3,5, & - 7,7,7,3,3,1,1,5,5,3,7,1,1,1,3,5,3,1,1,3,3,7,5,1,1,3,7,1,5,7, & - 3,7,5,5,7,3,5,3,1,5,3,1,1,7,5,1,7,3,7,5,1,7,1,7,7,1,1,7,1,5, & - 5,1,1,7,5,7,1,5,3,5,3,3,7,1,5,1,1,5,5,3,3,7,5,5,1,1,1,3,1,5, & - 7,7,1,7,5,7,3,7,3,1,3,7,3,1,5,5,3,5,1,3,5,5,5,1,1,7,7,1,5,5, & - 1,3,5,1,5,3,5,3,3,7,5,7,3,7,3,1,3,7,7,3,3,1,1,3,3,3,3,3,5,5, & - 3,3,3,1,3,5,7,7,1,5,7,3,7,1,1,3,5,7,5,3,3,3/) - v(6:357,4) = (/ & - 1,7,9,13,11,1,3,7,9,5,13,13,11,3,15,5,3, & - 15,7,9,13,9,1,11,7,5,15,1,15,11,5,11,1,7,9,7,7,1,15,15,15,13, & - 3,3,15,5,9,7,13,3,7,5,11,9,1,9,1,5,7,13,9,9,1,7,3,5,1,11,11, & - 13,7,7,9,9,1,1,3,9,15,1,5,13,1,9,9,9,9,9,13,11,3,5,11,11,13, & - 5,3,15,1,11,11,7,13,15,11,13,9,11,15,15,13,3,15,7,9,11,13,11, & - 9,9,5,13,9,1,13,7,7,7,7,7,5,9,7,13,11,9,11,15,3,13,11,1,11,3, & - 3,9,11,1,7,1,15,15,3,1,9,1,7,13,11,3,13,11,7,3,3,5,13,11,5, & - 11,1,3,9,7,15,7,5,13,7,9,13,15,13,9,7,15,7,9,5,11,11,13,13,9, & - 3,5,13,9,11,15,11,7,1,7,13,3,13,3,13,9,15,7,13,13,3,13,15,15, & - 11,9,13,9,15,1,1,15,11,11,7,1,11,13,9,13,3,5,11,13,9,9,13,1, & - 11,15,13,3,13,7,15,1,15,3,3,11,7,13,7,7,9,7,5,15,9,5,5,7,15, & - 13,15,5,15,5,3,1,11,7,1,5,7,9,3,11,1,15,1,3,15,11,13,5,13,1, & - 7,1,15,7,5,1,1,15,13,11,11,13,5,11,7,9,7,1,5,3,9,5,5,11,5,1, & - 7,1,11,7,9,13,15,13,3,1,11,13,15,1,1,11,9,13,3,13,11,15,13,9, & - 9,9,5,5,5,5,1,15,5,9/) - v(358:710,4) = (/ & - 11,7,15,5,3,13,5,3,11,5,1,11,13,9,11, & - 3,7,13,15,1,7,11,1,13,1,15,1,9,7,3,9,11,1,9,13,13,3,11,7,9,1, & - 7,15,9,1,5,13,5,11,3,9,15,11,13,5,1,7,7,5,13,7,7,9,5,11,11,1, & - 1,15,3,13,9,13,9,9,11,5,5,13,15,3,9,15,3,11,11,15,15,3,11,15, & - 15,3,1,3,1,3,3,1,3,13,1,11,5,15,7,15,9,1,7,1,9,11,15,1,13,9, & - 13,11,7,3,7,3,13,7,9,7,7,3,3,9,9,7,5,11,13,13,7,7,15,9,5,5,3, & - 3,13,3,9,3,1,11,1,3,11,15,11,11,11,9,13,7,9,15,9,11,1,3,3,9, & - 7,15,13,13,7,15,9,13,9,15,13,15,9,13,1,11,7,11,3,13,5,1,7,15, & - 3,13,7,13,13,11,3,5,3,13,11,9,9,3,11,11,7,9,13,11,7,15,13,7, & - 5,3,1,5,15,15,3,11,1,7,3,15,11,5,5,3,5,5,1,15,5,1,5,3,7,5,11, & - 3,13,9,13,15,5,3,5,9,5,3,11,1,13,9,15,3,5,11,9,1,3,15,9,9,9, & - 11,7,5,13,1,15,3,13,9,13,5,1,5,1,13,13,7,7,1,9,5,11,9,11,13, & - 3,15,15,13,15,7,5,7,9,7,9,9,9,11,9,3,11,15,13,13,5,9,15,1,1, & - 9,5,13,3,13,15,3,1,3,11,13,1,15,9,9,3,1,9,1,9,1,13,11,15,7, & - 11,15,13,15,1,9,9,7/) - v(711:1065,4) = (/ & - 3,5,11,7,3,9,5,15,7,5,3,13,7,1,1,9, & - 15,15,15,11,3,5,15,13,7,15,15,11,11,9,5,15,9,7,3,13,1,1,5,1, & - 3,1,7,1,1,5,1,11,11,9,9,5,13,7,7,7,1,1,9,9,11,11,15,7,5,5,3, & - 11,1,3,7,13,7,7,7,3,15,15,11,9,3,9,3,15,13,5,3,3,3,5,9,15,9, & - 9,1,5,9,9,15,5,15,7,9,1,9,9,5,11,5,15,15,11,7,7,7,1,1,11,11, & - 13,15,3,13,5,1,7,1,11,3,13,15,3,5,3,5,7,3,9,9,5,1,7,11,9,3,5, & - 11,13,13,13,9,15,5,7,1,15,11,9,15,15,13,13,13,1,11,9,15,9,5, & - 15,5,7,3,11,3,15,7,13,11,7,3,7,13,5,13,15,5,13,9,1,15,11,5,5, & - 1,11,3,3,7,1,9,7,15,9,9,3,11,15,7,1,3,1,1,1,9,1,5,15,15,7,5, & - 5,7,9,7,15,13,13,11,1,9,11,1,13,1,7,15,15,5,5,1,11,3,9,11,9, & - 9,9,1,9,3,5,15,1,1,9,7,3,3,1,9,9,11,9,9,13,13,3,13,11,13,5,1, & - 5,5,9,9,3,13,13,9,15,9,11,7,11,9,13,9,1,15,9,7,7,1,7,9,9,15, & - 1,11,1,13,13,15,9,13,7,15,3,9,3,1,13,7,5,9,3,1,7,1,1,13,3,3, & - 11,1,7,13,15,15,5,7,13,13,15,11,13,1,13,13,3,9,15,15,11,15,9, & - 15,1,13,15,1,1,5/) - v(1066:1111,4) = (/ & - 11,5,1,11,11,5,3,9,1,3,5,13,9,7,7,1, & - 9,9,15,7,5,5,15,13,9,7,13,3,13,11,13,7,9,13,13,13,15,9,5,5,3, & - 3,3,1,3,15/) - v(8:331,5) = (/ & - 9,3,27,15,29,21,23,19,11,25,7,13,17,1, & - 25,29,3,31,11,5,23,27,19,21,5,1,17,13,7,15,9,31,25,3,5,23,7, & - 3,17,23,3,3,21,25,25,23,11,19,3,11,31,7,9,5,17,23,17,17,25, & - 13,11,31,27,19,17,23,7,5,11,19,19,7,13,21,21,7,9,11,1,5,21, & - 11,13,25,9,7,7,27,15,25,15,21,17,19,19,21,5,11,3,5,29,31,29, & - 5,5,1,31,27,11,13,1,3,7,11,7,3,23,13,31,17,1,27,11,25,1,23, & - 29,17,25,7,25,27,17,13,17,23,5,17,5,13,11,21,5,11,5,9,31,19, & - 17,9,9,27,21,15,15,1,1,29,5,31,11,17,23,19,21,25,15,11,5,5,1, & - 19,19,19,7,13,21,17,17,25,23,19,23,15,13,5,19,25,9,7,3,21,17, & - 25,1,27,25,27,25,9,13,3,17,25,23,9,25,9,13,17,17,3,15,7,7,29, & - 3,19,29,29,19,29,13,15,25,27,1,3,9,9,13,31,29,31,5,15,29,1, & - 19,5,9,19,5,15,3,5,7,15,17,17,23,11,9,23,19,3,17,1,27,9,9,17, & - 13,25,29,23,29,11,31,25,21,29,19,27,31,3,5,3,3,13,21,9,29,3, & - 17,11,11,9,21,19,7,17,31,25,1,27,5,15,27,29,29,29,25,27,25,3, & - 21,17,25,13,15,17,13,23,9,3,11,7,9,9,7,17,7,1/) - v(332:654,5) = (/ & - 27,1,9,5,31,21,25,25,21,11,1,23,19,27, & - 15,3,5,23,9,25,7,29,11,9,13,5,11,1,3,31,27,3,17,27,11,13,15, & - 29,15,1,15,23,25,13,21,15,3,29,29,5,25,17,11,7,15,5,21,7,31, & - 13,11,23,5,7,23,27,21,29,15,7,27,27,19,7,15,27,27,19,19,9,15, & - 1,3,29,29,5,27,31,9,1,7,3,19,19,29,9,3,21,31,29,25,1,3,9,27, & - 5,27,25,21,11,29,31,27,21,29,17,9,17,13,11,25,15,21,11,19,31, & - 3,19,5,3,3,9,13,13,3,29,7,5,9,23,13,21,23,21,31,11,7,7,3,23, & - 1,23,5,9,17,21,1,17,29,7,5,17,13,25,17,9,19,9,5,7,21,19,13,9, & - 7,3,9,3,15,31,29,29,25,13,9,21,9,31,7,15,5,31,7,15,27,25,19, & - 9,9,25,25,23,1,9,7,11,15,19,15,27,17,11,11,31,13,25,25,9,7, & - 13,29,19,5,19,31,25,13,25,15,5,9,29,31,9,29,27,25,27,11,17,5, & - 17,3,23,15,9,9,17,17,31,11,19,25,13,23,15,25,21,31,19,3,11, & - 25,7,15,19,7,5,3,13,13,1,23,5,25,11,25,15,13,21,11,23,29,5, & - 17,27,9,19,15,5,29,23,19,1,27,3,23,21,19,27,11,17,13,27,11, & - 31,23,5,9,21,31,29,11,21,17,15,7,15,7,9,21,27,25/) - v(655:975,5) = (/ & - 29,11,3,21,13,23,19,27,17,29,25,17,9, & - 1,19,23,5,23,1,17,17,13,27,23,7,7,11,13,17,13,11,21,13,23,1, & - 27,13,9,7,1,27,29,5,13,25,21,3,31,15,13,3,19,13,1,27,15,17,1, & - 3,13,13,13,31,29,27,7,7,21,29,15,17,17,21,19,17,3,15,5,27,27, & - 3,31,31,7,21,3,13,11,17,27,25,1,9,7,29,27,21,23,13,25,29,15, & - 17,29,9,15,3,21,15,17,17,31,9,9,23,19,25,3,1,11,27,29,1,31, & - 29,25,29,1,23,29,25,13,3,31,25,5,5,11,3,21,9,23,7,11,23,11,1, & - 1,3,23,25,23,1,23,3,27,9,27,3,23,25,19,29,29,13,27,5,9,29,29, & - 13,17,3,23,19,7,13,3,19,23,5,29,29,13,13,5,19,5,17,9,11,11, & - 29,27,23,19,17,25,13,1,13,3,11,1,17,29,1,13,17,9,17,21,1,11, & - 1,1,25,5,7,29,29,19,19,1,29,13,3,1,31,15,13,3,1,11,19,5,29, & - 13,29,23,3,1,31,13,19,17,5,5,1,29,23,3,19,25,19,27,9,27,13, & - 15,29,23,13,25,25,17,19,17,15,27,3,25,17,27,3,27,31,23,13,31, & - 11,15,7,21,19,27,19,21,29,7,31,13,9,9,7,21,13,11,9,11,29,19, & - 11,19,21,5,29,13,7,19,19,27,23,31,1,27,21,7,3,7,11/) - v(976:1111,5) = (/ & - 23,13,29,11,31,19,1,5,5,11,5,3,27,5, & - 7,11,31,1,27,31,31,23,5,21,27,9,25,3,15,19,1,19,9,5,25,21,15, & - 25,29,15,21,11,19,15,3,7,13,11,25,17,1,5,31,13,29,23,9,5,29, & - 7,17,27,7,17,31,9,31,9,9,7,21,3,3,3,9,11,21,11,31,9,25,5,1, & - 31,13,29,9,29,1,11,19,7,27,13,31,7,31,7,25,23,21,29,11,11,13, & - 11,27,1,23,31,21,23,21,19,31,5,31,25,25,19,17,11,25,7,13,1, & - 29,17,23,15,7,29,17,13,3,17/) - v(14:324,6) = (/ & - 37,33,7,5,11,39,63,59,17,15,23,29,3,21, & - 13,31,25,9,49,33,19,29,11,19,27,15,25,63,55,17,63,49,19,41, & - 59,3,57,33,49,53,57,57,39,21,7,53,9,55,15,59,19,49,31,3,39,5, & - 5,41,9,19,9,57,25,1,15,51,11,19,61,53,29,19,11,9,21,19,43,13, & - 13,41,25,31,9,11,19,5,53,37,7,51,45,7,7,61,23,45,7,59,41,1, & - 29,61,37,27,47,15,31,35,31,17,51,13,25,45,5,5,33,39,5,47,29, & - 35,47,63,45,37,47,59,21,59,33,51,9,27,13,25,43,3,17,21,59,61, & - 27,47,57,11,17,39,1,63,21,59,17,13,31,3,31,7,9,27,37,23,31,9, & - 45,43,31,63,21,39,51,27,7,53,11,1,59,39,23,49,23,7,55,59,3, & - 19,35,13,9,13,15,23,9,7,43,55,3,19,9,27,33,27,49,23,47,19,7, & - 11,55,27,35,5,5,55,35,37,9,33,29,47,25,11,47,53,61,59,3,53, & - 47,5,19,59,5,47,23,45,53,3,49,61,47,39,29,17,57,5,17,31,23, & - 41,39,5,27,7,29,29,33,31,41,31,29,17,29,29,9,9,31,27,53,35,5, & - 61,1,49,13,57,29,5,21,43,25,57,49,37,27,11,61,37,49,5,63,63, & - 3,45,37,63,21,21,19,27,59,21,45,23,13,15,3,43,63,39,19/) - v(325:632,6) = (/ & - 63,31,41,41,15,43,63,53,1,63,31,7,17, & - 11,61,31,51,37,29,59,25,63,59,47,15,27,19,29,45,35,55,39,19, & - 43,21,19,13,17,51,37,5,33,35,49,25,45,1,63,47,9,63,15,25,25, & - 15,41,13,3,19,51,49,37,25,49,13,53,47,23,35,29,33,21,35,23,3, & - 43,31,63,9,1,61,43,3,11,55,11,35,1,63,35,49,19,45,9,57,51,1, & - 47,41,9,11,37,19,55,23,55,55,13,7,47,37,11,43,17,3,25,19,55, & - 59,37,33,43,1,5,21,5,63,49,61,21,51,15,19,43,47,17,9,53,45, & - 11,51,25,11,25,47,47,1,43,29,17,31,15,59,27,63,11,41,51,29,7, & - 27,63,31,43,3,29,39,3,59,59,1,53,63,23,63,47,51,23,61,39,47, & - 21,39,15,3,9,57,61,39,37,21,51,1,23,43,27,25,11,13,21,43,7, & - 11,33,55,1,37,35,27,61,39,5,19,61,61,57,59,21,59,61,57,25,55, & - 27,31,41,33,63,19,57,35,13,63,35,17,11,11,49,41,55,5,45,17, & - 35,5,31,31,37,17,45,51,1,39,49,55,19,41,13,5,51,5,49,1,21,13, & - 17,59,51,11,3,61,1,33,37,33,61,25,27,59,7,49,13,63,3,33,3,15, & - 9,13,35,39,11,59,59,1,57,11,5,57,13,31,13,11,55,45,9,55,55/) - v(633:942,6) = (/ & - 19,25,41,23,45,29,63,59,27,39,21,37,7, & - 61,49,35,39,9,29,7,25,23,57,5,19,15,33,49,37,25,17,45,29,15, & - 25,3,3,49,11,39,15,19,57,39,15,11,3,57,31,55,61,19,5,41,35, & - 59,61,39,41,53,53,63,31,9,59,13,35,55,41,49,5,41,25,27,43,5, & - 5,43,5,5,17,5,15,27,29,17,9,3,55,31,1,45,45,13,57,17,3,61,15, & - 49,15,47,9,37,45,9,51,61,21,33,11,21,63,63,47,57,61,49,9,59, & - 19,29,21,23,55,23,43,41,57,9,39,27,41,35,61,29,57,63,21,31, & - 59,35,49,3,49,47,49,33,21,19,21,35,11,17,37,23,59,13,37,35, & - 55,57,1,29,45,11,1,15,9,33,19,53,43,39,23,7,13,13,1,19,41,55, & - 1,13,15,59,55,15,3,57,37,31,17,1,3,21,29,25,55,9,37,33,53,41, & - 51,19,57,13,63,43,19,7,13,37,33,19,15,63,51,11,49,23,57,47, & - 51,15,53,41,1,15,37,61,11,35,29,33,23,55,11,59,19,61,61,45, & - 13,49,13,63,5,61,5,31,17,61,63,13,27,57,1,21,5,11,39,57,51, & - 53,39,25,41,39,37,23,31,25,33,17,57,29,27,23,47,41,29,19,47, & - 41,25,5,51,43,39,29,7,31,45,51,49,55,17,43,49,45,9,29,3,5,47, & - 9,15,19/) - v(943:1111,6) = (/ & - 51,45,57,63,9,21,59,3,9,13,45,23,15, & - 31,21,15,51,35,9,11,61,23,53,29,51,45,31,29,5,35,29,53,35,17, & - 59,55,27,51,59,27,47,15,29,37,7,49,55,5,19,45,29,19,57,33,53, & - 45,21,9,3,35,29,43,31,39,3,45,1,41,29,5,59,41,33,35,27,19,13, & - 25,27,43,33,35,17,17,23,7,35,15,61,61,53,5,15,23,11,13,43,55, & - 47,25,43,15,57,45,1,49,63,57,15,31,31,7,53,27,15,47,23,7,29, & - 53,47,9,53,3,25,55,45,63,21,17,23,31,27,27,43,63,55,63,45,51, & - 15,27,5,37,43,11,27,5,27,59,21,7,39,27,63,35,47,55,17,17,17, & - 3,19,21,13,49,61,39,15/) - v(20:305,7) = (/ & - 13,33,115,41,79,17,29,119,75,73,105,7, & - 59,65,21,3,113,61,89,45,107,21,71,79,19,71,61,41,57,121,87, & - 119,55,85,121,119,11,23,61,11,35,33,43,107,113,101,29,87,119, & - 97,29,17,89,5,127,89,119,117,103,105,41,83,25,41,55,69,117, & - 49,127,29,1,99,53,83,15,31,73,115,35,21,89,5,1,91,53,35,95, & - 83,19,85,55,51,101,33,41,55,45,95,61,27,37,89,75,57,61,15, & - 117,15,21,27,25,27,123,39,109,93,51,21,91,109,107,45,15,93, & - 127,3,53,81,79,107,79,87,35,109,73,35,83,107,1,51,7,59,33, & - 115,43,111,45,121,105,125,87,101,41,95,75,1,57,117,21,27,67, & - 29,53,117,63,1,77,89,115,49,127,15,79,81,29,65,103,33,73,79, & - 29,21,113,31,33,107,95,111,59,99,117,63,63,99,39,9,35,63,125, & - 99,45,93,33,93,9,105,75,51,115,11,37,17,41,21,43,73,19,93,7, & - 95,81,93,79,81,55,9,51,63,45,89,73,19,115,39,47,81,39,5,5,45, & - 53,65,49,17,105,13,107,5,5,19,73,59,43,83,97,115,27,1,69,103, & - 3,99,103,63,67,25,121,97,77,13,83,103,41,11,27,81,37,33,125, & - 71,41,41,59,41,87,123/) - v(306:589,7) = (/ & - 43,101,63,45,39,21,97,15,97,111,21,49, & - 13,17,79,91,65,105,75,1,45,67,83,107,125,87,15,81,95,105,65, & - 45,59,103,23,103,99,67,99,47,117,71,89,35,53,73,9,115,49,37, & - 1,35,9,45,81,19,127,17,17,105,89,49,101,7,37,33,11,95,95,17, & - 111,105,41,115,5,69,101,27,27,101,103,53,9,21,43,79,91,65, & - 117,87,125,55,45,63,85,83,97,45,83,87,113,93,95,5,17,77,77, & - 127,123,45,81,85,121,119,27,85,41,49,15,107,21,51,119,11,87, & - 101,115,63,63,37,121,109,7,43,69,19,77,49,71,59,35,7,13,55, & - 101,127,103,85,109,29,61,67,21,111,67,23,57,75,71,101,123,41, & - 107,101,107,125,27,47,119,41,19,127,33,31,109,7,91,91,39,125, & - 105,47,125,123,91,9,103,45,23,117,9,125,73,11,37,61,79,21,5, & - 47,117,67,53,85,33,81,121,47,61,51,127,29,65,45,41,95,57,73, & - 33,117,61,111,59,123,65,47,105,23,29,107,37,81,67,29,115,119, & - 75,73,99,103,7,57,45,61,95,49,101,101,35,47,119,39,67,31,103, & - 7,61,127,87,3,35,29,73,95,103,71,75,51,87,57,97,11,105,87,41, & - 73,109,69,35,121,39,111,1,77/) - v(590:875,7) = (/ & - 39,47,53,91,3,17,51,83,39,125,85,111, & - 21,69,85,29,55,11,117,1,47,17,65,63,47,117,17,115,51,25,33, & - 123,123,83,51,113,95,121,51,91,109,43,55,35,55,87,33,37,5,3, & - 45,21,105,127,35,17,35,37,97,97,21,77,123,17,89,53,105,75,25, & - 125,13,47,21,125,23,55,63,61,5,17,93,57,121,69,73,93,121,105, & - 75,91,67,95,75,9,69,97,99,93,11,53,19,73,5,33,79,107,65,69, & - 79,125,25,93,55,61,17,117,69,97,87,111,37,93,59,79,95,53,115, & - 53,85,85,65,59,23,75,21,67,27,99,79,27,3,95,27,69,19,75,47, & - 59,41,85,77,99,55,49,93,93,119,51,125,63,13,15,45,61,19,105, & - 115,17,83,7,7,11,61,37,63,89,95,119,113,67,123,91,33,37,99, & - 43,11,33,65,81,79,81,107,63,63,55,89,91,25,93,101,27,55,75, & - 121,79,43,125,73,27,109,35,21,71,113,89,59,95,41,45,113,119, & - 113,39,59,73,15,13,59,67,121,27,7,105,15,59,59,35,91,89,23, & - 125,97,53,41,91,111,29,31,3,103,61,71,35,7,119,29,45,49,111, & - 41,109,59,125,13,27,19,79,9,75,83,81,33,91,109,33,29,107,111, & - 101,107,109,65,59,43,37/) - v(876:1111,7) = (/ & - 1,9,15,109,37,111,113,119,79,73,65, & - 71,93,17,101,87,97,43,23,75,109,41,49,53,31,97,105,109,119, & - 51,9,53,113,97,73,89,79,49,61,105,13,99,53,71,7,87,21,101,5, & - 71,31,123,121,121,73,79,115,13,39,101,19,37,51,83,97,55,81, & - 91,127,105,89,63,47,49,75,37,77,15,49,107,23,23,35,19,69,17, & - 59,63,73,29,125,61,65,95,101,81,57,69,83,37,11,37,95,1,73,27, & - 29,57,7,65,83,99,69,19,103,43,95,25,19,103,41,125,97,71,105, & - 83,83,61,39,9,45,117,63,31,5,117,67,125,41,117,43,77,97,15, & - 29,5,59,25,63,87,39,39,77,85,37,81,73,89,29,125,109,21,23, & - 119,105,43,93,97,15,125,29,51,69,37,45,31,75,109,119,53,5, & - 101,125,121,35,29,7,63,17,63,13,69,15,105,51,127,105,9,57,95, & - 59,109,35,49,23,33,107,55,33,57,79,73,69,59,107,55,11,63,95, & - 103,23,125,91,31,91,51,65,61,75,69,107,65,101,59,35,15/) - v(38:299,8) = (/ & - 7,23,39,217,141,27,53,181,169,35,15, & - 207,45,247,185,117,41,81,223,151,81,189,61,95,185,23,73,113, & - 239,85,9,201,83,53,183,203,91,149,101,13,111,239,3,205,253, & - 247,121,189,169,179,197,175,217,249,195,95,63,19,7,5,75,217, & - 245,111,189,165,169,141,221,249,159,253,207,249,219,23,49, & - 127,237,5,25,177,37,103,65,167,81,87,119,45,79,143,57,79,187, & - 143,183,75,97,211,149,175,37,135,189,225,241,63,33,43,13,73, & - 213,57,239,183,117,21,29,115,43,205,223,15,3,159,51,101,127, & - 99,239,171,113,171,119,189,245,201,27,185,229,105,153,189,33, & - 35,137,77,97,17,181,55,197,201,155,37,197,137,223,25,179,91, & - 23,235,53,253,49,181,249,53,173,97,247,67,115,103,159,239,69, & - 173,217,95,221,247,97,91,123,223,213,129,181,87,239,85,89, & - 249,141,39,57,249,71,101,159,33,137,189,71,253,205,171,13, & - 249,109,131,199,189,179,31,99,113,41,173,23,189,197,3,135,9, & - 95,195,27,183,1,123,73,53,99,197,59,27,101,55,193,31,61,119, & - 11,7,255,233,53,157,193,97,83,65,81,239,167,69,71,109/) - v(300:559,8) = (/ & - 97,137,71,193,189,115,79,205,37,227, & - 53,33,91,229,245,105,77,229,161,103,93,13,161,229,223,69,15, & - 25,23,233,93,25,217,247,61,75,27,9,223,213,55,197,145,89,199, & - 41,201,5,149,35,119,183,53,11,13,3,179,229,43,55,187,233,47, & - 133,91,47,71,93,105,145,45,255,221,115,175,19,129,5,209,197, & - 57,177,115,187,119,77,211,111,33,113,23,87,137,41,7,83,43, & - 121,145,5,219,27,11,111,207,55,97,63,229,53,33,149,23,187, & - 153,91,193,183,59,211,93,139,59,179,163,209,77,39,111,79,229, & - 85,237,199,137,147,25,73,121,129,83,87,93,205,167,53,107,229, & - 213,95,219,109,175,13,209,97,61,147,19,13,123,73,35,141,81, & - 19,171,255,111,107,233,113,133,89,9,231,95,69,33,1,253,219, & - 253,247,129,11,251,221,153,35,103,239,7,27,235,181,5,207,53, & - 149,155,225,165,137,155,201,97,245,203,47,39,35,105,239,49, & - 15,253,7,237,213,55,87,199,27,175,49,41,229,85,3,149,179,129, & - 185,249,197,15,97,197,139,203,63,33,251,217,199,199,99,249, & - 33,229,177,13,209,147,97,31,125,177,137/) - v(560:819,8) = (/ & - 187,11,91,223,29,169,231,59,31,163,41, & - 57,87,247,25,127,101,207,187,73,61,105,27,91,171,243,33,3,1, & - 21,229,93,71,61,37,183,65,211,53,11,151,165,47,5,129,79,101, & - 147,169,181,19,95,77,139,197,219,97,239,183,143,9,13,209,23, & - 215,53,137,203,19,151,171,133,219,231,3,15,253,225,33,111, & - 183,213,169,119,111,15,201,123,121,225,113,113,225,161,165,1, & - 139,55,3,93,217,193,97,29,69,231,161,93,69,143,137,9,87,183, & - 113,183,73,215,137,89,251,163,41,227,145,57,81,57,11,135,145, & - 161,175,159,25,55,167,157,211,97,247,249,23,129,159,71,197, & - 127,141,219,5,233,131,217,101,131,33,157,173,69,207,239,81, & - 205,11,41,169,65,193,77,201,173,1,221,157,1,15,113,147,137, & - 205,225,73,45,49,149,113,253,99,17,119,105,117,129,243,75, & - 203,53,29,247,35,247,171,31,199,213,29,251,7,251,187,91,11, & - 149,13,205,37,249,137,139,9,7,113,183,205,187,39,3,79,155, & - 227,89,185,51,127,63,83,41,133,183,181,127,19,255,219,59,251, & - 3,187,57,217,115,217,229,181,185,149,83,115,11/) - v(820:1074,8) = (/ & - 123,19,109,165,103,123,219,129,155, & - 207,177,9,49,181,231,33,233,67,155,41,9,95,123,65,117,249,85, & - 169,129,241,173,251,225,147,165,69,81,239,95,23,83,227,249, & - 143,171,193,9,21,57,73,97,57,29,239,151,159,191,47,51,1,223, & - 251,251,151,41,119,127,131,33,209,123,53,241,25,31,183,107, & - 25,115,39,11,213,239,219,109,185,35,133,123,185,27,55,245,61, & - 75,205,213,169,163,63,55,49,83,195,51,31,41,15,203,41,63,127, & - 161,5,143,7,199,251,95,75,101,15,43,237,197,117,167,155,21, & - 83,205,255,49,101,213,237,135,135,21,73,93,115,7,85,223,237, & - 79,89,5,57,239,67,65,201,155,71,85,195,89,181,119,135,147, & - 237,173,41,155,67,113,111,21,183,23,103,207,253,69,219,205, & - 195,43,197,229,139,177,129,69,97,201,163,189,11,99,91,253, & - 239,91,145,19,179,231,121,7,225,237,125,191,119,59,175,237, & - 131,79,43,45,205,199,251,153,207,37,179,113,255,107,217,61,7, & - 181,247,31,13,113,145,107,233,233,43,79,23,169,137,129,183, & - 53,91,55,103,223,87,177,157,79,213,139/) - v(1075:1111,8) = (/ & - 183,231,205,143,129,243,205,93,59, & - 15,89,9,11,47,133,227,75,9,91,19,171,163,79,7,103,5,119,155, & - 75,11,71,95,17,13,243,207,187/) - v(54:299,9) = (/ & - 235,307,495,417,57,151,19,119,375,451, & - 55,449,501,53,185,317,17,21,487,13,347,393,15,391,307,189, & - 381,71,163,99,467,167,433,337,257,179,47,385,23,117,369,425, & - 207,433,301,147,333,85,221,423,49,3,43,229,227,201,383,281, & - 229,207,21,343,251,397,173,507,421,443,399,53,345,77,385,317, & - 155,187,269,501,19,169,235,415,61,247,183,5,257,401,451,95, & - 455,49,489,75,459,377,87,463,155,233,115,429,211,419,143,487, & - 195,209,461,193,157,193,363,181,271,445,381,231,135,327,403, & - 171,197,181,343,113,313,393,311,415,267,247,425,233,289,55, & - 39,247,327,141,5,189,183,27,337,341,327,87,429,357,265,251, & - 437,201,29,339,257,377,17,53,327,47,375,393,369,403,125,429, & - 257,157,217,85,267,117,337,447,219,501,41,41,193,509,131,207, & - 505,421,149,111,177,167,223,291,91,29,305,151,177,337,183, & - 361,435,307,507,77,181,507,315,145,423,71,103,493,271,469, & - 339,237,437,483,31,219,61,131,391,233,219,69,57,459,225,421, & - 7,461,111,451,277,185,193,125,251,199,73,71,7,409,417,149/) - v(300:550,9) = (/ & - 193,53,437,29,467,229,31,35,75,105, & - 503,75,317,401,367,131,365,441,433,93,377,405,465,259,283, & - 443,143,445,3,461,329,309,77,323,155,347,45,381,315,463,207, & - 321,157,109,479,313,345,167,439,307,235,473,79,101,245,19, & - 381,251,35,25,107,187,115,113,321,115,445,61,77,293,405,13, & - 53,17,171,299,41,79,3,485,331,13,257,59,201,497,81,451,199, & - 171,81,253,365,75,451,149,483,81,453,469,485,305,163,401,15, & - 91,3,129,35,239,355,211,387,101,299,67,375,405,357,267,363, & - 79,83,437,457,39,97,473,289,179,57,23,49,79,71,341,287,95, & - 229,271,475,49,241,261,495,353,381,13,291,37,251,105,399,81, & - 89,265,507,205,145,331,129,119,503,249,1,289,463,163,443,63, & - 123,361,261,49,429,137,355,175,507,59,277,391,25,185,381,197, & - 39,5,429,119,247,177,329,465,421,271,467,151,45,429,137,471, & - 11,17,409,347,199,463,177,11,51,361,95,497,163,351,127,395, & - 511,327,353,49,105,151,321,331,329,509,107,109,303,467,287, & - 161,45,385,289,363,331,265,407,37,433,315,343,63,51,185,71, & - 27,267/) - v(551:798,9) = (/ & - 503,239,293,245,281,297,75,461,371, & - 129,189,189,339,287,111,111,379,93,27,185,347,337,247,507, & - 161,231,43,499,73,327,263,331,249,493,37,25,115,3,167,197, & - 127,357,497,103,125,191,165,55,101,95,79,351,341,43,125,135, & - 173,289,373,133,421,241,281,213,177,363,151,227,145,363,239, & - 431,81,397,241,67,291,255,405,421,399,75,399,105,329,41,425, & - 7,283,375,475,427,277,209,411,3,137,195,289,509,121,55,147, & - 275,251,19,129,285,415,487,491,193,219,403,23,97,65,285,75, & - 21,373,261,339,239,495,415,333,107,435,297,213,149,463,199, & - 323,45,19,301,121,499,187,229,63,425,99,281,35,125,349,87, & - 101,59,195,511,355,73,263,243,101,165,141,11,389,219,187,449, & - 447,393,477,305,221,51,355,209,499,479,265,377,145,411,173, & - 11,433,483,135,385,341,89,209,391,33,395,319,451,119,341,227, & - 375,61,331,493,411,293,47,203,375,167,395,155,5,237,361,489, & - 127,21,345,101,371,233,431,109,119,277,125,263,73,135,123,83, & - 123,405,69,75,287,401,23,283,393,41,379,431,11,475,505,19, & - 365,265,271/) - v(799:1045,9) = (/ & - 499,489,443,165,91,83,291,319,199, & - 107,245,389,143,137,89,125,281,381,215,131,299,249,375,455, & - 43,73,281,217,297,229,431,357,81,357,171,451,481,13,387,491, & - 489,439,385,487,177,393,33,71,375,443,129,407,395,127,65,333, & - 309,119,197,435,497,373,71,379,509,387,159,265,477,463,449, & - 47,353,249,335,505,89,141,55,235,187,87,363,93,363,101,67, & - 215,321,331,305,261,411,491,479,65,307,469,415,131,315,487, & - 83,455,19,113,163,503,99,499,251,239,81,167,391,255,317,363, & - 359,395,419,307,251,267,171,461,183,465,165,163,293,477,223, & - 403,389,97,335,357,297,19,469,501,249,85,213,311,265,379,297, & - 283,393,449,463,289,159,289,499,407,129,137,221,43,89,403, & - 271,75,83,445,453,389,149,143,423,499,317,445,157,137,453, & - 163,87,23,391,119,427,323,173,89,259,377,511,249,31,363,229, & - 353,329,493,427,57,205,389,91,83,13,219,439,45,35,371,441,17, & - 267,501,53,25,333,17,201,475,257,417,345,381,377,55,403,77, & - 389,347,363,211,413,419,5,167,219,201,285,425,11,77,269,489, & - 281,403,79/) - v(1046:1111,9) = (/ & - 425,125,81,331,437,271,397,299,475, & - 271,249,413,233,261,495,171,69,27,409,21,421,367,81,483,255, & - 15,219,365,497,181,75,431,99,325,407,229,281,63,83,493,5,113, & - 15,271,37,87,451,299,83,451,311,441,47,455,47,253,13,109,369, & - 347,11,409,275,63,441,15/) - v(102:344,10) = (/ & - 519,307,931,1023,517,771,151,1023, & - 539,725,45,927,707,29,125,371,275,279,817,389,453,989,1015, & - 29,169,743,99,923,981,181,693,309,227,111,219,897,377,425, & - 609,227,19,221,143,581,147,919,127,725,793,289,411,835,921, & - 957,443,349,813,5,105,457,393,539,101,197,697,27,343,515,69, & - 485,383,855,693,133,87,743,747,475,87,469,763,721,345,479, & - 965,527,121,271,353,467,177,245,627,113,357,7,691,725,355, & - 889,635,737,429,545,925,357,873,187,351,677,999,921,477,233, & - 765,495,81,953,479,89,173,473,131,961,411,291,967,65,511,13, & - 805,945,369,827,295,163,835,259,207,331,29,315,999,133,967, & - 41,117,677,471,717,881,755,351,723,259,879,455,721,289,149, & - 199,805,987,851,423,597,129,11,733,549,153,285,451,559,377, & - 109,357,143,693,615,677,701,475,767,85,229,509,547,151,389, & - 711,785,657,319,509,99,1007,775,359,697,677,85,497,105,615, & - 891,71,449,835,609,377,693,665,627,215,911,503,729,131,19, & - 895,199,161,239,633,1013,537,255,23,149,679,1021,595,199,557, & - 659,251,829,727,439,495,647,223/) - v(345:586,10) = (/ & - 949,625,87,481,85,799,917,769,949, & - 739,115,499,945,547,225,1015,469,737,495,353,103,17,665,639, & - 525,75,447,185,43,729,577,863,735,317,99,17,477,893,537,519, & - 1017,375,297,325,999,353,343,729,135,489,859,267,141,831,141, & - 893,249,807,53,613,131,547,977,131,999,175,31,341,739,467, & - 675,241,645,247,391,583,183,973,433,367,131,467,571,309,385, & - 977,111,917,935,473,345,411,313,97,149,959,841,839,669,431, & - 51,41,301,247,1015,377,329,945,269,67,979,581,643,823,557,91, & - 405,117,801,509,347,893,303,227,783,555,867,99,703,111,797, & - 873,541,919,513,343,319,517,135,871,917,285,663,301,15,763, & - 89,323,757,317,807,309,1013,345,499,279,711,915,411,281,193, & - 739,365,315,375,809,469,487,621,857,975,537,939,585,129,625, & - 447,129,1017,133,83,3,415,661,53,115,903,49,79,55,385,261, & - 345,297,199,385,617,25,515,275,849,401,471,377,661,535,505, & - 939,465,225,929,219,955,659,441,117,527,427,515,287,191,33, & - 389,197,825,63,417,949,35,571,9,131,609,439,95,19,569,893, & - 451,397,971,801/) - v(587:824,10) = (/ & - 125,471,187,257,67,949,621,453,411, & - 621,955,309,783,893,597,377,753,145,637,941,593,317,555,375, & - 575,175,403,571,555,109,377,931,499,649,653,329,279,271,647, & - 721,665,429,957,803,767,425,477,995,105,495,575,687,385,227, & - 923,563,723,481,717,111,633,113,369,955,253,321,409,909,367, & - 33,967,453,863,449,539,781,911,113,7,219,725,1015,971,1021, & - 525,785,873,191,893,297,507,215,21,153,645,913,755,371,881, & - 113,903,225,49,587,201,927,429,599,513,97,319,331,833,325, & - 887,139,927,399,163,307,803,169,1019,869,537,907,479,335,697, & - 479,353,769,787,1023,855,493,883,521,735,297,1011,991,879, & - 855,591,415,917,375,453,553,189,841,339,211,601,57,765,745, & - 621,209,875,639,7,595,971,263,1009,201,23,77,621,33,535,963, & - 661,523,263,917,103,623,231,47,301,549,337,675,189,357,1005, & - 789,189,319,721,1005,525,675,539,191,813,917,51,167,415,579, & - 755,605,721,837,529,31,327,799,961,279,409,847,649,241,285, & - 545,407,161,591,73,313,811,17,663,269,261,37,783,127,917,231, & - 577,975,793/) - v(825:1065,10) = (/ & - 921,343,751,139,221,79,817,393,545, & - 11,781,71,1,699,767,917,9,107,341,587,903,965,599,507,843, & - 739,579,397,397,325,775,565,925,75,55,979,931,93,957,857,753, & - 965,795,67,5,87,909,97,995,271,875,671,613,33,351,69,811,669, & - 729,401,647,241,435,447,721,271,745,53,775,99,343,451,427, & - 593,339,845,243,345,17,573,421,517,971,499,435,769,75,203, & - 793,985,343,955,735,523,659,703,303,421,951,405,631,825,735, & - 433,841,485,49,749,107,669,211,497,143,99,57,277,969,107,397, & - 563,551,447,381,187,57,405,731,769,923,955,915,737,595,341, & - 253,823,197,321,315,181,885,497,159,571,981,899,785,947,217, & - 217,135,753,623,565,717,903,581,955,621,361,869,87,943,907, & - 853,353,335,197,771,433,743,195,91,1023,63,301,647,205,485, & - 927,1003,987,359,577,147,141,1017,701,273,89,589,487,859,343, & - 91,847,341,173,287,1003,289,639,983,685,697,35,701,645,911, & - 501,705,873,763,745,657,559,699,315,347,429,197,165,955,859, & - 167,303,833,531,473,635,641,195,589,821,205,3,635,371,891, & - 249,123/) - v(1066:1111,10) = (/ & - 77,623,993,401,525,427,71,655,951, & - 357,851,899,535,493,323,1003,343,515,859,1017,5,423,315,1011, & - 703,41,777,163,95,831,79,975,235,633,723,297,589,317,679,981, & - 195,399,1003,121,501,155/) - v(162:376,11) = (/ & - 7,2011,1001,49,825,415,1441,383,1581, & - 623,1621,1319,1387,619,839,217,75,1955,505,281,1629,1379,53, & - 1111,1399,301,209,49,155,1647,631,129,1569,335,67,1955,1611, & - 2021,1305,121,37,877,835,1457,669,1405,935,1735,665,551,789, & - 1543,1267,1027,1,1911,163,1929,67,1975,1681,1413,191,1711, & - 1307,401,725,1229,1403,1609,2035,917,921,1789,41,2003,187,67, & - 1635,717,1449,277,1903,1179,363,1211,1231,647,1261,1029,1485, & - 1309,1149,317,1335,171,243,271,1055,1601,1129,1653,205,1463, & - 1681,1621,197,951,573,1697,1265,1321,1805,1235,1853,1307,945, & - 1197,1411,833,273,1517,1747,1095,1345,869,57,1383,221,1713, & - 335,1751,1141,839,523,1861,1105,389,1177,1877,805,93,1591, & - 423,1835,99,1781,1515,1909,1011,303,385,1635,357,973,1781, & - 1707,1363,1053,649,1469,623,1429,1241,1151,1055,503,921,3, & - 349,1149,293,45,303,877,1565,1583,1001,663,1535,395,1141, & - 1481,1797,643,1507,465,2027,1695,367,937,719,545,1991,83,819, & - 239,1791,1461,1647,1501,1161,1629,139,1595,1921,1267,1415, & - 509,347,777,1083,363,269,1015/) - v(377:589,11) = (/ & - 1809,1105,1429,1471,2019,381,2025, & - 1223,827,1733,887,1321,803,1951,1297,1995,833,1107,1135,1181, & - 1251,983,1389,1565,273,137,71,735,1005,933,67,1471,551,457, & - 1667,1729,919,285,1629,1815,653,1919,1039,531,393,1411,359, & - 221,699,1485,471,1357,1715,595,1677,153,1903,1281,215,781, & - 543,293,1807,965,1695,443,1985,321,879,1227,1915,839,1945, & - 1993,1165,51,557,723,1491,817,1237,947,1215,1911,1225,1965, & - 1889,1503,1177,73,1767,303,177,1897,1401,321,921,217,1779, & - 327,1889,333,615,1665,1825,1639,237,1205,361,129,1655,983, & - 1089,1171,401,677,643,749,303,1407,1873,1579,1491,1393,1247, & - 789,763,49,5,1607,1891,735,1557,1909,1765,1777,1127,813,695, & - 97,731,1503,1751,333,769,865,693,377,1919,957,1359,1627,1039, & - 1783,1065,1665,1917,1947,991,1997,841,459,221,327,1595,1881, & - 1269,1007,129,1413,475,1105,791,1983,1359,503,691,659,691, & - 343,1375,1919,263,1373,603,1383,297,781,145,285,767,1739, & - 1715,715,317,1333,85,831,1615,81,1667,1467,1457,1453,1825, & - 109,387,1207,2039,213,1351,1329,1173/) - v(590:802,11) = (/ & - 57,1769,951,183,23,451,1155,1551, & - 2037,811,635,1671,1451,863,1499,1673,363,1029,1077,1525,277, & - 1023,655,665,1869,1255,965,277,1601,329,1603,1901,395,65, & - 1307,2029,21,1321,543,1569,1185,1905,1701,413,2041,1697,725, & - 1417,1847,411,211,915,1891,17,1877,1699,687,1089,1973,1809, & - 851,1495,1257,63,1323,1307,609,881,1543,177,617,1505,1747, & - 1537,925,183,77,1723,1877,1703,397,459,521,257,1177,389,1947, & - 1553,1583,1831,261,485,289,1281,1543,1591,1123,573,821,1065, & - 1933,1373,2005,905,207,173,1573,1597,573,1883,1795,1499,1743, & - 553,335,333,1645,791,871,1157,969,557,141,223,1129,1685,423, & - 1069,391,99,95,1847,531,1859,1833,1833,341,237,1997,1799,409, & - 431,1917,363,335,1039,1085,1657,1975,1527,1111,659,389,899, & - 595,1439,1861,1979,1569,1087,1009,165,1895,1481,1583,29,1193, & - 1673,1075,301,1081,1377,1747,1497,1103,1789,887,739,1577,313, & - 1367,1299,1801,1131,1837,73,1865,1065,843,635,55,1655,913, & - 1037,223,1871,1161,461,479,511,1721,1107,389,151,35,375,1099, & - 937,1185,1701,769,639,1633/) - v(803:1018,11) = (/ & - 1609,379,1613,2031,685,289,975,671, & - 1599,1447,871,647,99,139,1427,959,89,117,841,891,1959,223, & - 1697,1145,499,1435,1809,1413,1445,1675,171,1073,1349,1545, & - 2039,1027,1563,859,215,1673,1919,1633,779,411,1845,1477,1489, & - 447,1545,351,1989,495,183,1639,1385,1805,1097,1249,1431,1571, & - 591,697,1509,709,31,1563,165,513,1425,1299,1081,145,1841, & - 1211,941,609,845,1169,1865,1593,347,293,1277,157,211,93,1679, & - 1799,527,41,473,563,187,1525,575,1579,857,703,1211,647,709, & - 981,285,697,163,981,153,1515,47,1553,599,225,1147,381,135, & - 821,1965,609,1033,983,503,1117,327,453,2005,1257,343,1649, & - 1199,599,1877,569,695,1587,1475,187,973,233,511,51,1083,665, & - 1321,531,1875,1939,859,1507,1979,1203,1965,737,921,1565,1943, & - 819,223,365,167,1705,413,1577,745,1573,655,1633,1003,91,1123, & - 477,1741,1663,35,715,37,1513,815,941,1379,263,1831,1735,1111, & - 1449,353,1941,1655,1349,877,285,1723,125,1753,985,723,175, & - 439,791,1051,1261,717,1555,1757,1777,577,1583,1957,873,331, & - 1163,313,1,1963,963,1905,821/) - v(1019:1111,11) = (/ & - 1677,185,709,545,1723,215,1885, & - 1249,583,1803,839,885,485,413,1767,425,129,1035,329,1263, & - 1881,1779,1565,359,367,453,707,1419,831,1889,887,1871,1869, & - 747,223,1547,1799,433,1441,553,2021,1303,1505,1735,1619,1065, & - 1161,2047,347,867,881,1447,329,781,1065,219,589,645,1257, & - 1833,749,1841,1733,1179,1191,1025,1639,1955,1423,1685,1711, & - 493,549,783,1653,397,895,233,759,1505,677,1449,1573,1297, & - 1821,1691,791,289,1187,867,1535,575,183/) - v(338:545,12) = (/ & - 3915,97,3047,937,2897,953,127,1201, & - 3819,193,2053,3061,3759,1553,2007,2493,603,3343,3751,1059, & - 783,1789,1589,283,1093,3919,2747,277,2605,2169,2905,721,4069, & - 233,261,1137,3993,3619,2881,1275,3865,1299,3757,1193,733,993, & - 1153,2945,3163,3179,437,271,3493,3971,1005,2615,2253,1131, & - 585,2775,2171,2383,2937,2447,1745,663,1515,3767,2709,1767, & - 3185,3017,2815,1829,87,3341,793,2627,2169,1875,3745,367,3783, & - 783,827,3253,2639,2955,3539,1579,2109,379,2939,3019,1999, & - 2253,2911,3733,481,1767,1055,4019,4085,105,1829,2097,2379, & - 1567,2713,737,3423,3941,2659,3961,1755,3613,1937,1559,2287, & - 2743,67,2859,325,2601,1149,3259,2403,3947,2011,175,3389,3915, & - 1315,2447,141,359,3609,3933,729,2051,1755,2149,2107,1741, & - 1051,3681,471,1055,845,257,1559,1061,2803,2219,1315,1369, & - 3211,4027,105,11,1077,2857,337,3553,3503,3917,2665,3823,3403, & - 3711,2085,1103,1641,701,4095,2883,1435,653,2363,1597,767,869, & - 1825,1117,1297,501,505,149,873,2673,551,1499,2793,3277,2143, & - 3663,533,3991,575,1877,1009,3929,473,3009,2595,3249,675,3593/) - v(546:752,12) = (/ & - 2453,1567,973,595,1335,1715,589,85, & - 2265,3069,461,1659,2627,1307,1731,1501,1699,3545,3803,2157, & - 453,2813,2047,2999,3841,2361,1079,573,69,1363,1597,3427,2899, & - 2771,1327,1117,1523,3521,2393,2537,1979,3179,683,2453,453, & - 1227,779,671,3483,2135,3139,3381,3945,57,1541,3405,3381,2371, & - 2879,1985,987,3017,3031,3839,1401,3749,2977,681,1175,1519, & - 3355,907,117,771,3741,3337,1743,1227,3335,2755,1909,3603, & - 2397,653,87,2025,2617,3257,287,3051,3809,897,2215,63,2043, & - 1757,3671,297,3131,1305,293,3865,3173,3397,2269,3673,717, & - 3041,3341,3595,3819,2871,3973,1129,513,871,1485,3977,2473, & - 1171,1143,3063,3547,2183,3993,133,2529,2699,233,2355,231, & - 3241,611,1309,3829,1839,1495,301,1169,1613,2673,243,3601, & - 3669,2813,2671,2679,3463,2477,1795,617,2317,1855,1057,1703, & - 1761,2515,801,1205,1311,473,3963,697,1221,251,381,3887,1761, & - 3093,3721,2079,4085,379,3601,3845,433,1781,29,1897,1599,2163, & - 75,3475,3957,1641,3911,2959,2833,1279,1099,403,799,2183,2699, & - 1711,2037,727,289,1785,1575,3633,2367,1261,3953,1735,171, & - 1959/) - v(753:960,12) = (/ & - 2867,859,2951,3211,15,1279,1323,599, & - 1651,3951,1011,315,3513,3351,1725,3793,2399,287,4017,3571, & - 1007,541,3115,429,1585,1285,755,1211,3047,915,3611,2697,2129, & - 3669,81,3939,2437,915,779,3567,3701,2479,3807,1893,3927,2619, & - 2543,3633,2007,3857,3837,487,1769,3759,3105,2727,3155,2479, & - 1341,1657,2767,2541,577,2105,799,17,2871,3637,953,65,69,2897, & - 3841,3559,4067,2335,3409,1087,425,2813,1705,1701,1237,821, & - 1375,3673,2693,3925,1541,1871,2285,847,4035,1101,2029,855, & - 2733,2503,121,2855,1069,3463,3505,1539,607,1349,575,2301, & - 2321,1101,333,291,2171,4085,2173,2541,1195,925,4039,1379,699, & - 1979,275,953,1755,1643,325,101,2263,3329,3673,3413,1977,2727, & - 2313,1419,887,609,2475,591,2613,2081,3805,3435,2409,111,3557, & - 3607,903,231,3059,473,2959,2925,3861,2043,3887,351,2865,369, & - 1377,2639,1261,3625,3279,2201,2949,3049,449,1297,897,1891, & - 411,2773,749,2753,1825,853,2775,3547,3923,3923,987,3723,2189, & - 3877,3577,297,2763,1845,3083,2951,483,2169,3985,245,3655, & - 3441,1023,235,835,3693,3585,327,1003,543,3059,2637/) - v(961:1111,12) = (/ & - 2923,87,3617,1031,1043,903,2913, & - 2177,2641,3279,389,2009,525,4085,3299,987,2409,813,2683,373, & - 2695,3775,2375,1119,2791,223,325,587,1379,2877,2867,3793,655, & - 831,3425,1663,1681,2657,1865,3943,2977,1979,2271,3247,1267, & - 1747,811,159,429,2001,1195,3065,553,1499,3529,1081,2877,3077, & - 845,1793,2409,3995,2559,4081,1195,2955,1117,1409,785,287, & - 1521,1607,85,3055,3123,2533,2329,3477,799,3683,3715,337,3139, & - 3311,431,3511,2299,365,2941,3067,1331,1081,1097,2853,2299, & - 495,1745,749,3819,619,1059,3559,183,3743,723,949,3501,733, & - 2599,3983,3961,911,1899,985,2493,1795,653,157,433,2361,3093, & - 3119,3679,2367,1701,1445,1321,2397,1241,3305,3985,2349,4067, & - 3805,3073,2837,1567,3783,451,2441,1181,487,543,1201,3735, & - 2517,733,1535,2175,3613,3019/) - v(482:680,13) = (/ & - 2319,653,1379,1675,1951,7075,2087, & - 7147,1427,893,171,2019,7235,5697,3615,1961,7517,6849,2893, & - 1883,2863,2173,4543,73,381,3893,6045,1643,7669,1027,1549, & - 3983,1985,6589,7497,2745,2375,7047,1117,1171,1975,5199,3915, & - 3695,8113,4303,3773,7705,6855,1675,2245,2817,1719,569,1021, & - 2077,5945,1833,2631,4851,6371,833,7987,331,1899,8093,6719, & - 6903,5903,5657,5007,2689,6637,2675,1645,1819,689,6709,7717, & - 6295,7013,7695,3705,7069,2621,3631,6571,6259,7261,3397,7645, & - 1115,4753,2047,7579,2271,5403,4911,7629,4225,1209,6955,6951, & - 1829,5579,5231,1783,4285,7425,599,5785,3275,5643,2263,657, & - 6769,6261,1251,3249,4447,4111,3991,1215,131,4397,3487,7585, & - 5565,7199,3573,7105,7409,1671,949,3889,5971,3333,225,3647, & - 5403,3409,7459,6879,5789,6567,5581,4919,1927,4407,8085,4691, & - 611,3005,591,753,589,171,5729,5891,1033,3049,6567,5257,8003, & - 1757,4489,4923,6379,5171,1757,689,3081,1389,4113,455,2761, & - 847,7575,5829,633,6629,1103,7635,803,6175,6587,2711,3879,67, & - 1179,4761,7281,1557,3379,2459,4273,4127,7147,35/) - v(681:877,13) = (/ & - 3549,395,3735,5787,4179,5889,5057, & - 7473,4713,2133,2897,1841,2125,1029,1695,6523,1143,5105,7133, & - 3351,2775,3971,4503,7589,5155,4305,1641,4717,2427,5617,1267, & - 399,5831,4305,4241,3395,3045,4899,1713,171,411,7099,5473, & - 5209,1195,1077,1309,2953,7343,4887,3229,6759,6721,6775,675, & - 4039,2493,7511,3269,4199,6625,7943,2013,4145,667,513,2303, & - 4591,7941,2741,987,8061,3161,5951,1431,831,5559,7405,1357, & - 4319,4235,5421,2559,4415,2439,823,1725,6219,4903,6699,5451, & - 349,7703,2927,7809,6179,1417,5987,3017,4983,3479,4525,4643, & - 4911,227,5475,2287,5581,6817,1937,1421,4415,7977,1789,3907, & - 6815,6789,6003,5609,4507,337,7427,7943,3075,6427,1019,7121, & - 4763,81,3587,2929,1795,8067,2415,1265,4025,5599,4771,3025, & - 2313,6129,7611,6881,5253,4413,7869,105,3173,1629,2537,1023, & - 4409,7209,4413,7107,7469,33,1955,2881,5167,6451,4211,179, & - 5573,7879,3387,7759,5455,7157,1891,5683,5689,6535,3109,6555, & - 6873,1249,4251,6437,49,2745,1201,7327,4179,6783,623,2779, & - 5963,2585,6927,5333,4033,285,7467,4443,4917,3/) - v(878:1070,13) = (/ & - 4319,5517,3449,813,5499,2515,5771, & - 3357,2073,4395,4925,2643,7215,5817,1199,1597,1619,7535,4833, & - 609,4797,8171,6847,793,6757,8165,3371,2431,5235,4739,7703, & - 7223,6525,5891,5605,4433,3533,5267,5125,5037,225,6717,1121, & - 5741,2013,4327,4839,569,5227,7677,4315,2391,5551,859,3627, & - 6377,3903,4311,6527,7573,4905,7731,1909,1555,3279,1949,1887, & - 6675,5509,2033,5473,3539,5033,5935,6095,4761,1771,1271,1717, & - 4415,5083,6277,3147,7695,2461,4783,4539,5833,5583,651,1419, & - 2605,5511,3913,5795,2333,2329,4431,3725,6069,2699,7055,6879, & - 1017,3121,2547,4603,2385,6915,6103,5669,7833,2001,4287,6619, & - 955,2761,5711,6291,3415,3909,2841,5627,4939,7671,6059,6275, & - 6517,1931,4583,7301,1267,7509,1435,2169,6939,3515,2985,2787, & - 2123,1969,3307,353,4359,7059,5273,5873,6657,6765,6229,3179, & - 1583,6237,2155,371,273,7491,3309,6805,3015,6831,7819,713, & - 4747,3935,4109,1311,709,3089,7059,4247,2989,1509,4919,1841, & - 3045,3821,6929,4655,1333,6429,6649,2131,5265,1051,261,8057, & - 3379,2179,1993,5655,3063,6381/) - v(1071:1111,13) = (/ & - 3587,7417,1579,1541,2107,5085,2873, & - 6141,955,3537,2157,841,1999,1465,5171,5651,1535,7235,4349, & - 1263,1453,1005,6893,2919,1947,1635,3963,397,969,4569,655, & - 6737,2995,7235,7713,973,4821,2377,1673,1,6541/) -! -! Set POLY. -! - poly(1:211)= (/ & - 1,3,7,11,13,19,25,37,59,47,61,55,41,67,97,91, & - 109,103,115,131,193,137,145,143,241,157,185,167,229,171,213, & - 191,253,203,211,239,247,285,369,299,301,333,351,355,357,361, & - 391,397,425,451,463,487,501,529,539,545,557,563,601,607,617, & - 623,631,637,647,661,675,677,687,695,701,719,721,731,757,761, & - 787,789,799,803,817,827,847,859,865,875,877,883,895,901,911, & - 949,953,967,971,973,981,985,995,1001,1019,1033,1051,1063, & - 1069,1125,1135,1153,1163,1221,1239,1255,1267,1279,1293,1305, & - 1315,1329,1341,1347,1367,1387,1413,1423,1431,1441,1479,1509, & - 1527,1531,1555,1557,1573,1591,1603,1615,1627,1657,1663,1673, & - 1717,1729,1747,1759,1789,1815,1821,1825,1849,1863,1869,1877, & - 1881,1891,1917,1933,1939,1969,2011,2035,2041,2053,2071,2091, & - 2093,2119,2147,2149,2161,2171,2189,2197,2207,2217,2225,2255, & - 2257,2273,2279,2283,2293,2317,2323,2341,2345,2363,2365,2373, & - 2377,2385,2395,2419,2421,2431,2435,2447,2475,2477,2489,2503, & - 2521,2533,2551,2561,2567,2579,2581,2601,2633,2657,2669/) - poly(212:401)= (/ & - 2681,2687,2693,2705,2717,2727,2731,2739, & - 2741,2773,2783,2793,2799,2801,2811,2819,2825,2833,2867,2879, & - 2881,2891,2905,2911,2917,2927,2941,2951,2955,2963,2965,2991, & - 2999,3005,3017,3035,3037,3047,3053,3083,3085,3097,3103,3159, & - 3169,3179,3187,3205,3209,3223,3227,3229,3251,3263,3271,3277, & - 3283,3285,3299,3305,3319,3331,3343,3357,3367,3373,3393,3399, & - 3413,3417,3427,3439,3441,3475,3487,3497,3515,3517,3529,3543, & - 3547,3553,3559,3573,3589,3613,3617,3623,3627,3635,3641,3655, & - 3659,3669,3679,3697,3707,3709,3713,3731,3743,3747,3771,3791, & - 3805,3827,3833,3851,3865,3889,3895,3933,3947,3949,3957,3971, & - 3985,3991,3995,4007,4013,4021,4045,4051,4069,4073,4179,4201, & - 4219,4221,4249,4305,4331,4359,4383,4387,4411,4431,4439,4449, & - 4459,4485,4531,4569,4575,4621,4663,4669,4711,4723,4735,4793, & - 4801,4811,4879,4893,4897,4921,4927,4941,4977,5017,5027,5033, & - 5127,5169,5175,5199,5213,5223,5237,5287,5293,5331,5391,5405, & - 5453,5523,5573,5591,5597,5611,5641,5703,5717,5721,5797,5821, & - 5909,5913/) - poly(402:591)= (/ & - 5955,5957,6005,6025,6061,6067,6079,6081, & - 6231,6237,6289,6295,6329,6383,6427,6453,6465,6501,6523,6539, & - 6577,6589,6601,6607,6631,6683,6699,6707,6761,6795,6865,6881, & - 6901,6923,6931,6943,6999,7057,7079,7103,7105,7123,7173,7185, & - 7191,7207,7245,7303,7327,7333,7355,7365,7369,7375,7411,7431, & - 7459,7491,7505,7515,7541,7557,7561,7701,7705,7727,7749,7761, & - 7783,7795,7823,7907,7953,7963,7975,8049,8089,8123,8125,8137, & - 8219,8231,8245,8275,8293,8303,8331,8333,8351,8357,8367,8379, & - 8381,8387,8393,8417,8435,8461,8469,8489,8495,8507,8515,8551, & - 8555,8569,8585,8599,8605,8639,8641,8647,8653,8671,8675,8689, & - 8699,8729,8741,8759,8765,8771,8795,8797,8825,8831,8841,8855, & - 8859,8883,8895,8909,8943,8951,8955,8965,8999,9003,9031,9045, & - 9049,9071,9073,9085,9095,9101,9109,9123,9129,9137,9143,9147, & - 9185,9197,9209,9227,9235,9247,9253,9257,9277,9297,9303,9313, & - 9325,9343,9347,9371,9373,9397,9407,9409,9415,9419,9443,9481, & - 9495,9501,9505,9517,9529,9555,9557,9571,9585,9591,9607,9611, & - 9621,9625/) - poly(592:765)= (/ & - 9631,9647,9661,9669,9679,9687,9707,9731, & - 9733,9745,9773,9791,9803,9811,9817,9833,9847,9851,9863,9875, & - 9881,9905,9911,9917,9923,9963,9973,10003,10025,10043,10063, & - 10071,10077,10091,10099,10105,10115,10129,10145,10169,10183, & - 10187,10207,10223,10225,10247,10265,10271,10275,10289,10299, & - 10301,10309,10343,10357,10373,10411,10413,10431,10445,10453, & - 10463,10467,10473,10491,10505,10511,10513,10523,10539,10549, & - 10559,10561,10571,10581,10615,10621,10625,10643,10655,10671, & - 10679,10685,10691,10711,10739,10741,10755,10767,10781,10785, & - 10803,10805,10829,10857,10863,10865,10875,10877,10917,10921, & - 10929,10949,10967,10971,10987,10995,11009,11029,11043,11045, & - 11055,11063,11075,11081,11117,11135,11141,11159,11163,11181, & - 11187,11225,11237,11261,11279,11297,11307,11309,11327,11329, & - 11341,11377,11403,11405,11413,11427,11439,11453,11461,11473, & - 11479,11489,11495,11499,11533,11545,11561,11567,11575,11579, & - 11589,11611,11623,11637,11657,11663,11687,11691,11701,11747, & - 11761,11773,11783,11795,11797,11817,11849,11855,11867,11869, & - 11873,11883,11919/) - poly(766:936)= (/ & - 11921,11927,11933,11947,11955,11961, & - 11999,12027,12029,12037,12041,12049,12055,12095,12097,12107, & - 12109,12121,12127,12133,12137,12181,12197,12207,12209,12239, & - 12253,12263,12269,12277,12287,12295,12309,12313,12335,12361, & - 12367,12391,12409,12415,12433,12449,12469,12479,12481,12499, & - 12505,12517,12527,12549,12559,12597,12615,12621,12639,12643, & - 12657,12667,12707,12713,12727,12741,12745,12763,12769,12779, & - 12781,12787,12799,12809,12815,12829,12839,12857,12875,12883, & - 12889,12901,12929,12947,12953,12959,12969,12983,12987,12995, & - 13015,13019,13031,13063,13077,13103,13137,13149,13173,13207, & - 13211,13227,13241,13249,13255,13269,13283,13285,13303,13307, & - 13321,13339,13351,13377,13389,13407,13417,13431,13435,13447, & - 13459,13465,13477,13501,13513,13531,13543,13561,13581,13599, & - 13605,13617,13623,13637,13647,13661,13677,13683,13695,13725, & - 13729,13753,13773,13781,13785,13795,13801,13807,13825,13835, & - 13855,13861,13871,13883,13897,13905,13915,13939,13941,13969, & - 13979,13981,13997,14027,14035,14037,14051,14063,14085,14095, & - 14107,14113,14125,14137,14145/) - poly(937:1107)= (/ & - 14151,14163,14193,14199,14219,14229, & - 14233,14243,14277,14287,14289,14295,14301,14305,14323,14339, & - 14341,14359,14365,14375,14387,14411,14425,14441,14449,14499, & - 14513,14523,14537,14543,14561,14579,14585,14593,14599,14603, & - 14611,14641,14671,14695,14701,14723,14725,14743,14753,14759, & - 14765,14795,14797,14803,14831,14839,14845,14855,14889,14895, & - 14909,14929,14941,14945,14951,14963,14965,14985,15033,15039, & - 15053,15059,15061,15071,15077,15081,15099,15121,15147,15149, & - 15157,15167,15187,15193,15203,15205,15215,15217,15223,15243, & - 15257,15269,15273,15287,15291,15313,15335,15347,15359,15373, & - 15379,15381,15391,15395,15397,15419,15439,15453,15469,15491, & - 15503,15517,15527,15531,15545,15559,15593,15611,15613,15619, & - 15639,15643,15649,15661,15667,15669,15681,15693,15717,15721, & - 15741,15745,15765,15793,15799,15811,15825,15835,15847,15851, & - 15865,15877,15881,15887,15899,15915,15935,15937,15955,15973, & - 15977,16011,16035,16061,16069,16087,16093,16097,16121,16141, & - 16153,16159,16165,16183,16189,16195,16197,16201,16209,16215, & - 16225,16259,16265,16273,16299/) - poly(1108:1111)= (/ & - 16309,16355,16375,16381/) - - end if - - if ( dim_num /= dim_num_save ) then -! -! Check parameters. -! - if ( dim_num < 2 .or. dim_max < dim_num ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I4_SOBOL - Fatal error!' - write ( *, '(a)' ) ' The spatial dimension DIM_NUM should satisfy:' - write ( *, '(a,i8)' ) ' 2 <= DIM_NUM <= ', dim_max - write ( *, '(a,i8)' ) ' But this input value is DIM_NUM = ', dim_num - stop - end if - - dim_num_save = dim_num -! -! Set ATMOST = 2**LOG_MAX - 1. -! - atmost = 0 - do i = 1, log_max - atmost = 2 * atmost + 1 - end do -! -! Find the highest 1 bit in ATMOST (should be LOG_MAX). -! - maxcol = i4_bit_hi1 ( atmost ) -! -! Initialize row 1 of V. -! - v(1,1:maxcol) = 1 -! -! Initialize the remaining rows of V. -! - do i = 2, dim_num -! -! The bit pattern of the integer POLY(I) gives the form -! of polynomial I. -! -! Find the degree of polynomial I from binary encoding. -! - j = poly(i) - m = 0 - - do - - j = j / 2 - - if ( j <= 0 ) then - exit - end if - - m = m + 1 - - end do -! -! We expand this bit pattern to separate components -! of the logical array INCLUD. -! - j = poly(i) - do k = m, 1, - 1 - j2 = j / 2 - includ(k) = ( j /= ( 2 * j2 ) ) - j = j2 - end do -! -! Calculate the remaining elements of row I as explained -! in Bratley and Fox, section 2. -! - do j = m + 1, maxcol - - newv = v(i,j-m) - l = 1 - - do k = 1, m - - l = 2 * l - - if ( includ(k) ) then - newv = ieor ( newv, l * v(i,j-k) ) - end if - - end do - - v(i,j) = newv - - end do - - end do -! -! Multiply columns of V by appropriate power of 2. -! - l = 1 - do j = maxcol - 1, 1, - 1 - l = 2 * l - v(1:dim_num,j) = v(1:dim_num,j) * l - end do -! -! RECIPD is 1/(common denominator of the elements in V) = 1 / ( 2 * L ). -! - recipd = real ( l, kind = 4 ) - recipd = 0.5E+00 / recipd - - end if - - if ( seed < 0 ) then - seed = 0 - end if - - if ( seed == 0 ) then - - l = 1 - lastq(1:dim_num) = 0 - - else if ( seed == seed_save + 1 ) then -! -! Find the position of the right-hand zero in SEED. -! - l = i4_bit_lo0 ( seed ) - - else if ( seed <= seed_save ) then - - seed_save = 0 - l = 1 - lastq(1:dim_num) = 0 - - do seed_temp = seed_save, seed - 1 - l = i4_bit_lo0 ( seed_temp ) - lastq(1:dim_num) = ieor ( lastq(1:dim_num), v(1:dim_num,l) ) - end do - - l = i4_bit_lo0 ( seed ) - - else if ( seed_save+1 < seed ) then - - do seed_temp = seed_save+1, seed - 1 - l = i4_bit_lo0 ( seed_temp ) - lastq(1:dim_num) = ieor ( lastq(1:dim_num), v(1:dim_num,l) ) - end do - - l = i4_bit_lo0 ( seed ) - - end if - -! write ( *, * ) ' seed = ', seed, ' l = ', l -! -! Check that the user is not calling too many times! -! - if ( maxcol < l ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I4_SOBOL - Fatal error!' - write ( *, '(a)' ) ' Too many calls!' - write ( *, '(a,i12)' ) ' MAXCOL = ', maxcol - write ( *, '(a,i12)' ) ' L = ', l - stop - end if -! -! Calculate the new components of QUASI. -! - quasi(1:dim_num) = real ( lastq(1:dim_num), kind = 4 ) * recipd - lastq(1:dim_num) = ieor ( lastq(1:dim_num), v(1:dim_num,l) ) - - seed_save = seed - seed = seed + 1 - - return -end -subroutine i4_sobol_generate ( m, n, skip, r ) - -!*****************************************************************************80 -! -!! I4_SOBOL_GENERATE generates a Sobol dataset. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, the spatial dimension. -! -! Input, integer ( kind = 4 ) N, the number of points to generate. -! -! Input, integer ( kind = 4 ) SKIP, the number of initial points to skip. -! -! Output, real ( kind = 4 ) R(M,N), the points. -! - implicit none - - integer ( kind = 4 ) m - integer ( kind = 4 ) n - - integer ( kind = 4 ) j - real ( kind = 4 ), dimension ( m, n ) :: r - integer ( kind = 4 ) seed - integer ( kind = 4 ) skip - - do j = 1, n - seed = skip + j - 1 - call i4_sobol ( m, seed, r(1:m,j) ) - end do - - return -end -subroutine i4_sobol_write ( m, n, skip, r, file_out_name ) - -!*****************************************************************************80 -! -!! I4_SOBOL_WRITE writes a Sobol dataset to a file. -! -! Discussion: -! -! The initial lines of the file are comments, which begin with a -! '#' character. -! -! Thereafter, each line of the file contains the M-dimensional -! components of the SKIP+I-1 entry of the Sobol sequence. -! -! For the Sobol sequence, the value of SKIP is the same -! as the value of SEED used to generate the first point. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer M, the spatial dimension. -! -! Input, integer N, the number of (successive) points. -! -! Input, integer SKIP, the number of skipped points. -! -! Input, real R(M,N), the points. -! -! Input, character ( len = * ) FILE_OUT_NAME, the name of -! the output file. -! - implicit none - - integer ( kind = 4 ) m - integer ( kind = 4 ) n - - character ( len = * ) file_out_name - integer file_out_unit - integer ios - integer ( kind = 4 ) j - real ( kind = 4 ) r(m,n) - integer ( kind = 4 ) skip - character string - - call get_unit ( file_out_unit ) - - open ( unit = file_out_unit, file = file_out_name, status = 'replace', & - iostat = ios ) - - if ( ios /= 0 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I4_SOBOL_WRITE - Fatal error!' - write ( *, '(a)' ) ' Could not open the output file.' - stop - end if - - call timestring ( string ) - - write ( file_out_unit, '(a)' ) '# ' // trim ( file_out_name ) - write ( file_out_unit, '(a)' ) '# created by I4_SOBOL_WRITE.F90.' - write ( file_out_unit, '(a)' ) '#' - write ( file_out_unit, '(a)' ) '# File generated on ' & - // trim ( string ) - write ( file_out_unit, '(a)' ) '#' - write ( file_out_unit, '(a,i8)' ) '# Spatial dimension M = ', m - write ( file_out_unit, '(a,i8)' ) '# Number of points N = ', n - write ( file_out_unit, '(a,g14.6)' ) '# Epsilon (unit roundoff) = ', & - epsilon ( r(1,1) ) - write ( file_out_unit, '(a,i8)' ) '# Initial values skipped = ', skip - write ( file_out_unit, '(a)' ) '#' - - write ( string, '(a,i3,a)' ) '(', m, '(2x,f10.6))' - do j = 1, n - write ( file_out_unit, string ) r(1:m,j) - end do - - close ( unit = file_out_unit ) - - return -end -function i4_uniform ( a, b, seed ) - -!*****************************************************************************80 -! -!! I4_UNIFORM returns a scaled pseudorandom I4. -! -! Discussion: -! -! An I4 is an integer ( kind = 4 ) value. -! -! The pseudorandom number will be scaled to be uniformly distributed -! between A and B. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 November 2006 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Paul Bratley, Bennett Fox, Linus Schrage, -! A Guide to Simulation, -! Springer Verlag, pages 201-202, 1983. -! -! Pierre L'Ecuyer, -! Random Number Generation, -! in Handbook of Simulation, -! edited by Jerry Banks, -! Wiley Interscience, page 95, 1998. -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, pages 362-376, 1986. -! -! Peter Lewis, Allen Goodman, James Miller -! A Pseudo-Random Number Generator for the System/360, -! IBM Systems Journal, -! Volume 8, pages 136-143, 1969. -! -! Parameters: -! -! Input, integer ( kind = 4 ) A, B, the limits of the interval. -! -! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which -! should NOT be 0. On output, SEED has been updated. -! -! Output, integer ( kind = 4 ) I4_UNIFORM, a number between A and B. -! - implicit none - - integer ( kind = 4 ) a - integer ( kind = 4 ) b - integer ( kind = 4 ) i4_uniform - integer ( kind = 4 ) k - real ( kind = 4 ) r - integer ( kind = 4 ) seed - integer ( kind = 4 ) value - - if ( seed == 0 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I4_UNIFORM - Fatal error!' - write ( *, '(a)' ) ' Input value of SEED = 0.' - stop - end if - - k = seed / 127773 - - seed = 16807 * ( seed - k * 127773 ) - k * 2836 - - if ( seed < 0 ) then - seed = seed + 2147483647 - end if - - r = real ( seed, kind = 4 ) * 4.656612875E-10 -! -! Scale R to lie between A-0.5 and B+0.5. -! - r = ( 1.0E+00 - r ) * ( real ( min ( a, b ), kind = 4 ) - 0.5E+00 ) & - + r * ( real ( max ( a, b ), kind = 4 ) + 0.5E+00 ) -! -! Use rounding to convert R to an integer between A and B. -! - value = nint ( r, kind = 4 ) - - value = max ( value, min ( a, b ) ) - value = min ( value, max ( a, b ) ) - - i4_uniform = value - - return -end -function i4_xor ( i, j ) - -!*****************************************************************************80 -! -!! I4_XOR calculates the exclusive OR of two integers. -! -! Discussion: -! -! This function is NOT needed in FORTRAN90, which supplies the -! intrinsic IEOR function for this purpose. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) I, J, two values whose exclusive OR is needed. -! -! Output, integer ( kind = 4 ) I4_XOR, the exclusive OR of I and J. -! - implicit none - - integer ( kind = 4 ) i - integer ( kind = 4 ) i1 - integer ( kind = 4 ) i2 - integer ( kind = 4 ) i4_xor - integer ( kind = 4 ) j - integer ( kind = 4 ) j1 - integer ( kind = 4 ) j2 - integer ( kind = 4 ) k - integer ( kind = 4 ) l - - i1 = i - j1 = j - k = 0 - l = 1 - - do while ( i1 /= 0 .or. j1 /= 0 ) - - i2 = i1 / 2 - j2 = j1 / 2 - - if ( & - ( ( i1 == 2 * i2 ) .and. ( j1 /= 2 * j2 ) ) .or. & - ( ( i1 /= 2 * i2 ) .and. ( j1 == 2 * j2 ) ) ) then - k = k + l - end if - - i1 = i2 - j1 = j2 - l = 2 * l - - end do - - i4_xor = k - - return -end -function i8_bit_hi1 ( n ) - -!*****************************************************************************80 -! -!! I8_BIT_HI1 returns the position of the high 1 bit base 2 in an integer. -! -! Discussion: -! -! This routine uses the integer precision corresponding to a KIND of 8. -! -! Example: -! -! N Binary Hi 1 -! ---- -------- ---- -! 0 0 0 -! 1 1 1 -! 2 10 2 -! 3 11 2 -! 4 100 3 -! 5 101 3 -! 6 110 3 -! 7 111 3 -! 8 1000 4 -! 9 1001 4 -! 10 1010 4 -! 11 1011 4 -! 12 1100 4 -! 13 1101 4 -! 14 1110 4 -! 15 1111 4 -! 16 10000 5 -! 17 10001 5 -! 1023 1111111111 10 -! 1024 10000000000 11 -! 1025 10000000001 11 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 May 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 8 ) N, the integer to be measured. -! N should be nonnegative. If N is nonpositive, I8_BIT_HI1 -! will always be 0. -! -! Output, integer ( kind = 8 ) I8_BIT_HI1, the number of bits base 2. -! - implicit none - - integer ( kind = 8 ) :: bit - integer ( kind = 8 ) :: i8_bit_hi1 - integer ( kind = 8 ) :: i - integer ( kind = 8 ) :: n - - i = n - bit = 0 - - do - - if ( i <= 0 ) then - exit - end if - - bit = bit + 1 - i = i / 2 - - end do - - i8_bit_hi1 = bit - - return -end -function i8_bit_lo0 ( n ) - -!*****************************************************************************80 -! -!! I8_BIT_LO0 returns the position of the low 0 bit base 2 in an integer. -! -! Discussion: -! -! This routine uses the integer precision corresponding to a KIND of 8. -! -! Example: -! -! N Binary Lo 0 -! ---- -------- ---- -! 0 0 1 -! 1 1 2 -! 2 10 1 -! 3 11 3 -! 4 100 1 -! 5 101 2 -! 6 110 1 -! 7 111 4 -! 8 1000 1 -! 9 1001 2 -! 10 1010 1 -! 11 1011 3 -! 12 1100 1 -! 13 1101 2 -! 14 1110 1 -! 15 1111 5 -! 16 10000 1 -! 17 10001 2 -! 1023 1111111111 1 -! 1024 10000000000 1 -! 1025 10000000001 1 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 May 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 8 ) N, the integer to be measured. -! N should be nonnegative. -! -! Output, integer ( kind = 8 ) I8_BIT_LO0, the position of the low 1 bit. -! - implicit none - - integer ( kind = 8 ) :: bit - integer ( kind = 8 ) :: i - integer ( kind = 8 ) :: i2 - integer ( kind = 8 ) :: i8_bit_lo0 - integer ( kind = 8 ) :: n - - bit = 0 - i = n - - do - - bit = bit + 1 - i2 = i / 2 - - if ( i == 2 * i2 ) then - exit - end if - - i = i2 - - end do - - i8_bit_lo0 = bit - - return -end -subroutine i8_sobol ( dim_num, seed, quasi ) - -!*****************************************************************************80 -! -!! I8_SOBOL generates a new quasirandom Sobol vector with each call. -! -! Discussion: -! -! The routine adapts the ideas of Antonov and Saleev. -! -! This routine uses the integer and real precisions corresponding -! to a KIND of 8. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 25 June 2008 -! -! Author: -! -! FORTRAN77 original version by Bennett Fox -! FORTRAN90 version by John Burkardt -! -! Reference: -! -! IA Antonov, VM Saleev, -! An Economic Method of Computing LP Tau-Sequences, -! USSR Computational Mathematics and Mathematical Physics, -! Volume 19, 1980, pages 252-256. -! -! Paul Bratley, Bennett Fox, -! Algorithm 659: -! Implementing Sobol's Quasirandom Sequence Generator, -! ACM Transactions on Mathematical Software, -! Volume 14, Number 1, March 1988, pages 88-100 -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, December 1986, pages 362-376. -! -! Stephen Joe, Frances Kuo, -! Remark on Algorithm 659: -! Implementing Sobol's Quasirandom Sequence Generator, -! ACM Transactions on Mathematical Software, -! Volume 29, Number 1, March 2003, pages 49-57. -! -! Ilya Sobol, -! Uniformly Distributed Sequences with an Additional Uniform Property, -! USSR Computational Mathematics and Mathematical Physics, -! Volume 16, 1977, pages 236-242. -! -! Ilya Sobol, YL Levitan, -! The Production of Points Uniformly Distributed in a Multidimensional -! Cube (in Russian), -! Preprint IPM Akademii Nauk SSSR, -! Number 40, Moscow 1976. -! -! Parameters: -! -! Input, integer ( kind = 8 ) DIM_NUM, the number of spatial dimensions. -! DIM_NUM must satisfy 2 <= DIM_NUM <= 1111. -! -! Input/output, integer ( kind = 8 ) SEED, the "seed" for the sequence. -! This is essentially the index in the sequence of the quasirandom -! value to be generated. On output, SEED has been set to the -! appropriate next value, usually simply SEED+1. -! If SEED is less than 0 on input, it is treated as though it were 0. -! An input value of 0 requests the first (0-th) element of the sequence. -! -! Output, real ( kind = 8 ) QUASI(DIM_NUM), the next quasirandom vector. -! - implicit none - - integer ( kind = 8 ) :: dim_num - integer ( kind = 8 ), parameter :: dim_max = 1111 - integer ( kind = 8 ), parameter :: log_max = 62 - - integer ( kind = 8 ) :: atmost - integer ( kind = 8 ), save :: dim_num_save = 0 - integer ( kind = 8 ) :: i - integer ( kind = 8 ) :: i8_bit_hi1 - integer ( kind = 8 ) :: i8_bit_lo0 - integer ( kind = 8 ) :: inc - logical includ(log_max) - logical, save :: initialized = .false. - integer ( kind = 8 ) :: j - integer ( kind = 8 ) :: j2 - integer ( kind = 8 ) :: k - integer ( kind = 8 ) :: l - integer ( kind = 8 ), save, dimension(dim_max) :: lastq - integer ( kind = 8 ) :: m - integer ( kind = 8 ), save :: maxcol - integer ( kind = 8 ) :: newv - integer ( kind = 8 ), save, dimension(1:dim_max) :: poly - real ( kind = 8 ), dimension ( dim_num ) :: quasi - real ( kind = 8 ), save :: recipd - integer ( kind = 8 ) :: seed - integer ( kind = 8 ), save :: seed_save = - 1 - integer ( kind = 8 ) :: seed_temp - integer ( kind = 8 ), save, dimension(1:dim_max,1:log_max) :: v - - if ( .not. initialized .or. dim_num /= dim_num_save ) then - - initialized = .true. - - v(1:dim_max,1:log_max) = 0 -! -! Initialize (part of) V. -! - v(2:1111,1) = 1 - v(3:401,2) = (/ & - 1,3,1,3,1,3,3,1,3,1,3,1,3,1,1,3,1,3,1,3, & - 1,3,3,1,1,1,3,1,3,1,3,3,1,3,1,1,1,3,1,3,1,1,1,3,3,1,3,3,1,1, & - 3,3,1,3,3,3,1,3,1,3,1,1,3,3,1,1,1,1,3,1,1,3,1,1,1,3,3,1,3,3, & - 1,3,3,3,1,3,3,3,1,3,3,1,3,3,3,1,3,1,3,1,1,3,3,1,3,3,1,1,1,3, & - 3,1,3,3,1,3,1,1,3,3,3,1,1,1,3,1,1,3,1,1,3,3,1,3,1,3,3,3,3,1, & - 1,1,3,3,1,1,3,1,1,1,1,1,1,3,1,3,1,1,1,3,1,3,1,3,3,3,1,1,3,3, & - 1,3,1,3,1,1,3,1,3,1,3,1,3,1,1,1,3,3,1,3,3,1,3,1,1,1,3,1,3,1, & - 1,3,1,1,3,3,1,1,3,3,3,1,3,3,3,1,3,1,3,1,1,1,3,1,1,1,3,1,1,1, & - 1,1,3,3,3,1,1,1,1,3,3,3,1,3,3,1,1,1,1,3,1,1,3,1,3,3,1,1,3,3, & - 1,1,1,1,3,1,3,3,1,3,3,1,1,1,3,3,3,1,3,3,1,3,3,1,3,1,3,3,3,1, & - 3,1,1,3,1,3,1,1,1,3,3,3,1,1,3,1,3,1,1,1,1,1,1,3,1,1,3,1,3,3, & - 1,1,1,1,3,1,3,1,3,1,1,1,1,3,3,1,1,1,1,1,3,3,3,1,1,3,3,3,3,3, & - 1,3,3,1,3,3,3,3,1,1,1,1,1,1,3,1,1,3,1,1,1,3,1,1,1,3,3,3,1,3, & - 1,1,3,3,3,1,3,3,1,3,1,3,3,1,3,3,3,1,1/) - v(402:800,2) = (/ & - 3,3,1,3,1,3,1,1,1,3,3,3,3,1,3,1,1,3,1, & - 3,1,1,1,3,1,3,1,3,1,3,3,3,3,3,3,3,3,1,3,3,3,3,3,1,3,1,3,3,3, & - 1,3,1,3,1,3,3,1,3,3,3,3,3,3,3,3,3,1,1,1,1,1,1,3,3,1,1,3,3,1, & - 1,1,3,3,1,1,3,3,3,3,1,1,3,1,3,3,1,3,3,1,1,1,3,3,3,1,1,3,3,3, & - 3,3,1,1,1,3,1,3,3,1,3,3,3,3,1,1,3,1,1,3,1,3,1,3,1,3,3,1,1,3, & - 3,1,3,3,1,3,3,1,1,3,1,3,3,1,1,3,1,3,1,3,1,1,3,3,1,1,1,3,3,1, & - 3,1,1,3,3,1,1,3,1,3,1,1,1,1,1,3,1,1,1,1,3,1,3,1,1,3,3,1,1,3, & - 1,3,1,3,3,3,1,3,3,3,1,1,3,3,3,1,1,1,1,3,1,3,1,3,1,1,3,3,1,1, & - 1,3,3,1,3,1,3,1,1,1,1,1,1,3,1,3,3,1,3,3,3,1,3,1,1,3,3,1,1,3, & - 3,1,1,1,3,1,3,3,1,1,3,1,1,3,1,3,1,1,1,3,3,3,3,1,1,3,3,1,1,1, & - 1,3,1,1,3,3,3,1,1,3,3,1,3,3,1,1,3,3,3,3,3,3,3,1,3,3,1,3,1,3, & - 1,1,3,3,1,1,1,3,1,3,3,1,3,3,1,3,1,1,3,3,3,1,1,1,3,1,1,1,3,3, & - 3,1,3,3,1,3,1,1,3,3,3,1,3,3,1,1,1,3,1,3,3,3,3,3,3,3,3,1,3,3, & - 1,3,1,1,3,3,3,1,3,3,3,3,3,1,3,3,3,1,1,1/) - v(801:1111,2) = (/ & - 3,3,1,3,3,1,3,1,3,1,3,1,3,3,3,3,3,3, & - 1,1,3,1,3,1,1,1,1,1,3,1,1,1,3,1,3,1,1,3,3,3,1,3,1,3,1,1,3,1, & - 3,3,1,3,1,3,3,1,3,3,1,3,3,3,3,3,3,1,3,1,1,3,3,3,1,1,3,3,3,3, & - 3,3,3,1,3,3,3,3,1,3,1,3,3,3,1,3,1,3,1,1,1,3,3,1,3,1,1,3,3,1, & - 3,1,1,1,1,3,1,3,1,1,3,1,3,1,3,3,3,3,3,3,1,3,3,3,3,1,3,3,1,3, & - 3,3,3,3,1,1,1,1,3,3,3,1,3,3,1,1,3,3,1,1,3,3,1,3,1,1,3,1,3,3, & - 3,3,3,1,3,1,1,3,3,3,3,1,3,1,1,3,3,3,3,3,3,1,1,3,1,3,1,1,3,1, & - 1,1,1,3,3,1,1,3,1,1,1,3,1,3,1,1,3,3,1,3,1,1,3,3,3,3,3,1,3,1, & - 1,1,3,1,1,1,3,1,1,3,1,3,3,3,3,3,1,1,1,3,3,3,3,1,3,3,3,3,1,1, & - 3,3,3,1,3,1,1,3,3,1,3,3,1,1,1,1,1,3,1,1,3,3,1,1,1,3,1,1,3,3, & - 1,3,3,3,3,3,3,3,3,1,1,3,3,1,1,3,1,3,3,3,3,3,1/) - v(4:402,3) = (/ & - 7,5,1,3,3,7,5,5,7,7,1,3,3,7,5,1,1,5,3,7, & - 1,7,5,1,3,7,7,1,1,1,5,7,7,5,1,3,3,7,5,5,5,3,3,3,1,1,5,1,1,5, & - 3,3,3,3,1,3,7,5,7,3,7,1,3,3,5,1,3,5,5,7,7,7,1,1,3,3,1,1,5,1, & - 5,7,5,1,7,5,3,3,1,5,7,1,7,5,1,7,3,1,7,1,7,3,3,5,7,3,3,5,1,3, & - 3,1,3,5,1,3,3,3,7,1,1,7,3,1,3,7,5,5,7,5,5,3,1,3,3,3,1,3,3,7, & - 3,3,1,7,5,1,7,7,5,7,5,1,3,1,7,3,7,3,5,7,3,1,3,3,3,1,5,7,3,3, & - 7,7,7,5,3,1,7,1,3,7,5,3,3,3,7,1,1,3,1,5,7,1,3,5,3,5,3,3,7,5, & - 5,3,3,1,3,7,7,7,1,5,7,1,3,1,1,7,1,3,1,7,1,5,3,5,3,1,1,5,5,3, & - 3,5,7,1,5,3,7,7,3,5,3,3,1,7,3,1,3,5,7,1,3,7,1,5,1,3,1,5,3,1, & - 7,1,5,5,5,3,7,1,1,7,3,1,1,7,5,7,5,7,7,3,7,1,3,7,7,3,5,1,1,7, & - 1,5,5,5,1,5,1,7,5,5,7,1,1,7,1,7,7,1,1,3,3,3,7,7,5,3,7,3,1,3, & - 7,5,3,3,5,7,1,1,5,5,7,7,1,1,1,1,5,5,5,7,5,7,1,1,3,5,1,3,3,7, & - 3,7,5,3,5,3,1,7,1,7,7,1,1,7,7,7,5,5,1,1,7,5,5,7,5,1,1,5,5,5, & - 5,5,5,1,3,1,5,7,3,3,5,7,3,7,1,7,7,1,3/) - v(403:801,3) = (/ & - 5,1,5,5,3,7,3,7,7,5,7,5,7,1,1,5,3,5,1, & - 5,3,7,1,5,7,7,3,5,1,3,5,1,5,3,3,3,7,3,5,1,3,7,7,3,7,5,3,3,1, & - 7,5,1,1,3,7,1,7,1,7,3,7,3,5,7,3,5,3,1,1,1,5,7,7,3,3,1,1,1,5, & - 5,7,3,1,1,3,3,7,3,3,5,1,3,7,3,3,7,3,5,7,5,7,7,3,3,5,1,3,5,3, & - 1,3,5,1,1,3,7,7,1,5,1,3,7,3,7,3,5,1,7,1,1,3,5,3,7,1,5,5,1,1, & - 3,1,3,3,7,1,7,3,1,7,3,1,7,3,5,3,5,7,3,3,3,5,1,7,7,1,3,1,3,7, & - 7,1,3,7,3,1,5,3,1,1,1,5,3,3,7,1,5,3,5,1,3,1,3,1,5,7,7,1,1,5, & - 3,1,5,1,1,7,7,3,5,5,1,7,1,5,1,1,3,1,5,7,5,7,7,1,5,1,1,3,5,1, & - 5,5,3,1,3,1,5,5,3,3,3,3,1,1,3,1,3,5,5,7,5,5,7,5,7,1,3,7,7,3, & - 5,5,7,5,5,3,3,3,1,7,1,5,5,5,3,3,5,1,3,1,3,3,3,7,1,7,7,3,7,1, & - 1,5,7,1,7,1,7,7,1,3,7,5,1,3,5,5,5,1,1,7,1,7,1,7,7,3,1,1,5,1, & - 5,1,5,3,5,5,5,5,5,3,3,7,3,3,5,5,3,7,1,5,7,5,1,5,5,3,5,5,7,5, & - 3,5,5,5,1,5,5,5,5,1,3,5,3,1,7,5,5,7,1,5,3,3,1,5,3,7,1,7,5,1, & - 1,3,1,1,7,1,5,5,3,7,3,7,5,3,1,1,3,1,3,5/) - v(802:1111,3) = (/ & - 5,7,5,3,7,7,7,3,7,3,7,1,3,1,7,7,1,7, & - 3,7,3,7,3,7,3,5,1,1,7,3,1,5,5,7,1,5,5,5,7,1,5,5,1,5,5,3,1,3, & - 1,7,3,1,3,5,7,7,7,1,1,7,3,1,5,5,5,1,1,1,1,1,5,3,5,1,3,5,3,1, & - 1,1,1,3,7,3,7,5,7,1,5,5,7,5,3,3,7,5,3,1,1,3,1,3,1,1,3,7,1,7, & - 1,1,5,1,7,5,3,7,3,5,3,1,1,5,5,1,7,7,3,7,3,7,1,5,1,5,3,7,3,5, & - 7,7,7,3,3,1,1,5,5,3,7,1,1,1,3,5,3,1,1,3,3,7,5,1,1,3,7,1,5,7, & - 3,7,5,5,7,3,5,3,1,5,3,1,1,7,5,1,7,3,7,5,1,7,1,7,7,1,1,7,1,5, & - 5,1,1,7,5,7,1,5,3,5,3,3,7,1,5,1,1,5,5,3,3,7,5,5,1,1,1,3,1,5, & - 7,7,1,7,5,7,3,7,3,1,3,7,3,1,5,5,3,5,1,3,5,5,5,1,1,7,7,1,5,5, & - 1,3,5,1,5,3,5,3,3,7,5,7,3,7,3,1,3,7,7,3,3,1,1,3,3,3,3,3,5,5, & - 3,3,3,1,3,5,7,7,1,5,7,3,7,1,1,3,5,7,5,3,3,3/) - v(6:357,4) = (/ & - 1,7,9,13,11,1,3,7,9,5,13,13,11,3,15,5,3, & - 15,7,9,13,9,1,11,7,5,15,1,15,11,5,11,1,7,9,7,7,1,15,15,15,13, & - 3,3,15,5,9,7,13,3,7,5,11,9,1,9,1,5,7,13,9,9,1,7,3,5,1,11,11, & - 13,7,7,9,9,1,1,3,9,15,1,5,13,1,9,9,9,9,9,13,11,3,5,11,11,13, & - 5,3,15,1,11,11,7,13,15,11,13,9,11,15,15,13,3,15,7,9,11,13,11, & - 9,9,5,13,9,1,13,7,7,7,7,7,5,9,7,13,11,9,11,15,3,13,11,1,11,3, & - 3,9,11,1,7,1,15,15,3,1,9,1,7,13,11,3,13,11,7,3,3,5,13,11,5, & - 11,1,3,9,7,15,7,5,13,7,9,13,15,13,9,7,15,7,9,5,11,11,13,13,9, & - 3,5,13,9,11,15,11,7,1,7,13,3,13,3,13,9,15,7,13,13,3,13,15,15, & - 11,9,13,9,15,1,1,15,11,11,7,1,11,13,9,13,3,5,11,13,9,9,13,1, & - 11,15,13,3,13,7,15,1,15,3,3,11,7,13,7,7,9,7,5,15,9,5,5,7,15, & - 13,15,5,15,5,3,1,11,7,1,5,7,9,3,11,1,15,1,3,15,11,13,5,13,1, & - 7,1,15,7,5,1,1,15,13,11,11,13,5,11,7,9,7,1,5,3,9,5,5,11,5,1, & - 7,1,11,7,9,13,15,13,3,1,11,13,15,1,1,11,9,13,3,13,11,15,13,9, & - 9,9,5,5,5,5,1,15,5,9/) - v(358:710,4) = (/ & - 11,7,15,5,3,13,5,3,11,5,1,11,13,9,11, & - 3,7,13,15,1,7,11,1,13,1,15,1,9,7,3,9,11,1,9,13,13,3,11,7,9,1, & - 7,15,9,1,5,13,5,11,3,9,15,11,13,5,1,7,7,5,13,7,7,9,5,11,11,1, & - 1,15,3,13,9,13,9,9,11,5,5,13,15,3,9,15,3,11,11,15,15,3,11,15, & - 15,3,1,3,1,3,3,1,3,13,1,11,5,15,7,15,9,1,7,1,9,11,15,1,13,9, & - 13,11,7,3,7,3,13,7,9,7,7,3,3,9,9,7,5,11,13,13,7,7,15,9,5,5,3, & - 3,13,3,9,3,1,11,1,3,11,15,11,11,11,9,13,7,9,15,9,11,1,3,3,9, & - 7,15,13,13,7,15,9,13,9,15,13,15,9,13,1,11,7,11,3,13,5,1,7,15, & - 3,13,7,13,13,11,3,5,3,13,11,9,9,3,11,11,7,9,13,11,7,15,13,7, & - 5,3,1,5,15,15,3,11,1,7,3,15,11,5,5,3,5,5,1,15,5,1,5,3,7,5,11, & - 3,13,9,13,15,5,3,5,9,5,3,11,1,13,9,15,3,5,11,9,1,3,15,9,9,9, & - 11,7,5,13,1,15,3,13,9,13,5,1,5,1,13,13,7,7,1,9,5,11,9,11,13, & - 3,15,15,13,15,7,5,7,9,7,9,9,9,11,9,3,11,15,13,13,5,9,15,1,1, & - 9,5,13,3,13,15,3,1,3,11,13,1,15,9,9,3,1,9,1,9,1,13,11,15,7, & - 11,15,13,15,1,9,9,7/) - v(711:1065,4) = (/ & - 3,5,11,7,3,9,5,15,7,5,3,13,7,1,1,9, & - 15,15,15,11,3,5,15,13,7,15,15,11,11,9,5,15,9,7,3,13,1,1,5,1, & - 3,1,7,1,1,5,1,11,11,9,9,5,13,7,7,7,1,1,9,9,11,11,15,7,5,5,3, & - 11,1,3,7,13,7,7,7,3,15,15,11,9,3,9,3,15,13,5,3,3,3,5,9,15,9, & - 9,1,5,9,9,15,5,15,7,9,1,9,9,5,11,5,15,15,11,7,7,7,1,1,11,11, & - 13,15,3,13,5,1,7,1,11,3,13,15,3,5,3,5,7,3,9,9,5,1,7,11,9,3,5, & - 11,13,13,13,9,15,5,7,1,15,11,9,15,15,13,13,13,1,11,9,15,9,5, & - 15,5,7,3,11,3,15,7,13,11,7,3,7,13,5,13,15,5,13,9,1,15,11,5,5, & - 1,11,3,3,7,1,9,7,15,9,9,3,11,15,7,1,3,1,1,1,9,1,5,15,15,7,5, & - 5,7,9,7,15,13,13,11,1,9,11,1,13,1,7,15,15,5,5,1,11,3,9,11,9, & - 9,9,1,9,3,5,15,1,1,9,7,3,3,1,9,9,11,9,9,13,13,3,13,11,13,5,1, & - 5,5,9,9,3,13,13,9,15,9,11,7,11,9,13,9,1,15,9,7,7,1,7,9,9,15, & - 1,11,1,13,13,15,9,13,7,15,3,9,3,1,13,7,5,9,3,1,7,1,1,13,3,3, & - 11,1,7,13,15,15,5,7,13,13,15,11,13,1,13,13,3,9,15,15,11,15,9, & - 15,1,13,15,1,1,5/) - v(1066:1111,4) = (/ & - 11,5,1,11,11,5,3,9,1,3,5,13,9,7,7,1, & - 9,9,15,7,5,5,15,13,9,7,13,3,13,11,13,7,9,13,13,13,15,9,5,5,3, & - 3,3,1,3,15/) - v(8:331,5) = (/ & - 9,3,27,15,29,21,23,19,11,25,7,13,17,1, & - 25,29,3,31,11,5,23,27,19,21,5,1,17,13,7,15,9,31,25,3,5,23,7, & - 3,17,23,3,3,21,25,25,23,11,19,3,11,31,7,9,5,17,23,17,17,25, & - 13,11,31,27,19,17,23,7,5,11,19,19,7,13,21,21,7,9,11,1,5,21, & - 11,13,25,9,7,7,27,15,25,15,21,17,19,19,21,5,11,3,5,29,31,29, & - 5,5,1,31,27,11,13,1,3,7,11,7,3,23,13,31,17,1,27,11,25,1,23, & - 29,17,25,7,25,27,17,13,17,23,5,17,5,13,11,21,5,11,5,9,31,19, & - 17,9,9,27,21,15,15,1,1,29,5,31,11,17,23,19,21,25,15,11,5,5,1, & - 19,19,19,7,13,21,17,17,25,23,19,23,15,13,5,19,25,9,7,3,21,17, & - 25,1,27,25,27,25,9,13,3,17,25,23,9,25,9,13,17,17,3,15,7,7,29, & - 3,19,29,29,19,29,13,15,25,27,1,3,9,9,13,31,29,31,5,15,29,1, & - 19,5,9,19,5,15,3,5,7,15,17,17,23,11,9,23,19,3,17,1,27,9,9,17, & - 13,25,29,23,29,11,31,25,21,29,19,27,31,3,5,3,3,13,21,9,29,3, & - 17,11,11,9,21,19,7,17,31,25,1,27,5,15,27,29,29,29,25,27,25,3, & - 21,17,25,13,15,17,13,23,9,3,11,7,9,9,7,17,7,1/) - v(332:654,5) = (/ & - 27,1,9,5,31,21,25,25,21,11,1,23,19,27, & - 15,3,5,23,9,25,7,29,11,9,13,5,11,1,3,31,27,3,17,27,11,13,15, & - 29,15,1,15,23,25,13,21,15,3,29,29,5,25,17,11,7,15,5,21,7,31, & - 13,11,23,5,7,23,27,21,29,15,7,27,27,19,7,15,27,27,19,19,9,15, & - 1,3,29,29,5,27,31,9,1,7,3,19,19,29,9,3,21,31,29,25,1,3,9,27, & - 5,27,25,21,11,29,31,27,21,29,17,9,17,13,11,25,15,21,11,19,31, & - 3,19,5,3,3,9,13,13,3,29,7,5,9,23,13,21,23,21,31,11,7,7,3,23, & - 1,23,5,9,17,21,1,17,29,7,5,17,13,25,17,9,19,9,5,7,21,19,13,9, & - 7,3,9,3,15,31,29,29,25,13,9,21,9,31,7,15,5,31,7,15,27,25,19, & - 9,9,25,25,23,1,9,7,11,15,19,15,27,17,11,11,31,13,25,25,9,7, & - 13,29,19,5,19,31,25,13,25,15,5,9,29,31,9,29,27,25,27,11,17,5, & - 17,3,23,15,9,9,17,17,31,11,19,25,13,23,15,25,21,31,19,3,11, & - 25,7,15,19,7,5,3,13,13,1,23,5,25,11,25,15,13,21,11,23,29,5, & - 17,27,9,19,15,5,29,23,19,1,27,3,23,21,19,27,11,17,13,27,11, & - 31,23,5,9,21,31,29,11,21,17,15,7,15,7,9,21,27,25/) - v(655:975,5) = (/ & - 29,11,3,21,13,23,19,27,17,29,25,17,9, & - 1,19,23,5,23,1,17,17,13,27,23,7,7,11,13,17,13,11,21,13,23,1, & - 27,13,9,7,1,27,29,5,13,25,21,3,31,15,13,3,19,13,1,27,15,17,1, & - 3,13,13,13,31,29,27,7,7,21,29,15,17,17,21,19,17,3,15,5,27,27, & - 3,31,31,7,21,3,13,11,17,27,25,1,9,7,29,27,21,23,13,25,29,15, & - 17,29,9,15,3,21,15,17,17,31,9,9,23,19,25,3,1,11,27,29,1,31, & - 29,25,29,1,23,29,25,13,3,31,25,5,5,11,3,21,9,23,7,11,23,11,1, & - 1,3,23,25,23,1,23,3,27,9,27,3,23,25,19,29,29,13,27,5,9,29,29, & - 13,17,3,23,19,7,13,3,19,23,5,29,29,13,13,5,19,5,17,9,11,11, & - 29,27,23,19,17,25,13,1,13,3,11,1,17,29,1,13,17,9,17,21,1,11, & - 1,1,25,5,7,29,29,19,19,1,29,13,3,1,31,15,13,3,1,11,19,5,29, & - 13,29,23,3,1,31,13,19,17,5,5,1,29,23,3,19,25,19,27,9,27,13, & - 15,29,23,13,25,25,17,19,17,15,27,3,25,17,27,3,27,31,23,13,31, & - 11,15,7,21,19,27,19,21,29,7,31,13,9,9,7,21,13,11,9,11,29,19, & - 11,19,21,5,29,13,7,19,19,27,23,31,1,27,21,7,3,7,11/) - v(976:1111,5) = (/ & - 23,13,29,11,31,19,1,5,5,11,5,3,27,5, & - 7,11,31,1,27,31,31,23,5,21,27,9,25,3,15,19,1,19,9,5,25,21,15, & - 25,29,15,21,11,19,15,3,7,13,11,25,17,1,5,31,13,29,23,9,5,29, & - 7,17,27,7,17,31,9,31,9,9,7,21,3,3,3,9,11,21,11,31,9,25,5,1, & - 31,13,29,9,29,1,11,19,7,27,13,31,7,31,7,25,23,21,29,11,11,13, & - 11,27,1,23,31,21,23,21,19,31,5,31,25,25,19,17,11,25,7,13,1, & - 29,17,23,15,7,29,17,13,3,17/) - v(14:324,6) = (/ & - 37,33,7,5,11,39,63,59,17,15,23,29,3,21, & - 13,31,25,9,49,33,19,29,11,19,27,15,25,63,55,17,63,49,19,41, & - 59,3,57,33,49,53,57,57,39,21,7,53,9,55,15,59,19,49,31,3,39,5, & - 5,41,9,19,9,57,25,1,15,51,11,19,61,53,29,19,11,9,21,19,43,13, & - 13,41,25,31,9,11,19,5,53,37,7,51,45,7,7,61,23,45,7,59,41,1, & - 29,61,37,27,47,15,31,35,31,17,51,13,25,45,5,5,33,39,5,47,29, & - 35,47,63,45,37,47,59,21,59,33,51,9,27,13,25,43,3,17,21,59,61, & - 27,47,57,11,17,39,1,63,21,59,17,13,31,3,31,7,9,27,37,23,31,9, & - 45,43,31,63,21,39,51,27,7,53,11,1,59,39,23,49,23,7,55,59,3, & - 19,35,13,9,13,15,23,9,7,43,55,3,19,9,27,33,27,49,23,47,19,7, & - 11,55,27,35,5,5,55,35,37,9,33,29,47,25,11,47,53,61,59,3,53, & - 47,5,19,59,5,47,23,45,53,3,49,61,47,39,29,17,57,5,17,31,23, & - 41,39,5,27,7,29,29,33,31,41,31,29,17,29,29,9,9,31,27,53,35,5, & - 61,1,49,13,57,29,5,21,43,25,57,49,37,27,11,61,37,49,5,63,63, & - 3,45,37,63,21,21,19,27,59,21,45,23,13,15,3,43,63,39,19/) - v(325:632,6) = (/ & - 63,31,41,41,15,43,63,53,1,63,31,7,17, & - 11,61,31,51,37,29,59,25,63,59,47,15,27,19,29,45,35,55,39,19, & - 43,21,19,13,17,51,37,5,33,35,49,25,45,1,63,47,9,63,15,25,25, & - 15,41,13,3,19,51,49,37,25,49,13,53,47,23,35,29,33,21,35,23,3, & - 43,31,63,9,1,61,43,3,11,55,11,35,1,63,35,49,19,45,9,57,51,1, & - 47,41,9,11,37,19,55,23,55,55,13,7,47,37,11,43,17,3,25,19,55, & - 59,37,33,43,1,5,21,5,63,49,61,21,51,15,19,43,47,17,9,53,45, & - 11,51,25,11,25,47,47,1,43,29,17,31,15,59,27,63,11,41,51,29,7, & - 27,63,31,43,3,29,39,3,59,59,1,53,63,23,63,47,51,23,61,39,47, & - 21,39,15,3,9,57,61,39,37,21,51,1,23,43,27,25,11,13,21,43,7, & - 11,33,55,1,37,35,27,61,39,5,19,61,61,57,59,21,59,61,57,25,55, & - 27,31,41,33,63,19,57,35,13,63,35,17,11,11,49,41,55,5,45,17, & - 35,5,31,31,37,17,45,51,1,39,49,55,19,41,13,5,51,5,49,1,21,13, & - 17,59,51,11,3,61,1,33,37,33,61,25,27,59,7,49,13,63,3,33,3,15, & - 9,13,35,39,11,59,59,1,57,11,5,57,13,31,13,11,55,45,9,55,55/) - v(633:942,6) = (/ & - 19,25,41,23,45,29,63,59,27,39,21,37,7, & - 61,49,35,39,9,29,7,25,23,57,5,19,15,33,49,37,25,17,45,29,15, & - 25,3,3,49,11,39,15,19,57,39,15,11,3,57,31,55,61,19,5,41,35, & - 59,61,39,41,53,53,63,31,9,59,13,35,55,41,49,5,41,25,27,43,5, & - 5,43,5,5,17,5,15,27,29,17,9,3,55,31,1,45,45,13,57,17,3,61,15, & - 49,15,47,9,37,45,9,51,61,21,33,11,21,63,63,47,57,61,49,9,59, & - 19,29,21,23,55,23,43,41,57,9,39,27,41,35,61,29,57,63,21,31, & - 59,35,49,3,49,47,49,33,21,19,21,35,11,17,37,23,59,13,37,35, & - 55,57,1,29,45,11,1,15,9,33,19,53,43,39,23,7,13,13,1,19,41,55, & - 1,13,15,59,55,15,3,57,37,31,17,1,3,21,29,25,55,9,37,33,53,41, & - 51,19,57,13,63,43,19,7,13,37,33,19,15,63,51,11,49,23,57,47, & - 51,15,53,41,1,15,37,61,11,35,29,33,23,55,11,59,19,61,61,45, & - 13,49,13,63,5,61,5,31,17,61,63,13,27,57,1,21,5,11,39,57,51, & - 53,39,25,41,39,37,23,31,25,33,17,57,29,27,23,47,41,29,19,47, & - 41,25,5,51,43,39,29,7,31,45,51,49,55,17,43,49,45,9,29,3,5,47, & - 9,15,19/) - v(943:1111,6) = (/ & - 51,45,57,63,9,21,59,3,9,13,45,23,15, & - 31,21,15,51,35,9,11,61,23,53,29,51,45,31,29,5,35,29,53,35,17, & - 59,55,27,51,59,27,47,15,29,37,7,49,55,5,19,45,29,19,57,33,53, & - 45,21,9,3,35,29,43,31,39,3,45,1,41,29,5,59,41,33,35,27,19,13, & - 25,27,43,33,35,17,17,23,7,35,15,61,61,53,5,15,23,11,13,43,55, & - 47,25,43,15,57,45,1,49,63,57,15,31,31,7,53,27,15,47,23,7,29, & - 53,47,9,53,3,25,55,45,63,21,17,23,31,27,27,43,63,55,63,45,51, & - 15,27,5,37,43,11,27,5,27,59,21,7,39,27,63,35,47,55,17,17,17, & - 3,19,21,13,49,61,39,15/) - v(20:305,7) = (/ & - 13,33,115,41,79,17,29,119,75,73,105,7, & - 59,65,21,3,113,61,89,45,107,21,71,79,19,71,61,41,57,121,87, & - 119,55,85,121,119,11,23,61,11,35,33,43,107,113,101,29,87,119, & - 97,29,17,89,5,127,89,119,117,103,105,41,83,25,41,55,69,117, & - 49,127,29,1,99,53,83,15,31,73,115,35,21,89,5,1,91,53,35,95, & - 83,19,85,55,51,101,33,41,55,45,95,61,27,37,89,75,57,61,15, & - 117,15,21,27,25,27,123,39,109,93,51,21,91,109,107,45,15,93, & - 127,3,53,81,79,107,79,87,35,109,73,35,83,107,1,51,7,59,33, & - 115,43,111,45,121,105,125,87,101,41,95,75,1,57,117,21,27,67, & - 29,53,117,63,1,77,89,115,49,127,15,79,81,29,65,103,33,73,79, & - 29,21,113,31,33,107,95,111,59,99,117,63,63,99,39,9,35,63,125, & - 99,45,93,33,93,9,105,75,51,115,11,37,17,41,21,43,73,19,93,7, & - 95,81,93,79,81,55,9,51,63,45,89,73,19,115,39,47,81,39,5,5,45, & - 53,65,49,17,105,13,107,5,5,19,73,59,43,83,97,115,27,1,69,103, & - 3,99,103,63,67,25,121,97,77,13,83,103,41,11,27,81,37,33,125, & - 71,41,41,59,41,87,123/) - v(306:589,7) = (/ & - 43,101,63,45,39,21,97,15,97,111,21,49, & - 13,17,79,91,65,105,75,1,45,67,83,107,125,87,15,81,95,105,65, & - 45,59,103,23,103,99,67,99,47,117,71,89,35,53,73,9,115,49,37, & - 1,35,9,45,81,19,127,17,17,105,89,49,101,7,37,33,11,95,95,17, & - 111,105,41,115,5,69,101,27,27,101,103,53,9,21,43,79,91,65, & - 117,87,125,55,45,63,85,83,97,45,83,87,113,93,95,5,17,77,77, & - 127,123,45,81,85,121,119,27,85,41,49,15,107,21,51,119,11,87, & - 101,115,63,63,37,121,109,7,43,69,19,77,49,71,59,35,7,13,55, & - 101,127,103,85,109,29,61,67,21,111,67,23,57,75,71,101,123,41, & - 107,101,107,125,27,47,119,41,19,127,33,31,109,7,91,91,39,125, & - 105,47,125,123,91,9,103,45,23,117,9,125,73,11,37,61,79,21,5, & - 47,117,67,53,85,33,81,121,47,61,51,127,29,65,45,41,95,57,73, & - 33,117,61,111,59,123,65,47,105,23,29,107,37,81,67,29,115,119, & - 75,73,99,103,7,57,45,61,95,49,101,101,35,47,119,39,67,31,103, & - 7,61,127,87,3,35,29,73,95,103,71,75,51,87,57,97,11,105,87,41, & - 73,109,69,35,121,39,111,1,77/) - v(590:875,7) = (/ & - 39,47,53,91,3,17,51,83,39,125,85,111, & - 21,69,85,29,55,11,117,1,47,17,65,63,47,117,17,115,51,25,33, & - 123,123,83,51,113,95,121,51,91,109,43,55,35,55,87,33,37,5,3, & - 45,21,105,127,35,17,35,37,97,97,21,77,123,17,89,53,105,75,25, & - 125,13,47,21,125,23,55,63,61,5,17,93,57,121,69,73,93,121,105, & - 75,91,67,95,75,9,69,97,99,93,11,53,19,73,5,33,79,107,65,69, & - 79,125,25,93,55,61,17,117,69,97,87,111,37,93,59,79,95,53,115, & - 53,85,85,65,59,23,75,21,67,27,99,79,27,3,95,27,69,19,75,47, & - 59,41,85,77,99,55,49,93,93,119,51,125,63,13,15,45,61,19,105, & - 115,17,83,7,7,11,61,37,63,89,95,119,113,67,123,91,33,37,99, & - 43,11,33,65,81,79,81,107,63,63,55,89,91,25,93,101,27,55,75, & - 121,79,43,125,73,27,109,35,21,71,113,89,59,95,41,45,113,119, & - 113,39,59,73,15,13,59,67,121,27,7,105,15,59,59,35,91,89,23, & - 125,97,53,41,91,111,29,31,3,103,61,71,35,7,119,29,45,49,111, & - 41,109,59,125,13,27,19,79,9,75,83,81,33,91,109,33,29,107,111, & - 101,107,109,65,59,43,37/) - v(876:1111,7) = (/ & - 1,9,15,109,37,111,113,119,79,73,65, & - 71,93,17,101,87,97,43,23,75,109,41,49,53,31,97,105,109,119, & - 51,9,53,113,97,73,89,79,49,61,105,13,99,53,71,7,87,21,101,5, & - 71,31,123,121,121,73,79,115,13,39,101,19,37,51,83,97,55,81, & - 91,127,105,89,63,47,49,75,37,77,15,49,107,23,23,35,19,69,17, & - 59,63,73,29,125,61,65,95,101,81,57,69,83,37,11,37,95,1,73,27, & - 29,57,7,65,83,99,69,19,103,43,95,25,19,103,41,125,97,71,105, & - 83,83,61,39,9,45,117,63,31,5,117,67,125,41,117,43,77,97,15, & - 29,5,59,25,63,87,39,39,77,85,37,81,73,89,29,125,109,21,23, & - 119,105,43,93,97,15,125,29,51,69,37,45,31,75,109,119,53,5, & - 101,125,121,35,29,7,63,17,63,13,69,15,105,51,127,105,9,57,95, & - 59,109,35,49,23,33,107,55,33,57,79,73,69,59,107,55,11,63,95, & - 103,23,125,91,31,91,51,65,61,75,69,107,65,101,59,35,15/) - v(38:299,8) = (/ & - 7,23,39,217,141,27,53,181,169,35,15, & - 207,45,247,185,117,41,81,223,151,81,189,61,95,185,23,73,113, & - 239,85,9,201,83,53,183,203,91,149,101,13,111,239,3,205,253, & - 247,121,189,169,179,197,175,217,249,195,95,63,19,7,5,75,217, & - 245,111,189,165,169,141,221,249,159,253,207,249,219,23,49, & - 127,237,5,25,177,37,103,65,167,81,87,119,45,79,143,57,79,187, & - 143,183,75,97,211,149,175,37,135,189,225,241,63,33,43,13,73, & - 213,57,239,183,117,21,29,115,43,205,223,15,3,159,51,101,127, & - 99,239,171,113,171,119,189,245,201,27,185,229,105,153,189,33, & - 35,137,77,97,17,181,55,197,201,155,37,197,137,223,25,179,91, & - 23,235,53,253,49,181,249,53,173,97,247,67,115,103,159,239,69, & - 173,217,95,221,247,97,91,123,223,213,129,181,87,239,85,89, & - 249,141,39,57,249,71,101,159,33,137,189,71,253,205,171,13, & - 249,109,131,199,189,179,31,99,113,41,173,23,189,197,3,135,9, & - 95,195,27,183,1,123,73,53,99,197,59,27,101,55,193,31,61,119, & - 11,7,255,233,53,157,193,97,83,65,81,239,167,69,71,109/) - v(300:559,8) = (/ & - 97,137,71,193,189,115,79,205,37,227, & - 53,33,91,229,245,105,77,229,161,103,93,13,161,229,223,69,15, & - 25,23,233,93,25,217,247,61,75,27,9,223,213,55,197,145,89,199, & - 41,201,5,149,35,119,183,53,11,13,3,179,229,43,55,187,233,47, & - 133,91,47,71,93,105,145,45,255,221,115,175,19,129,5,209,197, & - 57,177,115,187,119,77,211,111,33,113,23,87,137,41,7,83,43, & - 121,145,5,219,27,11,111,207,55,97,63,229,53,33,149,23,187, & - 153,91,193,183,59,211,93,139,59,179,163,209,77,39,111,79,229, & - 85,237,199,137,147,25,73,121,129,83,87,93,205,167,53,107,229, & - 213,95,219,109,175,13,209,97,61,147,19,13,123,73,35,141,81, & - 19,171,255,111,107,233,113,133,89,9,231,95,69,33,1,253,219, & - 253,247,129,11,251,221,153,35,103,239,7,27,235,181,5,207,53, & - 149,155,225,165,137,155,201,97,245,203,47,39,35,105,239,49, & - 15,253,7,237,213,55,87,199,27,175,49,41,229,85,3,149,179,129, & - 185,249,197,15,97,197,139,203,63,33,251,217,199,199,99,249, & - 33,229,177,13,209,147,97,31,125,177,137/) - v(560:819,8) = (/ & - 187,11,91,223,29,169,231,59,31,163,41, & - 57,87,247,25,127,101,207,187,73,61,105,27,91,171,243,33,3,1, & - 21,229,93,71,61,37,183,65,211,53,11,151,165,47,5,129,79,101, & - 147,169,181,19,95,77,139,197,219,97,239,183,143,9,13,209,23, & - 215,53,137,203,19,151,171,133,219,231,3,15,253,225,33,111, & - 183,213,169,119,111,15,201,123,121,225,113,113,225,161,165,1, & - 139,55,3,93,217,193,97,29,69,231,161,93,69,143,137,9,87,183, & - 113,183,73,215,137,89,251,163,41,227,145,57,81,57,11,135,145, & - 161,175,159,25,55,167,157,211,97,247,249,23,129,159,71,197, & - 127,141,219,5,233,131,217,101,131,33,157,173,69,207,239,81, & - 205,11,41,169,65,193,77,201,173,1,221,157,1,15,113,147,137, & - 205,225,73,45,49,149,113,253,99,17,119,105,117,129,243,75, & - 203,53,29,247,35,247,171,31,199,213,29,251,7,251,187,91,11, & - 149,13,205,37,249,137,139,9,7,113,183,205,187,39,3,79,155, & - 227,89,185,51,127,63,83,41,133,183,181,127,19,255,219,59,251, & - 3,187,57,217,115,217,229,181,185,149,83,115,11/) - v(820:1074,8) = (/ & - 123,19,109,165,103,123,219,129,155, & - 207,177,9,49,181,231,33,233,67,155,41,9,95,123,65,117,249,85, & - 169,129,241,173,251,225,147,165,69,81,239,95,23,83,227,249, & - 143,171,193,9,21,57,73,97,57,29,239,151,159,191,47,51,1,223, & - 251,251,151,41,119,127,131,33,209,123,53,241,25,31,183,107, & - 25,115,39,11,213,239,219,109,185,35,133,123,185,27,55,245,61, & - 75,205,213,169,163,63,55,49,83,195,51,31,41,15,203,41,63,127, & - 161,5,143,7,199,251,95,75,101,15,43,237,197,117,167,155,21, & - 83,205,255,49,101,213,237,135,135,21,73,93,115,7,85,223,237, & - 79,89,5,57,239,67,65,201,155,71,85,195,89,181,119,135,147, & - 237,173,41,155,67,113,111,21,183,23,103,207,253,69,219,205, & - 195,43,197,229,139,177,129,69,97,201,163,189,11,99,91,253, & - 239,91,145,19,179,231,121,7,225,237,125,191,119,59,175,237, & - 131,79,43,45,205,199,251,153,207,37,179,113,255,107,217,61,7, & - 181,247,31,13,113,145,107,233,233,43,79,23,169,137,129,183, & - 53,91,55,103,223,87,177,157,79,213,139/) - v(1075:1111,8) = (/ & - 183,231,205,143,129,243,205,93,59, & - 15,89,9,11,47,133,227,75,9,91,19,171,163,79,7,103,5,119,155, & - 75,11,71,95,17,13,243,207,187/) - v(54:299,9) = (/ & - 235,307,495,417,57,151,19,119,375,451, & - 55,449,501,53,185,317,17,21,487,13,347,393,15,391,307,189, & - 381,71,163,99,467,167,433,337,257,179,47,385,23,117,369,425, & - 207,433,301,147,333,85,221,423,49,3,43,229,227,201,383,281, & - 229,207,21,343,251,397,173,507,421,443,399,53,345,77,385,317, & - 155,187,269,501,19,169,235,415,61,247,183,5,257,401,451,95, & - 455,49,489,75,459,377,87,463,155,233,115,429,211,419,143,487, & - 195,209,461,193,157,193,363,181,271,445,381,231,135,327,403, & - 171,197,181,343,113,313,393,311,415,267,247,425,233,289,55, & - 39,247,327,141,5,189,183,27,337,341,327,87,429,357,265,251, & - 437,201,29,339,257,377,17,53,327,47,375,393,369,403,125,429, & - 257,157,217,85,267,117,337,447,219,501,41,41,193,509,131,207, & - 505,421,149,111,177,167,223,291,91,29,305,151,177,337,183, & - 361,435,307,507,77,181,507,315,145,423,71,103,493,271,469, & - 339,237,437,483,31,219,61,131,391,233,219,69,57,459,225,421, & - 7,461,111,451,277,185,193,125,251,199,73,71,7,409,417,149/) - v(300:550,9) = (/ & - 193,53,437,29,467,229,31,35,75,105, & - 503,75,317,401,367,131,365,441,433,93,377,405,465,259,283, & - 443,143,445,3,461,329,309,77,323,155,347,45,381,315,463,207, & - 321,157,109,479,313,345,167,439,307,235,473,79,101,245,19, & - 381,251,35,25,107,187,115,113,321,115,445,61,77,293,405,13, & - 53,17,171,299,41,79,3,485,331,13,257,59,201,497,81,451,199, & - 171,81,253,365,75,451,149,483,81,453,469,485,305,163,401,15, & - 91,3,129,35,239,355,211,387,101,299,67,375,405,357,267,363, & - 79,83,437,457,39,97,473,289,179,57,23,49,79,71,341,287,95, & - 229,271,475,49,241,261,495,353,381,13,291,37,251,105,399,81, & - 89,265,507,205,145,331,129,119,503,249,1,289,463,163,443,63, & - 123,361,261,49,429,137,355,175,507,59,277,391,25,185,381,197, & - 39,5,429,119,247,177,329,465,421,271,467,151,45,429,137,471, & - 11,17,409,347,199,463,177,11,51,361,95,497,163,351,127,395, & - 511,327,353,49,105,151,321,331,329,509,107,109,303,467,287, & - 161,45,385,289,363,331,265,407,37,433,315,343,63,51,185,71, & - 27,267/) - v(551:798,9) = (/ & - 503,239,293,245,281,297,75,461,371, & - 129,189,189,339,287,111,111,379,93,27,185,347,337,247,507, & - 161,231,43,499,73,327,263,331,249,493,37,25,115,3,167,197, & - 127,357,497,103,125,191,165,55,101,95,79,351,341,43,125,135, & - 173,289,373,133,421,241,281,213,177,363,151,227,145,363,239, & - 431,81,397,241,67,291,255,405,421,399,75,399,105,329,41,425, & - 7,283,375,475,427,277,209,411,3,137,195,289,509,121,55,147, & - 275,251,19,129,285,415,487,491,193,219,403,23,97,65,285,75, & - 21,373,261,339,239,495,415,333,107,435,297,213,149,463,199, & - 323,45,19,301,121,499,187,229,63,425,99,281,35,125,349,87, & - 101,59,195,511,355,73,263,243,101,165,141,11,389,219,187,449, & - 447,393,477,305,221,51,355,209,499,479,265,377,145,411,173, & - 11,433,483,135,385,341,89,209,391,33,395,319,451,119,341,227, & - 375,61,331,493,411,293,47,203,375,167,395,155,5,237,361,489, & - 127,21,345,101,371,233,431,109,119,277,125,263,73,135,123,83, & - 123,405,69,75,287,401,23,283,393,41,379,431,11,475,505,19, & - 365,265,271/) - v(799:1045,9) = (/ & - 499,489,443,165,91,83,291,319,199, & - 107,245,389,143,137,89,125,281,381,215,131,299,249,375,455, & - 43,73,281,217,297,229,431,357,81,357,171,451,481,13,387,491, & - 489,439,385,487,177,393,33,71,375,443,129,407,395,127,65,333, & - 309,119,197,435,497,373,71,379,509,387,159,265,477,463,449, & - 47,353,249,335,505,89,141,55,235,187,87,363,93,363,101,67, & - 215,321,331,305,261,411,491,479,65,307,469,415,131,315,487, & - 83,455,19,113,163,503,99,499,251,239,81,167,391,255,317,363, & - 359,395,419,307,251,267,171,461,183,465,165,163,293,477,223, & - 403,389,97,335,357,297,19,469,501,249,85,213,311,265,379,297, & - 283,393,449,463,289,159,289,499,407,129,137,221,43,89,403, & - 271,75,83,445,453,389,149,143,423,499,317,445,157,137,453, & - 163,87,23,391,119,427,323,173,89,259,377,511,249,31,363,229, & - 353,329,493,427,57,205,389,91,83,13,219,439,45,35,371,441,17, & - 267,501,53,25,333,17,201,475,257,417,345,381,377,55,403,77, & - 389,347,363,211,413,419,5,167,219,201,285,425,11,77,269,489, & - 281,403,79/) - v(1046:1111,9) = (/ & - 425,125,81,331,437,271,397,299,475, & - 271,249,413,233,261,495,171,69,27,409,21,421,367,81,483,255, & - 15,219,365,497,181,75,431,99,325,407,229,281,63,83,493,5,113, & - 15,271,37,87,451,299,83,451,311,441,47,455,47,253,13,109,369, & - 347,11,409,275,63,441,15/) - v(102:344,10) = (/ & - 519,307,931,1023,517,771,151,1023, & - 539,725,45,927,707,29,125,371,275,279,817,389,453,989,1015, & - 29,169,743,99,923,981,181,693,309,227,111,219,897,377,425, & - 609,227,19,221,143,581,147,919,127,725,793,289,411,835,921, & - 957,443,349,813,5,105,457,393,539,101,197,697,27,343,515,69, & - 485,383,855,693,133,87,743,747,475,87,469,763,721,345,479, & - 965,527,121,271,353,467,177,245,627,113,357,7,691,725,355, & - 889,635,737,429,545,925,357,873,187,351,677,999,921,477,233, & - 765,495,81,953,479,89,173,473,131,961,411,291,967,65,511,13, & - 805,945,369,827,295,163,835,259,207,331,29,315,999,133,967, & - 41,117,677,471,717,881,755,351,723,259,879,455,721,289,149, & - 199,805,987,851,423,597,129,11,733,549,153,285,451,559,377, & - 109,357,143,693,615,677,701,475,767,85,229,509,547,151,389, & - 711,785,657,319,509,99,1007,775,359,697,677,85,497,105,615, & - 891,71,449,835,609,377,693,665,627,215,911,503,729,131,19, & - 895,199,161,239,633,1013,537,255,23,149,679,1021,595,199,557, & - 659,251,829,727,439,495,647,223/) - v(345:586,10) = (/ & - 949,625,87,481,85,799,917,769,949, & - 739,115,499,945,547,225,1015,469,737,495,353,103,17,665,639, & - 525,75,447,185,43,729,577,863,735,317,99,17,477,893,537,519, & - 1017,375,297,325,999,353,343,729,135,489,859,267,141,831,141, & - 893,249,807,53,613,131,547,977,131,999,175,31,341,739,467, & - 675,241,645,247,391,583,183,973,433,367,131,467,571,309,385, & - 977,111,917,935,473,345,411,313,97,149,959,841,839,669,431, & - 51,41,301,247,1015,377,329,945,269,67,979,581,643,823,557,91, & - 405,117,801,509,347,893,303,227,783,555,867,99,703,111,797, & - 873,541,919,513,343,319,517,135,871,917,285,663,301,15,763, & - 89,323,757,317,807,309,1013,345,499,279,711,915,411,281,193, & - 739,365,315,375,809,469,487,621,857,975,537,939,585,129,625, & - 447,129,1017,133,83,3,415,661,53,115,903,49,79,55,385,261, & - 345,297,199,385,617,25,515,275,849,401,471,377,661,535,505, & - 939,465,225,929,219,955,659,441,117,527,427,515,287,191,33, & - 389,197,825,63,417,949,35,571,9,131,609,439,95,19,569,893, & - 451,397,971,801/) - v(587:824,10) = (/ & - 125,471,187,257,67,949,621,453,411, & - 621,955,309,783,893,597,377,753,145,637,941,593,317,555,375, & - 575,175,403,571,555,109,377,931,499,649,653,329,279,271,647, & - 721,665,429,957,803,767,425,477,995,105,495,575,687,385,227, & - 923,563,723,481,717,111,633,113,369,955,253,321,409,909,367, & - 33,967,453,863,449,539,781,911,113,7,219,725,1015,971,1021, & - 525,785,873,191,893,297,507,215,21,153,645,913,755,371,881, & - 113,903,225,49,587,201,927,429,599,513,97,319,331,833,325, & - 887,139,927,399,163,307,803,169,1019,869,537,907,479,335,697, & - 479,353,769,787,1023,855,493,883,521,735,297,1011,991,879, & - 855,591,415,917,375,453,553,189,841,339,211,601,57,765,745, & - 621,209,875,639,7,595,971,263,1009,201,23,77,621,33,535,963, & - 661,523,263,917,103,623,231,47,301,549,337,675,189,357,1005, & - 789,189,319,721,1005,525,675,539,191,813,917,51,167,415,579, & - 755,605,721,837,529,31,327,799,961,279,409,847,649,241,285, & - 545,407,161,591,73,313,811,17,663,269,261,37,783,127,917,231, & - 577,975,793/) - v(825:1065,10) = (/ & - 921,343,751,139,221,79,817,393,545, & - 11,781,71,1,699,767,917,9,107,341,587,903,965,599,507,843, & - 739,579,397,397,325,775,565,925,75,55,979,931,93,957,857,753, & - 965,795,67,5,87,909,97,995,271,875,671,613,33,351,69,811,669, & - 729,401,647,241,435,447,721,271,745,53,775,99,343,451,427, & - 593,339,845,243,345,17,573,421,517,971,499,435,769,75,203, & - 793,985,343,955,735,523,659,703,303,421,951,405,631,825,735, & - 433,841,485,49,749,107,669,211,497,143,99,57,277,969,107,397, & - 563,551,447,381,187,57,405,731,769,923,955,915,737,595,341, & - 253,823,197,321,315,181,885,497,159,571,981,899,785,947,217, & - 217,135,753,623,565,717,903,581,955,621,361,869,87,943,907, & - 853,353,335,197,771,433,743,195,91,1023,63,301,647,205,485, & - 927,1003,987,359,577,147,141,1017,701,273,89,589,487,859,343, & - 91,847,341,173,287,1003,289,639,983,685,697,35,701,645,911, & - 501,705,873,763,745,657,559,699,315,347,429,197,165,955,859, & - 167,303,833,531,473,635,641,195,589,821,205,3,635,371,891, & - 249,123/) - v(1066:1111,10) = (/ & - 77,623,993,401,525,427,71,655,951, & - 357,851,899,535,493,323,1003,343,515,859,1017,5,423,315,1011, & - 703,41,777,163,95,831,79,975,235,633,723,297,589,317,679,981, & - 195,399,1003,121,501,155/) - v(162:376,11) = (/ & - 7,2011,1001,49,825,415,1441,383,1581, & - 623,1621,1319,1387,619,839,217,75,1955,505,281,1629,1379,53, & - 1111,1399,301,209,49,155,1647,631,129,1569,335,67,1955,1611, & - 2021,1305,121,37,877,835,1457,669,1405,935,1735,665,551,789, & - 1543,1267,1027,1,1911,163,1929,67,1975,1681,1413,191,1711, & - 1307,401,725,1229,1403,1609,2035,917,921,1789,41,2003,187,67, & - 1635,717,1449,277,1903,1179,363,1211,1231,647,1261,1029,1485, & - 1309,1149,317,1335,171,243,271,1055,1601,1129,1653,205,1463, & - 1681,1621,197,951,573,1697,1265,1321,1805,1235,1853,1307,945, & - 1197,1411,833,273,1517,1747,1095,1345,869,57,1383,221,1713, & - 335,1751,1141,839,523,1861,1105,389,1177,1877,805,93,1591, & - 423,1835,99,1781,1515,1909,1011,303,385,1635,357,973,1781, & - 1707,1363,1053,649,1469,623,1429,1241,1151,1055,503,921,3, & - 349,1149,293,45,303,877,1565,1583,1001,663,1535,395,1141, & - 1481,1797,643,1507,465,2027,1695,367,937,719,545,1991,83,819, & - 239,1791,1461,1647,1501,1161,1629,139,1595,1921,1267,1415, & - 509,347,777,1083,363,269,1015/) - v(377:589,11) = (/ & - 1809,1105,1429,1471,2019,381,2025, & - 1223,827,1733,887,1321,803,1951,1297,1995,833,1107,1135,1181, & - 1251,983,1389,1565,273,137,71,735,1005,933,67,1471,551,457, & - 1667,1729,919,285,1629,1815,653,1919,1039,531,393,1411,359, & - 221,699,1485,471,1357,1715,595,1677,153,1903,1281,215,781, & - 543,293,1807,965,1695,443,1985,321,879,1227,1915,839,1945, & - 1993,1165,51,557,723,1491,817,1237,947,1215,1911,1225,1965, & - 1889,1503,1177,73,1767,303,177,1897,1401,321,921,217,1779, & - 327,1889,333,615,1665,1825,1639,237,1205,361,129,1655,983, & - 1089,1171,401,677,643,749,303,1407,1873,1579,1491,1393,1247, & - 789,763,49,5,1607,1891,735,1557,1909,1765,1777,1127,813,695, & - 97,731,1503,1751,333,769,865,693,377,1919,957,1359,1627,1039, & - 1783,1065,1665,1917,1947,991,1997,841,459,221,327,1595,1881, & - 1269,1007,129,1413,475,1105,791,1983,1359,503,691,659,691, & - 343,1375,1919,263,1373,603,1383,297,781,145,285,767,1739, & - 1715,715,317,1333,85,831,1615,81,1667,1467,1457,1453,1825, & - 109,387,1207,2039,213,1351,1329,1173/) - v(590:802,11) = (/ & - 57,1769,951,183,23,451,1155,1551, & - 2037,811,635,1671,1451,863,1499,1673,363,1029,1077,1525,277, & - 1023,655,665,1869,1255,965,277,1601,329,1603,1901,395,65, & - 1307,2029,21,1321,543,1569,1185,1905,1701,413,2041,1697,725, & - 1417,1847,411,211,915,1891,17,1877,1699,687,1089,1973,1809, & - 851,1495,1257,63,1323,1307,609,881,1543,177,617,1505,1747, & - 1537,925,183,77,1723,1877,1703,397,459,521,257,1177,389,1947, & - 1553,1583,1831,261,485,289,1281,1543,1591,1123,573,821,1065, & - 1933,1373,2005,905,207,173,1573,1597,573,1883,1795,1499,1743, & - 553,335,333,1645,791,871,1157,969,557,141,223,1129,1685,423, & - 1069,391,99,95,1847,531,1859,1833,1833,341,237,1997,1799,409, & - 431,1917,363,335,1039,1085,1657,1975,1527,1111,659,389,899, & - 595,1439,1861,1979,1569,1087,1009,165,1895,1481,1583,29,1193, & - 1673,1075,301,1081,1377,1747,1497,1103,1789,887,739,1577,313, & - 1367,1299,1801,1131,1837,73,1865,1065,843,635,55,1655,913, & - 1037,223,1871,1161,461,479,511,1721,1107,389,151,35,375,1099, & - 937,1185,1701,769,639,1633/) - v(803:1018,11) = (/ & - 1609,379,1613,2031,685,289,975,671, & - 1599,1447,871,647,99,139,1427,959,89,117,841,891,1959,223, & - 1697,1145,499,1435,1809,1413,1445,1675,171,1073,1349,1545, & - 2039,1027,1563,859,215,1673,1919,1633,779,411,1845,1477,1489, & - 447,1545,351,1989,495,183,1639,1385,1805,1097,1249,1431,1571, & - 591,697,1509,709,31,1563,165,513,1425,1299,1081,145,1841, & - 1211,941,609,845,1169,1865,1593,347,293,1277,157,211,93,1679, & - 1799,527,41,473,563,187,1525,575,1579,857,703,1211,647,709, & - 981,285,697,163,981,153,1515,47,1553,599,225,1147,381,135, & - 821,1965,609,1033,983,503,1117,327,453,2005,1257,343,1649, & - 1199,599,1877,569,695,1587,1475,187,973,233,511,51,1083,665, & - 1321,531,1875,1939,859,1507,1979,1203,1965,737,921,1565,1943, & - 819,223,365,167,1705,413,1577,745,1573,655,1633,1003,91,1123, & - 477,1741,1663,35,715,37,1513,815,941,1379,263,1831,1735,1111, & - 1449,353,1941,1655,1349,877,285,1723,125,1753,985,723,175, & - 439,791,1051,1261,717,1555,1757,1777,577,1583,1957,873,331, & - 1163,313,1,1963,963,1905,821/) - v(1019:1111,11) = (/ & - 1677,185,709,545,1723,215,1885, & - 1249,583,1803,839,885,485,413,1767,425,129,1035,329,1263, & - 1881,1779,1565,359,367,453,707,1419,831,1889,887,1871,1869, & - 747,223,1547,1799,433,1441,553,2021,1303,1505,1735,1619,1065, & - 1161,2047,347,867,881,1447,329,781,1065,219,589,645,1257, & - 1833,749,1841,1733,1179,1191,1025,1639,1955,1423,1685,1711, & - 493,549,783,1653,397,895,233,759,1505,677,1449,1573,1297, & - 1821,1691,791,289,1187,867,1535,575,183/) - v(338:545,12) = (/ & - 3915,97,3047,937,2897,953,127,1201, & - 3819,193,2053,3061,3759,1553,2007,2493,603,3343,3751,1059, & - 783,1789,1589,283,1093,3919,2747,277,2605,2169,2905,721,4069, & - 233,261,1137,3993,3619,2881,1275,3865,1299,3757,1193,733,993, & - 1153,2945,3163,3179,437,271,3493,3971,1005,2615,2253,1131, & - 585,2775,2171,2383,2937,2447,1745,663,1515,3767,2709,1767, & - 3185,3017,2815,1829,87,3341,793,2627,2169,1875,3745,367,3783, & - 783,827,3253,2639,2955,3539,1579,2109,379,2939,3019,1999, & - 2253,2911,3733,481,1767,1055,4019,4085,105,1829,2097,2379, & - 1567,2713,737,3423,3941,2659,3961,1755,3613,1937,1559,2287, & - 2743,67,2859,325,2601,1149,3259,2403,3947,2011,175,3389,3915, & - 1315,2447,141,359,3609,3933,729,2051,1755,2149,2107,1741, & - 1051,3681,471,1055,845,257,1559,1061,2803,2219,1315,1369, & - 3211,4027,105,11,1077,2857,337,3553,3503,3917,2665,3823,3403, & - 3711,2085,1103,1641,701,4095,2883,1435,653,2363,1597,767,869, & - 1825,1117,1297,501,505,149,873,2673,551,1499,2793,3277,2143, & - 3663,533,3991,575,1877,1009,3929,473,3009,2595,3249,675,3593/) - v(546:752,12) = (/ & - 2453,1567,973,595,1335,1715,589,85, & - 2265,3069,461,1659,2627,1307,1731,1501,1699,3545,3803,2157, & - 453,2813,2047,2999,3841,2361,1079,573,69,1363,1597,3427,2899, & - 2771,1327,1117,1523,3521,2393,2537,1979,3179,683,2453,453, & - 1227,779,671,3483,2135,3139,3381,3945,57,1541,3405,3381,2371, & - 2879,1985,987,3017,3031,3839,1401,3749,2977,681,1175,1519, & - 3355,907,117,771,3741,3337,1743,1227,3335,2755,1909,3603, & - 2397,653,87,2025,2617,3257,287,3051,3809,897,2215,63,2043, & - 1757,3671,297,3131,1305,293,3865,3173,3397,2269,3673,717, & - 3041,3341,3595,3819,2871,3973,1129,513,871,1485,3977,2473, & - 1171,1143,3063,3547,2183,3993,133,2529,2699,233,2355,231, & - 3241,611,1309,3829,1839,1495,301,1169,1613,2673,243,3601, & - 3669,2813,2671,2679,3463,2477,1795,617,2317,1855,1057,1703, & - 1761,2515,801,1205,1311,473,3963,697,1221,251,381,3887,1761, & - 3093,3721,2079,4085,379,3601,3845,433,1781,29,1897,1599,2163, & - 75,3475,3957,1641,3911,2959,2833,1279,1099,403,799,2183,2699, & - 1711,2037,727,289,1785,1575,3633,2367,1261,3953,1735,171, & - 1959/) - v(753:960,12) = (/ & - 2867,859,2951,3211,15,1279,1323,599, & - 1651,3951,1011,315,3513,3351,1725,3793,2399,287,4017,3571, & - 1007,541,3115,429,1585,1285,755,1211,3047,915,3611,2697,2129, & - 3669,81,3939,2437,915,779,3567,3701,2479,3807,1893,3927,2619, & - 2543,3633,2007,3857,3837,487,1769,3759,3105,2727,3155,2479, & - 1341,1657,2767,2541,577,2105,799,17,2871,3637,953,65,69,2897, & - 3841,3559,4067,2335,3409,1087,425,2813,1705,1701,1237,821, & - 1375,3673,2693,3925,1541,1871,2285,847,4035,1101,2029,855, & - 2733,2503,121,2855,1069,3463,3505,1539,607,1349,575,2301, & - 2321,1101,333,291,2171,4085,2173,2541,1195,925,4039,1379,699, & - 1979,275,953,1755,1643,325,101,2263,3329,3673,3413,1977,2727, & - 2313,1419,887,609,2475,591,2613,2081,3805,3435,2409,111,3557, & - 3607,903,231,3059,473,2959,2925,3861,2043,3887,351,2865,369, & - 1377,2639,1261,3625,3279,2201,2949,3049,449,1297,897,1891, & - 411,2773,749,2753,1825,853,2775,3547,3923,3923,987,3723,2189, & - 3877,3577,297,2763,1845,3083,2951,483,2169,3985,245,3655, & - 3441,1023,235,835,3693,3585,327,1003,543,3059,2637/) - v(961:1111,12) = (/ & - 2923,87,3617,1031,1043,903,2913, & - 2177,2641,3279,389,2009,525,4085,3299,987,2409,813,2683,373, & - 2695,3775,2375,1119,2791,223,325,587,1379,2877,2867,3793,655, & - 831,3425,1663,1681,2657,1865,3943,2977,1979,2271,3247,1267, & - 1747,811,159,429,2001,1195,3065,553,1499,3529,1081,2877,3077, & - 845,1793,2409,3995,2559,4081,1195,2955,1117,1409,785,287, & - 1521,1607,85,3055,3123,2533,2329,3477,799,3683,3715,337,3139, & - 3311,431,3511,2299,365,2941,3067,1331,1081,1097,2853,2299, & - 495,1745,749,3819,619,1059,3559,183,3743,723,949,3501,733, & - 2599,3983,3961,911,1899,985,2493,1795,653,157,433,2361,3093, & - 3119,3679,2367,1701,1445,1321,2397,1241,3305,3985,2349,4067, & - 3805,3073,2837,1567,3783,451,2441,1181,487,543,1201,3735, & - 2517,733,1535,2175,3613,3019/) - v(482:680,13) = (/ & - 2319,653,1379,1675,1951,7075,2087, & - 7147,1427,893,171,2019,7235,5697,3615,1961,7517,6849,2893, & - 1883,2863,2173,4543,73,381,3893,6045,1643,7669,1027,1549, & - 3983,1985,6589,7497,2745,2375,7047,1117,1171,1975,5199,3915, & - 3695,8113,4303,3773,7705,6855,1675,2245,2817,1719,569,1021, & - 2077,5945,1833,2631,4851,6371,833,7987,331,1899,8093,6719, & - 6903,5903,5657,5007,2689,6637,2675,1645,1819,689,6709,7717, & - 6295,7013,7695,3705,7069,2621,3631,6571,6259,7261,3397,7645, & - 1115,4753,2047,7579,2271,5403,4911,7629,4225,1209,6955,6951, & - 1829,5579,5231,1783,4285,7425,599,5785,3275,5643,2263,657, & - 6769,6261,1251,3249,4447,4111,3991,1215,131,4397,3487,7585, & - 5565,7199,3573,7105,7409,1671,949,3889,5971,3333,225,3647, & - 5403,3409,7459,6879,5789,6567,5581,4919,1927,4407,8085,4691, & - 611,3005,591,753,589,171,5729,5891,1033,3049,6567,5257,8003, & - 1757,4489,4923,6379,5171,1757,689,3081,1389,4113,455,2761, & - 847,7575,5829,633,6629,1103,7635,803,6175,6587,2711,3879,67, & - 1179,4761,7281,1557,3379,2459,4273,4127,7147,35/) - v(681:877,13) = (/ & - 3549,395,3735,5787,4179,5889,5057, & - 7473,4713,2133,2897,1841,2125,1029,1695,6523,1143,5105,7133, & - 3351,2775,3971,4503,7589,5155,4305,1641,4717,2427,5617,1267, & - 399,5831,4305,4241,3395,3045,4899,1713,171,411,7099,5473, & - 5209,1195,1077,1309,2953,7343,4887,3229,6759,6721,6775,675, & - 4039,2493,7511,3269,4199,6625,7943,2013,4145,667,513,2303, & - 4591,7941,2741,987,8061,3161,5951,1431,831,5559,7405,1357, & - 4319,4235,5421,2559,4415,2439,823,1725,6219,4903,6699,5451, & - 349,7703,2927,7809,6179,1417,5987,3017,4983,3479,4525,4643, & - 4911,227,5475,2287,5581,6817,1937,1421,4415,7977,1789,3907, & - 6815,6789,6003,5609,4507,337,7427,7943,3075,6427,1019,7121, & - 4763,81,3587,2929,1795,8067,2415,1265,4025,5599,4771,3025, & - 2313,6129,7611,6881,5253,4413,7869,105,3173,1629,2537,1023, & - 4409,7209,4413,7107,7469,33,1955,2881,5167,6451,4211,179, & - 5573,7879,3387,7759,5455,7157,1891,5683,5689,6535,3109,6555, & - 6873,1249,4251,6437,49,2745,1201,7327,4179,6783,623,2779, & - 5963,2585,6927,5333,4033,285,7467,4443,4917,3/) - v(878:1070,13) = (/ & - 4319,5517,3449,813,5499,2515,5771, & - 3357,2073,4395,4925,2643,7215,5817,1199,1597,1619,7535,4833, & - 609,4797,8171,6847,793,6757,8165,3371,2431,5235,4739,7703, & - 7223,6525,5891,5605,4433,3533,5267,5125,5037,225,6717,1121, & - 5741,2013,4327,4839,569,5227,7677,4315,2391,5551,859,3627, & - 6377,3903,4311,6527,7573,4905,7731,1909,1555,3279,1949,1887, & - 6675,5509,2033,5473,3539,5033,5935,6095,4761,1771,1271,1717, & - 4415,5083,6277,3147,7695,2461,4783,4539,5833,5583,651,1419, & - 2605,5511,3913,5795,2333,2329,4431,3725,6069,2699,7055,6879, & - 1017,3121,2547,4603,2385,6915,6103,5669,7833,2001,4287,6619, & - 955,2761,5711,6291,3415,3909,2841,5627,4939,7671,6059,6275, & - 6517,1931,4583,7301,1267,7509,1435,2169,6939,3515,2985,2787, & - 2123,1969,3307,353,4359,7059,5273,5873,6657,6765,6229,3179, & - 1583,6237,2155,371,273,7491,3309,6805,3015,6831,7819,713, & - 4747,3935,4109,1311,709,3089,7059,4247,2989,1509,4919,1841, & - 3045,3821,6929,4655,1333,6429,6649,2131,5265,1051,261,8057, & - 3379,2179,1993,5655,3063,6381/) - v(1071:1111,13) = (/ & - 3587,7417,1579,1541,2107,5085,2873, & - 6141,955,3537,2157,841,1999,1465,5171,5651,1535,7235,4349, & - 1263,1453,1005,6893,2919,1947,1635,3963,397,969,4569,655, & - 6737,2995,7235,7713,973,4821,2377,1673,1,6541/) -! -! Set POLY. -! - poly(1:211)= (/ & - 1,3,7,11,13,19,25,37,59,47,61,55,41,67,97,91, & - 109,103,115,131,193,137,145,143,241,157,185,167,229,171,213, & - 191,253,203,211,239,247,285,369,299,301,333,351,355,357,361, & - 391,397,425,451,463,487,501,529,539,545,557,563,601,607,617, & - 623,631,637,647,661,675,677,687,695,701,719,721,731,757,761, & - 787,789,799,803,817,827,847,859,865,875,877,883,895,901,911, & - 949,953,967,971,973,981,985,995,1001,1019,1033,1051,1063, & - 1069,1125,1135,1153,1163,1221,1239,1255,1267,1279,1293,1305, & - 1315,1329,1341,1347,1367,1387,1413,1423,1431,1441,1479,1509, & - 1527,1531,1555,1557,1573,1591,1603,1615,1627,1657,1663,1673, & - 1717,1729,1747,1759,1789,1815,1821,1825,1849,1863,1869,1877, & - 1881,1891,1917,1933,1939,1969,2011,2035,2041,2053,2071,2091, & - 2093,2119,2147,2149,2161,2171,2189,2197,2207,2217,2225,2255, & - 2257,2273,2279,2283,2293,2317,2323,2341,2345,2363,2365,2373, & - 2377,2385,2395,2419,2421,2431,2435,2447,2475,2477,2489,2503, & - 2521,2533,2551,2561,2567,2579,2581,2601,2633,2657,2669/) - poly(212:401)= (/ & - 2681,2687,2693,2705,2717,2727,2731,2739, & - 2741,2773,2783,2793,2799,2801,2811,2819,2825,2833,2867,2879, & - 2881,2891,2905,2911,2917,2927,2941,2951,2955,2963,2965,2991, & - 2999,3005,3017,3035,3037,3047,3053,3083,3085,3097,3103,3159, & - 3169,3179,3187,3205,3209,3223,3227,3229,3251,3263,3271,3277, & - 3283,3285,3299,3305,3319,3331,3343,3357,3367,3373,3393,3399, & - 3413,3417,3427,3439,3441,3475,3487,3497,3515,3517,3529,3543, & - 3547,3553,3559,3573,3589,3613,3617,3623,3627,3635,3641,3655, & - 3659,3669,3679,3697,3707,3709,3713,3731,3743,3747,3771,3791, & - 3805,3827,3833,3851,3865,3889,3895,3933,3947,3949,3957,3971, & - 3985,3991,3995,4007,4013,4021,4045,4051,4069,4073,4179,4201, & - 4219,4221,4249,4305,4331,4359,4383,4387,4411,4431,4439,4449, & - 4459,4485,4531,4569,4575,4621,4663,4669,4711,4723,4735,4793, & - 4801,4811,4879,4893,4897,4921,4927,4941,4977,5017,5027,5033, & - 5127,5169,5175,5199,5213,5223,5237,5287,5293,5331,5391,5405, & - 5453,5523,5573,5591,5597,5611,5641,5703,5717,5721,5797,5821, & - 5909,5913/) - poly(402:591)= (/ & - 5955,5957,6005,6025,6061,6067,6079,6081, & - 6231,6237,6289,6295,6329,6383,6427,6453,6465,6501,6523,6539, & - 6577,6589,6601,6607,6631,6683,6699,6707,6761,6795,6865,6881, & - 6901,6923,6931,6943,6999,7057,7079,7103,7105,7123,7173,7185, & - 7191,7207,7245,7303,7327,7333,7355,7365,7369,7375,7411,7431, & - 7459,7491,7505,7515,7541,7557,7561,7701,7705,7727,7749,7761, & - 7783,7795,7823,7907,7953,7963,7975,8049,8089,8123,8125,8137, & - 8219,8231,8245,8275,8293,8303,8331,8333,8351,8357,8367,8379, & - 8381,8387,8393,8417,8435,8461,8469,8489,8495,8507,8515,8551, & - 8555,8569,8585,8599,8605,8639,8641,8647,8653,8671,8675,8689, & - 8699,8729,8741,8759,8765,8771,8795,8797,8825,8831,8841,8855, & - 8859,8883,8895,8909,8943,8951,8955,8965,8999,9003,9031,9045, & - 9049,9071,9073,9085,9095,9101,9109,9123,9129,9137,9143,9147, & - 9185,9197,9209,9227,9235,9247,9253,9257,9277,9297,9303,9313, & - 9325,9343,9347,9371,9373,9397,9407,9409,9415,9419,9443,9481, & - 9495,9501,9505,9517,9529,9555,9557,9571,9585,9591,9607,9611, & - 9621,9625/) - poly(592:765)= (/ & - 9631,9647,9661,9669,9679,9687,9707,9731, & - 9733,9745,9773,9791,9803,9811,9817,9833,9847,9851,9863,9875, & - 9881,9905,9911,9917,9923,9963,9973,10003,10025,10043,10063, & - 10071,10077,10091,10099,10105,10115,10129,10145,10169,10183, & - 10187,10207,10223,10225,10247,10265,10271,10275,10289,10299, & - 10301,10309,10343,10357,10373,10411,10413,10431,10445,10453, & - 10463,10467,10473,10491,10505,10511,10513,10523,10539,10549, & - 10559,10561,10571,10581,10615,10621,10625,10643,10655,10671, & - 10679,10685,10691,10711,10739,10741,10755,10767,10781,10785, & - 10803,10805,10829,10857,10863,10865,10875,10877,10917,10921, & - 10929,10949,10967,10971,10987,10995,11009,11029,11043,11045, & - 11055,11063,11075,11081,11117,11135,11141,11159,11163,11181, & - 11187,11225,11237,11261,11279,11297,11307,11309,11327,11329, & - 11341,11377,11403,11405,11413,11427,11439,11453,11461,11473, & - 11479,11489,11495,11499,11533,11545,11561,11567,11575,11579, & - 11589,11611,11623,11637,11657,11663,11687,11691,11701,11747, & - 11761,11773,11783,11795,11797,11817,11849,11855,11867,11869, & - 11873,11883,11919/) - poly(766:936)= (/ & - 11921,11927,11933,11947,11955,11961, & - 11999,12027,12029,12037,12041,12049,12055,12095,12097,12107, & - 12109,12121,12127,12133,12137,12181,12197,12207,12209,12239, & - 12253,12263,12269,12277,12287,12295,12309,12313,12335,12361, & - 12367,12391,12409,12415,12433,12449,12469,12479,12481,12499, & - 12505,12517,12527,12549,12559,12597,12615,12621,12639,12643, & - 12657,12667,12707,12713,12727,12741,12745,12763,12769,12779, & - 12781,12787,12799,12809,12815,12829,12839,12857,12875,12883, & - 12889,12901,12929,12947,12953,12959,12969,12983,12987,12995, & - 13015,13019,13031,13063,13077,13103,13137,13149,13173,13207, & - 13211,13227,13241,13249,13255,13269,13283,13285,13303,13307, & - 13321,13339,13351,13377,13389,13407,13417,13431,13435,13447, & - 13459,13465,13477,13501,13513,13531,13543,13561,13581,13599, & - 13605,13617,13623,13637,13647,13661,13677,13683,13695,13725, & - 13729,13753,13773,13781,13785,13795,13801,13807,13825,13835, & - 13855,13861,13871,13883,13897,13905,13915,13939,13941,13969, & - 13979,13981,13997,14027,14035,14037,14051,14063,14085,14095, & - 14107,14113,14125,14137,14145/) - poly(937:1107)= (/ & - 14151,14163,14193,14199,14219,14229, & - 14233,14243,14277,14287,14289,14295,14301,14305,14323,14339, & - 14341,14359,14365,14375,14387,14411,14425,14441,14449,14499, & - 14513,14523,14537,14543,14561,14579,14585,14593,14599,14603, & - 14611,14641,14671,14695,14701,14723,14725,14743,14753,14759, & - 14765,14795,14797,14803,14831,14839,14845,14855,14889,14895, & - 14909,14929,14941,14945,14951,14963,14965,14985,15033,15039, & - 15053,15059,15061,15071,15077,15081,15099,15121,15147,15149, & - 15157,15167,15187,15193,15203,15205,15215,15217,15223,15243, & - 15257,15269,15273,15287,15291,15313,15335,15347,15359,15373, & - 15379,15381,15391,15395,15397,15419,15439,15453,15469,15491, & - 15503,15517,15527,15531,15545,15559,15593,15611,15613,15619, & - 15639,15643,15649,15661,15667,15669,15681,15693,15717,15721, & - 15741,15745,15765,15793,15799,15811,15825,15835,15847,15851, & - 15865,15877,15881,15887,15899,15915,15935,15937,15955,15973, & - 15977,16011,16035,16061,16069,16087,16093,16097,16121,16141, & - 16153,16159,16165,16183,16189,16195,16197,16201,16209,16215, & - 16225,16259,16265,16273,16299/) - poly(1108:1111)= (/ & - 16309,16355,16375,16381/) - - end if - - if ( dim_num /= dim_num_save ) then -! -! Check parameters. -! - if ( dim_num < 2 .or. dim_max < dim_num ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I8_SOBOL - Fatal error!' - write ( *, '(a)' ) ' The spatial dimension DIM_NUM should satisfy:' - write ( *, '(a,i8)' ) ' 2 <= DIM_NUM <= ', dim_max - write ( *, '(a,i8)' ) ' But this input value is DIM_NUM = ', dim_num - stop - end if - - dim_num_save = dim_num -! -! Set ATMOST = 2**LOG_MAX - 1. -! - atmost = 0 - do i = 1, log_max - atmost = 2 * atmost + 1 - end do -! -! Find the highest 1 bit in ATMOST (should be LOG_MAX). -! - maxcol = i8_bit_hi1 ( atmost ) -! -! Initialize row 1 of V. -! - v(1,1:maxcol) = 1 -! -! Initialize the remaining rows of V. -! - do i = 2, dim_num -! -! The bit pattern of the integer POLY(I) gives the form -! of polynomial I. -! -! Find the degree of polynomial I from binary encoding. -! - j = poly(i) - m = 0 - - do - - j = j / 2 - - if ( j <= 0 ) then - exit - end if - - m = m + 1 - - end do -! -! We expand this bit pattern to separate components -! of the logical array INCLUD. -! - j = poly(i) - do k = m, 1, - 1 - j2 = j / 2 - includ(k) = ( j /= ( 2 * j2 ) ) - j = j2 - end do -! -! Calculate the remaining elements of row I as explained -! in Bratley and Fox, section 2. -! - do j = m + 1, maxcol - - newv = v(i,j-m) - l = 1 - - do k = 1, m - - l = 2 * l - - if ( includ(k) ) then - newv = ieor ( newv, l * v(i,j-k) ) - end if - - end do - - v(i,j) = newv - - end do - - end do -! -! Multiply columns of V by appropriate power of 2. -! - l = 1 - do j = maxcol - 1, 1, - 1 - l = 2 * l - v(1:dim_num,j) = v(1:dim_num,j) * l - end do -! -! RECIPD is 1/(common denominator of the elements in V) = 1 / ( 2 * L ). -! - recipd = real ( l, kind = 8 ) - recipd = 0.5D+00 / recipd - - end if - - if ( seed < 0 ) then - seed = 0 - end if - - if ( seed == 0 ) then - - l = 1 - lastq(1:dim_num) = 0 - - else if ( seed == seed_save + 1 ) then -! -! Find the position of the right-hand zero in SEED. -! - l = i8_bit_lo0 ( seed ) - - else if ( seed <= seed_save ) then - - seed_save = 0 - l = 1 - lastq(1:dim_num) = 0 - - do seed_temp = seed_save, seed - 1 - l = i8_bit_lo0 ( seed_temp ) - lastq(1:dim_num) = ieor ( lastq(1:dim_num), v(1:dim_num,l) ) - end do - - l = i8_bit_lo0 ( seed ) - - else if ( seed_save+1 < seed ) then - - do seed_temp = seed_save+1, seed - 1 - l = i8_bit_lo0 ( seed_temp ) - lastq(1:dim_num) = ieor ( lastq(1:dim_num), v(1:dim_num,l) ) - end do - - l = i8_bit_lo0 ( seed ) - - end if -! -! Check that the user is not calling too many times! -! - if ( maxcol < l ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I8_SOBOL - Fatal error!' - write ( *, '(a)' ) ' Too many calls!' - write ( *, '(a,i12)' ) ' MAXCOL = ', maxcol - write ( *, '(a,i12)' ) ' L = ', l - stop - end if -! -! Calculate the new components of QUASI. -! - quasi(1:dim_num) = real ( lastq(1:dim_num), kind = 8 ) * recipd - lastq(1:dim_num) = ieor ( lastq(1:dim_num), v(1:dim_num,l) ) - - seed_save = seed - seed = seed + 1 - - return -end -subroutine i8_sobol_generate ( m, n, skip, r ) - -!*****************************************************************************80 -! -!! I8_SOBOL_GENERATE generates a Sobol dataset. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 August 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer M, the spatial dimension. -! -! Input, integer N, the number of points to generate. -! -! Input, integer ( kind = 8 ) SKIP, the number of initial points to skip. -! -! Output, real ( kind = 8 ) R(M,N), the points. -! - implicit none - - integer ( kind = 8 ) m - integer ( kind = 8 ) n - - integer ( kind = 8 ) j - real ( kind = 8 ), dimension ( m, n ) :: r - integer ( kind = 8 ) seed - integer ( kind = 8 ) skip - - do j = 1, n - seed = skip + j - 1 - call i8_sobol ( m, seed, r(1:m,j) ) - end do - - return -end -subroutine i8_sobol_write ( m, n, skip, r, file_out_name ) - -!*****************************************************************************80 -! -!! I8_SOBOL_WRITE writes a Sobol dataset to a file. -! -! Discussion: -! -! The initial lines of the file are comments, which begin with a -! '#' character. -! -! Thereafter, each line of the file contains the M-dimensional -! components of the SKIP+I-1 entry of the Sobol sequence. -! -! For the Sobol sequence, the value of SKIP is the same -! as the value of SEED used to generate the first point. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 04 June 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 8 ) M, the spatial dimension. -! -! Input, integer ( kind = 8 ) N, the number of (successive) points. -! -! Input, integer ( kind = 8 ) SKIP, the number of skipped points. -! -! Input, real ( kind = 8 ) R(M,N), the points. -! -! Input, character ( len = * ) FILE_OUT_NAME, the name of -! the output file. -! - implicit none - - integer ( kind = 8 ) m - integer ( kind = 8 ) n - - character ( len = * ) file_out_name - integer file_out_unit - integer ios - integer ( kind = 8 ) j - real ( kind = 8 ) r(m,n) - integer ( kind = 8 ) skip - character ( len = 40 ) string - - call get_unit ( file_out_unit ) - - open ( unit = file_out_unit, file = file_out_name, status = 'replace', & - iostat = ios ) - - if ( ios /= 0 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I8_SOBOL_WRITE - Fatal error!' - write ( *, '(a)' ) ' Could not open the output file.' - stop - end if - - call timestring ( string ) - - write ( file_out_unit, '(a)' ) '# ' // trim ( file_out_name ) - write ( file_out_unit, '(a)' ) '# created by I8_SOBOL_WRITE.F90.' - write ( file_out_unit, '(a)' ) '#' - write ( file_out_unit, '(a)' ) '# File generated on ' & - // trim ( string ) - write ( file_out_unit, '(a)' ) '#' - write ( file_out_unit, '(a,i8)' ) '# Spatial dimension M = ', m - write ( file_out_unit, '(a,i8)' ) '# Number of points N = ', n - write ( file_out_unit, '(a,g14.6)' ) '# Epsilon (unit roundoff) = ', & - epsilon ( r(1,1) ) - write ( file_out_unit, '(a,i8)' ) '# Initial values skipped = ', skip - write ( file_out_unit, '(a)' ) '#' - - write ( string, '(a,i3,a)' ) '(', m, '(2x,f10.6))' - do j = 1, n - write ( file_out_unit, string ) r(1:m,j) - end do - - close ( unit = file_out_unit ) - - return -end -function i8_uniform ( a, b, seed ) - -!*****************************************************************************80 -! -!! I8_UNIFORM returns a scaled pseudorandom I8. -! -! Discussion: -! -! An I8 is an integer ( kind = 8 ) value. -! -! Note that ALL integer variables in this routine are -! of type integer ( kind = 8 )! -! -! The pseudorandom number should be uniformly distributed -! between A and B. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 November 2006 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Paul Bratley, Bennett Fox, Linus Schrage, -! A Guide to Simulation, -! Springer Verlag, pages 201-202, 1983. -! -! Pierre L'Ecuyer, -! Random Number Generation, -! in Handbook of Simulation, -! edited by Jerry Banks, -! Wiley Interscience, page 95, 1998. -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, pages 362-376, 1986. -! -! Peter Lewis, Allen Goodman, James Miller -! A Pseudo-Random Number Generator for the System/360, -! IBM Systems Journal, -! Volume 8, pages 136-143, 1969. -! -! Parameters: -! -! Input, integer ( kind = 8 ) A, B, the limits of the interval. -! -! Input/output, integer ( kind = 8 ) SEED, the "seed" value, which -! should NOT be 0. On output, SEED has been updated. -! -! Output, integer ( kind = 8 ) I8_UNIFORM, a number between A and B. -! - implicit none - - integer ( kind = 8 ) a - integer ( kind = 8 ) b - integer ( kind = 8 ) i8_uniform - real ( kind = 8 ) r - real ( kind = 8 ) r8i8_uniform_01 - integer ( kind = 8 ) seed - integer ( kind = 8 ) value - - if ( seed == 0 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I8_UNIFORM - Fatal error!' - write ( *, '(a)' ) ' Input value of SEED = 0.' - stop - end if - - r = r8i8_uniform_01 ( seed ) -! -! Scale R to lie between A-0.5 and B+0.5. -! - r = ( 1.0D+00 - r ) * ( real ( min ( a, b ), kind = 8 ) - 0.5D+00 ) & - + r * ( real ( max ( a, b ), kind = 8 ) + 0.5D+00 ) -! -! Use rounding to convert R to an integer between A and B. -! - value = nint ( r, kind = 8 ) - - value = max ( value, min ( a, b ) ) - value = min ( value, max ( a, b ) ) - - i8_uniform = value - - return -end -function i8_xor ( i, j ) - -!*****************************************************************************80 -! -!! I8_XOR calculates the exclusive OR of two integers. -! -! Discussion: -! -! This function is NOT needed in FORTRAN90, which supplies the -! intrinsic IEOR function for this purpose. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 8 ) I, J, two values whose exclusive OR is needed. -! -! Output, integer ( kind = 8 ) I8_XOR, the exclusive OR of I and J. -! - implicit none - - integer ( kind = 8 ) i - integer ( kind = 8 ) i1 - integer ( kind = 8 ) i2 - integer ( kind = 8 ) i8_xor - integer ( kind = 8 ) j - integer ( kind = 8 ) j1 - integer ( kind = 8 ) j2 - integer ( kind = 8 ) k - integer ( kind = 8 ) l - - i1 = i - j1 = j - k = 0 - l = 1 - - do while ( i1 /= 0 .or. j1 /= 0 ) - - i2 = i1 / 2 - j2 = j1 / 2 - - if ( & - ( ( i1 == 2 * i2 ) .and. ( j1 /= 2 * j2 ) ) .or. & - ( ( i1 /= 2 * i2 ) .and. ( j1 == 2 * j2 ) ) ) then - k = k + l - end if - - i1 = i2 - j1 = j2 - l = 2 * l - - end do - - i8_xor = k - - return -end -function r8i8_uniform_01 ( seed ) - -!*****************************************************************************80 -! -!! R8I8_UNIFORM_01 returns a unit pseudorandom R8 using an I8 seed. -! -! Discussion: -! -! An R8 is a real ( kind = 8 ) value. -! -! An I8 is an integer ( kind = 8 ) value. -! -! This routine implements the recursion -! -! seed = 16807 * seed mod ( 2**31 - 1 ) -! r8_uniform_01 = seed / ( 2**31 - 1 ) -! -! The integer arithmetic never requires more than 32 bits, -! including a sign bit. -! -! If the initial seed is 12345, then the first three computations are -! -! Input Output R8I8_UNIFORM_01 -! SEED SEED -! -! 12345 207482415 0.096616 -! 207482415 1790989824 0.833995 -! 1790989824 2035175616 0.947702 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 20 September 2006 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Paul Bratley, Bennett Fox, Linus Schrage, -! A Guide to Simulation, -! Springer Verlag, pages 201-202, 1983. -! -! Pierre L'Ecuyer, -! Random Number Generation, -! in Handbook of Simulation, -! edited by Jerry Banks, -! Wiley Interscience, page 95, 1998. -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, pages 362-376, 1986. -! -! Peter Lewis, Allen Goodman, James Miller -! A Pseudo-Random Number Generator for the System/360, -! IBM Systems Journal, -! Volume 8, pages 136-143, 1969. -! -! Parameters: -! -! Input/output, integer ( kind = 8 ) SEED, the "seed" value, which should -! NOT be 0. On output, SEED has been updated. -! -! Output, real ( kind = 8 ) R8I8_UNIFORM_01, a new pseudorandom variate, -! strictly between 0 and 1. -! - implicit none - - integer ( kind = 8 ) k - real ( kind = 8 ) r8i8_uniform_01 - integer ( kind = 8 ) seed - - if ( seed == 0 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'R8I8_UNIFORM_01 - Fatal error!' - write ( *, '(a)' ) ' Input value of SEED = 0.' - stop - end if - - k = seed / 127773 - - seed = 16807 * ( seed - k * 127773 ) - k * 2836 - - if ( seed < 0 ) then - seed = seed + huge ( seed ) - end if - - r8i8_uniform_01 = real ( seed, kind = 8 ) * 4.656612875D-10 - - return -end -function tau_sobol ( dim_num ) - -!*****************************************************************************80 -! -!! TAU_SOBOL defines favorable starting seeds for Sobol sequences. -! -! Discussion: -! -! For spatial dimensions 1 through 13, this routine returns -! a "favorable" value TAU by which an appropriate starting point -! in the Sobol sequence can be determined. -! -! These starting points have the form N = 2**K, where -! for integration problems, it is desirable that -! TAU + DIM_NUM - 1 <= K -! while for optimization problems, it is desirable that -! TAU < K. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 July 2006 -! -! Author: -! -! FORTRAN77 original version by Bennett Fox. -! FORTRAN90 version by John Burkardt -! -! Reference: -! -! IA Antonov, VM Saleev, -! USSR Computational Mathematics and Mathematical Physics, -! Volume 19, 1980, pages 252 - 256. -! -! Paul Bratley, Bennett Fox, -! Algorithm 659: -! Implementing Sobol's Quasirandom Sequence Generator, -! ACM Transactions on Mathematical Software, -! Volume 14, Number 1, pages 88-100, 1988. -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, pages 362-376, 1986. -! -! Stephen Joe, Frances Kuo -! Remark on Algorithm 659: -! Implementing Sobol's Quasirandom Sequence Generator, -! ACM Transactions on Mathematical Software, -! Volume 29, Number 1, pages 49-57, March 2003. -! -! Ilya Sobol, -! USSR Computational Mathematics and Mathematical Physics, -! Volume 16, pages 236-242, 1977. -! -! Ilya Sobol, YL Levitan, -! The Production of Points Uniformly Distributed in a Multidimensional -! Cube (in Russian), -! Preprint IPM Akad. Nauk SSSR, -! Number 40, Moscow 1976. -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. Only values -! of 1 through 13 will result in useful responses. -! -! Output, integer ( kind = 4 ) TAU_SOBOL, the value TAU. -! - implicit none - - integer ( kind = 4 ), parameter :: dim_max = 13 - - integer ( kind = 4 ) dim_num - integer ( kind = 4 ), save, dimension ( dim_max ) :: tau = (/ & - 0, 0, 1, 3, 5, & - 8, 11, 15, 19, 23, & - 27, 31, 35 /) - integer ( kind = 4 ) tau_sobol - - if ( 1 <= dim_num .and. dim_num <= dim_max ) then - tau_sobol = tau(dim_num) - else - tau_sobol = - 1 - end if - - return -end -subroutine timestamp ( ) - -!*****************************************************************************80 -! -!! TIMESTAMP prints the current YMDHMS date as a time stamp. -! -! Example: -! -! May 31 2001 9:45:54.872 AM -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 31 May 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! None -! - implicit none - - character ( len = 8 ) ampm - integer d - character ( len = 8 ) date - integer h - integer m - integer mm - character ( len = 9 ), parameter, dimension(12) :: month = (/ & - 'January ', 'February ', 'March ', 'April ', & - 'May ', 'June ', 'July ', 'August ', & - 'September', 'October ', 'November ', 'December ' /) - integer n - integer s - character ( len = 10 ) time - integer values(8) - integer y - character ( len = 5 ) zone - - call date_and_time ( date, time, zone, values ) - - y = values(1) - m = values(2) - d = values(3) - h = values(5) - n = values(6) - s = values(7) - mm = values(8) - - if ( h < 12 ) then - ampm = 'AM' - else if ( h == 12 ) then - if ( n == 0 .and. s == 0 ) then - ampm = 'Noon' - else - ampm = 'PM' - end if - else - h = h - 12 - if ( h < 12 ) then - ampm = 'PM' - else if ( h == 12 ) then - if ( n == 0 .and. s == 0 ) then - ampm = 'Midnight' - else - ampm = 'AM' - end if - end if - end if - - write ( *, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & - trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm ) - - return -end -subroutine timestring ( string ) - -!*****************************************************************************80 -! -!! TIMESTRING writes the current YMDHMS date into a string. -! -! Example: -! -! STRING = 'May 31 2001 9:45:54.872 AM' -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 15 March 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, character ( len = * ) STRING, contains the date information. -! A character length of 40 should always be sufficient. -! - implicit none - - character ( len = 8 ) ampm - integer d - character ( len = 8 ) date - integer h - integer m - integer mm - character ( len = 9 ), parameter, dimension(12) :: month = (/ & - 'January ', 'February ', 'March ', 'April ', & - 'May ', 'June ', 'July ', 'August ', & - 'September', 'October ', 'November ', 'December ' /) - integer n - integer s - character ( len = * ) string - character ( len = 10 ) time - integer values(8) - integer y - character ( len = 5 ) zone - - call date_and_time ( date, time, zone, values ) - - y = values(1) - m = values(2) - d = values(3) - h = values(5) - n = values(6) - s = values(7) - mm = values(8) - - if ( h < 12 ) then - ampm = 'AM' - else if ( h == 12 ) then - if ( n == 0 .and. s == 0 ) then - ampm = 'Noon' - else - ampm = 'PM' - end if - else - h = h - 12 - if ( h < 12 ) then - ampm = 'PM' - else if ( h == 12 ) then - if ( n == 0 .and. s == 0 ) then - ampm = 'Midnight' - else - ampm = 'AM' - end if - end if - end if - - write ( string, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & - trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm ) - - return -end diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/all-wcprops b/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/all-wcprops deleted file mode 100644 index 10be7eb..0000000 --- a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/all-wcprops +++ /dev/null @@ -1,89 +0,0 @@ -K 25 -svn:wc:ra_dav:version-url -V 62 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/9/trunk/FUSE_SRC/FUSE_NETCDF -END -get_smodel.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/9/trunk/FUSE_SRC/FUSE_NETCDF/get_smodel.f90 -END -getmahudat.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NETCDF/getmahudat.f90 -END -handle_err.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NETCDF/handle_err.f90 -END -get_fparam.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NETCDF/get_fparam.f90 -END -put_output.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NETCDF/put_output.f90 -END -put_sstats.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NETCDF/put_sstats.f90 -END -extractor.f90 -K 25 -svn:wc:ra_dav:version-url -V 76 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NETCDF/extractor.f90 -END -put_params.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NETCDF/put_params.f90 -END -caldatss.f90 -K 25 -svn:wc:ra_dav:version-url -V 75 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NETCDF/caldatss.f90 -END -def_output.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NETCDF/def_output.f90 -END -juldayss.f90 -K 25 -svn:wc:ra_dav:version-url -V 75 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NETCDF/juldayss.f90 -END -def_sstats.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NETCDF/def_sstats.f90 -END -get_objfnc.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/9/trunk/FUSE_SRC/FUSE_NETCDF/get_objfnc.f90 -END -def_params.f90 -K 25 -svn:wc:ra_dav:version-url -V 77 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NETCDF/def_params.f90 -END diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/entries b/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/entries deleted file mode 100644 index a700a05..0000000 --- a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/entries +++ /dev/null @@ -1,504 +0,0 @@ -10 - -dir -63 -https://venture1.projectlocker.com/UoNEnvEngGroup/FUSE/svn/trunk/FUSE_SRC/FUSE_NETCDF -https://venture1.projectlocker.com/UoNEnvEngGroup/FUSE/svn - - - -2009-10-18T15:43:55.974595Z -9 -kavetski - - - - - - - - - - - - - - -7fd0be38-6417-4f01-9cbe-fd474d0c6e94 - -get_smodel.f90 -file - - - - -2013-06-12T18:10:48.631575Z -5296f4b9bf64ff7460d5faa00b7b29b8 -2009-10-18T15:43:55.974595Z -9 -kavetski - - - - - - - - - - - - - - - - - - - - - -2149 - -getmahudat.f90 -file - - - - -2013-06-12T18:10:48.631575Z -d402080257fbc597fba921a6ece7d7b8 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -9015 - -handle_err.f90 -file - - - - -2013-06-12T18:10:48.631575Z -e552f0e7cb4e8ad98fac02291b80fe94 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -416 - -get_fparam.f90 -file - - - - -2013-06-12T18:10:48.631575Z -98381b06f867ca870442cfa69980e596 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -2861 - -put_output.f90 -file - - - - -2013-06-12T18:10:48.631575Z -ce234cba1a3df238b8ba80713b681c65 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1767 - -put_sstats.f90 -file - - - - -2013-06-12T18:10:48.631575Z -db6654e3598812e5d63dee995ac517fd -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1874 - -extractor.f90 -file - - - - -2013-06-12T18:10:48.631575Z -4269df300c13eaf459e8d92a967aebbd -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1795 - -put_params.f90 -file - - - - -2013-06-12T18:10:48.631575Z -03061297d7b60b20c221602f4fdfeaa8 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -2162 - -caldatss.f90 -file - - - - -2013-06-12T18:10:48.631575Z -6b8f493960ca8e0427f499e47f928ab3 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1822 - -def_output.f90 -file - - - - -2013-06-12T18:10:48.631575Z -d1309ae2073211ab720465343c4b75f2 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1558 - -juldayss.f90 -file - - - - -2013-06-12T18:10:48.631575Z -8d2a0abdcb5da6bcf3bb382e30ef3b92 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1316 - -def_sstats.f90 -file - - - - -2013-06-12T18:10:48.631575Z -8129ed4fd9b3a7814e5a96195c727b7e -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1746 - -get_objfnc.f90 -file - - - - -2013-06-12T18:10:48.631575Z -804a22b2766f96a552ae36a21ea47d6a -2009-10-18T15:43:55.974595Z -9 -kavetski - - - - - - - - - - - - - - - - - - - - - -2283 - -def_params.f90 -file - - - - -2013-06-12T18:10:48.631575Z -a1a9b1c977e4fe5a063dc2166195834c -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1992 - diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/caldatss.f90.svn-base b/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/caldatss.f90.svn-base deleted file mode 100644 index 12ab140..0000000 --- a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/caldatss.f90.svn-base +++ /dev/null @@ -1,52 +0,0 @@ -!----------------------------------------------------------------------- -! Code from "Numerical Recipes in Fortran-77 -! -! Ref: Press, W.H., S.A. Teukolsky, W.T. Vetterling, and B.P. -! Flannery, 1992: Numerical Recipes in Fortran 77: -! The Art of Scientific Computing (2nd Ed.) Cambridge -! University Press, 933pp. -!----------------------------------------------------------------------- -! Modified by David Rupp 2006-March-07 to account for hours -! Output is yyyy, mm, dd, hh -!----------------------------------------------------------------------- -SUBROUTINE caldatss(julianss,iyyy,mm,id,ih,im,ss) -!SUBROUTINE caldat(julian,mm,id,iyyy) -!INTEGER id,iyyy,julian,mm,IGREG -INTEGER iyyy, mm, id, ih, im, julian, IGREG -DOUBLE PRECISION julianss, juliandd, hours, minutes, ss -PARAMETER (IGREG=2299161) -INTEGER ja,jalpha,jb,jc,jd,je - -! gets the julian day in units of days since the beginning of time -juliandd = julianss / 86400 -julian = int(juliandd) -! gets the hours, (remaining decimal)*24 -hours = (juliandd-julian)*24 -ih = int(hours) ! convert to an integer -! get the minutes, (remaining decimal)*60 -minutes = (hours-ih)*60 -im = int(minutes) -! get the seconds (keep as a decimal -ss = (minutes-im)*60 - -! uses the integer julian from above (below original num rec) -if(julian.ge.IGREG)then - jalpha=int(((julian-1867216)-0.25)/36524.25) - ja=julian+1+jalpha-int(0.25*jalpha) -else if(julian.lt.0)then - ja=julian+36525*(1-julian/36525) -else - ja=julian -endif -jb=ja+1524 -jc=int(6680.+((jb-2439870)-122.1)/365.25) -jd=365*jc+int(0.25*jc) -je=int((jb-jd)/30.6001) -id=jb-jd-int(30.6001*je) -mm=je-1 -if(mm.gt.12)mm=mm-12 -iyyy=jc-4715 -if(mm.gt.2)iyyy=iyyy-1 -if(iyyy.le.0)iyyy=iyyy-1 -if(julian.lt.0)iyyy=iyyy-100*(1-julian/36525) -ENDSUBROUTINE caldatss diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/def_output.f90.svn-base b/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/def_output.f90.svn-base deleted file mode 100644 index d93b3a0..0000000 --- a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/def_output.f90.svn-base +++ /dev/null @@ -1,28 +0,0 @@ -SUBROUTINE DEF_OUTPUT(NTIM) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Define NetCDF output files -- time-varying model output -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition (includes filename) -USE metaoutput ! metadata for all model variables -IMPLICIT NONE -! input -INTEGER(I4B), INTENT(IN) :: NTIM ! number of time steps -! internal -INTEGER(I4B) :: IERR,NCID ! error code; NetCDF ID -INTEGER(I4B) :: NTIM_DIM ! time -INTEGER(I4B) :: NPAR_DIM ! number of parameter sets -INTEGER(I4B) :: NMOD_DIM ! number of models -INTEGER(I4B), DIMENSION(3) :: TVAR ! time-varying dimensions -INTEGER(I4B) :: IVAR ! loop through variables -INTEGER(I4B) :: IVAR_ID ! variable ID -! --------------------------------------------------------------------------------------- -! CONTENT REMOVED FOR COPYRIGHT VIOLATION -! --------------------------------------------------------------------------------------- -END SUBROUTINE DEF_OUTPUT diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/def_params.f90.svn-base b/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/def_params.f90.svn-base deleted file mode 100644 index 3bd4e59..0000000 --- a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/def_params.f90.svn-base +++ /dev/null @@ -1,33 +0,0 @@ -SUBROUTINE DEF_PARAMS(NMOD) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Define NetCDF output files -- parameter variables -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition (includes filename) -USE metaparams ! metadata for all model parameters -USE multistats, ONLY:MSTATS ! model statistics structure -IMPLICIT NONE -! input -INTEGER(I4B), INTENT(IN) :: NMOD ! number of models -! internal -INTEGER(I4B) :: IERR,NCID ! error code; NetCDF ID -INTEGER(I4B) :: NPAR_DIM ! number of parameter sets -INTEGER(I4B) :: NMOD_DIM ! number of models -INTEGER(I4B) :: NDIF_DIM ! differences in models -INTEGER(I4B) :: NAME_DIM ! length of string defining models -INTEGER(I4B) :: ERRM_DIM ! length of string defining error message -INTEGER(I4B), DIMENSION(2) :: FVAR ! fixed dimensions -INTEGER(I4B), DIMENSION(3) :: SVAR ! model descriptor dimensions -INTEGER(I4B), DIMENSION(3) :: EVAR ! error message dimensions -INTEGER(I4B) :: IVAR ! loop through variables -INTEGER(I4B) :: IVAR_ID ! variable ID -! --------------------------------------------------------------------------------------- -! CONTENT REMOVED FOR COPYRIGHT VIOLATION -! --------------------------------------------------------------------------------------- -END SUBROUTINE DEF_PARAMS diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/def_sstats.f90.svn-base b/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/def_sstats.f90.svn-base deleted file mode 100644 index ea37a1b..0000000 --- a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/def_sstats.f90.svn-base +++ /dev/null @@ -1,29 +0,0 @@ -SUBROUTINE DEF_SSTATS() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Define NetCDF output files -- summary statistics -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition (includes filename) -USE meta_stats ! metadata for summary statistics -USE model_numerix ! model numerix decisions -IMPLICIT NONE -! internal -INTEGER(I4B) :: IERR,NCID ! error code; NetCDF ID -INTEGER(I4B) :: NPAR_DIM ! number of parameter sets -INTEGER(I4B) :: NMOD_DIM ! number of models -INTEGER(I4B) :: NORD_DIM ! number of ordinates in prob distn -INTEGER(I4B), DIMENSION(2) :: FVAR ! dimensions for summary statistics -INTEGER(I4B), DIMENSION(3) :: PVAR ! dimensions for probability distributions -INTEGER(I4B) :: IVAR ! loop through variables -INTEGER(I4B) :: IVAR_ID ! variable ID -INTEGER(I4B) :: IORD_ID ! ordinates ID -! --------------------------------------------------------------------------------------- -! CONTENT REMOVED FOR COPYRIGHT VIOLATION -! --------------------------------------------------------------------------------------- -END SUBROUTINE DEF_SSTATS diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/extractor.f90.svn-base b/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/extractor.f90.svn-base deleted file mode 100644 index b443c5b..0000000 --- a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/extractor.f90.svn-base +++ /dev/null @@ -1,47 +0,0 @@ -!---------------------------------------------------------------------------------------- -! This is part of the code used as a replacement for the udunits -! libraries. It extracts the year, month and day from the reference -! given in the netCDF data file -! -! David Rupp -- 2006-March-07 -! -!---------------------------------------------------------------------------------------- -SUBROUTINE EXTRACTOR(REFDATE,YY,IM,DD,HH) -USE nrtype -IMPLICIT NONE -CHARACTER(LEN=50) :: REFDATE ! ref time and units string netCDF file -CHARACTER(LEN=50) :: REFD ! temporary time and units string -CHARACTER(LEN=4) :: CYYYY ! char year extracted from UNITSTR -CHARACTER(LEN=2) :: CMM, CDD, CHH ! char month and day and hour extracted from UNISTR -INTEGER(I4B) :: POSIT ! used to extract date from UNITSTR -INTEGER(I4B) :: YY,IM,DD,HH ! start time (year,month,day,hour) - -! strip out time units, if they exist (seconds since , days since , hours since ) -REFD = TRIM(REFDATE) -POSIT = INDEX(REFDATE, 'since') -IF (POSIT.GT.0) REFD = REFD(POSIT+6:50) ! +6 because 'since' has 5 characters -! get the year -POSIT = INDEX(REFD, '-') ! up to - -CYYYY = REFD(1:POSIT-1) -! get the month -REFD = REFD(POSIT+1:50) -POSIT = INDEX(REFD, '-') ! up to - -CMM = REFD(1:POSIT-1) -! get the day -REFD = REFD(POSIT+1:50) -POSIT = INDEX(REFD, ' ') ! up to space -CDD = REFD(1:POSIT-1) -! get the hour -REFD = REFD(POSIT+1:50) -POSIT = INDEX(REFD, ':') ! up to : -IF (POSIT.GT.0) THEN - CHH = REFD(1:POSIT-1) -ELSE - CHH = '00' -ENDIF -! convert to integers -READ(CYYYY,'(i4)') YY -READ(CMM,'(i2)') IM -READ(CDD,'(i2)') DD -READ(CHH,'(i2)') HH -END SUBROUTINE EXTRACTOR diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/get_fparam.f90.svn-base b/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/get_fparam.f90.svn-base deleted file mode 100644 index 27e2acc..0000000 --- a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/get_fparam.f90.svn-base +++ /dev/null @@ -1,55 +0,0 @@ -SUBROUTINE GET_FPARAM(NETCDF_FILE,IMOD,MPAR,XPAR) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Read parameters in LPARAM from the last parameter set in the specified NetCDF file -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE ddirectory ! defines data directory -USE multiparam, ONLY: LPARAM, NUMPAR ! parameter names -IMPLICIT NONE -! input -CHARACTER(LEN=*), INTENT(IN) :: NETCDF_FILE ! NetCDF file name -INTEGER(I4B), INTENT(IN) :: IMOD ! model index -INTEGER(I4B), INTENT(IN) :: MPAR ! number of model parameters -! internal -LOGICAL(LGT) :: LEXIST ! .TRUE. if NetCDF file exists -INTEGER(I4B) :: IERR ! error code -INTEGER(I4B) :: NCID ! NetCDF file ID -INTEGER(I4B) :: IDIMID ! NetCDF dimension ID -INTEGER(I4B) :: IVARID ! NetCDF variable ID -INTEGER(I4B) :: IPAR ! loop through model parameters -INTEGER(I4B) :: NPAR ! number of parameter sets in output file -REAL(MSP) :: APAR ! parameter value (single precision) -! output -REAL(SP), DIMENSION(MPAR), INTENT(OUT) :: XPAR ! parameter value (whatever precision SP is) -include 'netcdf.inc' ! use netCDF libraries -! --------------------------------------------------------------------------------------- -! check that the file exists -INQUIRE(FILE=TRIM(OUTPUT_PATH)//TRIM(NETCDF_FILE),EXIST=LEXIST) -IF (.NOT.LEXIST) THEN - print *, ' NetCDF file defining the desired model does not exist ' - print *, ' File = ', TRIM(OUTPUT_PATH)//TRIM(NETCDF_FILE) - STOP -ENDIF -! open file -IERR = NF_OPEN(TRIM(OUTPUT_PATH)//TRIM(NETCDF_FILE),NF_NOWRITE,NCID); CALL HANDLE_ERR(IERR) - ! get number of parameter sets - IERR = NF_INQ_DIMID(NCID,'par',IDIMID); CALL HANDLE_ERR(IERR) - IERR = NF_INQ_DIMLEN(NCID,IDIMID,NPAR); CALL HANDLE_ERR(IERR) - ! loop through parameters - DO IPAR=1,NUMPAR - ! get parameter value - IERR = NF_INQ_VARID(NCID,TRIM(LPARAM(IPAR)%PARNAME),IVARID); CALL HANDLE_ERR(IERR) - IERR = NF_GET_VAR1_REAL(NCID,IVARID,(/IMOD,NPAR/),APAR); CALL HANDLE_ERR(IERR) - ! put parameter value in the output vector - XPAR(IPAR) = APAR - END DO -! close NetCDF file -IERR = NF_CLOSE(NCID) -! --------------------------------------------------------------------------------------- -END SUBROUTINE GET_FPARAM diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/get_objfnc.f90.svn-base b/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/get_objfnc.f90.svn-base deleted file mode 100644 index 82b94d6..0000000 --- a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/get_objfnc.f90.svn-base +++ /dev/null @@ -1,40 +0,0 @@ -MODULE GET_OBJFNC_MODULE -IMPLICIT NONE -CONTAINS -! --------------------------------------------------------------------------------------- -SUBROUTINE GET_OBJFNC(NETCDF_FILE,OF_NAME,IMOD,IPARSET,OF,XOPT) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Read data in variable "OF_NAME" from file "NETCDF_FILE" -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE fuse_fileManager,only:INPUT_PATH ! defines data directory -USE multiparam, ONLY: LPARAM, NUMPAR ! parameter names -IMPLICIT NONE -! input -CHARACTER(LEN=*), INTENT(IN) :: NETCDF_FILE ! NetCDF file name -CHARACTER(LEN=*), INTENT(IN) :: OF_NAME ! Objective function name -INTEGER(I4B), INTENT(IN) :: IMOD ! Model index -INTEGER(I4B), INTENT(IN) :: IPARSET ! index of the parameter set -! internal -LOGICAL(LGT) :: LEXIST ! .TRUE. if NetCDF file exists -INTEGER(I4B) :: IERR ! error code -INTEGER(I4B) :: NCID ! NetCDF file ID -INTEGER(I4B) :: IDIMID ! NetCDF dimension ID -INTEGER(I4B) :: IVARID ! NetCDF variable ID -INTEGER(I4B) :: IPAR ! loop through model parameters -REAL(MSP) :: OF_VAL ! objective function value (single precision) -REAL(MSP) :: APAR ! parameter value (single precision) -! output -REAL(SP), INTENT(OUT) :: OF ! objective function value (whatever precision SP is) -REAL(SP), DIMENSION(:), INTENT(OUT) :: XOPT ! optimal parameter set -! --------------------------------------------------------------------------------------- -! CONTENT REMOVED FOR COPYRIGHT VIOLATION -! --------------------------------------------------------------------------------------- -END SUBROUTINE GET_OBJFNC -END MODULE GET_OBJFNC_MODULE diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/get_smodel.f90.svn-base b/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/get_smodel.f90.svn-base deleted file mode 100644 index 26de20b..0000000 --- a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/get_smodel.f90.svn-base +++ /dev/null @@ -1,37 +0,0 @@ -SUBROUTINE GET_SMODEL(NETCDF_FILE,IMOD) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Read model decisions from a NetCDF output file -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE model_defn -- populate structure SMODL -! --------------------------------------------------------------------------------------- -USE nrtype ! data types, etc. -! USE fuse_fileManager,only ! defines data directory -USE model_defn ! model definition structures -IMPLICIT NONE -! input -CHARACTER(LEN=*), INTENT(IN) :: NETCDF_FILE ! NetCDF file name -INTEGER(I4B), INTENT(IN) :: IMOD ! model index -! internal -LOGICAL(LGT) :: LEXIST ! .TRUE. if NetCDF file exists -INTEGER(I4B) :: IERR ! error code -INTEGER(I4B) :: NCID ! NetCDF file ID -INTEGER(I4B) :: IDIMID ! NetCDF dimension ID -INTEGER(I4B) :: IVARID ! NetCDF variable ID -INTEGER(I4B) :: NDESC ! number of model descriptors -INTEGER(I4B) :: NCHAR ! length of model descriptors -INTEGER(I4B) :: IDESC ! loop thru model descriptors -INTEGER(I4B), DIMENSION(3) :: ISTART ! start indices for data read -INTEGER(I4B), DIMENSION(3) :: ICOUNT ! number of elements read in each dimension -CHARACTER(LEN=50) :: TXTVEC ! text vector -! --------------------------------------------------------------------------------------- -! CONTENT REMOVED FOR COPYRIGHT VIOLATION -! --------------------------------------------------------------------------------------- -END SUBROUTINE GET_SMODEL diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/getmahudat.f90.svn-base b/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/getmahudat.f90.svn-base deleted file mode 100644 index 718ecea..0000000 --- a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/getmahudat.f90.svn-base +++ /dev/null @@ -1,158 +0,0 @@ -SUBROUTINE GETMAHUDAT(NFORCE) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2008 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Read Mahurangi data from NetCDF files -! -! Data is stored in two files -! Rain = rain_wra-mixed_1997010100_2002123100_02001770_hourly.nc -! PET = pet_wra-mixed_1997010100_2002123100_02001770_hourly.nc -! -! The rain file includes data from 13 stations, and the potential ET file includes PET -! estimates for the lowest elevation and highest elevation sub-basin in the Mahurangi. -! -! Simply average over the spatial dimension. -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multiforce -- populate structure AFORCE(*)%(*) -! --------------------------------------------------------------------------------------- -USE nrtype ! data types, etc. -USE ddirectory ! defines data directory -USE multiforce ! model forcing structures -USE multiroute ! model routing structures -IMPLICIT NONE -! internal -INTEGER(I4B) :: I ! looping -integer(i4b),parameter::lenPath=1024 !DK211008: allows longer file paths -INTEGER(I4B) :: IBEG,IEND ! start/end indices of desired data -INTEGER(I4B) :: IVAR ! loop through variables -CHARACTER(LEN=lenPath) :: FNAME_INPUT ! name of input file -CHARACTER(LEN=64) :: VARNAME ! name of variable -INTEGER(I4B) :: IERR ! error code -INTEGER(I4B) :: NCID ! NetCDF file ID -INTEGER(I4B) :: IDIMID ! NetCDF dimension ID -INTEGER(I4B) :: IVARID ! NetCDF variable ID -INTEGER(I4B) :: NTIM ! number of data intervals -INTEGER(I4B) :: NSTN ! number of stations -REAL(DP),DIMENSION(:),ALLOCATABLE :: ATIME ! time vector -REAL(MSP),DIMENSION(:,:),ALLOCATABLE :: TDATA ! space-time data array -REAL(SP) :: TAVE ! average of temporary data for one time interval -CHARACTER(LEN=256) :: TUNITS ! time units -REAL(DP) :: REF_ZERO ! ref date in sec since year dot -REAL(DP) :: JULDAYSS ! FUNCTION NAME, used to compute REF_ZERO -REAL(DP) :: JUL_TIME ! time stamp -- date in sec since year dot -INTEGER(I4B) :: ITIM ! loop through time -INTEGER(I4B) :: JTIM ! time index in output array -INTEGER(I4B) :: IY,IM,ID,IH ! reference time -INTEGER(I4B) :: JY,JM,JD,JH ! time for a given time step -INTEGER(I4B) :: JMIN ! minute (NOT USED -- returned by caldatss.f) -REAL(DP) :: JSEC ! second (NOT USED -- returned by caldatss.f) -INTEGER(I4B) :: ISTA ! index of station desired -REAL(DP) :: AREA_K2 ! catchment area (km^2) -REAL(DP) :: AREA_M2 ! catchment area (m^2) -! output -INTEGER(I4B), INTENT(OUT) :: NFORCE ! number of time steps -include 'netcdf.inc' ! use netCDF libraries -! --------------------------------------------------------------------------------------- -! define the start and end indices -IBEG =5088 ; IEND=40151; NFORCE=(IEND-IBEG)+1 -! allocate space for the forcing structure (shared in module multiforce) -ALLOCATE(AFORCE(NFORCE),STAT=IERR); IF(IERR.NE.0) STOP ' problem allocating space for AFORCE ' -! allocate space for the output structure (shared in module multiroute) -ALLOCATE(AROUTE(NFORCE),STAT=IERR); IF(IERR.NE.0) STOP ' problem allocating space for AROUTE ' -! define catchment attributes -ISTA = 1 ! station #1 is Mahurangi at College -AREA_K2 = 46.650_dp ! Mahurangi catchment area (km^2) -AREA_M2 = AREA_K2 * 1000000._dp ! Mahurangi catchment area (m^2) -! loop through variables (1=rain, 2=pet, 3=flow) -DO IVAR=1,3 - ! define variable names - FORALL(I=1:LEN(VARNAME)) VARNAME(I:I) = ' ' - IF (IVAR.EQ.1) VARNAME='rain' - IF (IVAR.EQ.2) VARNAME='pet' - IF (IVAR.EQ.3) VARNAME='flow' - ! --------------------------------------------------------------------------------------- - ! (1) EXTRACT DATA FROM NETCDF FILES - ! --------------------------------------------------------------------------------------- - ! define filenames - FORALL(I=1:LEN(FNAME_INPUT)) FNAME_INPUT(I:I) = ' ' - FNAME_INPUT = DATA_PATH(1:LEN_TRIM(DATA_PATH))//TRIM(VARNAME)//& - '_wra-mixed_1997010100_2002123100_02001770_hourly.nc' - ! open file - IERR = NF_OPEN(TRIM(FNAME_INPUT),NF_NOWRITE,NCID); CALL HANDLE_ERR(IERR) - ! get the number of time elements - IERR = NF_INQ_DIMID(NCID,'time',IDIMID); CALL HANDLE_ERR(IERR) - IERR = NF_INQ_DIMLEN(NCID,IDIMID,NTIM); CALL HANDLE_ERR(IERR) - ! get the number of "stations" - IERR = NF_INQ_DIMID(NCID,'station',IDIMID); CALL HANDLE_ERR(IERR) - IERR = NF_INQ_DIMLEN(NCID,IDIMID,NSTN); CALL HANDLE_ERR(IERR) - ! allocate space for temporary arrays - ALLOCATE(ATIME(NTIM),STAT=IERR); IF(IERR.NE.0) STOP ' problem allocating space for ATIME ' - ALLOCATE(TDATA(NSTN,NTIM),STAT=IERR); IF(IERR.NE.0) STOP ' problem allocating space for TDATA ' - ! get the time data - IERR = NF_INQ_VARID(NCID,'time',IVARID); CALL HANDLE_ERR(IERR) - IERR = NF_GET_VARA_DOUBLE(NCID,IVARID,(/1/),(/NTIM/),ATIME); CALL HANDLE_ERR(IERR) - IERR = NF_GET_ATT_TEXT(NCID,IVARID,'units',TUNITS); CALL HANDLE_ERR(IERR) - ! get the data - IERR = NF_INQ_VARID(NCID,TRIM(VARNAME),IVARID); CALL HANDLE_ERR(IERR) - IERR = NF_GET_VARA_REAL(NCID,IVARID,(/1,1/),(/NSTN,NTIM/),TDATA); CALL HANDLE_ERR(IERR) - ! close the NetCDF file - IERR = NF_CLOSE(NCID); CALL HANDLE_ERR(IERR) - ! --------------------------------------------------------------------------------------- - ! (2) PUT DATA INTO DATA STRUCTURES - ! --------------------------------------------------------------------------------------- - ! convert the ref date in units of seconds since year dot - CALL EXTRACTOR(TUNITS,IY,IM,ID,IH) ! get year, month, day, hour, of reference date - REF_ZERO = JULDAYSS(IY,IM,ID,IH) ! get the ref date in units of seconds since year dot - ! loop through time - DO ITIM=MAX(1,IBEG),MIN(IEND,NTIM) - ! define time index in output array - JTIM = (ITIM-IBEG)+1 - ! put time in time arrays - JUL_TIME = REF_ZERO+ATIME(ITIM) ! get the julian time (double precision) - IF (IVAR.EQ.1) THEN - ! get the year/month/day/hour/minute/second (+0.1 sec to avoid min=59 sec=60) - CALL CALDATSS(JUL_TIME+0.1_sp,JY,JM,JD,JH,JMIN,JSEC); JSEC = ANINT(JSEC) - AFORCE(JTIM)%IY = JY; AFORCE(JTIM)%IM = JM; AFORCE(JTIM)%ID = JD; AFORCE(JTIM)%IH = JH - AFORCE(JTIM)%IMIN = JMIN; AFORCE(JTIM)%DSEC = JSEC; AFORCE(JTIM)%DTIME = JUL_TIME - ! check that the time matches - ELSE - IF (ABS(AFORCE(JTIM)%DTIME - JUL_TIME) .GT. 1.0D0) THEN ! (one-second tolerance) - WRITE(*,'(2(F20.1,1X))') AFORCE(JTIM)%DTIME, JUL_TIME - STOP ' mis-match in time ' - ENDIF - ENDIF - ! compute average from temporary data array (and convert mm/h --> mm/d) - IF (TRIM(VARNAME).EQ.'rain' .OR. TRIM(VARNAME).EQ.'pet') THEN - TAVE = (SUM(TDATA(:,ITIM))/NSTN)*24. ! compute average - IF (ANY(TDATA(:,ITIM) .LT. 0.)) STOP ' MISSING FORCING DATA IN DESIRED TIME RANGE ' - ENDIF - ! select a station (and convert from m3/s to mm/h) - IF (TRIM(VARNAME).EQ.'flow') THEN - TAVE = (TDATA(ISTA,ITIM)/AREA_M2)*1000.*3600. ! m3/s --> mm/h - IF (TDATA(ISTA,ITIM) .LT. 0.) STOP ' MISSING VALIDATION DATA IN DESIRED TIME RANGE ' - ENDIF - ! put data in the data structures - IF (TRIM(VARNAME).EQ.'rain') AFORCE(JTIM)%PPT = TAVE - IF (TRIM(VARNAME).EQ.'pet') AFORCE(JTIM)%PET = TAVE - IF (TRIM(VARNAME).EQ.'flow') AFORCE(JTIM)%OBSQ = TAVE - !IF (IVAR.EQ.3) & - ! WRITE(*,'(I10,1X,I4,1X,4(I2,1X),F9.3,1X,F15.1,1X,3(ES12.4,1X))') ITIM, AFORCE(JTIM) - END DO ! (looping through time) - ! deallocate arrays - DEALLOCATE(ATIME,TDATA, STAT=IERR); IF (IERR.NE.0) STOP ' problem deallocating ATIME/TDATA ' -END DO ! (looping through variables) -! flush buffer -CALL FLUSH(6) -! save the number of time steps -NUMTIM = NFORCE ! (NUMTIM is stored in module multiforce) -! save the time step (DELTIM is stored in module multiforce) -DELTIM = (AFORCE(2)%DTIME - AFORCE(1)%DTIME) / 86400._sp -!pause -! --------------------------------------------------------------------------------------- -END SUBROUTINE GETMAHUDAT diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/handle_err.f90.svn-base b/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/handle_err.f90.svn-base deleted file mode 100644 index fe68330..0000000 --- a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/handle_err.f90.svn-base +++ /dev/null @@ -1,8 +0,0 @@ -SUBROUTINE HANDLE_ERR(IERR) -! Used to print our error statements from NetCDF calls and stop -USE nrtype -INTEGER(I4B) :: IERR ! error code -! --------------------------------------------------------------------------------------- -! CONTENT REMOVED FOR COPYRIGHT VIOLATION -! --------------------------------------------------------------------------------------- -END SUBROUTINE HANDLE_ERR diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/juldayss.f90.svn-base b/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/juldayss.f90.svn-base deleted file mode 100644 index 61720f2..0000000 --- a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/juldayss.f90.svn-base +++ /dev/null @@ -1,46 +0,0 @@ -!----------------------------------------------------------------------- -! Code from "Numerical Recipes in Fortran-77 -! -! Ref: Press, W.H., S.A. Teukolsky, W.T. Vetterling, and B.P. -! Flannery, 1992: Numerical Recipes in Fortran 77: -! The Art of Scientific Computing (2nd Ed.) Cambridge -! University Press, 933pp. -!----------------------------------------------------------------------- -! Modified by David Rupp 2006-March-07 to account for hours with -! Output julian time in units of seconds from date -!----------------------------------------------------------------------- -FUNCTION juldayss(yyin,mmin,ddin,hhin) -INTEGER julday,iyyy,mm,id,ih,IGREG -INTEGER yyin,mmin,ddin,hhin -DOUBLE PRECISION juldayss -PARAMETER (IGREG=15+31*(10+12*1582)) !IGREG = 588829 -INTEGER ja,jm,jy - -iyyy = yyin -mm= mmin -id = ddin -ih = hhin - -jy=iyyy -if (jy.eq.0) then - write(*,*) 'julday: there is no year zero' - stop -endif -if (jy.lt.0) jy=jy+1 -if (mm.gt.2) then - jm=mm+1 -else - jy=jy-1 - jm=mm+13 -endif -julday=int(365.25*jy)+int(30.6001*jm)+id+1720995 -if (id+31*(mm+12*iyyy).ge.IGREG) then - ja=int(0.01*jy) - julday=julday+2-ja+int(0.25*ja) -endif - -juldayss = 86400.0D0*real(julday, KIND(JULDAYSS) ) & - + real(ih, KIND(JULDAYSS) )*3600.0D0 - -return -END diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/put_output.f90.svn-base b/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/put_output.f90.svn-base deleted file mode 100644 index b9acbe0..0000000 --- a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/put_output.f90.svn-base +++ /dev/null @@ -1,30 +0,0 @@ -SUBROUTINE PUT_OUTPUT(IPAR,IMOD,ITIM) -! --------------------------------------------------------------------------------------- -! 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 -IMPLICIT NONE -! input -INTEGER(I4B), INTENT(IN) :: IPAR ! parameter set index -INTEGER(I4B), INTENT(IN) :: IMOD ! model index -INTEGER(I4B), INTENT(IN) :: ITIM ! time step index -! internal -INTEGER(I4B) :: IERR,NCID ! error code; NetCDF ID -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) -INTEGER(I4B) :: IVAR_ID ! variable ID -! --------------------------------------------------------------------------------------- -! CONTENT REMOVED FOR COPYRIGHT VIOLATION -! --------------------------------------------------------------------------------------- -END SUBROUTINE PUT_OUTPUT diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/put_params.f90.svn-base b/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/put_params.f90.svn-base deleted file mode 100644 index 9ab7356..0000000 --- a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/put_params.f90.svn-base +++ /dev/null @@ -1,35 +0,0 @@ -SUBROUTINE PUT_PARAMS(IPAR,IMOD) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! write NetCDF output files -- model parameters -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition structures (includes filename) -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 -INTEGER(I4B), INTENT(IN) :: IMOD ! model index -! internal -INTEGER(I4B) :: IERR,NCID ! error code; NetCDF ID -INTEGER(I4B), DIMENSION(2) :: 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=8 ! number of model descriptors -INTEGER(I4B), PARAMETER :: NCHAR=10 ! length of model descriptors -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 -! --------------------------------------------------------------------------------------- -! CONTENT REMOVED FOR COPYRIGHT VIOLATION -! --------------------------------------------------------------------------------------- -END SUBROUTINE PUT_PARAMS diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/put_sstats.f90.svn-base b/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/put_sstats.f90.svn-base deleted file mode 100644 index 30342ca..0000000 --- a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/.svn/text-base/put_sstats.f90.svn-base +++ /dev/null @@ -1,31 +0,0 @@ -SUBROUTINE PUT_SSTATS(IPAR,IMOD) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! write NetCDF output files -- summary statistics -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition structures (includes filename) -USE meta_stats ! metadata for summary statistics -USE multistats ! model summary statistics -USE model_numerix ! model numerix parameters and arrays -USE sumextract_module ! module to extract summary statistics -IMPLICIT NONE -! input -INTEGER(I4B), INTENT(IN) :: IPAR ! parameter set index -INTEGER(I4B), INTENT(IN) :: IMOD ! model index -! internal -INTEGER(I4B) :: IERR,NCID ! error code; NetCDF ID -INTEGER(I4B), DIMENSION(2) :: INDX ! indices for parameter write -INTEGER(I4B) :: IVAR ! loop through parameters -REAL(SP) :: XPAR ! desired parameter (SP may not be SP) -REAL(MSP) :: APAR ! desired parameter (...but MSP is SP) -INTEGER(I4B) :: IVAR_ID ! variable ID -! --------------------------------------------------------------------------------------- -! CONTENT REMOVED FOR COPYRIGHT VIOLATION -! --------------------------------------------------------------------------------------- -END SUBROUTINE PUT_SSTATS diff --git a/build/FUSE_SRC/FUSE_NR/.svn/all-wcprops b/build/FUSE_SRC/FUSE_NR/.svn/all-wcprops deleted file mode 100644 index 85a3a0b..0000000 --- a/build/FUSE_SRC/FUSE_NR/.svn/all-wcprops +++ /dev/null @@ -1,77 +0,0 @@ -K 25 -svn:wc:ra_dav:version-url -V 58 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NR -END -lubksb.f90 -K 25 -svn:wc:ra_dav:version-url -V 69 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NR/lubksb.f90 -END -ludcmp.f90 -K 25 -svn:wc:ra_dav:version-url -V 69 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NR/ludcmp.f90 -END -svbksb.f90 -K 25 -svn:wc:ra_dav:version-url -V 69 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NR/svbksb.f90 -END -gammln.f90 -K 25 -svn:wc:ra_dav:version-url -V 69 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NR/gammln.f90 -END -pythag.f90 -K 25 -svn:wc:ra_dav:version-url -V 69 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NR/pythag.f90 -END -svdcmp.f90 -K 25 -svn:wc:ra_dav:version-url -V 69 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NR/svdcmp.f90 -END -nrutil.f90 -K 25 -svn:wc:ra_dav:version-url -V 69 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NR/nrutil.f90 -END -gcf.f90 -K 25 -svn:wc:ra_dav:version-url -V 66 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NR/gcf.f90 -END -nr.f90 -K 25 -svn:wc:ra_dav:version-url -V 65 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NR/nr.f90 -END -gser.f90 -K 25 -svn:wc:ra_dav:version-url -V 67 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NR/gser.f90 -END -gammp.f90 -K 25 -svn:wc:ra_dav:version-url -V 68 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NR/gammp.f90 -END -nrtype.f90 -K 25 -svn:wc:ra_dav:version-url -V 69 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NR/nrtype.f90 -END diff --git a/build/FUSE_SRC/FUSE_NR/.svn/entries b/build/FUSE_SRC/FUSE_NR/.svn/entries deleted file mode 100644 index 67b286b..0000000 --- a/build/FUSE_SRC/FUSE_NR/.svn/entries +++ /dev/null @@ -1,436 +0,0 @@ -10 - -dir -63 -https://venture1.projectlocker.com/UoNEnvEngGroup/FUSE/svn/trunk/FUSE_SRC/FUSE_NR -https://venture1.projectlocker.com/UoNEnvEngGroup/FUSE/svn - - - -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - -7fd0be38-6417-4f01-9cbe-fd474d0c6e94 - -lubksb.f90 -file - - - - -2013-06-12T18:10:48.579574Z -c318f073662410dda23ac0881cf64d2c -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -646 - -ludcmp.f90 -file - - - - -2013-06-12T18:10:48.579574Z -6ec5d7b4511bf137b88dc5859cafb312 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -864 - -svbksb.f90 -file - - - - -2013-06-12T18:10:48.579574Z -a47e2b61190e56b351b9fc7baaeaace8 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -544 - -gammln.f90 -file - - - - -2013-06-12T18:10:48.583574Z -3b99681787a1b4c6c9e0966099618aee -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1353 - -pythag.f90 -file - - - - -2013-06-12T18:10:48.583574Z -8df323c34443791617635f725186cb40 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -388 - -svdcmp.f90 -file - - - - -2013-06-12T18:10:48.583574Z -bc67c65e85a25646ed33549337ad7afb -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -3981 - -nrutil.f90 -file - - - - -2013-06-12T18:10:48.583574Z -644ebaadc616b000030ebea7c7410a82 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -29215 - -gcf.f90 -file - - - - -2013-06-12T18:10:48.583574Z -8baa2f4bd0014bb51462b17983a33b02 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -2235 - -nr.f90 -file - - - - -2013-06-12T18:10:48.583574Z -02418d4b1f0c164cd0cbbd8b28bade49 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -87419 - -gser.f90 -file - - - - -2013-06-12T18:10:48.583574Z -9d4bd6c81b3a4f8c575715d230d91c04 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1909 - -gammp.f90 -file - - - - -2013-06-12T18:10:48.583574Z -89c888f887b89c08af9dee6d5ad4cea7 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -840 - -nrtype.f90 -file - - - - -2013-06-12T18:10:48.583574Z -82d359488ba50f78181d9dd774d5cfa6 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1546 - diff --git a/build/FUSE_SRC/FUSE_NR/.svn/text-base/gammln.f90.svn-base b/build/FUSE_SRC/FUSE_NR/.svn/text-base/gammln.f90.svn-base deleted file mode 100644 index 9d8993c..0000000 --- a/build/FUSE_SRC/FUSE_NR/.svn/text-base/gammln.f90.svn-base +++ /dev/null @@ -1,45 +0,0 @@ - FUNCTION gammln_s(xx) - USE nrtype; USE nrutil, ONLY : arth,assert - IMPLICIT NONE - REAL(SP), INTENT(IN) :: xx - REAL(SP) :: gammln_s - REAL(SP) :: tmp,x - REAL(SP) :: stp = 2.5066282746310005_sp - REAL(SP), DIMENSION(6) :: coef = (/76.18009172947146_sp,& - -86.50532032941677_sp,24.01409824083091_sp,& - -1.231739572450155_sp,0.1208650973866179e-2_sp,& - -0.5395239384953e-5_sp/) - call assert(xx > 0.0, 'gammln_s arg') - x=xx - tmp=x+5.5_sp - tmp=(x+0.5_sp)*log(tmp)-tmp - gammln_s=tmp+log(stp*(1.000000000190015_sp+& - sum(coef(:)/arth(x+1.0_sp,1.0_sp,size(coef))))/x) - END FUNCTION gammln_s - - - FUNCTION gammln_v(xx) - USE nrtype; USE nrutil, ONLY: assert - IMPLICIT NONE - INTEGER(I4B) :: i - REAL(SP), DIMENSION(:), INTENT(IN) :: xx - REAL(SP), DIMENSION(size(xx)) :: gammln_v - REAL(SP), DIMENSION(size(xx)) :: ser,tmp,x,y - REAL(SP) :: stp = 2.5066282746310005_sp - REAL(SP), DIMENSION(6) :: coef = (/76.18009172947146_sp,& - -86.50532032941677_sp,24.01409824083091_sp,& - -1.231739572450155_sp,0.1208650973866179e-2_sp,& - -0.5395239384953e-5_sp/) - if (size(xx) == 0) RETURN - call assert(all(xx > 0.0), 'gammln_v arg') - x=xx - tmp=x+5.5_sp - tmp=(x+0.5_sp)*log(tmp)-tmp - ser=1.000000000190015_sp - y=x - do i=1,size(coef) - y=y+1.0_sp - ser=ser+coef(i)/y - end do - gammln_v=tmp+log(stp*ser/x) - END FUNCTION gammln_v diff --git a/build/FUSE_SRC/FUSE_NR/.svn/text-base/gammp.f90.svn-base b/build/FUSE_SRC/FUSE_NR/.svn/text-base/gammp.f90.svn-base deleted file mode 100644 index 4234264..0000000 --- a/build/FUSE_SRC/FUSE_NR/.svn/text-base/gammp.f90.svn-base +++ /dev/null @@ -1,29 +0,0 @@ - FUNCTION gammp_s(a,x) - USE nrtype; USE nrutil, ONLY : assert - USE nr, ONLY : gcf,gser - IMPLICIT NONE - REAL(SP), INTENT(IN) :: a,x - REAL(SP) :: gammp_s - call assert( x >= 0.0, a > 0.0, 'gammp_s args') - if (x= 0.0), all(a > 0.0), 'gammp_v args') - mask = (x ITMAX) call nrerror('a too large, ITMAX too small in gcf_s') - if (present(gln)) then - gln=gammln(a) - gcf_s=exp(-x+a*log(x)-gln)*h - else - gcf_s=exp(-x+a*log(x)-gammln(a))*h - end if - END FUNCTION gcf_s - - - FUNCTION gcf_v(a,x,gln) - USE nrtype; USE nrutil, ONLY : assert_eq,nrerror - USE nr, ONLY : gammln - IMPLICIT NONE - REAL(SP), DIMENSION(:), INTENT(IN) :: a,x - REAL(SP), DIMENSION(:), OPTIONAL, INTENT(OUT) :: gln - REAL(SP), DIMENSION(size(a)) :: gcf_v - INTEGER(I4B), PARAMETER :: ITMAX=100 - REAL(SP), PARAMETER :: EPS=epsilon(x),FPMIN=tiny(x)/EPS - INTEGER(I4B) :: i - REAL(SP), DIMENSION(size(a)) :: an,b,c,d,del,h - LOGICAL(LGT), DIMENSION(size(a)) :: converged,zero - i=assert_eq(size(a),size(x),'gcf_v') - zero=(x == 0.0_sp) - where (zero) - gcf_v=1.0_sp - elsewhere - b=x+1.0_sp-a - c=1.0_sp/FPMIN - d=1.0_sp/b - h=d - end where - converged=zero - do i=1,ITMAX - where (.not. converged) - an=-i*(i-a) - b=b+2.0_sp - d=an*d+b - d=merge(FPMIN,d, abs(d) ITMAX) call nrerror('a too large, ITMAX too small in gcf_v') - if (present(gln)) then - if (size(gln) < size(a)) call & - nrerror('gser: Not enough space for gln') - gln=gammln(a) - where (.not. zero) gcf_v=exp(-x+a*log(x)-gln)*h - else - where (.not. zero) gcf_v=exp(-x+a*log(x)-gammln(a))*h - end if - END FUNCTION gcf_v diff --git a/build/FUSE_SRC/FUSE_NR/.svn/text-base/gser.f90.svn-base b/build/FUSE_SRC/FUSE_NR/.svn/text-base/gser.f90.svn-base deleted file mode 100644 index 8f51688..0000000 --- a/build/FUSE_SRC/FUSE_NR/.svn/text-base/gser.f90.svn-base +++ /dev/null @@ -1,72 +0,0 @@ - FUNCTION gser_s(a,x,gln) - USE nrtype; USE nrutil, ONLY : nrerror - USE nr, ONLY : gammln - IMPLICIT NONE - REAL(SP), INTENT(IN) :: a,x - REAL(SP), OPTIONAL, INTENT(OUT) :: gln - REAL(SP) :: gser_s - INTEGER(I4B), PARAMETER :: ITMAX=100 - REAL(SP), PARAMETER :: EPS=epsilon(x) - INTEGER(I4B) :: n - REAL(SP) :: ap,del,summ - if (x == 0.0) then - gser_s=0.0 - RETURN - end if - ap=a - summ=1.0_sp/a - del=summ - do n=1,ITMAX - ap=ap+1.0_sp - del=del*x/ap - summ=summ+del - if (abs(del) < abs(summ)*EPS) exit - end do - if (n > ITMAX) call nrerror('a too large, ITMAX too small in gser_s') - if (present(gln)) then - gln=gammln(a) - gser_s=summ*exp(-x+a*log(x)-gln) - else - gser_s=summ*exp(-x+a*log(x)-gammln(a)) - end if - END FUNCTION gser_s - - - FUNCTION gser_v(a,x,gln) - USE nrtype; USE nrutil, ONLY : assert_eq,nrerror - USE nr, ONLY : gammln - IMPLICIT NONE - REAL(SP), DIMENSION(:), INTENT(IN) :: a,x - REAL(SP), DIMENSION(:), OPTIONAL, INTENT(OUT) :: gln - REAL(SP), DIMENSION(size(a)) :: gser_v - INTEGER(I4B), PARAMETER :: ITMAX=100 - REAL(SP), PARAMETER :: EPS=epsilon(x) - INTEGER(I4B) :: n - REAL(SP), DIMENSION(size(a)) :: ap,del,summ - LOGICAL(LGT), DIMENSION(size(a)) :: converged,zero - n=assert_eq(size(a),size(x),'gser_v') - zero=(x == 0.0) - where (zero) gser_v=0.0 - ap=a - summ=1.0_sp/a - del=summ - converged=zero - do n=1,ITMAX - where (.not. converged) - ap=ap+1.0_sp - del=del*x/ap - summ=summ+del - converged = (abs(del) < abs(summ)*EPS) - end where - if (all(converged)) exit - end do - if (n > ITMAX) call nrerror('a too large, ITMAX too small in gser_v') - if (present(gln)) then - if (size(gln) < size(a)) call & - nrerror('gser: Not enough space for gln') - gln=gammln(a) - where (.not. zero) gser_v=summ*exp(-x+a*log(x)-gln) - else - where (.not. zero) gser_v=summ*exp(-x+a*log(x)-gammln(a)) - end if - END FUNCTION gser_v diff --git a/build/FUSE_SRC/FUSE_NR/.svn/text-base/lubksb.f90.svn-base b/build/FUSE_SRC/FUSE_NR/.svn/text-base/lubksb.f90.svn-base deleted file mode 100644 index 94780a9..0000000 --- a/build/FUSE_SRC/FUSE_NR/.svn/text-base/lubksb.f90.svn-base +++ /dev/null @@ -1,25 +0,0 @@ - SUBROUTINE lubksb(a,indx,b) - USE nrtype; USE nrutil, ONLY : assert_eq - IMPLICIT NONE - REAL(SP), DIMENSION(:,:), INTENT(IN) :: a - INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx - REAL(SP), DIMENSION(:), INTENT(INOUT) :: b - INTEGER(I4B) :: i,n,ii,ll - REAL(SP) :: summ - n=assert_eq(size(a,1),size(a,2),size(indx),'lubksb') - ii=0 - do i=1,n - ll=indx(i) - summ=b(ll) - b(ll)=b(i) - if (ii /= 0) then - summ=summ-dot_product(a(i,ii:i-1),b(ii:i-1)) - else if (summ /= 0.0) then - ii=i - end if - b(i)=summ - end do - do i=n,1,-1 - b(i) = (b(i)-dot_product(a(i,i+1:n),b(i+1:n)))/a(i,i) - end do - END SUBROUTINE lubksb diff --git a/build/FUSE_SRC/FUSE_NR/.svn/text-base/ludcmp.f90.svn-base b/build/FUSE_SRC/FUSE_NR/.svn/text-base/ludcmp.f90.svn-base deleted file mode 100644 index 242b469..0000000 --- a/build/FUSE_SRC/FUSE_NR/.svn/text-base/ludcmp.f90.svn-base +++ /dev/null @@ -1,27 +0,0 @@ - SUBROUTINE ludcmp(a,indx,d) - USE nrtype; USE nrutil, ONLY : assert_eq,imaxloc,nrerror,outerprod,swap - IMPLICIT NONE - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a - INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: indx - REAL(SP), INTENT(OUT) :: d - REAL(SP), DIMENSION(size(a,1)) :: vv - REAL(SP), PARAMETER :: TINY=1.0e-20_sp - INTEGER(I4B) :: j,n,imax - n=assert_eq(size(a,1),size(a,2),size(indx),'ludcmp') - d=1.0 - vv=maxval(abs(a),dim=2) - if (any(vv == 0.0)) call nrerror('singular matrix in ludcmp') - vv=1.0_sp/vv - do j=1,n - imax=(j-1)+imaxloc(vv(j:n)*abs(a(j:n,j))) - if (j /= imax) then - call swap(a(imax,:),a(j,:)) - d=-d - vv(imax)=vv(j) - end if - indx(j)=imax - if (a(j,j) == 0.0) a(j,j)=TINY - a(j+1:n,j)=a(j+1:n,j)/a(j,j) - a(j+1:n,j+1:n)=a(j+1:n,j+1:n)-outerprod(a(j+1:n,j),a(j,j+1:n)) - end do - END SUBROUTINE ludcmp diff --git a/build/FUSE_SRC/FUSE_NR/.svn/text-base/nr.f90.svn-base b/build/FUSE_SRC/FUSE_NR/.svn/text-base/nr.f90.svn-base deleted file mode 100644 index b18ca96..0000000 --- a/build/FUSE_SRC/FUSE_NR/.svn/text-base/nr.f90.svn-base +++ /dev/null @@ -1,3168 +0,0 @@ -MODULE nr - INTERFACE - SUBROUTINE airy(x,ai,bi,aip,bip) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP), INTENT(OUT) :: ai,bi,aip,bip - END SUBROUTINE airy - END INTERFACE - INTERFACE - SUBROUTINE amebsa(p,y,pb,yb,ftol,func,iter,temptr) - USE nrtype - INTEGER(I4B), INTENT(INOUT) :: iter - REAL(SP), INTENT(INOUT) :: yb - REAL(SP), INTENT(IN) :: ftol,temptr - REAL(SP), DIMENSION(:), INTENT(INOUT) :: y,pb - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: p - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP) :: func - END FUNCTION func - END INTERFACE - END SUBROUTINE amebsa - END INTERFACE - INTERFACE - SUBROUTINE amoeba(p,y,ftol,func,iter) - USE nrtype - INTEGER(I4B), INTENT(OUT) :: iter - REAL(SP), INTENT(IN) :: ftol - REAL(SP), DIMENSION(:), INTENT(INOUT) :: y - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: p - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP) :: func - END FUNCTION func - END INTERFACE - END SUBROUTINE amoeba - END INTERFACE - INTERFACE - SUBROUTINE anneal(x,y,iorder) - USE nrtype - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: iorder - REAL(SP), DIMENSION(:), INTENT(IN) :: x,y - END SUBROUTINE anneal - END INTERFACE -! INTERFACE -! SUBROUTINE asolve(b,x,itrnsp) -! USE nrtype -! REAL(sP), DIMENSION(:), INTENT(IN) :: b -! REAL(sP), DIMENSION(:), INTENT(OUT) :: x -! INTEGER(I4B), INTENT(IN) :: itrnsp -! END SUBROUTINE asolve -! END INTERFACE -! INTERFACE -! SUBROUTINE atimes(x,r,itrnsp) -! USE nrtype -! REAL(sP), DIMENSION(:), INTENT(IN) :: x -! REAL(sP), DIMENSION(:), INTENT(OUT) :: r -! INTEGER(I4B), INTENT(IN) :: itrnsp -! END SUBROUTINE atimes -! END INTERFACE - INTERFACE - SUBROUTINE avevar(data,ave,var) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: data - REAL(SP), INTENT(OUT) :: ave,var - END SUBROUTINE avevar - END INTERFACE - INTERFACE - SUBROUTINE balanc(a) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a - END SUBROUTINE balanc - END INTERFACE - INTERFACE - SUBROUTINE banbks(a,m1,m2,al,indx,b) - USE nrtype - INTEGER(I4B), INTENT(IN) :: m1,m2 - INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx - REAL(SP), DIMENSION(:,:), INTENT(IN) :: a,al - REAL(SP), DIMENSION(:), INTENT(INOUT) :: b - END SUBROUTINE banbks - END INTERFACE - INTERFACE - SUBROUTINE bandec(a,m1,m2,al,indx,d) - USE nrtype - INTEGER(I4B), INTENT(IN) :: m1,m2 - INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: indx - REAL(SP), INTENT(OUT) :: d - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a - REAL(SP), DIMENSION(:,:), INTENT(OUT) :: al - END SUBROUTINE bandec - END INTERFACE - INTERFACE - SUBROUTINE banmul(a,m1,m2,x,b) - USE nrtype - INTEGER(I4B), INTENT(IN) :: m1,m2 - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(:), INTENT(OUT) :: b - REAL(SP), DIMENSION(:,:), INTENT(IN) :: a - END SUBROUTINE banmul - END INTERFACE - INTERFACE - SUBROUTINE bcucof(y,y1,y2,y12,d1,d2,c) - USE nrtype - REAL(SP), INTENT(IN) :: d1,d2 - REAL(SP), DIMENSION(4), INTENT(IN) :: y,y1,y2,y12 - REAL(SP), DIMENSION(4,4), INTENT(OUT) :: c - END SUBROUTINE bcucof - END INTERFACE - INTERFACE - SUBROUTINE bcuint(y,y1,y2,y12,x1l,x1u,x2l,x2u,x1,x2,ansy,& - ansy1,ansy2) - USE nrtype - REAL(SP), DIMENSION(4), INTENT(IN) :: y,y1,y2,y12 - REAL(SP), INTENT(IN) :: x1l,x1u,x2l,x2u,x1,x2 - REAL(SP), INTENT(OUT) :: ansy,ansy1,ansy2 - END SUBROUTINE bcuint - END INTERFACE - INTERFACE beschb - SUBROUTINE beschb_s(x,gam1,gam2,gampl,gammi) - USE nrtype - REAL(sP), INTENT(IN) :: x - REAL(sP), INTENT(OUT) :: gam1,gam2,gampl,gammi - END SUBROUTINE beschb_s -!BL - SUBROUTINE beschb_v(x,gam1,gam2,gampl,gammi) - USE nrtype - REAL(sP), DIMENSION(:), INTENT(IN) :: x - REAL(sP), DIMENSION(:), INTENT(OUT) :: gam1,gam2,gampl,gammi - END SUBROUTINE beschb_v - END INTERFACE - INTERFACE bessi - FUNCTION bessi_s(n,x) - USE nrtype - INTEGER(I4B), INTENT(IN) :: n - REAL(SP), INTENT(IN) :: x - REAL(SP) :: bessi_s - END FUNCTION bessi_s -!BL - FUNCTION bessi_v(n,x) - USE nrtype - INTEGER(I4B), INTENT(IN) :: n - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: bessi_v - END FUNCTION bessi_v - END INTERFACE - INTERFACE bessi0 - FUNCTION bessi0_s(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: bessi0_s - END FUNCTION bessi0_s -!BL - FUNCTION bessi0_v(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: bessi0_v - END FUNCTION bessi0_v - END INTERFACE - INTERFACE bessi1 - FUNCTION bessi1_s(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: bessi1_s - END FUNCTION bessi1_s -!BL - FUNCTION bessi1_v(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: bessi1_v - END FUNCTION bessi1_v - END INTERFACE - INTERFACE - SUBROUTINE bessik(x,xnu,ri,rk,rip,rkp) - USE nrtype - REAL(SP), INTENT(IN) :: x,xnu - REAL(SP), INTENT(OUT) :: ri,rk,rip,rkp - END SUBROUTINE bessik - END INTERFACE - INTERFACE bessj - FUNCTION bessj_s(n,x) - USE nrtype - INTEGER(I4B), INTENT(IN) :: n - REAL(SP), INTENT(IN) :: x - REAL(SP) :: bessj_s - END FUNCTION bessj_s -!BL - FUNCTION bessj_v(n,x) - USE nrtype - INTEGER(I4B), INTENT(IN) :: n - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: bessj_v - END FUNCTION bessj_v - END INTERFACE - INTERFACE bessj0 - FUNCTION bessj0_s(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: bessj0_s - END FUNCTION bessj0_s -!BL - FUNCTION bessj0_v(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: bessj0_v - END FUNCTION bessj0_v - END INTERFACE - INTERFACE bessj1 - FUNCTION bessj1_s(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: bessj1_s - END FUNCTION bessj1_s -!BL - FUNCTION bessj1_v(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: bessj1_v - END FUNCTION bessj1_v - END INTERFACE - INTERFACE bessjy - SUBROUTINE bessjy_s(x,xnu,rj,ry,rjp,ryp) - USE nrtype - REAL(SP), INTENT(IN) :: x,xnu - REAL(SP), INTENT(OUT) :: rj,ry,rjp,ryp - END SUBROUTINE bessjy_s -!BL - SUBROUTINE bessjy_v(x,xnu,rj,ry,rjp,ryp) - USE nrtype - REAL(SP), INTENT(IN) :: xnu - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(:), INTENT(OUT) :: rj,rjp,ry,ryp - END SUBROUTINE bessjy_v - END INTERFACE - INTERFACE bessk - FUNCTION bessk_s(n,x) - USE nrtype - INTEGER(I4B), INTENT(IN) :: n - REAL(SP), INTENT(IN) :: x - REAL(SP) :: bessk_s - END FUNCTION bessk_s -!BL - FUNCTION bessk_v(n,x) - USE nrtype - INTEGER(I4B), INTENT(IN) :: n - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: bessk_v - END FUNCTION bessk_v - END INTERFACE - INTERFACE bessk0 - FUNCTION bessk0_s(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: bessk0_s - END FUNCTION bessk0_s -!BL - FUNCTION bessk0_v(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: bessk0_v - END FUNCTION bessk0_v - END INTERFACE - INTERFACE bessk1 - FUNCTION bessk1_s(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: bessk1_s - END FUNCTION bessk1_s -!BL - FUNCTION bessk1_v(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: bessk1_v - END FUNCTION bessk1_v - END INTERFACE - INTERFACE bessy - FUNCTION bessy_s(n,x) - USE nrtype - INTEGER(I4B), INTENT(IN) :: n - REAL(SP), INTENT(IN) :: x - REAL(SP) :: bessy_s - END FUNCTION bessy_s -!BL - FUNCTION bessy_v(n,x) - USE nrtype - INTEGER(I4B), INTENT(IN) :: n - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: bessy_v - END FUNCTION bessy_v - END INTERFACE - INTERFACE bessy0 - FUNCTION bessy0_s(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: bessy0_s - END FUNCTION bessy0_s -!BL - FUNCTION bessy0_v(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: bessy0_v - END FUNCTION bessy0_v - END INTERFACE - INTERFACE bessy1 - FUNCTION bessy1_s(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: bessy1_s - END FUNCTION bessy1_s -!BL - FUNCTION bessy1_v(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: bessy1_v - END FUNCTION bessy1_v - END INTERFACE - INTERFACE beta - FUNCTION beta_s(z,w) - USE nrtype - REAL(SP), INTENT(IN) :: z,w - REAL(SP) :: beta_s - END FUNCTION beta_s -!BL - FUNCTION beta_v(z,w) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: z,w - REAL(SP), DIMENSION(size(z)) :: beta_v - END FUNCTION beta_v - END INTERFACE - INTERFACE betacf - FUNCTION betacf_s(a,b,x) - USE nrtype - REAL(SP), INTENT(IN) :: a,b,x - REAL(SP) :: betacf_s - END FUNCTION betacf_s -!BL - FUNCTION betacf_v(a,b,x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,x - REAL(SP), DIMENSION(size(x)) :: betacf_v - END FUNCTION betacf_v - END INTERFACE - INTERFACE betai - FUNCTION betai_s(a,b,x) - USE nrtype - REAL(SP), INTENT(IN) :: a,b,x - REAL(SP) :: betai_s - END FUNCTION betai_s -!BL - FUNCTION betai_v(a,b,x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,x - REAL(SP), DIMENSION(size(a)) :: betai_v - END FUNCTION betai_v - END INTERFACE - INTERFACE bico - FUNCTION bico_s(n,k) - USE nrtype - INTEGER(I4B), INTENT(IN) :: n,k - REAL(SP) :: bico_s - END FUNCTION bico_s -!BL - FUNCTION bico_v(n,k) - USE nrtype - INTEGER(I4B), DIMENSION(:), INTENT(IN) :: n,k - REAL(SP), DIMENSION(size(n)) :: bico_v - END FUNCTION bico_v - END INTERFACE - INTERFACE - FUNCTION bnldev(pp,n) - USE nrtype - REAL(SP), INTENT(IN) :: pp - INTEGER(I4B), INTENT(IN) :: n - REAL(SP) :: bnldev - END FUNCTION bnldev - END INTERFACE - INTERFACE - FUNCTION brent(ax,bx,cx,func,tol,xmin) - USE nrtype - REAL(SP), INTENT(IN) :: ax,bx,cx,tol - REAL(SP), INTENT(OUT) :: xmin - REAL(SP) :: brent - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: func - END FUNCTION func - END INTERFACE - END FUNCTION brent - END INTERFACE - INTERFACE - SUBROUTINE broydn(x,check) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: x - LOGICAL(LGT), INTENT(OUT) :: check - END SUBROUTINE broydn - END INTERFACE - INTERFACE - SUBROUTINE bsstep(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: y - REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal - REAL(SP), INTENT(INOUT) :: x - REAL(SP), INTENT(IN) :: htry,eps - REAL(SP), INTENT(OUT) :: hdid,hnext - INTERFACE - SUBROUTINE derivs(x,y,dydx) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP), DIMENSION(:), INTENT(IN) :: y - REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx - END SUBROUTINE derivs - END INTERFACE - END SUBROUTINE bsstep - END INTERFACE - INTERFACE - SUBROUTINE caldat(julian,mm,id,iyyy) - USE nrtype - INTEGER(I4B), INTENT(IN) :: julian - INTEGER(I4B), INTENT(OUT) :: mm,id,iyyy - END SUBROUTINE caldat - END INTERFACE - INTERFACE - FUNCTION chder(a,b,c) - USE nrtype - REAL(SP), INTENT(IN) :: a,b - REAL(SP), DIMENSION(:), INTENT(IN) :: c - REAL(SP), DIMENSION(size(c)) :: chder - END FUNCTION chder - END INTERFACE - INTERFACE chebev - FUNCTION chebev_s(a,b,c,x) - USE nrtype - REAL(SP), INTENT(IN) :: a,b,x - REAL(SP), DIMENSION(:), INTENT(IN) :: c - REAL(SP) :: chebev_s - END FUNCTION chebev_s -!BL - FUNCTION chebev_v(a,b,c,x) - USE nrtype - REAL(SP), INTENT(IN) :: a,b - REAL(SP), DIMENSION(:), INTENT(IN) :: c,x - REAL(SP), DIMENSION(size(x)) :: chebev_v - END FUNCTION chebev_v - END INTERFACE - INTERFACE - FUNCTION chebft(a,b,n,func) - USE nrtype - REAL(SP), INTENT(IN) :: a,b - INTEGER(I4B), INTENT(IN) :: n - REAL(SP), DIMENSION(n) :: chebft - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: func - END FUNCTION func - END INTERFACE - END FUNCTION chebft - END INTERFACE - INTERFACE - FUNCTION chebpc(c) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: c - REAL(SP), DIMENSION(size(c)) :: chebpc - END FUNCTION chebpc - END INTERFACE - INTERFACE - FUNCTION chint(a,b,c) - USE nrtype - REAL(SP), INTENT(IN) :: a,b - REAL(SP), DIMENSION(:), INTENT(IN) :: c - REAL(SP), DIMENSION(size(c)) :: chint - END FUNCTION chint - END INTERFACE - INTERFACE - SUBROUTINE choldc(a,p) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a - REAL(SP), DIMENSION(:), INTENT(OUT) :: p - END SUBROUTINE choldc - END INTERFACE - INTERFACE - SUBROUTINE cholsl(a,p,b,x) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(IN) :: a - REAL(SP), DIMENSION(:), INTENT(IN) :: p,b - REAL(SP), DIMENSION(:), INTENT(INOUT) :: x - END SUBROUTINE cholsl - END INTERFACE - INTERFACE - SUBROUTINE chsone(bins,ebins,knstrn,df,chsq,prob) - USE nrtype - INTEGER(I4B), INTENT(IN) :: knstrn - REAL(SP), INTENT(OUT) :: df,chsq,prob - REAL(SP), DIMENSION(:), INTENT(IN) :: bins,ebins - END SUBROUTINE chsone - END INTERFACE - INTERFACE - SUBROUTINE chstwo(bins1,bins2,knstrn,df,chsq,prob) - USE nrtype - INTEGER(I4B), INTENT(IN) :: knstrn - REAL(SP), INTENT(OUT) :: df,chsq,prob - REAL(SP), DIMENSION(:), INTENT(IN) :: bins1,bins2 - END SUBROUTINE chstwo - END INTERFACE - INTERFACE - SUBROUTINE cisi(x,ci,si) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP), INTENT(OUT) :: ci,si - END SUBROUTINE cisi - END INTERFACE - INTERFACE - SUBROUTINE cntab1(nn,chisq,df,prob,cramrv,ccc) - USE nrtype - INTEGER(I4B), DIMENSION(:,:), INTENT(IN) :: nn - REAL(SP), INTENT(OUT) :: chisq,df,prob,cramrv,ccc - END SUBROUTINE cntab1 - END INTERFACE - INTERFACE - SUBROUTINE cntab2(nn,h,hx,hy,hygx,hxgy,uygx,uxgy,uxy) - USE nrtype - INTEGER(I4B), DIMENSION(:,:), INTENT(IN) :: nn - REAL(SP), INTENT(OUT) :: h,hx,hy,hygx,hxgy,uygx,uxgy,uxy - END SUBROUTINE cntab2 - END INTERFACE - INTERFACE - FUNCTION convlv(data,respns,isign) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: data - REAL(SP), DIMENSION(:), INTENT(IN) :: respns - INTEGER(I4B), INTENT(IN) :: isign - REAL(SP), DIMENSION(size(data)) :: convlv - END FUNCTION convlv - END INTERFACE - INTERFACE - FUNCTION correl(data1,data2) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 - REAL(SP), DIMENSION(size(data1)) :: correl - END FUNCTION correl - END INTERFACE - INTERFACE - SUBROUTINE cosft1(y) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: y - END SUBROUTINE cosft1 - END INTERFACE - INTERFACE - SUBROUTINE cosft2(y,isign) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: y - INTEGER(I4B), INTENT(IN) :: isign - END SUBROUTINE cosft2 - END INTERFACE - INTERFACE - SUBROUTINE covsrt(covar,maska) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: covar - LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska - END SUBROUTINE covsrt - END INTERFACE - INTERFACE - SUBROUTINE cyclic(a,b,c,alpha,beta,r,x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN):: a,b,c,r - REAL(SP), INTENT(IN) :: alpha,beta - REAL(SP), DIMENSION(:), INTENT(OUT):: x - END SUBROUTINE cyclic - END INTERFACE - INTERFACE - SUBROUTINE daub4(a,isign) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: a - INTEGER(I4B), INTENT(IN) :: isign - END SUBROUTINE daub4 - END INTERFACE - INTERFACE dawson - FUNCTION dawson_s(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: dawson_s - END FUNCTION dawson_s -!BL - FUNCTION dawson_v(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: dawson_v - END FUNCTION dawson_v - END INTERFACE - INTERFACE - FUNCTION dbrent(ax,bx,cx,func,dbrent_dfunc,tol,xmin) - USE nrtype - REAL(SP), INTENT(IN) :: ax,bx,cx,tol - REAL(SP), INTENT(OUT) :: xmin - REAL(SP) :: dbrent - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: func - END FUNCTION func -!BL - FUNCTION dbrent_dfunc(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: dbrent_dfunc - END FUNCTION dbrent_dfunc - END INTERFACE - END FUNCTION dbrent - END INTERFACE - INTERFACE - SUBROUTINE ddpoly(c,x,pd) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP), DIMENSION(:), INTENT(IN) :: c - REAL(SP), DIMENSION(:), INTENT(OUT) :: pd - END SUBROUTINE ddpoly - END INTERFACE - INTERFACE - FUNCTION decchk(string,ch) - USE nrtype - CHARACTER(1), DIMENSION(:), INTENT(IN) :: string - CHARACTER(1), INTENT(OUT) :: ch - LOGICAL(LGT) :: decchk - END FUNCTION decchk - END INTERFACE - INTERFACE - SUBROUTINE dfpmin(p,gtol,iter,fret,func,dfunc) - USE nrtype - INTEGER(I4B), INTENT(OUT) :: iter - REAL(SP), INTENT(IN) :: gtol - REAL(SP), INTENT(OUT) :: fret - REAL(SP), DIMENSION(:), INTENT(INOUT) :: p - INTERFACE - FUNCTION func(p) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: p - REAL(SP) :: func - END FUNCTION func -!BL - FUNCTION dfunc(p) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: p - REAL(SP), DIMENSION(size(p)) :: dfunc - END FUNCTION dfunc - END INTERFACE - END SUBROUTINE dfpmin - END INTERFACE - INTERFACE - FUNCTION dfridr(func,x,h,err) - USE nrtype - REAL(SP), INTENT(IN) :: x,h - REAL(SP), INTENT(OUT) :: err - REAL(SP) :: dfridr - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: func - END FUNCTION func - END INTERFACE - END FUNCTION dfridr - END INTERFACE - INTERFACE - SUBROUTINE dftcor(w,delta,a,b,endpts,corre,corim,corfac) - USE nrtype - REAL(SP), INTENT(IN) :: w,delta,a,b - REAL(SP), INTENT(OUT) :: corre,corim,corfac - REAL(SP), DIMENSION(:), INTENT(IN) :: endpts - END SUBROUTINE dftcor - END INTERFACE - INTERFACE - SUBROUTINE dftint(func,a,b,w,cosint,sinint) - USE nrtype - REAL(SP), INTENT(IN) :: a,b,w - REAL(SP), INTENT(OUT) :: cosint,sinint - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: func - END FUNCTION func - END INTERFACE - END SUBROUTINE dftint - END INTERFACE - INTERFACE - SUBROUTINE difeq(k,k1,k2,jsf,is1,isf,indexv,s,y) - USE nrtype - INTEGER(I4B), INTENT(IN) :: is1,isf,jsf,k,k1,k2 - INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indexv - REAL(SP), DIMENSION(:,:), INTENT(OUT) :: s - REAL(SP), DIMENSION(:,:), INTENT(IN) :: y - END SUBROUTINE difeq - END INTERFACE - INTERFACE - FUNCTION eclass(lista,listb,n) - USE nrtype - INTEGER(I4B), DIMENSION(:), INTENT(IN) :: lista,listb - INTEGER(I4B), INTENT(IN) :: n - INTEGER(I4B), DIMENSION(n) :: eclass - END FUNCTION eclass - END INTERFACE - INTERFACE - FUNCTION eclazz(equiv,n) - USE nrtype - INTERFACE - FUNCTION equiv(i,j) - USE nrtype - LOGICAL(LGT) :: equiv - INTEGER(I4B), INTENT(IN) :: i,j - END FUNCTION equiv - END INTERFACE - INTEGER(I4B), INTENT(IN) :: n - INTEGER(I4B), DIMENSION(n) :: eclazz - END FUNCTION eclazz - END INTERFACE - INTERFACE - FUNCTION ei(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: ei - END FUNCTION ei - END INTERFACE - INTERFACE - SUBROUTINE eigsrt(d,v) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: d - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: v - END SUBROUTINE eigsrt - END INTERFACE - INTERFACE elle - FUNCTION elle_s(phi,ak) - USE nrtype - REAL(SP), INTENT(IN) :: phi,ak - REAL(SP) :: elle_s - END FUNCTION elle_s -!BL - FUNCTION elle_v(phi,ak) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: phi,ak - REAL(SP), DIMENSION(size(phi)) :: elle_v - END FUNCTION elle_v - END INTERFACE - INTERFACE ellf - FUNCTION ellf_s(phi,ak) - USE nrtype - REAL(SP), INTENT(IN) :: phi,ak - REAL(SP) :: ellf_s - END FUNCTION ellf_s -!BL - FUNCTION ellf_v(phi,ak) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: phi,ak - REAL(SP), DIMENSION(size(phi)) :: ellf_v - END FUNCTION ellf_v - END INTERFACE - INTERFACE ellpi - FUNCTION ellpi_s(phi,en,ak) - USE nrtype - REAL(SP), INTENT(IN) :: phi,en,ak - REAL(SP) :: ellpi_s - END FUNCTION ellpi_s -!BL - FUNCTION ellpi_v(phi,en,ak) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: phi,en,ak - REAL(SP), DIMENSION(size(phi)) :: ellpi_v - END FUNCTION ellpi_v - END INTERFACE - INTERFACE - SUBROUTINE elmhes(a) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a - END SUBROUTINE elmhes - END INTERFACE - INTERFACE erf - FUNCTION erf_s(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: erf_s - END FUNCTION erf_s -!BL - FUNCTION erf_v(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: erf_v - END FUNCTION erf_v - END INTERFACE - INTERFACE erfc - FUNCTION erfc_s(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: erfc_s - END FUNCTION erfc_s -!BL - FUNCTION erfc_v(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: erfc_v - END FUNCTION erfc_v - END INTERFACE - INTERFACE erfcc - FUNCTION erfcc_s(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: erfcc_s - END FUNCTION erfcc_s -!BL - FUNCTION erfcc_v(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: erfcc_v - END FUNCTION erfcc_v - END INTERFACE - INTERFACE - SUBROUTINE eulsum(sum,term,jterm) - USE nrtype - REAL(SP), INTENT(INOUT) :: sum - REAL(SP), INTENT(IN) :: term - INTEGER(I4B), INTENT(IN) :: jterm - END SUBROUTINE eulsum - END INTERFACE - INTERFACE - FUNCTION evlmem(fdt,d,xms) - USE nrtype - REAL(SP), INTENT(IN) :: fdt,xms - REAL(SP), DIMENSION(:), INTENT(IN) :: d - REAL(SP) :: evlmem - END FUNCTION evlmem - END INTERFACE - INTERFACE expdev - SUBROUTINE expdev_s(harvest) - USE nrtype - REAL(SP), INTENT(OUT) :: harvest - END SUBROUTINE expdev_s -!BL - SUBROUTINE expdev_v(harvest) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest - END SUBROUTINE expdev_v - END INTERFACE - INTERFACE - FUNCTION expint(n,x) - USE nrtype - INTEGER(I4B), INTENT(IN) :: n - REAL(SP), INTENT(IN) :: x - REAL(SP) :: expint - END FUNCTION expint - END INTERFACE - INTERFACE factln - FUNCTION factln_s(n) - USE nrtype - INTEGER(I4B), INTENT(IN) :: n - REAL(SP) :: factln_s - END FUNCTION factln_s -!BL - FUNCTION factln_v(n) - USE nrtype - INTEGER(I4B), DIMENSION(:), INTENT(IN) :: n - REAL(SP), DIMENSION(size(n)) :: factln_v - END FUNCTION factln_v - END INTERFACE - INTERFACE factrl - FUNCTION factrl_s(n) - USE nrtype - INTEGER(I4B), INTENT(IN) :: n - REAL(SP) :: factrl_s - END FUNCTION factrl_s -!BL - FUNCTION factrl_v(n) - USE nrtype - INTEGER(I4B), DIMENSION(:), INTENT(IN) :: n - REAL(SP), DIMENSION(size(n)) :: factrl_v - END FUNCTION factrl_v - END INTERFACE - INTERFACE - SUBROUTINE fasper(x,y,ofac,hifac,px,py,jmax,prob) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x,y - REAL(SP), INTENT(IN) :: ofac,hifac - INTEGER(I4B), INTENT(OUT) :: jmax - REAL(SP), INTENT(OUT) :: prob - REAL(SP), DIMENSION(:), POINTER :: px,py - END SUBROUTINE fasper - END INTERFACE - INTERFACE - SUBROUTINE fdjac(x,fvec,df) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: fvec - REAL(SP), DIMENSION(:), INTENT(INOUT) :: x - REAL(SP), DIMENSION(:,:), INTENT(OUT) :: df - END SUBROUTINE fdjac - END INTERFACE - INTERFACE - SUBROUTINE fgauss(x,a,y,dyda) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x,a - REAL(SP), DIMENSION(:), INTENT(OUT) :: y - REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dyda - END SUBROUTINE fgauss - END INTERFACE - INTERFACE - SUBROUTINE fit(x,y,a,b,siga,sigb,chi2,q,sig) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x,y - REAL(SP), INTENT(OUT) :: a,b,siga,sigb,chi2,q - REAL(SP), DIMENSION(:), OPTIONAL, INTENT(IN) :: sig - END SUBROUTINE fit - END INTERFACE - INTERFACE - SUBROUTINE fitexy(x,y,sigx,sigy,a,b,siga,sigb,chi2,q) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sigx,sigy - REAL(SP), INTENT(OUT) :: a,b,siga,sigb,chi2,q - END SUBROUTINE fitexy - END INTERFACE - INTERFACE - SUBROUTINE fixrts(d) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: d - END SUBROUTINE fixrts - END INTERFACE - INTERFACE - FUNCTION fleg(x,n) - USE nrtype - REAL(SP), INTENT(IN) :: x - INTEGER(I4B), INTENT(IN) :: n - REAL(SP), DIMENSION(n) :: fleg - END FUNCTION fleg - END INTERFACE - INTERFACE - SUBROUTINE flmoon(n,nph,jd,frac) - USE nrtype - INTEGER(I4B), INTENT(IN) :: n,nph - INTEGER(I4B), INTENT(OUT) :: jd - REAL(SP), INTENT(OUT) :: frac - END SUBROUTINE flmoon - END INTERFACE - INTERFACE four1 -!BL - SUBROUTINE four1_sp(data,isign) - USE nrtype - COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data - INTEGER(I4B), INTENT(IN) :: isign - END SUBROUTINE four1_sp - END INTERFACE - INTERFACE - SUBROUTINE four1_alt(data,isign) - USE nrtype - COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data - INTEGER(I4B), INTENT(IN) :: isign - END SUBROUTINE four1_alt - END INTERFACE - INTERFACE - SUBROUTINE four1_gather(data,isign) - USE nrtype - COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data - INTEGER(I4B), INTENT(IN) :: isign - END SUBROUTINE four1_gather - END INTERFACE - INTERFACE - SUBROUTINE four2(data,isign) - USE nrtype - COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data - INTEGER(I4B),INTENT(IN) :: isign - END SUBROUTINE four2 - END INTERFACE - INTERFACE - SUBROUTINE four2_alt(data,isign) - USE nrtype - COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data - INTEGER(I4B), INTENT(IN) :: isign - END SUBROUTINE four2_alt - END INTERFACE - INTERFACE - SUBROUTINE four3(data,isign) - USE nrtype - COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data - INTEGER(I4B),INTENT(IN) :: isign - END SUBROUTINE four3 - END INTERFACE - INTERFACE - SUBROUTINE four3_alt(data,isign) - USE nrtype - COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data - INTEGER(I4B), INTENT(IN) :: isign - END SUBROUTINE four3_alt - END INTERFACE - INTERFACE - SUBROUTINE fourcol(data,isign) - USE nrtype - COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data - INTEGER(I4B), INTENT(IN) :: isign - END SUBROUTINE fourcol - END INTERFACE - INTERFACE - SUBROUTINE fourcol_3d(data,isign) - USE nrtype - COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data - INTEGER(I4B), INTENT(IN) :: isign - END SUBROUTINE fourcol_3d - END INTERFACE - INTERFACE - SUBROUTINE fourn_gather(data,nn,isign) - USE nrtype - COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data - INTEGER(I4B), DIMENSION(:), INTENT(IN) :: nn - INTEGER(I4B), INTENT(IN) :: isign - END SUBROUTINE fourn_gather - END INTERFACE - INTERFACE fourrow -!BL - SUBROUTINE fourrow_sp(data,isign) - USE nrtype - COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data - INTEGER(I4B), INTENT(IN) :: isign - END SUBROUTINE fourrow_sp - END INTERFACE - INTERFACE - SUBROUTINE fourrow_3d(data,isign) - USE nrtype - COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data - INTEGER(I4B), INTENT(IN) :: isign - END SUBROUTINE fourrow_3d - END INTERFACE - INTERFACE - FUNCTION fpoly(x,n) - USE nrtype - REAL(SP), INTENT(IN) :: x - INTEGER(I4B), INTENT(IN) :: n - REAL(SP), DIMENSION(n) :: fpoly - END FUNCTION fpoly - END INTERFACE - INTERFACE - SUBROUTINE fred2(a,b,t,f,w,g,ak) - USE nrtype - REAL(SP), INTENT(IN) :: a,b - REAL(SP), DIMENSION(:), INTENT(OUT) :: t,f,w - INTERFACE - FUNCTION g(t) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: t - REAL(SP), DIMENSION(size(t)) :: g - END FUNCTION g -!BL - FUNCTION ak(t,s) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: t,s - REAL(SP), DIMENSION(size(t),size(s)) :: ak - END FUNCTION ak - END INTERFACE - END SUBROUTINE fred2 - END INTERFACE - INTERFACE - FUNCTION fredin(x,a,b,t,f,w,g,ak) - USE nrtype - REAL(SP), INTENT(IN) :: a,b - REAL(SP), DIMENSION(:), INTENT(IN) :: x,t,f,w - REAL(SP), DIMENSION(size(x)) :: fredin - INTERFACE - FUNCTION g(t) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: t - REAL(SP), DIMENSION(size(t)) :: g - END FUNCTION g -!BL - FUNCTION ak(t,s) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: t,s - REAL(SP), DIMENSION(size(t),size(s)) :: ak - END FUNCTION ak - END INTERFACE - END FUNCTION fredin - END INTERFACE - INTERFACE - SUBROUTINE frenel(x,s,c) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP), INTENT(OUT) :: s,c - END SUBROUTINE frenel - END INTERFACE - INTERFACE - SUBROUTINE frprmn(p,ftol,iter,fret) - USE nrtype - INTEGER(I4B), INTENT(OUT) :: iter - REAL(SP), INTENT(IN) :: ftol - REAL(SP), INTENT(OUT) :: fret - REAL(SP), DIMENSION(:), INTENT(INOUT) :: p - END SUBROUTINE frprmn - END INTERFACE - INTERFACE - SUBROUTINE ftest(data1,data2,f,prob) - USE nrtype - REAL(SP), INTENT(OUT) :: f,prob - REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 - END SUBROUTINE ftest - END INTERFACE - INTERFACE - FUNCTION gamdev(ia) - USE nrtype - INTEGER(I4B), INTENT(IN) :: ia - REAL(SP) :: gamdev - END FUNCTION gamdev - END INTERFACE - INTERFACE gammln - FUNCTION gammln_s(xx) - USE nrtype - REAL(SP), INTENT(IN) :: xx - REAL(SP) :: gammln_s - END FUNCTION gammln_s -!BL - FUNCTION gammln_v(xx) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: xx - REAL(SP), DIMENSION(size(xx)) :: gammln_v - END FUNCTION gammln_v - END INTERFACE - INTERFACE gammp - FUNCTION gammp_s(a,x) - USE nrtype - REAL(SP), INTENT(IN) :: a,x - REAL(SP) :: gammp_s - END FUNCTION gammp_s -!BL - FUNCTION gammp_v(a,x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: a,x - REAL(SP), DIMENSION(size(a)) :: gammp_v - END FUNCTION gammp_v - END INTERFACE - INTERFACE gammq - FUNCTION gammq_s(a,x) - USE nrtype - REAL(SP), INTENT(IN) :: a,x - REAL(SP) :: gammq_s - END FUNCTION gammq_s -!BL - FUNCTION gammq_v(a,x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: a,x - REAL(SP), DIMENSION(size(a)) :: gammq_v - END FUNCTION gammq_v - END INTERFACE - INTERFACE gasdev - SUBROUTINE gasdev_s(harvest) - USE nrtype - REAL(SP), INTENT(OUT) :: harvest - END SUBROUTINE gasdev_s -!BL - SUBROUTINE gasdev_v(harvest) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest - END SUBROUTINE gasdev_v - END INTERFACE - INTERFACE - SUBROUTINE gaucof(a,b,amu0,x,w) - USE nrtype - REAL(SP), INTENT(IN) :: amu0 - REAL(SP), DIMENSION(:), INTENT(INOUT) :: a,b - REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w - END SUBROUTINE gaucof - END INTERFACE - INTERFACE - SUBROUTINE gauher(x,w) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w - END SUBROUTINE gauher - END INTERFACE - INTERFACE - SUBROUTINE gaujac(x,w,alf,bet) - USE nrtype - REAL(SP), INTENT(IN) :: alf,bet - REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w - END SUBROUTINE gaujac - END INTERFACE - INTERFACE - SUBROUTINE gaulag(x,w,alf) - USE nrtype - REAL(SP), INTENT(IN) :: alf - REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w - END SUBROUTINE gaulag - END INTERFACE - INTERFACE - SUBROUTINE gauleg(x1,x2,x,w) - USE nrtype - REAL(SP), INTENT(IN) :: x1,x2 - REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w - END SUBROUTINE gauleg - END INTERFACE - INTERFACE - SUBROUTINE gaussj(a,b) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a,b - END SUBROUTINE gaussj - END INTERFACE - INTERFACE gcf - FUNCTION gcf_s(a,x,gln) - USE nrtype - REAL(SP), INTENT(IN) :: a,x - REAL(SP), OPTIONAL, INTENT(OUT) :: gln - REAL(SP) :: gcf_s - END FUNCTION gcf_s -!BL - FUNCTION gcf_v(a,x,gln) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: a,x - REAL(SP), DIMENSION(:), OPTIONAL, INTENT(OUT) :: gln - REAL(SP), DIMENSION(size(a)) :: gcf_v - END FUNCTION gcf_v - END INTERFACE - INTERFACE - FUNCTION golden(ax,bx,cx,func,tol,xmin) - USE nrtype - REAL(SP), INTENT(IN) :: ax,bx,cx,tol - REAL(SP), INTENT(OUT) :: xmin - REAL(SP) :: golden - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: func - END FUNCTION func - END INTERFACE - END FUNCTION golden - END INTERFACE - INTERFACE gser - FUNCTION gser_s(a,x,gln) - USE nrtype - REAL(SP), INTENT(IN) :: a,x - REAL(SP), OPTIONAL, INTENT(OUT) :: gln - REAL(SP) :: gser_s - END FUNCTION gser_s -!BL - FUNCTION gser_v(a,x,gln) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: a,x - REAL(SP), DIMENSION(:), OPTIONAL, INTENT(OUT) :: gln - REAL(SP), DIMENSION(size(a)) :: gser_v - END FUNCTION gser_v - END INTERFACE - INTERFACE - SUBROUTINE hqr(a,wr,wi) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(OUT) :: wr,wi - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a - END SUBROUTINE hqr - END INTERFACE - INTERFACE - SUBROUTINE hunt(xx,x,jlo) - USE nrtype - INTEGER(I4B), INTENT(INOUT) :: jlo - REAL(SP), INTENT(IN) :: x - REAL(SP), DIMENSION(:), INTENT(IN) :: xx - END SUBROUTINE hunt - END INTERFACE - INTERFACE - SUBROUTINE hypdrv(s,ry,rdyds) - USE nrtype - REAL(SP), INTENT(IN) :: s - REAL(SP), DIMENSION(:), INTENT(IN) :: ry - REAL(SP), DIMENSION(:), INTENT(OUT) :: rdyds - END SUBROUTINE hypdrv - END INTERFACE - INTERFACE - FUNCTION hypgeo(a,b,c,z) - USE nrtype - COMPLEX(SPC), INTENT(IN) :: a,b,c,z - COMPLEX(SPC) :: hypgeo - END FUNCTION hypgeo - END INTERFACE - INTERFACE - SUBROUTINE hypser(a,b,c,z,series,deriv) - USE nrtype - COMPLEX(SPC), INTENT(IN) :: a,b,c,z - COMPLEX(SPC), INTENT(OUT) :: series,deriv - END SUBROUTINE hypser - END INTERFACE - INTERFACE - FUNCTION icrc(crc,buf,jinit,jrev) - USE nrtype - CHARACTER(1), DIMENSION(:), INTENT(IN) :: buf - INTEGER(I2B), INTENT(IN) :: crc,jinit - INTEGER(I4B), INTENT(IN) :: jrev - INTEGER(I2B) :: icrc - END FUNCTION icrc - END INTERFACE - INTERFACE - FUNCTION igray(n,is) - USE nrtype - INTEGER(I4B), INTENT(IN) :: n,is - INTEGER(I4B) :: igray - END FUNCTION igray - END INTERFACE - INTERFACE - RECURSIVE SUBROUTINE index_bypack(arr,index,partial) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: arr - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: index - INTEGER, OPTIONAL, INTENT(IN) :: partial - END SUBROUTINE index_bypack - END INTERFACE - INTERFACE indexx - SUBROUTINE indexx_sp(arr,index) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: arr - INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: index - END SUBROUTINE indexx_sp - SUBROUTINE indexx_i4b(iarr,index) - USE nrtype - INTEGER(I4B), DIMENSION(:), INTENT(IN) :: iarr - INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: index - END SUBROUTINE indexx_i4b - END INTERFACE - INTERFACE - FUNCTION interp(uc) - USE nrtype - REAL(sP), DIMENSION(:,:), INTENT(IN) :: uc - REAL(sP), DIMENSION(2*size(uc,1)-1,2*size(uc,1)-1) :: interp - END FUNCTION interp - END INTERFACE - INTERFACE - FUNCTION rank(indx) - USE nrtype - INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx - INTEGER(I4B), DIMENSION(size(indx)) :: rank - END FUNCTION rank - END INTERFACE - INTERFACE - FUNCTION irbit1(iseed) - USE nrtype - INTEGER(I4B), INTENT(INOUT) :: iseed - INTEGER(I4B) :: irbit1 - END FUNCTION irbit1 - END INTERFACE - INTERFACE - FUNCTION irbit2(iseed) - USE nrtype - INTEGER(I4B), INTENT(INOUT) :: iseed - INTEGER(I4B) :: irbit2 - END FUNCTION irbit2 - END INTERFACE - INTERFACE - SUBROUTINE jacobi(a,d,v,nrot) - USE nrtype - INTEGER(I4B), INTENT(OUT) :: nrot - REAL(SP), DIMENSION(:), INTENT(OUT) :: d - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a - REAL(SP), DIMENSION(:,:), INTENT(OUT) :: v - END SUBROUTINE jacobi - END INTERFACE - INTERFACE - SUBROUTINE jacobn(x,y,dfdx,dfdy) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP), DIMENSION(:), INTENT(IN) :: y - REAL(SP), DIMENSION(:), INTENT(OUT) :: dfdx - REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dfdy - END SUBROUTINE jacobn - END INTERFACE - INTERFACE - FUNCTION julday(mm,id,iyyy) - USE nrtype - INTEGER(I4B), INTENT(IN) :: mm,id,iyyy - INTEGER(I4B) :: julday - END FUNCTION julday - END INTERFACE - INTERFACE - SUBROUTINE kendl1(data1,data2,tau,z,prob) - USE nrtype - REAL(SP), INTENT(OUT) :: tau,z,prob - REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 - END SUBROUTINE kendl1 - END INTERFACE - INTERFACE - SUBROUTINE kendl2(tab,tau,z,prob) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(IN) :: tab - REAL(SP), INTENT(OUT) :: tau,z,prob - END SUBROUTINE kendl2 - END INTERFACE - INTERFACE - FUNCTION kermom(y,m) - USE nrtype - REAL(SP), INTENT(IN) :: y - INTEGER(I4B), INTENT(IN) :: m - REAL(SP), DIMENSION(m) :: kermom - END FUNCTION kermom - END INTERFACE - INTERFACE - SUBROUTINE ks2d1s(x1,y1,quadvl,d1,prob) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x1,y1 - REAL(SP), INTENT(OUT) :: d1,prob - INTERFACE - SUBROUTINE quadvl(x,y,fa,fb,fc,fd) - USE nrtype - REAL(SP), INTENT(IN) :: x,y - REAL(SP), INTENT(OUT) :: fa,fb,fc,fd - END SUBROUTINE quadvl - END INTERFACE - END SUBROUTINE ks2d1s - END INTERFACE - INTERFACE - SUBROUTINE ks2d2s(x1,y1,x2,y2,d,prob) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x1,y1,x2,y2 - REAL(SP), INTENT(OUT) :: d,prob - END SUBROUTINE ks2d2s - END INTERFACE - INTERFACE - SUBROUTINE ksone(data,func,d,prob) - USE nrtype - REAL(SP), INTENT(OUT) :: d,prob - REAL(SP), DIMENSION(:), INTENT(INOUT) :: data - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: func - END FUNCTION func - END INTERFACE - END SUBROUTINE ksone - END INTERFACE - INTERFACE - SUBROUTINE kstwo(data1,data2,d,prob) - USE nrtype - REAL(SP), INTENT(OUT) :: d,prob - REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 - END SUBROUTINE kstwo - END INTERFACE - INTERFACE - SUBROUTINE laguer(a,x,its) - USE nrtype - INTEGER(I4B), INTENT(OUT) :: its - COMPLEX(SPC), INTENT(INOUT) :: x - COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: a - END SUBROUTINE laguer - END INTERFACE - INTERFACE - SUBROUTINE lfit(x,y,sig,a,maska,covar,chisq,funcs) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sig - REAL(SP), DIMENSION(:), INTENT(INOUT) :: a - LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: covar - REAL(SP), INTENT(OUT) :: chisq - INTERFACE - SUBROUTINE funcs(x,arr) - USE nrtype - REAL(SP),INTENT(IN) :: x - REAL(SP), DIMENSION(:), INTENT(OUT) :: arr - END SUBROUTINE funcs - END INTERFACE - END SUBROUTINE lfit - END INTERFACE - INTERFACE - SUBROUTINE linbcg(b,x,itol,tol,itmax,iter,err) - USE nrtype - REAL(sP), DIMENSION(:), INTENT(IN) :: b - REAL(sP), DIMENSION(:), INTENT(INOUT) :: x - INTEGER(I4B), INTENT(IN) :: itol,itmax - REAL(sP), INTENT(IN) :: tol - INTEGER(I4B), INTENT(OUT) :: iter - REAL(sP), INTENT(OUT) :: err - END SUBROUTINE linbcg - END INTERFACE - INTERFACE - SUBROUTINE linmin(p,xi,fret) - USE nrtype - REAL(SP), INTENT(OUT) :: fret - REAL(SP), DIMENSION(:), TARGET, INTENT(INOUT) :: p,xi - END SUBROUTINE linmin - END INTERFACE - INTERFACE - SUBROUTINE lnsrch(xold,fold,g,p,x,f,stpmax,check,func) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: xold,g - REAL(SP), DIMENSION(:), INTENT(INOUT) :: p - REAL(SP), INTENT(IN) :: fold,stpmax - REAL(SP), DIMENSION(:), INTENT(OUT) :: x - REAL(SP), INTENT(OUT) :: f - LOGICAL(LGT), INTENT(OUT) :: check - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP) :: func - REAL(SP), DIMENSION(:), INTENT(IN) :: x - END FUNCTION func - END INTERFACE - END SUBROUTINE lnsrch - END INTERFACE - INTERFACE - FUNCTION locate(xx,x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: xx - REAL(SP), INTENT(IN) :: x - INTEGER(I4B) :: locate - END FUNCTION locate - END INTERFACE - INTERFACE - FUNCTION lop(u) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(IN) :: u - REAL(SP), DIMENSION(size(u,1),size(u,1)) :: lop - END FUNCTION lop - END INTERFACE - INTERFACE - SUBROUTINE lubksb(a,indx,b) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(IN) :: a - INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx - REAL(SP), DIMENSION(:), INTENT(INOUT) :: b - END SUBROUTINE lubksb - END INTERFACE - INTERFACE - SUBROUTINE ludcmp(a,indx,d) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a - INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: indx - REAL(SP), INTENT(OUT) :: d - END SUBROUTINE ludcmp - END INTERFACE - INTERFACE - SUBROUTINE machar(ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,& - maxexp,eps,epsneg,xmin,xmax) - USE nrtype - INTEGER(I4B), INTENT(OUT) :: ibeta,iexp,irnd,it,machep,maxexp,& - minexp,negep,ngrd - REAL(SP), INTENT(OUT) :: eps,epsneg,xmax,xmin - END SUBROUTINE machar - END INTERFACE - INTERFACE - SUBROUTINE medfit(x,y,a,b,abdev) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x,y - REAL(SP), INTENT(OUT) :: a,b,abdev - END SUBROUTINE medfit - END INTERFACE - INTERFACE - SUBROUTINE memcof(data,xms,d) - USE nrtype - REAL(SP), INTENT(OUT) :: xms - REAL(SP), DIMENSION(:), INTENT(IN) :: data - REAL(SP), DIMENSION(:), INTENT(OUT) :: d - END SUBROUTINE memcof - END INTERFACE - INTERFACE - SUBROUTINE mgfas(u,maxcyc) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: u - INTEGER(I4B), INTENT(IN) :: maxcyc - END SUBROUTINE mgfas - END INTERFACE - INTERFACE - SUBROUTINE mglin(u,ncycle) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: u - INTEGER(I4B), INTENT(IN) :: ncycle - END SUBROUTINE mglin - END INTERFACE - INTERFACE - SUBROUTINE midexp(funk,aa,bb,s,n) - USE nrtype - REAL(SP), INTENT(IN) :: aa,bb - REAL(SP), INTENT(INOUT) :: s - INTEGER(I4B), INTENT(IN) :: n - INTERFACE - FUNCTION funk(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: funk - END FUNCTION funk - END INTERFACE - END SUBROUTINE midexp - END INTERFACE - INTERFACE - SUBROUTINE midinf(funk,aa,bb,s,n) - USE nrtype - REAL(SP), INTENT(IN) :: aa,bb - REAL(SP), INTENT(INOUT) :: s - INTEGER(I4B), INTENT(IN) :: n - INTERFACE - FUNCTION funk(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: funk - END FUNCTION funk - END INTERFACE - END SUBROUTINE midinf - END INTERFACE - INTERFACE - SUBROUTINE midpnt(func,a,b,s,n) - USE nrtype - REAL(SP), INTENT(IN) :: a,b - REAL(SP), INTENT(INOUT) :: s - INTEGER(I4B), INTENT(IN) :: n - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: func - END FUNCTION func - END INTERFACE - END SUBROUTINE midpnt - END INTERFACE - INTERFACE - SUBROUTINE midsql(funk,aa,bb,s,n) - USE nrtype - REAL(SP), INTENT(IN) :: aa,bb - REAL(SP), INTENT(INOUT) :: s - INTEGER(I4B), INTENT(IN) :: n - INTERFACE - FUNCTION funk(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: funk - END FUNCTION funk - END INTERFACE - END SUBROUTINE midsql - END INTERFACE - INTERFACE - SUBROUTINE midsqu(funk,aa,bb,s,n) - USE nrtype - REAL(SP), INTENT(IN) :: aa,bb - REAL(SP), INTENT(INOUT) :: s - INTEGER(I4B), INTENT(IN) :: n - INTERFACE - FUNCTION funk(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: funk - END FUNCTION funk - END INTERFACE - END SUBROUTINE midsqu - END INTERFACE - INTERFACE - RECURSIVE SUBROUTINE miser(func,regn,ndim,npts,dith,ave,var) - USE nrtype - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP) :: func - REAL(SP), DIMENSION(:), INTENT(IN) :: x - END FUNCTION func - END INTERFACE - REAL(SP), DIMENSION(:), INTENT(IN) :: regn - INTEGER(I4B), INTENT(IN) :: ndim,npts - REAL(SP), INTENT(IN) :: dith - REAL(SP), INTENT(OUT) :: ave,var - END SUBROUTINE miser - END INTERFACE - INTERFACE - SUBROUTINE mmid(y,dydx,xs,htot,nstep,yout,derivs) - USE nrtype - INTEGER(I4B), INTENT(IN) :: nstep - REAL(SP), INTENT(IN) :: xs,htot - REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx - REAL(SP), DIMENSION(:), INTENT(OUT) :: yout - INTERFACE - SUBROUTINE derivs(x,y,dydx) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP), DIMENSION(:), INTENT(IN) :: y - REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx - END SUBROUTINE derivs - END INTERFACE - END SUBROUTINE mmid - END INTERFACE - INTERFACE - SUBROUTINE mnbrak(ax,bx,cx,fa,fb,fc,func) - USE nrtype - REAL(SP), INTENT(INOUT) :: ax,bx - REAL(SP), INTENT(OUT) :: cx,fa,fb,fc - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: func - END FUNCTION func - END INTERFACE - END SUBROUTINE mnbrak - END INTERFACE - INTERFACE - SUBROUTINE mnewt(ntrial,x,tolx,tolf,usrfun) - USE nrtype - INTEGER(I4B), INTENT(IN) :: ntrial - REAL(SP), INTENT(IN) :: tolx,tolf - REAL(SP), DIMENSION(:), INTENT(INOUT) :: x - INTERFACE - SUBROUTINE usrfun(x,fvec,fjac) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(:), INTENT(OUT) :: fvec - REAL(SP), DIMENSION(:,:), INTENT(OUT) :: fjac - END SUBROUTINE usrfun - END INTERFACE - END SUBROUTINE mnewt - END INTERFACE - INTERFACE - SUBROUTINE moment(data,ave,adev,sdev,var,skew,curt) - USE nrtype - REAL(SP), INTENT(OUT) :: ave,adev,sdev,var,skew,curt - REAL(SP), DIMENSION(:), INTENT(IN) :: data - END SUBROUTINE moment - END INTERFACE - INTERFACE - SUBROUTINE mp2dfr(a,s,n,m) - USE nrtype - INTEGER(I4B), INTENT(IN) :: n - INTEGER(I4B), INTENT(OUT) :: m - CHARACTER(1), DIMENSION(:), INTENT(INOUT) :: a - CHARACTER(1), DIMENSION(:), INTENT(OUT) :: s - END SUBROUTINE mp2dfr - END INTERFACE - INTERFACE - SUBROUTINE mpdiv(q,r,u,v,n,m) - USE nrtype - CHARACTER(1), DIMENSION(:), INTENT(OUT) :: q,r - CHARACTER(1), DIMENSION(:), INTENT(IN) :: u,v - INTEGER(I4B), INTENT(IN) :: n,m - END SUBROUTINE mpdiv - END INTERFACE - INTERFACE - SUBROUTINE mpinv(u,v,n,m) - USE nrtype - CHARACTER(1), DIMENSION(:), INTENT(OUT) :: u - CHARACTER(1), DIMENSION(:), INTENT(IN) :: v - INTEGER(I4B), INTENT(IN) :: n,m - END SUBROUTINE mpinv - END INTERFACE - INTERFACE - SUBROUTINE mpmul(w,u,v,n,m) - USE nrtype - CHARACTER(1), DIMENSION(:), INTENT(IN) :: u,v - CHARACTER(1), DIMENSION(:), INTENT(OUT) :: w - INTEGER(I4B), INTENT(IN) :: n,m - END SUBROUTINE mpmul - END INTERFACE - INTERFACE - SUBROUTINE mppi(n) - USE nrtype - INTEGER(I4B), INTENT(IN) :: n - END SUBROUTINE mppi - END INTERFACE - INTERFACE - SUBROUTINE mprove(a,alud,indx,b,x) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(IN) :: a,alud - INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx - REAL(SP), DIMENSION(:), INTENT(IN) :: b - REAL(SP), DIMENSION(:), INTENT(INOUT) :: x - END SUBROUTINE mprove - END INTERFACE - INTERFACE - SUBROUTINE mpsqrt(w,u,v,n,m) - USE nrtype - CHARACTER(1), DIMENSION(:), INTENT(OUT) :: w,u - CHARACTER(1), DIMENSION(:), INTENT(IN) :: v - INTEGER(I4B), INTENT(IN) :: n,m - END SUBROUTINE mpsqrt - END INTERFACE - INTERFACE - SUBROUTINE mrqcof(x,y,sig,a,maska,alpha,beta,chisq,funcs) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,a,sig - REAL(SP), DIMENSION(:), INTENT(OUT) :: beta - REAL(SP), DIMENSION(:,:), INTENT(OUT) :: alpha - REAL(SP), INTENT(OUT) :: chisq - LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska - INTERFACE - SUBROUTINE funcs(x,a,yfit,dyda) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x,a - REAL(SP), DIMENSION(:), INTENT(OUT) :: yfit - REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dyda - END SUBROUTINE funcs - END INTERFACE - END SUBROUTINE mrqcof - END INTERFACE - INTERFACE - SUBROUTINE mrqmin(x,y,sig,a,maska,covar,alpha,chisq,funcs,alamda) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sig - REAL(SP), DIMENSION(:), INTENT(INOUT) :: a - REAL(SP), DIMENSION(:,:), INTENT(OUT) :: covar,alpha - REAL(SP), INTENT(OUT) :: chisq - REAL(SP), INTENT(INOUT) :: alamda - LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska - INTERFACE - SUBROUTINE funcs(x,a,yfit,dyda) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x,a - REAL(SP), DIMENSION(:), INTENT(OUT) :: yfit - REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dyda - END SUBROUTINE funcs - END INTERFACE - END SUBROUTINE mrqmin - END INTERFACE - INTERFACE - SUBROUTINE newt(x,check) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: x - LOGICAL(LGT), INTENT(OUT) :: check - END SUBROUTINE newt - END INTERFACE - INTERFACE - SUBROUTINE odeint(ystart,x1,x2,eps,h1,hmin,derivs,rkqs) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: ystart - REAL(SP), INTENT(IN) :: x1,x2,eps,h1,hmin - INTERFACE - SUBROUTINE derivs(x,y,dydx) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP), DIMENSION(:), INTENT(IN) :: y - REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx - END SUBROUTINE derivs -!BL - SUBROUTINE rkqs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: y - REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal - REAL(SP), INTENT(INOUT) :: x - REAL(SP), INTENT(IN) :: htry,eps - REAL(SP), INTENT(OUT) :: hdid,hnext - INTERFACE - SUBROUTINE derivs(x,y,dydx) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP), DIMENSION(:), INTENT(IN) :: y - REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx - END SUBROUTINE derivs - END INTERFACE - END SUBROUTINE rkqs - END INTERFACE - END SUBROUTINE odeint - END INTERFACE - INTERFACE - SUBROUTINE orthog(anu,alpha,beta,a,b) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: anu,alpha,beta - REAL(SP), DIMENSION(:), INTENT(OUT) :: a,b - END SUBROUTINE orthog - END INTERFACE - INTERFACE - SUBROUTINE pade(cof,resid) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: cof - REAL(SP), INTENT(OUT) :: resid - END SUBROUTINE pade - END INTERFACE - INTERFACE - FUNCTION pccheb(d) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: d - REAL(SP), DIMENSION(size(d)) :: pccheb - END FUNCTION pccheb - END INTERFACE - INTERFACE - SUBROUTINE pcshft(a,b,d) - USE nrtype - REAL(SP), INTENT(IN) :: a,b - REAL(SP), DIMENSION(:), INTENT(INOUT) :: d - END SUBROUTINE pcshft - END INTERFACE - INTERFACE - SUBROUTINE pearsn(x,y,r,prob,z) - USE nrtype - REAL(SP), INTENT(OUT) :: r,prob,z - REAL(SP), DIMENSION(:), INTENT(IN) :: x,y - END SUBROUTINE pearsn - END INTERFACE - INTERFACE - SUBROUTINE period(x,y,ofac,hifac,px,py,jmax,prob) - USE nrtype - INTEGER(I4B), INTENT(OUT) :: jmax - REAL(SP), INTENT(IN) :: ofac,hifac - REAL(SP), INTENT(OUT) :: prob - REAL(SP), DIMENSION(:), INTENT(IN) :: x,y - REAL(SP), DIMENSION(:), POINTER :: px,py - END SUBROUTINE period - END INTERFACE - INTERFACE plgndr - FUNCTION plgndr_s(l,m,x) - USE nrtype - INTEGER(I4B), INTENT(IN) :: l,m - REAL(SP), INTENT(IN) :: x - REAL(SP) :: plgndr_s - END FUNCTION plgndr_s -!BL - FUNCTION plgndr_v(l,m,x) - USE nrtype - INTEGER(I4B), INTENT(IN) :: l,m - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: plgndr_v - END FUNCTION plgndr_v - END INTERFACE - INTERFACE - FUNCTION poidev(xm) - USE nrtype - REAL(SP), INTENT(IN) :: xm - REAL(SP) :: poidev - END FUNCTION poidev - END INTERFACE - INTERFACE - FUNCTION polcoe(x,y) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x,y - REAL(SP), DIMENSION(size(x)) :: polcoe - END FUNCTION polcoe - END INTERFACE - INTERFACE - FUNCTION polcof(xa,ya) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya - REAL(SP), DIMENSION(size(xa)) :: polcof - END FUNCTION polcof - END INTERFACE - INTERFACE - SUBROUTINE poldiv(u,v,q,r) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: u,v - REAL(SP), DIMENSION(:), INTENT(OUT) :: q,r - END SUBROUTINE poldiv - END INTERFACE - INTERFACE - SUBROUTINE polin2(x1a,x2a,ya,x1,x2,y,dy) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x1a,x2a - REAL(SP), DIMENSION(:,:), INTENT(IN) :: ya - REAL(SP), INTENT(IN) :: x1,x2 - REAL(SP), INTENT(OUT) :: y,dy - END SUBROUTINE polin2 - END INTERFACE - INTERFACE - SUBROUTINE polint(xa,ya,x,y,dy) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya - REAL(SP), INTENT(IN) :: x - REAL(SP), INTENT(OUT) :: y,dy - END SUBROUTINE polint - END INTERFACE - INTERFACE - SUBROUTINE powell(p,xi,ftol,iter,fret) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: p - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: xi - INTEGER(I4B), INTENT(OUT) :: iter - REAL(SP), INTENT(IN) :: ftol - REAL(SP), INTENT(OUT) :: fret - END SUBROUTINE powell - END INTERFACE - INTERFACE - FUNCTION predic(data,d,nfut) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: data,d - INTEGER(I4B), INTENT(IN) :: nfut - REAL(SP), DIMENSION(nfut) :: predic - END FUNCTION predic - END INTERFACE - INTERFACE - FUNCTION probks(alam) - USE nrtype - REAL(SP), INTENT(IN) :: alam - REAL(SP) :: probks - END FUNCTION probks - END INTERFACE - INTERFACE psdes - SUBROUTINE psdes_s(lword,rword) - USE nrtype - INTEGER(I4B), INTENT(INOUT) :: lword,rword - END SUBROUTINE psdes_s -!BL - SUBROUTINE psdes_v(lword,rword) - USE nrtype - INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: lword,rword - END SUBROUTINE psdes_v - END INTERFACE - INTERFACE - SUBROUTINE pwt(a,isign) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: a - INTEGER(I4B), INTENT(IN) :: isign - END SUBROUTINE pwt - END INTERFACE - INTERFACE - SUBROUTINE pwtset(n) - USE nrtype - INTEGER(I4B), INTENT(IN) :: n - END SUBROUTINE pwtset - END INTERFACE - INTERFACE pythag - FUNCTION pythag_sp(a,b) - USE nrtype - REAL(SP), INTENT(IN) :: a,b - REAL(SP) :: pythag_sp - END FUNCTION pythag_sp - END INTERFACE - INTERFACE - SUBROUTINE pzextr(iest,xest,yest,yz,dy) - USE nrtype - INTEGER(I4B), INTENT(IN) :: iest - REAL(SP), INTENT(IN) :: xest - REAL(SP), DIMENSION(:), INTENT(IN) :: yest - REAL(SP), DIMENSION(:), INTENT(OUT) :: yz,dy - END SUBROUTINE pzextr - END INTERFACE - INTERFACE - SUBROUTINE qrdcmp(a,c,d,sing) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a - REAL(SP), DIMENSION(:), INTENT(OUT) :: c,d - LOGICAL(LGT), INTENT(OUT) :: sing - END SUBROUTINE qrdcmp - END INTERFACE - INTERFACE - FUNCTION qromb(func,a,b) - USE nrtype - REAL(SP), INTENT(IN) :: a,b - REAL(SP) :: qromb - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: func - END FUNCTION func - END INTERFACE - END FUNCTION qromb - END INTERFACE - INTERFACE - FUNCTION qromo(func,a,b,choose) - USE nrtype - REAL(SP), INTENT(IN) :: a,b - REAL(SP) :: qromo - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: func - END FUNCTION func - END INTERFACE - INTERFACE - SUBROUTINE choose(funk,aa,bb,s,n) - USE nrtype - REAL(SP), INTENT(IN) :: aa,bb - REAL(SP), INTENT(INOUT) :: s - INTEGER(I4B), INTENT(IN) :: n - INTERFACE - FUNCTION funk(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: funk - END FUNCTION funk - END INTERFACE - END SUBROUTINE choose - END INTERFACE - END FUNCTION qromo - END INTERFACE - INTERFACE - SUBROUTINE qroot(p,b,c,eps) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: p - REAL(SP), INTENT(INOUT) :: b,c - REAL(SP), INTENT(IN) :: eps - END SUBROUTINE qroot - END INTERFACE - INTERFACE - SUBROUTINE qrsolv(a,c,d,b) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(IN) :: a - REAL(SP), DIMENSION(:), INTENT(IN) :: c,d - REAL(SP), DIMENSION(:), INTENT(INOUT) :: b - END SUBROUTINE qrsolv - END INTERFACE - INTERFACE - SUBROUTINE qrupdt(r,qt,u,v) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: r,qt - REAL(SP), DIMENSION(:), INTENT(INOUT) :: u - REAL(SP), DIMENSION(:), INTENT(IN) :: v - END SUBROUTINE qrupdt - END INTERFACE - INTERFACE - FUNCTION qsimp(func,a,b) - USE nrtype - REAL(SP), INTENT(IN) :: a,b - REAL(SP) :: qsimp - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: func - END FUNCTION func - END INTERFACE - END FUNCTION qsimp - END INTERFACE - INTERFACE - FUNCTION qtrap(func,a,b) - USE nrtype - REAL(SP), INTENT(IN) :: a,b - REAL(SP) :: qtrap - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: func - END FUNCTION func - END INTERFACE - END FUNCTION qtrap - END INTERFACE - INTERFACE - SUBROUTINE quadct(x,y,xx,yy,fa,fb,fc,fd) - USE nrtype - REAL(SP), INTENT(IN) :: x,y - REAL(SP), DIMENSION(:), INTENT(IN) :: xx,yy - REAL(SP), INTENT(OUT) :: fa,fb,fc,fd - END SUBROUTINE quadct - END INTERFACE - INTERFACE - SUBROUTINE quadmx(a) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(OUT) :: a - END SUBROUTINE quadmx - END INTERFACE - INTERFACE - SUBROUTINE quadvl(x,y,fa,fb,fc,fd) - USE nrtype - REAL(SP), INTENT(IN) :: x,y - REAL(SP), INTENT(OUT) :: fa,fb,fc,fd - END SUBROUTINE quadvl - END INTERFACE - INTERFACE - FUNCTION ran(idum) - INTEGER(selected_int_kind(9)), INTENT(INOUT) :: idum - REAL :: ran - END FUNCTION ran - END INTERFACE - INTERFACE ran0 - SUBROUTINE ran0_s(harvest) - USE nrtype - REAL(SP), INTENT(OUT) :: harvest - END SUBROUTINE ran0_s -!BL - SUBROUTINE ran0_v(harvest) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest - END SUBROUTINE ran0_v - END INTERFACE - INTERFACE ran1 - SUBROUTINE ran1_s(harvest) - USE nrtype - REAL(SP), INTENT(OUT) :: harvest - END SUBROUTINE ran1_s -!BL - SUBROUTINE ran1_v(harvest) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest - END SUBROUTINE ran1_v - END INTERFACE - INTERFACE ran2 - SUBROUTINE ran2_s(harvest) - USE nrtype - REAL(SP), INTENT(OUT) :: harvest - END SUBROUTINE ran2_s -!BL - SUBROUTINE ran2_v(harvest) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest - END SUBROUTINE ran2_v - END INTERFACE - INTERFACE ran3 - SUBROUTINE ran3_s(harvest) - USE nrtype - REAL(SP), INTENT(OUT) :: harvest - END SUBROUTINE ran3_s -!BL - SUBROUTINE ran3_v(harvest) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest - END SUBROUTINE ran3_v - END INTERFACE - INTERFACE - SUBROUTINE ratint(xa,ya,x,y,dy) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya - REAL(SP), INTENT(IN) :: x - REAL(SP), INTENT(OUT) :: y,dy - END SUBROUTINE ratint - END INTERFACE - INTERFACE - SUBROUTINE ratlsq(func,a,b,mm,kk,cof,dev) - USE nrtype - REAL(SP), INTENT(IN) :: a,b - INTEGER(I4B), INTENT(IN) :: mm,kk - REAL(SP), DIMENSION(:), INTENT(OUT) :: cof - REAL(SP), INTENT(OUT) :: dev - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: func - END FUNCTION func - END INTERFACE - END SUBROUTINE ratlsq - END INTERFACE - INTERFACE ratval - FUNCTION ratval_s(x,cof,mm,kk) - USE nrtype - REAL(SP), INTENT(IN) :: x - INTEGER(I4B), INTENT(IN) :: mm,kk - REAL(SP), DIMENSION(mm+kk+1), INTENT(IN) :: cof - REAL(SP) :: ratval_s - END FUNCTION ratval_s -!BL - FUNCTION ratval_v(x,cof,mm,kk) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - INTEGER(I4B), INTENT(IN) :: mm,kk - REAL(SP), DIMENSION(mm+kk+1), INTENT(IN) :: cof - REAL(SP), DIMENSION(size(x)) :: ratval_v - END FUNCTION ratval_v - END INTERFACE - INTERFACE rc - FUNCTION rc_s(x,y) - USE nrtype - REAL(SP), INTENT(IN) :: x,y - REAL(SP) :: rc_s - END FUNCTION rc_s -!BL - FUNCTION rc_v(x,y) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x,y - REAL(SP), DIMENSION(size(x)) :: rc_v - END FUNCTION rc_v - END INTERFACE - INTERFACE rd - FUNCTION rd_s(x,y,z) - USE nrtype - REAL(SP), INTENT(IN) :: x,y,z - REAL(SP) :: rd_s - END FUNCTION rd_s -!BL - FUNCTION rd_v(x,y,z) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,z - REAL(SP), DIMENSION(size(x)) :: rd_v - END FUNCTION rd_v - END INTERFACE - INTERFACE realft - SUBROUTINE realft_sp(data,isign,zdata) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: data - INTEGER(I4B), INTENT(IN) :: isign - COMPLEX(sPC), DIMENSION(:), OPTIONAL, TARGET :: zdata - END SUBROUTINE realft_sp - END INTERFACE - INTERFACE - RECURSIVE FUNCTION recur1(a,b) RESULT(u) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: a,b - REAL(SP), DIMENSION(size(a)) :: u - END FUNCTION recur1 - END INTERFACE - INTERFACE - FUNCTION recur2(a,b,c) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c - REAL(SP), DIMENSION(size(a)) :: recur2 - END FUNCTION recur2 - END INTERFACE - INTERFACE - SUBROUTINE relax(u,rhs) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: u - REAL(SP), DIMENSION(:,:), INTENT(IN) :: rhs - END SUBROUTINE relax - END INTERFACE - INTERFACE - SUBROUTINE relax2(u,rhs) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: u - REAL(SP), DIMENSION(:,:), INTENT(IN) :: rhs - END SUBROUTINE relax2 - END INTERFACE - INTERFACE - FUNCTION resid(u,rhs) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(IN) :: u,rhs - REAL(SP), DIMENSION(size(u,1),size(u,1)) :: resid - END FUNCTION resid - END INTERFACE - INTERFACE rf - FUNCTION rf_s(x,y,z) - USE nrtype - REAL(SP), INTENT(IN) :: x,y,z - REAL(SP) :: rf_s - END FUNCTION rf_s -!BL - FUNCTION rf_v(x,y,z) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,z - REAL(SP), DIMENSION(size(x)) :: rf_v - END FUNCTION rf_v - END INTERFACE - INTERFACE rj - FUNCTION rj_s(x,y,z,p) - USE nrtype - REAL(SP), INTENT(IN) :: x,y,z,p - REAL(SP) :: rj_s - END FUNCTION rj_s -!BL - FUNCTION rj_v(x,y,z,p) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,z,p - REAL(SP), DIMENSION(size(x)) :: rj_v - END FUNCTION rj_v - END INTERFACE - INTERFACE - SUBROUTINE rk4(y,dydx,x,h,yout,derivs) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx - REAL(SP), INTENT(IN) :: x,h - REAL(SP), DIMENSION(:), INTENT(OUT) :: yout - INTERFACE - SUBROUTINE derivs(x,y,dydx) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP), DIMENSION(:), INTENT(IN) :: y - REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx - END SUBROUTINE derivs - END INTERFACE - END SUBROUTINE rk4 - END INTERFACE - INTERFACE - SUBROUTINE rkck(y,dydx,x,h,yout,yerr,derivs) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx - REAL(SP), INTENT(IN) :: x,h - REAL(SP), DIMENSION(:), INTENT(OUT) :: yout,yerr - INTERFACE - SUBROUTINE derivs(x,y,dydx) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP), DIMENSION(:), INTENT(IN) :: y - REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx - END SUBROUTINE derivs - END INTERFACE - END SUBROUTINE rkck - END INTERFACE - INTERFACE - SUBROUTINE rkdumb(vstart,x1,x2,nstep,derivs) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: vstart - REAL(SP), INTENT(IN) :: x1,x2 - INTEGER(I4B), INTENT(IN) :: nstep - INTERFACE - SUBROUTINE derivs(x,y,dydx) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP), DIMENSION(:), INTENT(IN) :: y - REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx - END SUBROUTINE derivs - END INTERFACE - END SUBROUTINE rkdumb - END INTERFACE - INTERFACE - SUBROUTINE rkqs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: y - REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal - REAL(SP), INTENT(INOUT) :: x - REAL(SP), INTENT(IN) :: htry,eps - REAL(SP), INTENT(OUT) :: hdid,hnext - INTERFACE - SUBROUTINE derivs(x,y,dydx) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP), DIMENSION(:), INTENT(IN) :: y - REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx - END SUBROUTINE derivs - END INTERFACE - END SUBROUTINE rkqs - END INTERFACE - INTERFACE - SUBROUTINE rlft2(data,spec,speq,isign) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: data - COMPLEX(SPC), DIMENSION(:,:), INTENT(OUT) :: spec - COMPLEX(SPC), DIMENSION(:), INTENT(OUT) :: speq - INTEGER(I4B), INTENT(IN) :: isign - END SUBROUTINE rlft2 - END INTERFACE - INTERFACE - SUBROUTINE rlft3(data,spec,speq,isign) - USE nrtype - REAL(SP), DIMENSION(:,:,:), INTENT(INOUT) :: data - COMPLEX(SPC), DIMENSION(:,:,:), INTENT(OUT) :: spec - COMPLEX(SPC), DIMENSION(:,:), INTENT(OUT) :: speq - INTEGER(I4B), INTENT(IN) :: isign - END SUBROUTINE rlft3 - END INTERFACE - INTERFACE - SUBROUTINE rotate(r,qt,i,a,b) - USE nrtype - REAL(SP), DIMENSION(:,:), TARGET, INTENT(INOUT) :: r,qt - INTEGER(I4B), INTENT(IN) :: i - REAL(SP), INTENT(IN) :: a,b - END SUBROUTINE rotate - END INTERFACE - INTERFACE - SUBROUTINE rsolv(a,d,b) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(IN) :: a - REAL(SP), DIMENSION(:), INTENT(IN) :: d - REAL(SP), DIMENSION(:), INTENT(INOUT) :: b - END SUBROUTINE rsolv - END INTERFACE - INTERFACE - FUNCTION rstrct(uf) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(IN) :: uf - REAL(SP), DIMENSION((size(uf,1)+1)/2,(size(uf,1)+1)/2) :: rstrct - END FUNCTION rstrct - END INTERFACE - INTERFACE - FUNCTION rtbis(func,x1,x2,xacc) - USE nrtype - REAL(SP), INTENT(IN) :: x1,x2,xacc - REAL(SP) :: rtbis - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: func - END FUNCTION func - END INTERFACE - END FUNCTION rtbis - END INTERFACE - INTERFACE - FUNCTION rtflsp(func,x1,x2,xacc) - USE nrtype - REAL(SP), INTENT(IN) :: x1,x2,xacc - REAL(SP) :: rtflsp - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: func - END FUNCTION func - END INTERFACE - END FUNCTION rtflsp - END INTERFACE - INTERFACE - FUNCTION rtnewt(funcd,x1,x2,xacc) - USE nrtype - REAL(SP), INTENT(IN) :: x1,x2,xacc - REAL(SP) :: rtnewt - INTERFACE - SUBROUTINE funcd(x,fval,fderiv) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP), INTENT(OUT) :: fval,fderiv - END SUBROUTINE funcd - END INTERFACE - END FUNCTION rtnewt - END INTERFACE - INTERFACE - FUNCTION rtsafe(funcd,x1,x2,xacc) - USE nrtype - REAL(SP), INTENT(IN) :: x1,x2,xacc - REAL(SP) :: rtsafe - INTERFACE - SUBROUTINE funcd(x,fval,fderiv) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP), INTENT(OUT) :: fval,fderiv - END SUBROUTINE funcd - END INTERFACE - END FUNCTION rtsafe - END INTERFACE - INTERFACE - FUNCTION rtsec(func,x1,x2,xacc) - USE nrtype - REAL(SP), INTENT(IN) :: x1,x2,xacc - REAL(SP) :: rtsec - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: func - END FUNCTION func - END INTERFACE - END FUNCTION rtsec - END INTERFACE - INTERFACE - SUBROUTINE rzextr(iest,xest,yest,yz,dy) - USE nrtype - INTEGER(I4B), INTENT(IN) :: iest - REAL(SP), INTENT(IN) :: xest - REAL(SP), DIMENSION(:), INTENT(IN) :: yest - REAL(SP), DIMENSION(:), INTENT(OUT) :: yz,dy - END SUBROUTINE rzextr - END INTERFACE - INTERFACE - FUNCTION savgol(nl,nrr,ld,m) - USE nrtype - INTEGER(I4B), INTENT(IN) :: nl,nrr,ld,m - REAL(SP), DIMENSION(nl+nrr+1) :: savgol - END FUNCTION savgol - END INTERFACE - INTERFACE - SUBROUTINE scrsho(func) - USE nrtype - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: func - END FUNCTION func - END INTERFACE - END SUBROUTINE scrsho - END INTERFACE - INTERFACE - FUNCTION select(k,arr) - USE nrtype - INTEGER(I4B), INTENT(IN) :: k - REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr - REAL(SP) :: select - END FUNCTION select - END INTERFACE - INTERFACE - FUNCTION select_bypack(k,arr) - USE nrtype - INTEGER(I4B), INTENT(IN) :: k - REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr - REAL(SP) :: select_bypack - END FUNCTION select_bypack - END INTERFACE - INTERFACE - SUBROUTINE select_heap(arr,heap) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: arr - REAL(SP), DIMENSION(:), INTENT(OUT) :: heap - END SUBROUTINE select_heap - END INTERFACE - INTERFACE - FUNCTION select_inplace(k,arr) - USE nrtype - INTEGER(I4B), INTENT(IN) :: k - REAL(SP), DIMENSION(:), INTENT(IN) :: arr - REAL(SP) :: select_inplace - END FUNCTION select_inplace - END INTERFACE - INTERFACE - SUBROUTINE simplx(a,m1,m2,m3,icase,izrov,iposv) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a - INTEGER(I4B), INTENT(IN) :: m1,m2,m3 - INTEGER(I4B), INTENT(OUT) :: icase - INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: izrov,iposv - END SUBROUTINE simplx - END INTERFACE - INTERFACE - SUBROUTINE simpr(y,dydx,dfdx,dfdy,xs,htot,nstep,yout,derivs) - USE nrtype - REAL(SP), INTENT(IN) :: xs,htot - REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx,dfdx - REAL(SP), DIMENSION(:,:), INTENT(IN) :: dfdy - INTEGER(I4B), INTENT(IN) :: nstep - REAL(SP), DIMENSION(:), INTENT(OUT) :: yout - INTERFACE - SUBROUTINE derivs(x,y,dydx) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP), DIMENSION(:), INTENT(IN) :: y - REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx - END SUBROUTINE derivs - END INTERFACE - END SUBROUTINE simpr - END INTERFACE - INTERFACE - SUBROUTINE sinft(y) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: y - END SUBROUTINE sinft - END INTERFACE - INTERFACE - SUBROUTINE slvsm2(u,rhs) - USE nrtype - REAL(SP), DIMENSION(3,3), INTENT(OUT) :: u - REAL(SP), DIMENSION(3,3), INTENT(IN) :: rhs - END SUBROUTINE slvsm2 - END INTERFACE - INTERFACE - SUBROUTINE slvsml(u,rhs) - USE nrtype - REAL(SP), DIMENSION(3,3), INTENT(OUT) :: u - REAL(SP), DIMENSION(3,3), INTENT(IN) :: rhs - END SUBROUTINE slvsml - END INTERFACE - INTERFACE - SUBROUTINE sncndn(uu,emmc,sn,cn,dn) - USE nrtype - REAL(SP), INTENT(IN) :: uu,emmc - REAL(SP), INTENT(OUT) :: sn,cn,dn - END SUBROUTINE sncndn - END INTERFACE - INTERFACE - FUNCTION snrm(sx,itol) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: sx - INTEGER(I4B), INTENT(IN) :: itol - REAL(SP) :: snrm - END FUNCTION snrm - END INTERFACE - INTERFACE - SUBROUTINE sobseq(x,init) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(OUT) :: x - INTEGER(I4B), OPTIONAL, INTENT(IN) :: init - END SUBROUTINE sobseq - END INTERFACE - INTERFACE - SUBROUTINE solvde(itmax,conv,slowc,scalv,indexv,nb,y) - USE nrtype - INTEGER(I4B), INTENT(IN) :: itmax,nb - REAL(SP), INTENT(IN) :: conv,slowc - REAL(SP), DIMENSION(:), INTENT(IN) :: scalv - INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indexv - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: y - END SUBROUTINE solvde - END INTERFACE - INTERFACE - SUBROUTINE sor(a,b,c,d,e,f,u,rjac) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(IN) :: a,b,c,d,e,f - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: u - REAL(SP), INTENT(IN) :: rjac - END SUBROUTINE sor - END INTERFACE - INTERFACE - SUBROUTINE sort(arr) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr - END SUBROUTINE sort - END INTERFACE - INTERFACE - SUBROUTINE sort2(arr,slave) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr,slave - END SUBROUTINE sort2 - END INTERFACE - INTERFACE - SUBROUTINE sort3(arr,slave1,slave2) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr,slave1,slave2 - END SUBROUTINE sort3 - END INTERFACE - INTERFACE - SUBROUTINE sort_bypack(arr) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr - END SUBROUTINE sort_bypack - END INTERFACE - INTERFACE - SUBROUTINE sort_byreshape(arr) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr - END SUBROUTINE sort_byreshape - END INTERFACE - INTERFACE - SUBROUTINE sort_heap(arr) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr - END SUBROUTINE sort_heap - END INTERFACE - INTERFACE - SUBROUTINE sort_pick(arr) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr - END SUBROUTINE sort_pick - END INTERFACE - INTERFACE - SUBROUTINE sort_radix(arr) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr - END SUBROUTINE sort_radix - END INTERFACE - INTERFACE - SUBROUTINE sort_shell(arr) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr - END SUBROUTINE sort_shell - END INTERFACE - INTERFACE - SUBROUTINE spctrm(p,k,ovrlap,unit,n_window) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(OUT) :: p - INTEGER(I4B), INTENT(IN) :: k - LOGICAL(LGT), INTENT(IN) :: ovrlap - INTEGER(I4B), OPTIONAL, INTENT(IN) :: n_window,unit - END SUBROUTINE spctrm - END INTERFACE - INTERFACE - SUBROUTINE spear(data1,data2,d,zd,probd,rs,probrs) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 - REAL(SP), INTENT(OUT) :: d,zd,probd,rs,probrs - END SUBROUTINE spear - END INTERFACE - INTERFACE sphbes - SUBROUTINE sphbes_s(n,x,sj,sy,sjp,syp) - USE nrtype - INTEGER(I4B), INTENT(IN) :: n - REAL(SP), INTENT(IN) :: x - REAL(SP), INTENT(OUT) :: sj,sy,sjp,syp - END SUBROUTINE sphbes_s -!BL - SUBROUTINE sphbes_v(n,x,sj,sy,sjp,syp) - USE nrtype - INTEGER(I4B), INTENT(IN) :: n - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(:), INTENT(OUT) :: sj,sy,sjp,syp - END SUBROUTINE sphbes_v - END INTERFACE - INTERFACE - SUBROUTINE splie2(x1a,x2a,ya,y2a) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x1a,x2a - REAL(SP), DIMENSION(:,:), INTENT(IN) :: ya - REAL(SP), DIMENSION(:,:), INTENT(OUT) :: y2a - END SUBROUTINE splie2 - END INTERFACE - INTERFACE - FUNCTION splin2(x1a,x2a,ya,y2a,x1,x2) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x1a,x2a - REAL(SP), DIMENSION(:,:), INTENT(IN) :: ya,y2a - REAL(SP), INTENT(IN) :: x1,x2 - REAL(SP) :: splin2 - END FUNCTION splin2 - END INTERFACE - INTERFACE - SUBROUTINE spline(x,y,yp1,ypn,y2) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x,y - REAL(SP), INTENT(IN) :: yp1,ypn - REAL(SP), DIMENSION(:), INTENT(OUT) :: y2 - END SUBROUTINE spline - END INTERFACE - INTERFACE - FUNCTION splint(xa,ya,y2a,x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya,y2a - REAL(SP), INTENT(IN) :: x - REAL(SP) :: splint - END FUNCTION splint - END INTERFACE - INTERFACE sprsax -! SUBROUTINE sprsax_dp(sa,x,b) -! USE nrtype -! TYPE(sprs2_dp), INTENT(IN) :: sa -! REAL(SP), DIMENSION (:), INTENT(IN) :: x -! REAL(SP), DIMENSION (:), INTENT(OUT) :: b -! END SUBROUTINE sprsax_dp -!BL - SUBROUTINE sprsax_sp(sa,x,b) - USE nrtype - TYPE(sprs2_sp), INTENT(IN) :: sa - REAL(SP), DIMENSION (:), INTENT(IN) :: x - REAL(SP), DIMENSION (:), INTENT(OUT) :: b - END SUBROUTINE sprsax_sp - END INTERFACE - INTERFACE sprsdiag -! SUBROUTINE sprsdiag_dp(sa,b) -! USE nrtype -! TYPE(sprs2_dp), INTENT(IN) :: sa -! REAL(SP), DIMENSION(:), INTENT(OUT) :: b -! END SUBROUTINE sprsdiag_dp -!BL - SUBROUTINE sprsdiag_sp(sa,b) - USE nrtype - TYPE(sprs2_sp), INTENT(IN) :: sa - REAL(SP), DIMENSION(:), INTENT(OUT) :: b - END SUBROUTINE sprsdiag_sp - END INTERFACE - INTERFACE sprsin - SUBROUTINE sprsin_sp(a,thresh,sa) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(IN) :: a - REAL(SP), INTENT(IN) :: thresh - TYPE(sprs2_sp), INTENT(OUT) :: sa - END SUBROUTINE sprsin_sp -!BL -! SUBROUTINE sprsin_dp(a,thresh,sa) -! USE nrtype -! REAL(SP), DIMENSION(:,:), INTENT(IN) :: a -! REAL(SP), INTENT(IN) :: thresh -! TYPE(sprs2_dp), INTENT(OUT) :: sa -! END SUBROUTINE sprsin_dp - END INTERFACE - INTERFACE - SUBROUTINE sprstp(sa) - USE nrtype - TYPE(sprs2_sp), INTENT(INOUT) :: sa - END SUBROUTINE sprstp - END INTERFACE - INTERFACE sprstx -! SUBROUTINE sprstx_dp(sa,x,b) -! USE nrtype -! TYPE(sprs2_dp), INTENT(IN) :: sa -! REAL(SP), DIMENSION (:), INTENT(IN) :: x -! REAL(SP), DIMENSION (:), INTENT(OUT) :: b -! END SUBROUTINE sprstx_dp -!BL - SUBROUTINE sprstx_sp(sa,x,b) - USE nrtype - TYPE(sprs2_sp), INTENT(IN) :: sa - REAL(SP), DIMENSION (:), INTENT(IN) :: x - REAL(SP), DIMENSION (:), INTENT(OUT) :: b - END SUBROUTINE sprstx_sp - END INTERFACE - INTERFACE - SUBROUTINE stifbs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: y - REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal - REAL(SP), INTENT(IN) :: htry,eps - REAL(SP), INTENT(INOUT) :: x - REAL(SP), INTENT(OUT) :: hdid,hnext - INTERFACE - SUBROUTINE derivs(x,y,dydx) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP), DIMENSION(:), INTENT(IN) :: y - REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx - END SUBROUTINE derivs - END INTERFACE - END SUBROUTINE stifbs - END INTERFACE - INTERFACE - SUBROUTINE stiff(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: y - REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal - REAL(SP), INTENT(INOUT) :: x - REAL(SP), INTENT(IN) :: htry,eps - REAL(SP), INTENT(OUT) :: hdid,hnext - INTERFACE - SUBROUTINE derivs(x,y,dydx) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP), DIMENSION(:), INTENT(IN) :: y - REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx - END SUBROUTINE derivs - END INTERFACE - END SUBROUTINE stiff - END INTERFACE - INTERFACE - SUBROUTINE stoerm(y,d2y,xs,htot,nstep,yout,derivs) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: y,d2y - REAL(SP), INTENT(IN) :: xs,htot - INTEGER(I4B), INTENT(IN) :: nstep - REAL(SP), DIMENSION(:), INTENT(OUT) :: yout - INTERFACE - SUBROUTINE derivs(x,y,dydx) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP), DIMENSION(:), INTENT(IN) :: y - REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx - END SUBROUTINE derivs - END INTERFACE - END SUBROUTINE stoerm - END INTERFACE - INTERFACE svbksb - SUBROUTINE svbksb_sp(u,w,v,b,x) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(IN) :: u,v - REAL(SP), DIMENSION(:), INTENT(IN) :: w,b - REAL(SP), DIMENSION(:), INTENT(OUT) :: x - END SUBROUTINE svbksb_sp - END INTERFACE - INTERFACE svdcmp - SUBROUTINE svdcmp_sp(a,w,v) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a - REAL(SP), DIMENSION(:), INTENT(OUT) :: w - REAL(SP), DIMENSION(:,:), INTENT(OUT) :: v - END SUBROUTINE svdcmp_sp - END INTERFACE - INTERFACE - SUBROUTINE svdfit(x,y,sig,a,v,w,chisq,funcs) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sig - REAL(SP), DIMENSION(:), INTENT(OUT) :: a,w - REAL(SP), DIMENSION(:,:), INTENT(OUT) :: v - REAL(SP), INTENT(OUT) :: chisq - INTERFACE - FUNCTION funcs(x,n) - USE nrtype - REAL(SP), INTENT(IN) :: x - INTEGER(I4B), INTENT(IN) :: n - REAL(SP), DIMENSION(n) :: funcs - END FUNCTION funcs - END INTERFACE - END SUBROUTINE svdfit - END INTERFACE - INTERFACE - SUBROUTINE svdvar(v,w,cvm) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(IN) :: v - REAL(SP), DIMENSION(:), INTENT(IN) :: w - REAL(SP), DIMENSION(:,:), INTENT(OUT) :: cvm - END SUBROUTINE svdvar - END INTERFACE - INTERFACE - FUNCTION toeplz(r,y) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: r,y - REAL(SP), DIMENSION(size(y)) :: toeplz - END FUNCTION toeplz - END INTERFACE - INTERFACE - SUBROUTINE tptest(data1,data2,t,prob) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 - REAL(SP), INTENT(OUT) :: t,prob - END SUBROUTINE tptest - END INTERFACE - INTERFACE - SUBROUTINE tqli(d,e,z) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: d,e - REAL(SP), DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: z - END SUBROUTINE tqli - END INTERFACE - INTERFACE - SUBROUTINE trapzd(func,a,b,s,n) - USE nrtype - REAL(SP), INTENT(IN) :: a,b - REAL(SP), INTENT(INOUT) :: s - INTEGER(I4B), INTENT(IN) :: n - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x - REAL(SP), DIMENSION(size(x)) :: func - END FUNCTION func - END INTERFACE - END SUBROUTINE trapzd - END INTERFACE - INTERFACE - SUBROUTINE tred2(a,d,e,novectors) - USE nrtype - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a - REAL(SP), DIMENSION(:), INTENT(OUT) :: d,e - LOGICAL(LGT), OPTIONAL, INTENT(IN) :: novectors - END SUBROUTINE tred2 - END INTERFACE -! On a purely serial machine, for greater efficiency, remove -! the generic name tridag from the following interface, -! and put it on the next one after that. - INTERFACE tridag - RECURSIVE SUBROUTINE tridag_par(a,b,c,r,u) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c,r - REAL(SP), DIMENSION(:), INTENT(OUT) :: u - END SUBROUTINE tridag_par - END INTERFACE - INTERFACE - SUBROUTINE tridag_ser(a,b,c,r,u) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c,r - REAL(SP), DIMENSION(:), INTENT(OUT) :: u - END SUBROUTINE tridag_ser - END INTERFACE - INTERFACE - SUBROUTINE ttest(data1,data2,t,prob) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 - REAL(SP), INTENT(OUT) :: t,prob - END SUBROUTINE ttest - END INTERFACE - INTERFACE - SUBROUTINE tutest(data1,data2,t,prob) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 - REAL(SP), INTENT(OUT) :: t,prob - END SUBROUTINE tutest - END INTERFACE - INTERFACE - SUBROUTINE twofft(data1,data2,fft1,fft2) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 - COMPLEX(SPC), DIMENSION(:), INTENT(OUT) :: fft1,fft2 - END SUBROUTINE twofft - END INTERFACE - INTERFACE - FUNCTION vander(x,q) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: x,q - REAL(SP), DIMENSION(size(x)) :: vander - END FUNCTION vander - END INTERFACE - INTERFACE - SUBROUTINE vegas(region,func,init,ncall,itmx,nprn,tgral,sd,chi2a) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: region - INTEGER(I4B), INTENT(IN) :: init,ncall,itmx,nprn - REAL(SP), INTENT(OUT) :: tgral,sd,chi2a - INTERFACE - FUNCTION func(pt,wgt) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: pt - REAL(SP), INTENT(IN) :: wgt - REAL(SP) :: func - END FUNCTION func - END INTERFACE - END SUBROUTINE vegas - END INTERFACE - INTERFACE - SUBROUTINE voltra(t0,h,t,f,g,ak) - USE nrtype - REAL(SP), INTENT(IN) :: t0,h - REAL(SP), DIMENSION(:), INTENT(OUT) :: t - REAL(SP), DIMENSION(:,:), INTENT(OUT) :: f - INTERFACE - FUNCTION g(t) - USE nrtype - REAL(SP), INTENT(IN) :: t - REAL(SP), DIMENSION(:), POINTER :: g - END FUNCTION g -!BL - FUNCTION ak(t,s) - USE nrtype - REAL(SP), INTENT(IN) :: t,s - REAL(SP), DIMENSION(:,:), POINTER :: ak - END FUNCTION ak - END INTERFACE - END SUBROUTINE voltra - END INTERFACE - INTERFACE - SUBROUTINE wt1(a,isign,wtstep) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: a - INTEGER(I4B), INTENT(IN) :: isign - INTERFACE - SUBROUTINE wtstep(a,isign) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: a - INTEGER(I4B), INTENT(IN) :: isign - END SUBROUTINE wtstep - END INTERFACE - END SUBROUTINE wt1 - END INTERFACE - INTERFACE - SUBROUTINE wtn(a,nn,isign,wtstep) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: a - INTEGER(I4B), DIMENSION(:), INTENT(IN) :: nn - INTEGER(I4B), INTENT(IN) :: isign - INTERFACE - SUBROUTINE wtstep(a,isign) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(INOUT) :: a - INTEGER(I4B), INTENT(IN) :: isign - END SUBROUTINE wtstep - END INTERFACE - END SUBROUTINE wtn - END INTERFACE - INTERFACE - FUNCTION wwghts(n,h,kermom) - USE nrtype - INTEGER(I4B), INTENT(IN) :: n - REAL(SP), INTENT(IN) :: h - REAL(SP), DIMENSION(n) :: wwghts - INTERFACE - FUNCTION kermom(y,m) - USE nrtype - REAL(SP), INTENT(IN) :: y - INTEGER(I4B), INTENT(IN) :: m - REAL(SP), DIMENSION(m) :: kermom - END FUNCTION kermom - END INTERFACE - END FUNCTION wwghts - END INTERFACE - INTERFACE - SUBROUTINE zbrac(func,x1,x2,succes) - USE nrtype - REAL(SP), INTENT(INOUT) :: x1,x2 - LOGICAL(LGT), INTENT(OUT) :: succes - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: func - END FUNCTION func - END INTERFACE - END SUBROUTINE zbrac - END INTERFACE - INTERFACE - SUBROUTINE zbrak(func,x1,x2,n,xb1,xb2,nb) - USE nrtype - INTEGER(I4B), INTENT(IN) :: n - INTEGER(I4B), INTENT(OUT) :: nb - REAL(SP), INTENT(IN) :: x1,x2 - REAL(SP), DIMENSION(:), POINTER :: xb1,xb2 - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: func - END FUNCTION func - END INTERFACE - END SUBROUTINE zbrak - END INTERFACE - INTERFACE - FUNCTION zbrent(func,x1,x2,tol) - USE nrtype - REAL(SP), INTENT(IN) :: x1,x2,tol - REAL(SP) :: zbrent - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: func - END FUNCTION func - END INTERFACE - END FUNCTION zbrent - END INTERFACE - INTERFACE - SUBROUTINE zrhqr(a,rtr,rti) - USE nrtype - REAL(SP), DIMENSION(:), INTENT(IN) :: a - REAL(SP), DIMENSION(:), INTENT(OUT) :: rtr,rti - END SUBROUTINE zrhqr - END INTERFACE - INTERFACE - FUNCTION zriddr(func,x1,x2,xacc) - USE nrtype - REAL(SP), INTENT(IN) :: x1,x2,xacc - REAL(SP) :: zriddr - INTERFACE - FUNCTION func(x) - USE nrtype - REAL(SP), INTENT(IN) :: x - REAL(SP) :: func - END FUNCTION func - END INTERFACE - END FUNCTION zriddr - END INTERFACE - INTERFACE - SUBROUTINE zroots(a,roots,polish) - USE nrtype - COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: a - COMPLEX(SPC), DIMENSION(:), INTENT(OUT) :: roots - LOGICAL(LGT), INTENT(IN) :: polish - END SUBROUTINE zroots - END INTERFACE -END MODULE nr diff --git a/build/FUSE_SRC/FUSE_NR/.svn/text-base/nrtype.f90.svn-base b/build/FUSE_SRC/FUSE_NR/.svn/text-base/nrtype.f90.svn-base deleted file mode 100644 index 061468f..0000000 --- a/build/FUSE_SRC/FUSE_NR/.svn/text-base/nrtype.f90.svn-base +++ /dev/null @@ -1,31 +0,0 @@ -MODULE nrtype -use kinds_dmsl_kit_FUSE,only:mrk - INTEGER, PARAMETER :: I4B = SELECTED_INT_KIND(9) - INTEGER, PARAMETER :: I2B = SELECTED_INT_KIND(4) - INTEGER, PARAMETER :: I1B = SELECTED_INT_KIND(2) - INTEGER, PARAMETER :: DP = KIND(1.d0) - INTEGER, PARAMETER :: SP = mrk ! KIND(1.d0) ! link to kinds to avoid conflicts - INTEGER, PARAMETER :: MSP = KIND(1.0) ! SP still needed for f77 netcdf routines - INTEGER, PARAMETER :: SPC = KIND((1.0,1.0)) - INTEGER, PARAMETER :: LGT = KIND(.true.) - REAL(SP), PARAMETER :: PI=3.141592653589793238462643383279502884197_sp - REAL(SP), PARAMETER :: PIO2=1.57079632679489661923132169163975144209858_sp - REAL(SP), PARAMETER :: TWOPI=6.283185307179586476925286766559005768394_sp - REAL(SP), PARAMETER :: SQRT2=1.41421356237309504880168872420969807856967_sp - REAL(SP), PARAMETER :: EULER=0.5772156649015328606065120900824024310422_sp -! REAL(SP), PARAMETER :: PI_D=3.141592653589793238462643383279502884197_dp -! REAL(SP), PARAMETER :: PIO2_D=1.57079632679489661923132169163975144209858_dp -! REAL(SP), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_dp - TYPE sprs2_sp - INTEGER(I4B) :: n,len - REAL(SP), DIMENSION(:), POINTER :: val - INTEGER(I4B), DIMENSION(:), POINTER :: irow - INTEGER(I4B), DIMENSION(:), POINTER :: jcol - END TYPE sprs2_sp -! TYPE sprs2_dp -! INTEGER(I4B) :: n,len -! REAL(SP), DIMENSION(:), POINTER :: val -! INTEGER(I4B), DIMENSION(:), POINTER :: irow -! INTEGER(I4B), DIMENSION(:), POINTER :: jcol -! END TYPE sprs2_dp -END MODULE nrtype diff --git a/build/FUSE_SRC/FUSE_NR/.svn/text-base/nrutil.f90.svn-base b/build/FUSE_SRC/FUSE_NR/.svn/text-base/nrutil.f90.svn-base deleted file mode 100644 index ca8b4c4..0000000 --- a/build/FUSE_SRC/FUSE_NR/.svn/text-base/nrutil.f90.svn-base +++ /dev/null @@ -1,1086 +0,0 @@ -MODULE nrutil - USE nrtype - IMPLICIT NONE - INTEGER(I4B), PARAMETER :: NPAR_ARTH=16,NPAR2_ARTH=8 - INTEGER(I4B), PARAMETER :: NPAR_GEOP=4,NPAR2_GEOP=2 - INTEGER(I4B), PARAMETER :: NPAR_CUMSUM=16 - INTEGER(I4B), PARAMETER :: NPAR_CUMPROD=8 - INTEGER(I4B), PARAMETER :: NPAR_POLY=8 - INTEGER(I4B), PARAMETER :: NPAR_POLYTERM=8 - INTERFACE array_copy - MODULE PROCEDURE array_copy_r, array_copy_i ! array_copy_d - END INTERFACE - INTERFACE swap - MODULE PROCEDURE swap_i,swap_r,swap_rv,swap_c, & - swap_cv,swap_cm, & - masked_swap_rs,masked_swap_rv,masked_swap_rm - END INTERFACE - INTERFACE reallocate - MODULE PROCEDURE reallocate_rv,reallocate_rm,& - reallocate_iv,reallocate_im,reallocate_hv - END INTERFACE - INTERFACE imaxloc - MODULE PROCEDURE imaxloc_r,imaxloc_i - END INTERFACE - INTERFACE assert - MODULE PROCEDURE assert1,assert2,assert3,assert4,assert_v - END INTERFACE - INTERFACE assert_eq - MODULE PROCEDURE assert_eq2,assert_eq3,assert_eq4,assert_eqn - END INTERFACE - INTERFACE arth - !MODULE PROCEDURE arth_r, arth_d, arth_i - MODULE PROCEDURE arth_r, arth_i - END INTERFACE - INTERFACE geop - MODULE PROCEDURE geop_r, geop_i, geop_c !, geop_d - END INTERFACE - INTERFACE cumsum - MODULE PROCEDURE cumsum_r,cumsum_i - END INTERFACE - INTERFACE poly - MODULE PROCEDURE poly_rr,poly_rrv,& !,poly_dd,& !poly_ddv,& - poly_rc,poly_cc,poly_msk_rrv !,poly_msk_ddv - END INTERFACE - INTERFACE poly_term - MODULE PROCEDURE poly_term_rr,poly_term_cc - END INTERFACE - INTERFACE outerprod - MODULE PROCEDURE outerprod_r !,outerprod_d - END INTERFACE - INTERFACE outerdiff - MODULE PROCEDURE outerdiff_r,outerdiff_i !,outerdiff_d - END INTERFACE - INTERFACE scatter_add - MODULE PROCEDURE scatter_add_r !,scatter_add_d - END INTERFACE - INTERFACE scatter_max - MODULE PROCEDURE scatter_max_r !,scatter_max_d - END INTERFACE - INTERFACE diagadd - MODULE PROCEDURE diagadd_rv,diagadd_r - END INTERFACE - INTERFACE diagmult - MODULE PROCEDURE diagmult_rv,diagmult_r - END INTERFACE - INTERFACE get_diag - MODULE PROCEDURE get_diag_rv !, get_diag_dv - END INTERFACE - INTERFACE put_diag - MODULE PROCEDURE put_diag_rv, put_diag_r - END INTERFACE -CONTAINS -!BL - SUBROUTINE array_copy_r(src,dest,n_copied,n_not_copied) - REAL(SP), DIMENSION(:), INTENT(IN) :: src - REAL(SP), DIMENSION(:), INTENT(OUT) :: dest - INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied - n_copied=min(size(src),size(dest)) - n_not_copied=size(src)-n_copied - dest(1:n_copied)=src(1:n_copied) - END SUBROUTINE array_copy_r -!BL -! SUBROUTINE array_copy_d(src,dest,n_copied,n_not_copied) -! REAL(DP), DIMENSION(:), INTENT(IN) :: src -! REAL(DP), DIMENSION(:), INTENT(OUT) :: dest -! INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied -! n_copied=min(size(src),size(dest)) -! n_not_copied=size(src)-n_copied -! dest(1:n_copied)=src(1:n_copied) -! END SUBROUTINE array_copy_d -!BL - SUBROUTINE array_copy_i(src,dest,n_copied,n_not_copied) - INTEGER(I4B), DIMENSION(:), INTENT(IN) :: src - INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: dest - INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied - n_copied=min(size(src),size(dest)) - n_not_copied=size(src)-n_copied - dest(1:n_copied)=src(1:n_copied) - END SUBROUTINE array_copy_i -!BL -!BL - SUBROUTINE swap_i(a,b) - INTEGER(I4B), INTENT(INOUT) :: a,b - INTEGER(I4B) :: dum - dum=a - a=b - b=dum - END SUBROUTINE swap_i -!BL - SUBROUTINE swap_r(a,b) - REAL(SP), INTENT(INOUT) :: a,b - REAL(SP) :: dum - dum=a - a=b - b=dum - END SUBROUTINE swap_r -!BL - SUBROUTINE swap_rv(a,b) - REAL(SP), DIMENSION(:), INTENT(INOUT) :: a,b - REAL(SP), DIMENSION(SIZE(a)) :: dum - dum=a - a=b - b=dum - END SUBROUTINE swap_rv -!BL - SUBROUTINE swap_c(a,b) - COMPLEX(SPC), INTENT(INOUT) :: a,b - COMPLEX(SPC) :: dum - dum=a - a=b - b=dum - END SUBROUTINE swap_c -!BL - SUBROUTINE swap_cv(a,b) - COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: a,b - COMPLEX(SPC), DIMENSION(SIZE(a)) :: dum - dum=a - a=b - b=dum - END SUBROUTINE swap_cv -!BL - SUBROUTINE swap_cm(a,b) - COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: a,b - COMPLEX(SPC), DIMENSION(size(a,1),size(a,2)) :: dum - dum=a - a=b - b=dum - END SUBROUTINE swap_cm -!BL - SUBROUTINE masked_swap_rs(a,b,mask) - REAL(SP), INTENT(INOUT) :: a,b - LOGICAL(LGT), INTENT(IN) :: mask - REAL(SP) :: swp - if (mask) then - swp=a - a=b - b=swp - end if - END SUBROUTINE masked_swap_rs -!BL - SUBROUTINE masked_swap_rv(a,b,mask) - REAL(SP), DIMENSION(:), INTENT(INOUT) :: a,b - LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask - REAL(SP), DIMENSION(size(a)) :: swp - where (mask) - swp=a - a=b - b=swp - end where - END SUBROUTINE masked_swap_rv -!BL - SUBROUTINE masked_swap_rm(a,b,mask) - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a,b - LOGICAL(LGT), DIMENSION(:,:), INTENT(IN) :: mask - REAL(SP), DIMENSION(size(a,1),size(a,2)) :: swp - where (mask) - swp=a - a=b - b=swp - end where - END SUBROUTINE masked_swap_rm -!BL -!BL - FUNCTION reallocate_rv(p,n) - REAL(SP), DIMENSION(:), POINTER :: p, reallocate_rv - INTEGER(I4B), INTENT(IN) :: n - INTEGER(I4B) :: nold,ierr - allocate(reallocate_rv(n),stat=ierr) - if (ierr /= 0) call & - nrerror('reallocate_rv: problem in attempt to allocate memory') - if (.not. associated(p)) RETURN - nold=size(p) - reallocate_rv(1:min(nold,n))=p(1:min(nold,n)) - deallocate(p) - END FUNCTION reallocate_rv -!BL - FUNCTION reallocate_iv(p,n) - INTEGER(I4B), DIMENSION(:), POINTER :: p, reallocate_iv - INTEGER(I4B), INTENT(IN) :: n - INTEGER(I4B) :: nold,ierr - allocate(reallocate_iv(n),stat=ierr) - if (ierr /= 0) call & - nrerror('reallocate_iv: problem in attempt to allocate memory') - if (.not. associated(p)) RETURN - nold=size(p) - reallocate_iv(1:min(nold,n))=p(1:min(nold,n)) - deallocate(p) - END FUNCTION reallocate_iv -!BL - FUNCTION reallocate_hv(p,n) - CHARACTER(1), DIMENSION(:), POINTER :: p, reallocate_hv - INTEGER(I4B), INTENT(IN) :: n - INTEGER(I4B) :: nold,ierr - allocate(reallocate_hv(n),stat=ierr) - if (ierr /= 0) call & - nrerror('reallocate_hv: problem in attempt to allocate memory') - if (.not. associated(p)) RETURN - nold=size(p) - reallocate_hv(1:min(nold,n))=p(1:min(nold,n)) - deallocate(p) - END FUNCTION reallocate_hv -!BL - FUNCTION reallocate_rm(p,n,m) - REAL(SP), DIMENSION(:,:), POINTER :: p, reallocate_rm - INTEGER(I4B), INTENT(IN) :: n,m - INTEGER(I4B) :: nold,mold,ierr - allocate(reallocate_rm(n,m),stat=ierr) - if (ierr /= 0) call & - nrerror('reallocate_rm: problem in attempt to allocate memory') - if (.not. associated(p)) RETURN - nold=size(p,1) - mold=size(p,2) - reallocate_rm(1:min(nold,n),1:min(mold,m))=& - p(1:min(nold,n),1:min(mold,m)) - deallocate(p) - END FUNCTION reallocate_rm -!BL - FUNCTION reallocate_im(p,n,m) - INTEGER(I4B), DIMENSION(:,:), POINTER :: p, reallocate_im - INTEGER(I4B), INTENT(IN) :: n,m - INTEGER(I4B) :: nold,mold,ierr - allocate(reallocate_im(n,m),stat=ierr) - if (ierr /= 0) call & - nrerror('reallocate_im: problem in attempt to allocate memory') - if (.not. associated(p)) RETURN - nold=size(p,1) - mold=size(p,2) - reallocate_im(1:min(nold,n),1:min(mold,m))=& - p(1:min(nold,n),1:min(mold,m)) - deallocate(p) - END FUNCTION reallocate_im -!BL - FUNCTION ifirstloc(mask) - LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask - INTEGER(I4B) :: ifirstloc - INTEGER(I4B), DIMENSION(1) :: loc - loc=maxloc(merge(1,0,mask)) - ifirstloc=loc(1) - if (.not. mask(ifirstloc)) ifirstloc=size(mask)+1 - END FUNCTION ifirstloc -!BL - FUNCTION imaxloc_r(arr) - REAL(SP), DIMENSION(:), INTENT(IN) :: arr - INTEGER(I4B) :: imaxloc_r - INTEGER(I4B), DIMENSION(1) :: imax - imax=maxloc(arr(:)) - imaxloc_r=imax(1) - END FUNCTION imaxloc_r -!BL - FUNCTION imaxloc_i(iarr) - INTEGER(I4B), DIMENSION(:), INTENT(IN) :: iarr - INTEGER(I4B), DIMENSION(1) :: imax - INTEGER(I4B) :: imaxloc_i - imax=maxloc(iarr(:)) - imaxloc_i=imax(1) - END FUNCTION imaxloc_i -!BL - FUNCTION iminloc(arr) - REAL(SP), DIMENSION(:), INTENT(IN) :: arr - INTEGER(I4B), DIMENSION(1) :: imin - INTEGER(I4B) :: iminloc - imin=minloc(arr(:)) - iminloc=imin(1) - END FUNCTION iminloc -!BL - SUBROUTINE assert1(n1,string) - CHARACTER(LEN=*), INTENT(IN) :: string - LOGICAL, INTENT(IN) :: n1 - if (.not. n1) then - write (*,*) 'nrerror: an assertion failed with this tag:', & - string - STOP 'program terminated by assert1' - end if - END SUBROUTINE assert1 -!BL - SUBROUTINE assert2(n1,n2,string) - CHARACTER(LEN=*), INTENT(IN) :: string - LOGICAL, INTENT(IN) :: n1,n2 - if (.not. (n1 .and. n2)) then - write (*,*) 'nrerror: an assertion failed with this tag:', & - string - STOP 'program terminated by assert2' - end if - END SUBROUTINE assert2 -!BL - SUBROUTINE assert3(n1,n2,n3,string) - CHARACTER(LEN=*), INTENT(IN) :: string - LOGICAL, INTENT(IN) :: n1,n2,n3 - if (.not. (n1 .and. n2 .and. n3)) then - write (*,*) 'nrerror: an assertion failed with this tag:', & - string - STOP 'program terminated by assert3' - end if - END SUBROUTINE assert3 -!BL - SUBROUTINE assert4(n1,n2,n3,n4,string) - CHARACTER(LEN=*), INTENT(IN) :: string - LOGICAL, INTENT(IN) :: n1,n2,n3,n4 - if (.not. (n1 .and. n2 .and. n3 .and. n4)) then - write (*,*) 'nrerror: an assertion failed with this tag:', & - string - STOP 'program terminated by assert4' - end if - END SUBROUTINE assert4 -!BL - SUBROUTINE assert_v(n,string) - CHARACTER(LEN=*), INTENT(IN) :: string - LOGICAL, DIMENSION(:), INTENT(IN) :: n - if (.not. all(n)) then - write (*,*) 'nrerror: an assertion failed with this tag:', & - string - STOP 'program terminated by assert_v' - end if - END SUBROUTINE assert_v -!BL - FUNCTION assert_eq2(n1,n2,string) - CHARACTER(LEN=*), INTENT(IN) :: string - INTEGER, INTENT(IN) :: n1,n2 - INTEGER :: assert_eq2 - if (n1 == n2) then - assert_eq2=n1 - else - write (*,*) 'nrerror: an assert_eq failed with this tag:', & - string - STOP 'program terminated by assert_eq2' - end if - END FUNCTION assert_eq2 -!BL - FUNCTION assert_eq3(n1,n2,n3,string) - CHARACTER(LEN=*), INTENT(IN) :: string - INTEGER, INTENT(IN) :: n1,n2,n3 - INTEGER :: assert_eq3 - if (n1 == n2 .and. n2 == n3) then - assert_eq3=n1 - else - write (*,*) 'nrerror: an assert_eq failed with this tag:', & - string - STOP 'program terminated by assert_eq3' - end if - END FUNCTION assert_eq3 -!BL - FUNCTION assert_eq4(n1,n2,n3,n4,string) - CHARACTER(LEN=*), INTENT(IN) :: string - INTEGER, INTENT(IN) :: n1,n2,n3,n4 - INTEGER :: assert_eq4 - if (n1 == n2 .and. n2 == n3 .and. n3 == n4) then - assert_eq4=n1 - else - write (*,*) 'nrerror: an assert_eq failed with this tag:', & - string - STOP 'program terminated by assert_eq4' - end if - END FUNCTION assert_eq4 -!BL - FUNCTION assert_eqn(nn,string) - CHARACTER(LEN=*), INTENT(IN) :: string - INTEGER, DIMENSION(:), INTENT(IN) :: nn - INTEGER :: assert_eqn - if (all(nn(2:) == nn(1))) then - assert_eqn=nn(1) - else - write (*,*) 'nrerror: an assert_eq failed with this tag:', & - string - STOP 'program terminated by assert_eqn' - end if - END FUNCTION assert_eqn -!BL - SUBROUTINE nrerror(string) - CHARACTER(LEN=*), INTENT(IN) :: string - write (*,*) 'nrerror: ',string - STOP 'program terminated by nrerror' - END SUBROUTINE nrerror -!BL - FUNCTION arth_r(first,increment,n) - REAL(SP), INTENT(IN) :: first,increment - INTEGER(I4B), INTENT(IN) :: n - REAL(SP), DIMENSION(n) :: arth_r - INTEGER(I4B) :: k,k2 - REAL(SP) :: temp - if (n > 0) arth_r(1)=first - if (n <= NPAR_ARTH) then - do k=2,n - arth_r(k)=arth_r(k-1)+increment - end do - else - do k=2,NPAR2_ARTH - arth_r(k)=arth_r(k-1)+increment - end do - temp=increment*NPAR2_ARTH - k=NPAR2_ARTH - do - if (k >= n) exit - k2=k+k - arth_r(k+1:min(k2,n))=temp+arth_r(1:min(k,n-k)) - temp=temp+temp - k=k2 - end do - end if - END FUNCTION arth_r -!BL - FUNCTION arth_i(first,increment,n) - INTEGER(I4B), INTENT(IN) :: first,increment,n - INTEGER(I4B), DIMENSION(n) :: arth_i - INTEGER(I4B) :: k,k2,temp - if (n > 0) arth_i(1)=first - if (n <= NPAR_ARTH) then - do k=2,n - arth_i(k)=arth_i(k-1)+increment - end do - else - do k=2,NPAR2_ARTH - arth_i(k)=arth_i(k-1)+increment - end do - temp=increment*NPAR2_ARTH - k=NPAR2_ARTH - do - if (k >= n) exit - k2=k+k - arth_i(k+1:min(k2,n))=temp+arth_i(1:min(k,n-k)) - temp=temp+temp - k=k2 - end do - end if - END FUNCTION arth_i -!BL -!BL - FUNCTION geop_r(first,factor,n) - REAL(SP), INTENT(IN) :: first,factor - INTEGER(I4B), INTENT(IN) :: n - REAL(SP), DIMENSION(n) :: geop_r - INTEGER(I4B) :: k,k2 - REAL(SP) :: temp - if (n > 0) geop_r(1)=first - if (n <= NPAR_GEOP) then - do k=2,n - geop_r(k)=geop_r(k-1)*factor - end do - else - do k=2,NPAR2_GEOP - geop_r(k)=geop_r(k-1)*factor - end do - temp=factor**NPAR2_GEOP - k=NPAR2_GEOP - do - if (k >= n) exit - k2=k+k - geop_r(k+1:min(k2,n))=temp*geop_r(1:min(k,n-k)) - temp=temp*temp - k=k2 - end do - end if - END FUNCTION geop_r -!BL -! FUNCTION geop_d(first,factor,n) -! REAL(DP), INTENT(IN) :: first,factor -! INTEGER(I4B), INTENT(IN) :: n -! REAL(DP), DIMENSION(n) :: geop_d -! INTEGER(I4B) :: k,k2 -! REAL(DP) :: temp -! if (n > 0) geop_d(1)=first -! if (n <= NPAR_GEOP) then -! do k=2,n -! geop_d(k)=geop_d(k-1)*factor -! end do -! else -! do k=2,NPAR2_GEOP -! geop_d(k)=geop_d(k-1)*factor -! end do -! temp=factor**NPAR2_GEOP -! k=NPAR2_GEOP -! do -! if (k >= n) exit -! k2=k+k -! geop_d(k+1:min(k2,n))=temp*geop_d(1:min(k,n-k)) -! temp=temp*temp -! k=k2 -! end do -! end if -! END FUNCTION geop_d -!BL - FUNCTION geop_i(first,factor,n) - INTEGER(I4B), INTENT(IN) :: first,factor,n - INTEGER(I4B), DIMENSION(n) :: geop_i - INTEGER(I4B) :: k,k2,temp - if (n > 0) geop_i(1)=first - if (n <= NPAR_GEOP) then - do k=2,n - geop_i(k)=geop_i(k-1)*factor - end do - else - do k=2,NPAR2_GEOP - geop_i(k)=geop_i(k-1)*factor - end do - temp=factor**NPAR2_GEOP - k=NPAR2_GEOP - do - if (k >= n) exit - k2=k+k - geop_i(k+1:min(k2,n))=temp*geop_i(1:min(k,n-k)) - temp=temp*temp - k=k2 - end do - end if - END FUNCTION geop_i -!BL - FUNCTION geop_c(first,factor,n) - COMPLEX(SP), INTENT(IN) :: first,factor - INTEGER(I4B), INTENT(IN) :: n - COMPLEX(SP), DIMENSION(n) :: geop_c - INTEGER(I4B) :: k,k2 - COMPLEX(SP) :: temp - if (n > 0) geop_c(1)=first - if (n <= NPAR_GEOP) then - do k=2,n - geop_c(k)=geop_c(k-1)*factor - end do - else - do k=2,NPAR2_GEOP - geop_c(k)=geop_c(k-1)*factor - end do - temp=factor**NPAR2_GEOP - k=NPAR2_GEOP - do - if (k >= n) exit - k2=k+k - geop_c(k+1:min(k2,n))=temp*geop_c(1:min(k,n-k)) - temp=temp*temp - k=k2 - end do - end if - END FUNCTION geop_c -!BL - RECURSIVE FUNCTION cumsum_r(arr,seed) RESULT(ans) - REAL(SP), DIMENSION(:), INTENT(IN) :: arr - REAL(SP), OPTIONAL, INTENT(IN) :: seed - REAL(SP), DIMENSION(size(arr)) :: ans - INTEGER(I4B) :: n,j - REAL(SP) :: sd - n=size(arr) - if (n == 0_i4b) RETURN - sd=0.0_sp - if (present(seed)) sd=seed - ans(1)=arr(1)+sd - if (n < NPAR_CUMSUM) then - do j=2,n - ans(j)=ans(j-1)+arr(j) - end do - else - ans(2:n:2)=cumsum_r(arr(2:n:2)+arr(1:n-1:2),sd) - ans(3:n:2)=ans(2:n-1:2)+arr(3:n:2) - end if - END FUNCTION cumsum_r -!BL - RECURSIVE FUNCTION cumsum_i(arr,seed) RESULT(ans) - INTEGER(I4B), DIMENSION(:), INTENT(IN) :: arr - INTEGER(I4B), OPTIONAL, INTENT(IN) :: seed - INTEGER(I4B), DIMENSION(size(arr)) :: ans - INTEGER(I4B) :: n,j,sd - n=size(arr) - if (n == 0_i4b) RETURN - sd=0_i4b - if (present(seed)) sd=seed - ans(1)=arr(1)+sd - if (n < NPAR_CUMSUM) then - do j=2,n - ans(j)=ans(j-1)+arr(j) - end do - else - ans(2:n:2)=cumsum_i(arr(2:n:2)+arr(1:n-1:2),sd) - ans(3:n:2)=ans(2:n-1:2)+arr(3:n:2) - end if - END FUNCTION cumsum_i -!BL -!BL - RECURSIVE FUNCTION cumprod(arr,seed) RESULT(ans) - REAL(SP), DIMENSION(:), INTENT(IN) :: arr - REAL(SP), OPTIONAL, INTENT(IN) :: seed - REAL(SP), DIMENSION(size(arr)) :: ans - INTEGER(I4B) :: n,j - REAL(SP) :: sd - n=size(arr) - if (n == 0_i4b) RETURN - sd=1.0_sp - if (present(seed)) sd=seed - ans(1)=arr(1)*sd - if (n < NPAR_CUMPROD) then - do j=2,n - ans(j)=ans(j-1)*arr(j) - end do - else - ans(2:n:2)=cumprod(arr(2:n:2)*arr(1:n-1:2),sd) - ans(3:n:2)=ans(2:n-1:2)*arr(3:n:2) - end if - END FUNCTION cumprod -!BL -!BL - FUNCTION poly_rr(x,coeffs) - REAL(SP), INTENT(IN) :: x - REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs - REAL(SP) :: poly_rr - REAL(SP) :: pow - REAL(SP), DIMENSION(:), ALLOCATABLE :: vec - INTEGER(I4B) :: i,n,nn - n=size(coeffs) - if (n <= 0) then - poly_rr=0.0_sp - else if (n < NPAR_POLY) then - poly_rr=coeffs(n) - do i=n-1,1,-1 - poly_rr=x*poly_rr+coeffs(i) - end do - else - allocate(vec(n+1)) - pow=x - vec(1:n)=coeffs - do - vec(n+1)=0.0_sp - nn=ishft(n+1,-1) - vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2) - if (nn == 1) exit - pow=pow*pow - n=nn - end do - poly_rr=vec(1) - deallocate(vec) - end if - END FUNCTION poly_rr -!BL -! FUNCTION poly_dd(x,coeffs) -! REAL(DP), INTENT(IN) :: x -! REAL(DP), DIMENSION(:), INTENT(IN) :: coeffs -! REAL(DP) :: poly_dd -! REAL(DP) :: pow -! REAL(DP), DIMENSION(:), ALLOCATABLE :: vec -! INTEGER(I4B) :: i,n,nn -! n=size(coeffs) -! if (n <= 0) then -! poly_dd=0.0_dp -! else if (n < NPAR_POLY) then -! poly_dd=coeffs(n) -! do i=n-1,1,-1 -! poly_dd=x*poly_dd+coeffs(i) -! end do -! else -! allocate(vec(n+1)) -! pow=x -! vec(1:n)=coeffs -! do -! vec(n+1)=0.0_dp -! nn=ishft(n+1,-1) -! vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2) -! if (nn == 1) exit -! pow=pow*pow -! n=nn -! end do -! poly_dd=vec(1) -! deallocate(vec) -! end if -! END FUNCTION poly_dd -!BL - FUNCTION poly_rc(x,coeffs) - COMPLEX(SPC), INTENT(IN) :: x - REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs - COMPLEX(SPC) :: poly_rc - COMPLEX(SPC) :: pow - COMPLEX(SPC), DIMENSION(:), ALLOCATABLE :: vec - INTEGER(I4B) :: i,n,nn - n=size(coeffs) - if (n <= 0) then - poly_rc=0.0_sp - else if (n < NPAR_POLY) then - poly_rc=coeffs(n) - do i=n-1,1,-1 - poly_rc=x*poly_rc+coeffs(i) - end do - else - allocate(vec(n+1)) - pow=x - vec(1:n)=coeffs - do - vec(n+1)=0.0_sp - nn=ishft(n+1,-1) - vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2) - if (nn == 1) exit - pow=pow*pow - n=nn - end do - poly_rc=vec(1) - deallocate(vec) - end if - END FUNCTION poly_rc -!BL - FUNCTION poly_cc(x,coeffs) - COMPLEX(SPC), INTENT(IN) :: x - COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: coeffs - COMPLEX(SPC) :: poly_cc - COMPLEX(SPC) :: pow - COMPLEX(SPC), DIMENSION(:), ALLOCATABLE :: vec - INTEGER(I4B) :: i,n,nn - n=size(coeffs) - if (n <= 0) then - poly_cc=0.0_sp - else if (n < NPAR_POLY) then - poly_cc=coeffs(n) - do i=n-1,1,-1 - poly_cc=x*poly_cc+coeffs(i) - end do - else - allocate(vec(n+1)) - pow=x - vec(1:n)=coeffs - do - vec(n+1)=0.0_sp - nn=ishft(n+1,-1) - vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2) - if (nn == 1) exit - pow=pow*pow - n=nn - end do - poly_cc=vec(1) - deallocate(vec) - end if - END FUNCTION poly_cc -!BL - FUNCTION poly_rrv(x,coeffs) - REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs,x - REAL(SP), DIMENSION(size(x)) :: poly_rrv - INTEGER(I4B) :: i,n,m - m=size(coeffs) - n=size(x) - if (m <= 0) then - poly_rrv=0.0_sp - else if (m < n .or. m < NPAR_POLY) then - poly_rrv=coeffs(m) - do i=m-1,1,-1 - poly_rrv=x*poly_rrv+coeffs(i) - end do - else - do i=1,n - poly_rrv(i)=poly_rr(x(i),coeffs) - end do - end if - END FUNCTION poly_rrv -!BL -! FUNCTION poly_ddv(x,coeffs) -! REAL(DP), DIMENSION(:), INTENT(IN) :: coeffs,x -! REAL(DP), DIMENSION(size(x)) :: poly_ddv -! INTEGER(I4B) :: i,n,m -! m=size(coeffs) -! n=size(x) -! if (m <= 0) then -! poly_ddv=0.0_dp -! else if (m < n .or. m < NPAR_POLY) then -! poly_ddv=coeffs(m) -! do i=m-1,1,-1 -! poly_ddv=x*poly_ddv+coeffs(i) -! end do -! else -! do i=1,n -! poly_ddv(i)=poly_dd(x(i),coeffs) -! end do -! end if -! END FUNCTION poly_ddv -!BL - FUNCTION poly_msk_rrv(x,coeffs,mask) - REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs,x - LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask - REAL(SP), DIMENSION(size(x)) :: poly_msk_rrv - poly_msk_rrv=unpack(poly_rrv(pack(x,mask),coeffs),mask,0.0_sp) - END FUNCTION poly_msk_rrv -!BL -! FUNCTION poly_msk_ddv(x,coeffs,mask) -! REAL(DP), DIMENSION(:), INTENT(IN) :: coeffs,x -! LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask -! REAL(DP), DIMENSION(size(x)) :: poly_msk_ddv -! poly_msk_ddv=unpack(poly_ddv(pack(x,mask),coeffs),mask,0.0_dp) -! END FUNCTION poly_msk_ddv -!BL -!BL - RECURSIVE FUNCTION poly_term_rr(a,b) RESULT(u) - REAL(SP), DIMENSION(:), INTENT(IN) :: a - REAL(SP), INTENT(IN) :: b - REAL(SP), DIMENSION(size(a)) :: u - INTEGER(I4B) :: n,j - n=size(a) - if (n <= 0) RETURN - u(1)=a(1) - if (n < NPAR_POLYTERM) then - do j=2,n - u(j)=a(j)+b*u(j-1) - end do - else - u(2:n:2)=poly_term_rr(a(2:n:2)+a(1:n-1:2)*b,b*b) - u(3:n:2)=a(3:n:2)+b*u(2:n-1:2) - end if - END FUNCTION poly_term_rr -!BL - RECURSIVE FUNCTION poly_term_cc(a,b) RESULT(u) - COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: a - COMPLEX(SPC), INTENT(IN) :: b - COMPLEX(SPC), DIMENSION(size(a)) :: u - INTEGER(I4B) :: n,j - n=size(a) - if (n <= 0) RETURN - u(1)=a(1) - if (n < NPAR_POLYTERM) then - do j=2,n - u(j)=a(j)+b*u(j-1) - end do - else - u(2:n:2)=poly_term_cc(a(2:n:2)+a(1:n-1:2)*b,b*b) - u(3:n:2)=a(3:n:2)+b*u(2:n-1:2) - end if - END FUNCTION poly_term_cc -!BL -!BL - FUNCTION zroots_unity(n,nn) - INTEGER(I4B), INTENT(IN) :: n,nn - COMPLEX(SPC), DIMENSION(nn) :: zroots_unity - INTEGER(I4B) :: k - REAL(SP) :: theta - zroots_unity(1)=1.0 - theta=TWOPI/n - k=1 - do - if (k >= nn) exit - zroots_unity(k+1)=cmplx(cos(k*theta),sin(k*theta),SPC) - zroots_unity(k+2:min(2*k,nn))=zroots_unity(k+1)*& - zroots_unity(2:min(k,nn-k)) - k=2*k - end do - END FUNCTION zroots_unity -!BL - FUNCTION outerprod_r(a,b) - REAL(SP), DIMENSION(:), INTENT(IN) :: a,b - REAL(SP), DIMENSION(size(a),size(b)) :: outerprod_r - outerprod_r = spread(a,dim=2,ncopies=size(b)) * & - spread(b,dim=1,ncopies=size(a)) - END FUNCTION outerprod_r -!BL -! FUNCTION outerprod_d(a,b) -! REAL(DP), DIMENSION(:), INTENT(IN) :: a,b -! REAL(DP), DIMENSION(size(a),size(b)) :: outerprod_d -! outerprod_d = spread(a,dim=2,ncopies=size(b)) * & -! spread(b,dim=1,ncopies=size(a)) -! END FUNCTION outerprod_d -!BL - FUNCTION outerdiv(a,b) - REAL(SP), DIMENSION(:), INTENT(IN) :: a,b - REAL(SP), DIMENSION(size(a),size(b)) :: outerdiv - outerdiv = spread(a,dim=2,ncopies=size(b)) / & - spread(b,dim=1,ncopies=size(a)) - END FUNCTION outerdiv -!BL - FUNCTION outersum(a,b) - REAL(SP), DIMENSION(:), INTENT(IN) :: a,b - REAL(SP), DIMENSION(size(a),size(b)) :: outersum - outersum = spread(a,dim=2,ncopies=size(b)) + & - spread(b,dim=1,ncopies=size(a)) - END FUNCTION outersum -!BL - FUNCTION outerdiff_r(a,b) - REAL(SP), DIMENSION(:), INTENT(IN) :: a,b - REAL(SP), DIMENSION(size(a),size(b)) :: outerdiff_r - outerdiff_r = spread(a,dim=2,ncopies=size(b)) - & - spread(b,dim=1,ncopies=size(a)) - END FUNCTION outerdiff_r -!BL -! FUNCTION outerdiff_d(a,b) -! REAL(DP), DIMENSION(:), INTENT(IN) :: a,b -! REAL(DP), DIMENSION(size(a),size(b)) :: outerdiff_d -! outerdiff_d = spread(a,dim=2,ncopies=size(b)) - & -! spread(b,dim=1,ncopies=size(a)) -! END FUNCTION outerdiff_d -!BL - FUNCTION outerdiff_i(a,b) - INTEGER(I4B), DIMENSION(:), INTENT(IN) :: a,b - INTEGER(I4B), DIMENSION(size(a),size(b)) :: outerdiff_i - outerdiff_i = spread(a,dim=2,ncopies=size(b)) - & - spread(b,dim=1,ncopies=size(a)) - END FUNCTION outerdiff_i -!BL - FUNCTION outerand(a,b) - LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: a,b - LOGICAL(LGT), DIMENSION(size(a),size(b)) :: outerand - outerand = spread(a,dim=2,ncopies=size(b)) .and. & - spread(b,dim=1,ncopies=size(a)) - END FUNCTION outerand -!BL - SUBROUTINE scatter_add_r(dest,source,dest_index) - REAL(SP), DIMENSION(:), INTENT(OUT) :: dest - REAL(SP), DIMENSION(:), INTENT(IN) :: source - INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index - INTEGER(I4B) :: m,n,j,i - n=assert_eq2(size(source),size(dest_index),'scatter_add_r') - m=size(dest) - do j=1,n - i=dest_index(j) - if (i > 0 .and. i <= m) dest(i)=dest(i)+source(j) - end do - END SUBROUTINE scatter_add_r -! SUBROUTINE scatter_add_d(dest,source,dest_index) -! REAL(DP), DIMENSION(:), INTENT(OUT) :: dest -! REAL(DP), DIMENSION(:), INTENT(IN) :: source -! INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index -! INTEGER(I4B) :: m,n,j,i -! n=assert_eq2(size(source),size(dest_index),'scatter_add_d') -! m=size(dest) -! do j=1,n -! i=dest_index(j) -! if (i > 0 .and. i <= m) dest(i)=dest(i)+source(j) -! end do -! END SUBROUTINE scatter_add_d - SUBROUTINE scatter_max_r(dest,source,dest_index) - REAL(SP), DIMENSION(:), INTENT(OUT) :: dest - REAL(SP), DIMENSION(:), INTENT(IN) :: source - INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index - INTEGER(I4B) :: m,n,j,i - n=assert_eq2(size(source),size(dest_index),'scatter_max_r') - m=size(dest) - do j=1,n - i=dest_index(j) - if (i > 0 .and. i <= m) dest(i)=max(dest(i),source(j)) - end do - END SUBROUTINE scatter_max_r -!BL -! SUBROUTINE scatter_max_d(dest,source,dest_index) -! REAL(DP), DIMENSION(:), INTENT(OUT) :: dest -! REAL(DP), DIMENSION(:), INTENT(IN) :: source -! INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index -! INTEGER(I4B) :: m,n,j,i -! n=assert_eq2(size(source),size(dest_index),'scatter_max_d') -! m=size(dest) -! do j=1,n -! i=dest_index(j) -! if (i > 0 .and. i <= m) dest(i)=max(dest(i),source(j)) -! end do -! END SUBROUTINE scatter_max_d -!BL - SUBROUTINE diagadd_rv(mat,diag) - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat - REAL(SP), DIMENSION(:), INTENT(IN) :: diag - INTEGER(I4B) :: j,n - n = assert_eq2(size(diag),min(size(mat,1),size(mat,2)),'diagadd_rv') - do j=1,n - mat(j,j)=mat(j,j)+diag(j) - end do - END SUBROUTINE diagadd_rv -!BL - SUBROUTINE diagadd_r(mat,diag) - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat - REAL(SP), INTENT(IN) :: diag - INTEGER(I4B) :: j,n - n = min(size(mat,1),size(mat,2)) - do j=1,n - mat(j,j)=mat(j,j)+diag - end do - END SUBROUTINE diagadd_r -!BL - SUBROUTINE diagmult_rv(mat,diag) - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat - REAL(SP), DIMENSION(:), INTENT(IN) :: diag - INTEGER(I4B) :: j,n - n = assert_eq2(size(diag),min(size(mat,1),size(mat,2)),'diagmult_rv') - do j=1,n - mat(j,j)=mat(j,j)*diag(j) - end do - END SUBROUTINE diagmult_rv -!BL - SUBROUTINE diagmult_r(mat,diag) - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat - REAL(SP), INTENT(IN) :: diag - INTEGER(I4B) :: j,n - n = min(size(mat,1),size(mat,2)) - do j=1,n - mat(j,j)=mat(j,j)*diag - end do - END SUBROUTINE diagmult_r -!BL - FUNCTION get_diag_rv(mat) - REAL(SP), DIMENSION(:,:), INTENT(IN) :: mat - REAL(SP), DIMENSION(size(mat,1)) :: get_diag_rv - INTEGER(I4B) :: j - j=assert_eq2(size(mat,1),size(mat,2),'get_diag_rv') - do j=1,size(mat,1) - get_diag_rv(j)=mat(j,j) - end do - END FUNCTION get_diag_rv -!BL -! FUNCTION get_diag_dv(mat) -! REAL(DP), DIMENSION(:,:), INTENT(IN) :: mat -! REAL(DP), DIMENSION(size(mat,1)) :: get_diag_dv -! INTEGER(I4B) :: j -! j=assert_eq2(size(mat,1),size(mat,2),'get_diag_dv') -! do j=1,size(mat,1) -! get_diag_dv(j)=mat(j,j) -! end do -! END FUNCTION get_diag_dv -!BL - SUBROUTINE put_diag_rv(diagv,mat) - REAL(SP), DIMENSION(:), INTENT(IN) :: diagv - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat - INTEGER(I4B) :: j,n - n=assert_eq2(size(diagv),min(size(mat,1),size(mat,2)),'put_diag_rv') - do j=1,n - mat(j,j)=diagv(j) - end do - END SUBROUTINE put_diag_rv -!BL - SUBROUTINE put_diag_r(scal,mat) - REAL(SP), INTENT(IN) :: scal - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat - INTEGER(I4B) :: j,n - n = min(size(mat,1),size(mat,2)) - do j=1,n - mat(j,j)=scal - end do - END SUBROUTINE put_diag_r -!BL - SUBROUTINE unit_matrix(mat) - REAL(SP), DIMENSION(:,:), INTENT(OUT) :: mat - INTEGER(I4B) :: i,n - n=min(size(mat,1),size(mat,2)) - mat(:,:)=0.0_sp - do i=1,n - mat(i,i)=1.0_sp - end do - END SUBROUTINE unit_matrix -!BL - FUNCTION upper_triangle(j,k,extra) - INTEGER(I4B), INTENT(IN) :: j,k - INTEGER(I4B), OPTIONAL, INTENT(IN) :: extra - LOGICAL(LGT), DIMENSION(j,k) :: upper_triangle - INTEGER(I4B) :: n - n=0 - if (present(extra)) n=extra - upper_triangle=(outerdiff(arth_i(1,1,j),arth_i(1,1,k)) < n) - END FUNCTION upper_triangle -!BL - FUNCTION lower_triangle(j,k,extra) - INTEGER(I4B), INTENT(IN) :: j,k - INTEGER(I4B), OPTIONAL, INTENT(IN) :: extra - LOGICAL(LGT), DIMENSION(j,k) :: lower_triangle - INTEGER(I4B) :: n - n=0 - if (present(extra)) n=extra - lower_triangle=(outerdiff(arth_i(1,1,j),arth_i(1,1,k)) > -n) - END FUNCTION lower_triangle -!BL - FUNCTION vabs(v) - REAL(SP), DIMENSION(:), INTENT(IN) :: v - REAL(SP) :: vabs - real(SP)::vvAbs(size(v)) - integer(I4B)::iMax - real(sp)::hugeRe,sqrtHuge - vvAbs=abs(v); hugeRe=huge(1._sp); sqrtHuge=sqrt(hugeRe) - iMax=maxval(maxloc(vvAbs)) - if(vvAbs(iMax)>sqrtHuge)then -!D's safeguaard to avoid overflow in some cases - vabs=vvAbs(iMax) - else - vabs=sqrt(dot_product(v,v)) - endif - END FUNCTION vabs -!BL -END MODULE nrutil diff --git a/build/FUSE_SRC/FUSE_NR/.svn/text-base/pythag.f90.svn-base b/build/FUSE_SRC/FUSE_NR/.svn/text-base/pythag.f90.svn-base deleted file mode 100644 index b4cd8d5..0000000 --- a/build/FUSE_SRC/FUSE_NR/.svn/text-base/pythag.f90.svn-base +++ /dev/null @@ -1,18 +0,0 @@ - FUNCTION pythag_sp(a,b) - USE nrtype - IMPLICIT NONE - REAL(SP), INTENT(IN) :: a,b - REAL(SP) :: pythag_sp - REAL(SP) :: absa,absb - absa=abs(a) - absb=abs(b) - if (absa > absb) then - pythag_sp=absa*sqrt(1.0_sp+(absb/absa)**2) - else - if (absb == 0.0) then - pythag_sp=0.0 - else - pythag_sp=absb*sqrt(1.0_sp+(absa/absb)**2) - end if - end if - END FUNCTION pythag_sp diff --git a/build/FUSE_SRC/FUSE_NR/.svn/text-base/svbksb.f90.svn-base b/build/FUSE_SRC/FUSE_NR/.svn/text-base/svbksb.f90.svn-base deleted file mode 100644 index 4363597..0000000 --- a/build/FUSE_SRC/FUSE_NR/.svn/text-base/svbksb.f90.svn-base +++ /dev/null @@ -1,17 +0,0 @@ - SUBROUTINE svbksb_sp(u,w,v,b,x) - USE nrtype; USE nrutil, ONLY : assert_eq - REAL(SP), DIMENSION(:,:), INTENT(IN) :: u,v - REAL(SP), DIMENSION(:), INTENT(IN) :: w,b - REAL(SP), DIMENSION(:), INTENT(OUT) :: x - INTEGER(I4B) :: mdum,ndum - REAL(SP), DIMENSION(size(x)) :: tmp - mdum=assert_eq(size(u,1),size(b),'svbksb_sp: mdum') - ndum=assert_eq((/size(u,2),size(v,1),size(v,2),size(w),size(x)/),& - 'svbksb_sp: ndum') - where (w /= 0.0) - tmp=matmul(b,u)/w - elsewhere - tmp=0.0 - end where - x=matmul(v,tmp) - END SUBROUTINE svbksb_sp diff --git a/build/FUSE_SRC/FUSE_NR/.svn/text-base/svdcmp.f90.svn-base b/build/FUSE_SRC/FUSE_NR/.svn/text-base/svdcmp.f90.svn-base deleted file mode 100644 index da648f3..0000000 --- a/build/FUSE_SRC/FUSE_NR/.svn/text-base/svdcmp.f90.svn-base +++ /dev/null @@ -1,163 +0,0 @@ - SUBROUTINE svdcmp_sp(a,w,v) - USE nrtype; USE nrutil, ONLY : assert_eq,nrerror,outerprod - USE nr, ONLY : pythag - IMPLICIT NONE - REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a - REAL(SP), DIMENSION(:), INTENT(OUT) :: w - REAL(SP), DIMENSION(:,:), INTENT(OUT) :: v - INTEGER(I4B) :: i,its,j,k,l,m,n,nm - REAL(SP) :: anorm,c,f,g,h,s,scale,x,y,z - REAL(SP), DIMENSION(size(a,1)) :: tempm - REAL(SP), DIMENSION(size(a,2)) :: rv1,tempn - INTEGER(I4B), PARAMETER :: MAXITER=100 - m=size(a,1) - n=assert_eq(size(a,2),size(v,1),size(v,2),size(w),'svdcmp_sp') - g=0.0 - scale=0.0 - do i=1,n - l=i+1 - rv1(i)=scale*g - g=0.0 - scale=0.0 - if (i <= m) then - scale=sum(abs(a(i:m,i))) - if (scale /= 0.0) then - a(i:m,i)=a(i:m,i)/scale - s=dot_product(a(i:m,i),a(i:m,i)) - f=a(i,i) - g=-sign(sqrt(s),f) - h=f*g-s - a(i,i)=f-g - tempn(l:n)=matmul(a(i:m,i),a(i:m,l:n))/h - a(i:m,l:n)=a(i:m,l:n)+outerprod(a(i:m,i),tempn(l:n)) - a(i:m,i)=scale*a(i:m,i) - end if - end if - w(i)=scale*g - g=0.0 - scale=0.0 - if ((i <= m) .and. (i /= n)) then - scale=sum(abs(a(i,l:n))) - if (scale /= 0.0) then - a(i,l:n)=a(i,l:n)/scale - s=dot_product(a(i,l:n),a(i,l:n)) - f=a(i,l) - g=-sign(sqrt(s),f) - h=f*g-s - a(i,l)=f-g - rv1(l:n)=a(i,l:n)/h - tempm(l:m)=matmul(a(l:m,l:n),a(i,l:n)) - a(l:m,l:n)=a(l:m,l:n)+outerprod(tempm(l:m),rv1(l:n)) - a(i,l:n)=scale*a(i,l:n) - end if - end if - end do - anorm=maxval(abs(w)+abs(rv1)) - do i=n,1,-1 - if (i < n) then - if (g /= 0.0) then - v(l:n,i)=(a(i,l:n)/a(i,l))/g - tempn(l:n)=matmul(a(i,l:n),v(l:n,l:n)) - v(l:n,l:n)=v(l:n,l:n)+outerprod(v(l:n,i),tempn(l:n)) - end if - v(i,l:n)=0.0 - v(l:n,i)=0.0 - end if - v(i,i)=1.0 - g=rv1(i) - l=i - end do - do i=min(m,n),1,-1 - l=i+1 - g=w(i) - a(i,l:n)=0.0 - if (g /= 0.0) then - g=1.0_sp/g - tempn(l:n)=(matmul(a(l:m,i),a(l:m,l:n))/a(i,i))*g - a(i:m,l:n)=a(i:m,l:n)+outerprod(a(i:m,i),tempn(l:n)) - a(i:m,i)=a(i:m,i)*g - else - a(i:m,i)=0.0 - end if - a(i,i)=a(i,i)+1.0_sp - end do - do k=n,1,-1 - do its=1,MAXITER - do l=k,1,-1 - nm=l-1 - if ((abs(rv1(l))+anorm) == anorm) exit - if ((abs(w(nm))+anorm) == anorm) then - c=0.0 - s=1.0 - do i=l,k - f=s*rv1(i) - rv1(i)=c*rv1(i) - if ((abs(f)+anorm) == anorm) exit - g=w(i) - h=pythag(f,g) - w(i)=h - h=1.0_sp/h - c= (g*h) - s=-(f*h) - tempm(1:m)=a(1:m,nm) - a(1:m,nm)=a(1:m,nm)*c+a(1:m,i)*s - a(1:m,i)=-tempm(1:m)*s+a(1:m,i)*c - end do - exit - end if - end do - z=w(k) - if (l == k) then - if (z < 0.0) then - w(k)=-z - v(1:n,k)=-v(1:n,k) - end if - exit - end if - if (its == MAXITER) call nrerror('svdcmp_sp: no convergence in svdcmp') - x=w(l) - nm=k-1 - y=w(nm) - g=rv1(nm) - h=rv1(k) - f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0_sp*h*y) - g=pythag(f,1.0_sp) - f=((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x - c=1.0 - s=1.0 - do j=l,nm - i=j+1 - g=rv1(i) - y=w(i) - h=s*g - g=c*g - z=pythag(f,h) - rv1(j)=z - c=f/z - s=h/z - f= (x*c)+(g*s) - g=-(x*s)+(g*c) - h=y*s - y=y*c - tempn(1:n)=v(1:n,j) - v(1:n,j)=v(1:n,j)*c+v(1:n,i)*s - v(1:n,i)=-tempn(1:n)*s+v(1:n,i)*c - z=pythag(f,h) - w(j)=z - if (z /= 0.0) then - z=1.0_sp/z - c=f*z - s=h*z - end if - f= (c*g)+(s*y) - x=-(s*g)+(c*y) - tempm(1:m)=a(1:m,j) - a(1:m,j)=a(1:m,j)*c+a(1:m,i)*s - a(1:m,i)=-tempm(1:m)*s+a(1:m,i)*c - end do - rv1(l)=0.0 - rv1(k)=f - w(k)=x - end do - end do - END SUBROUTINE svdcmp_sp diff --git a/build/FUSE_SRC/FUSE_NUMERIX/.svn/all-wcprops b/build/FUSE_SRC/FUSE_NUMERIX/.svn/all-wcprops deleted file mode 100644 index 5dad31c..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/.svn/all-wcprops +++ /dev/null @@ -1,23 +0,0 @@ -K 25 -svn:wc:ra_dav:version-url -V 63 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NUMERIX -END -nmodel_run.f90 -K 25 -svn:wc:ra_dav:version-url -V 78 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NUMERIX/nmodel_run.f90 -END -numerix_driver.f90 -K 25 -svn:wc:ra_dav:version-url -V 82 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NUMERIX/numerix_driver.f90 -END -sobol.f90 -K 25 -svn:wc:ra_dav:version-url -V 73 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_NUMERIX/sobol.f90 -END diff --git a/build/FUSE_SRC/FUSE_NUMERIX/.svn/entries b/build/FUSE_SRC/FUSE_NUMERIX/.svn/entries deleted file mode 100644 index ccd9e53..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/.svn/entries +++ /dev/null @@ -1,130 +0,0 @@ -10 - -dir -63 -https://venture1.projectlocker.com/UoNEnvEngGroup/FUSE/svn/trunk/FUSE_SRC/FUSE_NUMERIX -https://venture1.projectlocker.com/UoNEnvEngGroup/FUSE/svn - - - -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - -7fd0be38-6417-4f01-9cbe-fd474d0c6e94 - -nmodel_run.f90 -file - - - - -2013-06-12T18:10:49.467578Z -bacf90056ae4b74ebf6058dae6ff6bf0 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -3683 - -numerix_driver.f90 -file - - - - -2013-06-12T18:10:49.467578Z -06ddeac118d10d31100b6c7a4afaa688 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -21461 - -sobol.f90 -file - - - - -2013-06-12T18:10:49.467578Z -0be2419af7c817a5ec0c7e618616af44 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -159630 - diff --git a/build/FUSE_SRC/FUSE_NUMERIX/.svn/text-base/nmodel_run.f90.svn-base b/build/FUSE_SRC/FUSE_NUMERIX/.svn/text-base/nmodel_run.f90.svn-base deleted file mode 100644 index 403a67a..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/.svn/text-base/nmodel_run.f90.svn-base +++ /dev/null @@ -1,67 +0,0 @@ -SUBROUTINE NMODEL_RUN(OUTPUT_FLAG,SSTATS_FLAG) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Run a single model with one parameter set -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -! data modules -USE multiforce ! model forcing data -USE multiparam ! model parameters -USE multistate ! model states -USE multiroute ! routed runoff -USE multistats ! summary statistics -! informational modules -USE par_insert_module ! insert parameters into data structures -IMPLICIT NONE -! input -LOGICAL(LGT), INTENT(IN) :: OUTPUT_FLAG ! .TRUE. if desire time series output -LOGICAL(LGT), INTENT(IN) :: SSTATS_FLAG ! .TRUE. if desire time series output -! internal -INTEGER(I4B) :: ITIM ! loop through time series -INTEGER(I4B) :: ONEMOD=1 ! index for model (1 = just one model) -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 -INTEGER(I4B) :: IERR ! error code -INTEGER(I4B), PARAMETER :: CLEN=1024 ! length of character string -CHARACTER(LEN=CLEN) :: MESSAGE ! error message -! --------------------------------------------------------------------------------------- -! allocate state vectors -ALLOCATE(STATE0(NSTATE),STATE1(NSTATE),STAT=IERR) -IF (IERR.NE.0) STOP ' problem allocating space for state vectors in fuse_rmse ' -! increment parameter counter -PCOUNT = PCOUNT + 1 -! write parameters to the NetCDF file -CALL PUT_PARAMS(PCOUNT,1) ! PCOUNT = index for parameter set, 1 = just one model for numerix test -! initialize summary statistics -IF (SSTATS_FLAG) CALL INIT_STATS() -! initialize model states and model time step -CALL INIT_STATE(fracState0) ! fracState0 is shared in MODULE multistate -HSTATE%STEP = DELTIM ! deltim is shared in module multiforce. -! loop through time -DO ITIM=1,NUMTIM ! (NUMTIM is shared in MODULE multiforce) - ! run model for one time step - MFORCE = AFORCE(ITIM) ! assign model forcing data - CALL INITFLUXES() ! set weighted sum of fluxes to zero - CALL SUBSTEPPER() ! run model for one time step using implicit solution with variable sub-steps - CALL Q_OVERLAND() ! overland flow routing - ! save instantaneous and routed runoff - AROUTE(ITIM)%Q_INSTNT = MROUTE%Q_INSTNT ! save instantaneous runoff - AROUTE(ITIM)%Q_ROUTED = MROUTE%Q_ROUTED ! save routed runoff - ! compute summary statistics - IF (SSTATS_FLAG) CALL COMP_STATS() - ! write output - IF (OUTPUT_FLAG) THEN - CALL PUT_OUTPUT(PCOUNT,1,ITIM) - !WRITE(*,'(I10,1X,I4,1X,4(I2,1X),F9.3,1X,F20.1,1X,4(F11.3,1X))') ITIM, AFORCE(ITIM), AROUTE(ITIM)%Q_ROUTED - ENDIF - !if (itim.ge.355) pause -END DO ! (itim) -! --------------------------------------------------------------------------------------- -END SUBROUTINE NMODEL_RUN diff --git a/build/FUSE_SRC/FUSE_NUMERIX/.svn/text-base/numerix_driver.f90.svn-base b/build/FUSE_SRC/FUSE_NUMERIX/.svn/text-base/numerix_driver.f90.svn-base deleted file mode 100644 index 803dfe0..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/.svn/text-base/numerix_driver.f90.svn-base +++ /dev/null @@ -1,401 +0,0 @@ -PROGRAM NMX_DRIVER -! --------------------------------------------------------------------------------------- -! Creator: -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! Driver program for model numerix tests -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE ddirectory ! directory for data files -! data modules -USE model_defn,nstateFUSE=>nstate ! model definition structures -USE multiforce, ONLY: DELTIM ! data interval = maximum model time step -USE multiparam, ONLY: LPARAM, PARATT, NUMPAR ! parameter metadata structures -USE multiroute ! model routing structures -USE multistats ! model statistics structures -! informational modules -USE selectmodl_module ! reads model control file -USE getpar_str_module ! extracts parameter metadata -USE par_insert_module ! inserts model parameters -! model numerix -USE model_numerix -IMPLICIT NONE -! get forcing data -CHARACTER(LEN=8) :: CBASID ! basin id -INTEGER(I4B) :: NTIM ! number of time steps -INTEGER(I4B) :: INFERN_START ! start of inference period -! get model setup -INTEGER(I4B) :: I,J,K ! looping -INTEGER(I4B) :: NMOD ! number of models -INTEGER(I4B) :: ERR ! error code -CHARACTER(LEN=256) :: MESSAGE ! error message -! define output files -INTEGER(I4B) :: ONEMOD ! index for defining output file (one file per model) -LOGICAL(LGT) :: OUTPUT_FLAG ! .TRUE. if desire time series output -LOGICAL(LGT) :: SSTATS_FLAG ! .TRUE. if desire summary statistics -! get command-line arguments -CHARACTER(LEN=11) :: NUM_EXPERIMENT ! name of numerical experiment -CHARACTER(LEN=11) :: PARNAM ! parameter name -CHARACTER(LEN=11) :: CRANGE ! range for parameter cut -CHARACTER(LEN=11) :: PAR_IDX ! index of parameter set -! loop through different model parameters -INTEGER(I4B) :: IPAR ! looping variable -INTEGER(I4B) :: JPAR ! looping variable -INTEGER(I4B) :: IPARSET ! looping variable -INTEGER(I4B) :: NCUT ! number of parameter values in the "cut" -TYPE(PARATT) :: PARAM_META ! parameter metadata (model parameters) -REAL(SP) :: XDEF ! default parameter value -REAL(SP) :: XLOW ! lower parameter bound -REAL(SP) :: XUPP ! upper parameter bound -REAL(SP), DIMENSION(:), ALLOCATABLE :: BL ! vector of lower parameter bounds -REAL(SP), DIMENSION(:), ALLOCATABLE :: BU ! vector of upper parameter bounds -REAL(SP), DIMENSION(:), ALLOCATABLE :: APAR ! model parameter set -INTEGER(KIND=4) :: ISEED ! seed for the random sequence -REAL(KIND=4),DIMENSION(:), ALLOCATABLE :: URAND ! vector of quasi-random numbers U[0,1] -REAL(SP) :: XFRC ! fractional range for the parameter cut -REAL(SP) :: XRNG ! range for the parameter cut -REAL(SP) :: XINC ! parameter increment -REAL(SP) :: XPAR ! parameter value -! loop through different parameter sets -INTEGER(I4B) :: ITRY ! (looping) -INTEGER(I4B) :: JTRY ! (looping) -INTEGER(I4B) :: KTRY ! (looping) -INTEGER(I4B) :: MTRY ! (looping) -INTEGER(I4B) :: NTRY ! (looping) -! --------------------------------------------------------------------------------------- -! (0) RETRIEVE COMMAND-LINE ARGUMENTS -! --------------------------------------------------------------------------------------- -! get name of numerical experiment -CALL GETARG(1,NUM_EXPERIMENT) -IF (LEN_TRIM(NUM_EXPERIMENT).EQ.0) & - STOP ' need name of numerical experiment as 1st command-line argument ' -! --------------------------------------------------------------------------------------- -! get parameters to diagnose smoothing -IF (TRIM(NUM_EXPERIMENT).EQ.'DIAG_SMOOTH') THEN - ! get parameter name - CALL GETARG(2,PARNAM) - IF (LEN_TRIM(PARNAM).EQ.0) STOP ' need parameter name as 2nd command-line argument ' - ! get range for cut - CALL GETARG(3,CRANGE) - IF (LEN_TRIM(CRANGE).EQ.0) STOP ' need range for cut as 3rd command-line argument ' - READ(CRANGE,*) XFRC ! convert range to to a real number -ENDIF -! --------------------------------------------------------------------------------------- -! get index of parameter set in the sobol sequence -IF (TRIM(NUM_EXPERIMENT).EQ.'ADAPT_STEPS') THEN - CALL GETARG(2,PAR_IDX) - IF (LEN_TRIM(PAR_IDX).EQ.0) STOP ' need index for parameter set as 2nd command-line argument ' - READ(PAR_IDX,*) ISEED ! convert index to an integer -ENDIF -! --------------------------------------------------------------------------------------- -! (1) GET MODEL FORCING DATA AND STORE IN MEMORY -! --------------------------------------------------------------------------------------- -! Read data from the "BATEA-compliant" ASCII files -CALL GETFORCING(INFERN_START,NTIM) -! --------------------------------------------------------------------------------------- -! (2) GET MODEL SETUP -- MODEL DEFINITION, AND PARAMETER AND VARIABLE INFO FOR ALL MODELS -! --------------------------------------------------------------------------------------- -! Define model attributes (valid for all models) -CALL UNIQUEMODL(NMOD) ! get nmod unique models -CALL GETNUMERIX() ! defines method/parameters used for numerical solution -CALL GETPARMETA() ! read parameter metadata (parameter bounds etc.) -! Identify a single model (read control file ../DataFiles/m_decisions.txt) -CALL SELECTMODL(ERR,MESSAGE) -IF (ERR.NE.0) THEN - PRINT *, TRIM(MESSAGE); STOP -ENDIF -! Define list of states and parameters for the current model -CALL ASSIGN_STT() ! state definitions are stored in module model_defn -CALL ASSIGN_FLX() ! flux definitions are stored in module model_defn -CALL ASSIGN_PAR() ! parameter defintions are stored in module multiparam -! compute derived model parameters (bucket sizes, etc.) -CALL PAR_DERIVE() -! -------------------------------------------------------------------------------------- -! (3) DEFINE NETCDF OUTPUT FILES -! -------------------------------------------------------------------------------------- -! Define output file names (shared in MODULE model_defn) -SELECT CASE(TRIM(NUM_EXPERIMENT)) - CASE('DIAG_SMOOTH') - FNAME_NETCDF = TRIM(OUTPUT_PATH)//TRIM(SMODL%MNAME)//'__'//TRIM(PARNAM)//'__'//TRIM(CRANGE)//'.nc' - CASE('EVAL_JACOBN') - FNAME_NETCDF = TRIM(OUTPUT_PATH)//TRIM(SMODL%MNAME)//'_eval_jacobn.nc' - CASE('CONV_PARAMS') - FNAME_NETCDF = TRIM(OUTPUT_PATH)//TRIM(SMODL%MNAME)//'_conv_params.nc' - CASE('LIMIT_ITERS') - FNAME_NETCDF = TRIM(OUTPUT_PATH)//TRIM(SMODL%MNAME)//'_limit_iters.nc' - CASE('FIXED_STEPS') - FNAME_NETCDF = TRIM(OUTPUT_PATH)//TRIM(SMODL%MNAME)//'_fixed-steps.nc' - CASE('ADAPT_STEPS') - FNAME_NETCDF = TRIM(OUTPUT_PATH)//TRIM(SMODL%MNAME)//'_adapt-steps_'//TRIM(PAR_IDX)//'.nc' - CASE DEFAULT - STOP ' 1st command line argument must be DIAG_SMOOTH, EVAL_JACOBN, CONV_PARAMS, LIMIT_ITERS, FIXED_STEPS, or ADAPT_STEPS ' -END SELECT -! Define NetCDF output files (only write parameters and summary statistics) -ONEMOD=1 ! one file per model (i.e., model dimension = 1) -PCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) -CALL DEF_PARAMS(ONEMOD) ! define model parameters (initial CREATE) -SELECT CASE(TRIM(NUM_EXPERIMENT)) - CASE('DIAG_SMOOTH'); OUTPUT_FLAG = .FALSE. ! .TRUE. if desire time series output - CASE('EVAL_JACOBN'); OUTPUT_FLAG = .TRUE. ! .TRUE. if desire time series output - CASE('CONV_PARAMS'); OUTPUT_FLAG = .TRUE. ! .TRUE. if desire time series output - CASE('LIMIT_ITERS'); OUTPUT_FLAG = .TRUE. ! .TRUE. if desire time series output - CASE('FIXED_STEPS'); OUTPUT_FLAG = .TRUE. ! .TRUE. if desire time series output - CASE('ADAPT_STEPS'); OUTPUT_FLAG = .FALSE. ! .TRUE. if desire time series output -END SELECT -SSTATS_FLAG = .TRUE. ! .TRUE. if desire summary statistics -IF (OUTPUT_FLAG) CALL DEF_OUTPUT(NTIM) ! define model output (REDEF) -IF (SSTATS_FLAG) CALL DEF_SSTATS() ! define summary statistics (REDEF) -! -------------------------------------------------------------------------------------- -! (4) TRY DIFFERENT NUMERICAL METHODS/CONSTANTS -! -------------------------------------------------------------------------------------- -SELECT CASE(TRIM(NUM_EXPERIMENT)) - CASE('DIAG_SMOOTH') - ! get parameter bounds and the parameter default values - CALL GETPAR_STR(TRIM(PARNAM),PARAM_META) - XLOW = PARAM_META%PARLOW - XUPP = PARAM_META%PARUPP - XDEF = PARAM_META%PARDEF - ! re-set parameters - CALL DEFAULT_NUMERIX() ! get default numerix parameters - NCUT = 100 ! number of parameter sets in the "cut" - MAX_TSTEP = 1. ! max step length = 1 day - TEMPORAL_ERROR_CONTROL = TS_ADAPT ! adaptive time steps - ! loop through different numerical methods - DO SOLUTION_METHOD=1,1 - DO TRUNCATION_ERROR=1,1 - DO ORDER_ACCEPT=1,1 - ! evaluate different parameters for step-size control - DO ITRY=0,4 ! play with different ERR_TRUNC_ABS parameters - ERR_TRUNC_ABS = 1. * 10.**-REAL(ITRY, KIND(SP)) - DO JTRY=0,4 ! play with different ERR_TRUNC_REL parameters - ERR_TRUNC_REL = 1. * 10.**-REAL(JTRY, KIND(SP)) - ! evaluate different error parameters for connvergence of implicit solution - DO MTRY=0,9,2 ! play with different ERR_ITER_FUNC parameters - ERR_ITER_FUNC = 1. * 10.**-REAL(MTRY, KIND(SP)) - DO NTRY=0,9,2 ! play with different ERR_ITER_DX parameters - ERR_ITER_DX = 1. * 10.**-REAL(NTRY, KIND(SP)) - ! get NCUT increments - XRNG = (XUPP-XLOW)*XFRC - XINC = XRNG/REAL(NCUT,KIND(SP)) - DO IPAR=0,NCUT - ! modify parameter value - XPAR = (XDEF - XRNG/2._SP) + REAL(IPAR,KIND(SP))*XINC - IF (XPAR.LT.XLOW) XPAR=XLOW - IF (XPAR.GT.XUPP) XPAR=XUPP - CALL PAR_INSERT(XPAR,PARNAM) - CALL NMODEL_RUN(OUTPUT_FLAG,SSTATS_FLAG) - ! write summary statistics - IF (SSTATS_FLAG) THEN - CALL MEAN_STATS() ! compute summary statistics - CALL PUT_SSTATS(PCOUNT,1) ! 1 = just one model for numerix test - ENDIF - END DO ! ipar - WRITE(*,'(2(A11,1X),7(I2,1X))') PARNAM, CRANGE, & - solution_method, truncation_error, order_accept, itry, jtry, mtry, ntry - END DO ! ntry - END DO ! mtry - END DO ! jtry - END DO ! itry - END DO ! order_accept - END DO ! truncation_error - END DO ! solution_method - ! ------------------------------------------------------------------------------------- - CASE('EVAL_JACOBN') - ! assess different Jacobian re-evaluation strategies - CALL DEFAULT_NUMERIX() ! get default numerix parameters - MAX_TSTEP = 1. ! max step length = 1 day - SOLUTION_METHOD = IMPLICIT_EULER ! implicit euler solution - TEMPORAL_ERROR_CONTROL = TS_ADAPT ! adaptive time steps - ! loop through different numerical methods - DO TRUNCATION_ERROR=0,1 - DO ORDER_ACCEPT=0,1 - ! evaluate different parameters for step-size control - DO ITRY=0,4 ! play with different ERR_TRUNC_ABS parameters - ERR_TRUNC_ABS = 1. * 10.**-REAL(ITRY, KIND(SP)) - DO JTRY=0,4 ! play with different ERR_TRUNC_REL parameters - ERR_TRUNC_REL = 1. * 10.**-REAL(JTRY, KIND(SP)) - DO KTRY=0,2 - JAC_RECOMPUTE=KTRY - IF (JAC_RECOMPUTE.EQ.CONSTFULLSTEP) & - ALLOCATE(fjacCOPY(nstateFUSE,nstateFUSE),fjacDCMP(nstateFUSE,nstateFUSE),& - fjacINDX(nstateFUSE) ) - ! evaluate different error parameters for connvergence of implicit solution - DO MTRY=0,9,2 ! play with different ERR_ITER_FUNC parameters - ERR_ITER_FUNC = 1. * 10.**-REAL(MTRY, KIND(SP)) - DO NTRY=0,9,2 ! play with different ERR_ITER_DX parameters - ERR_ITER_DX = 1. * 10.**-REAL(NTRY, KIND(SP)) - write(*,'(7(I2,1X))') TRUNCATION_ERROR, ORDER_ACCEPT, ITRY, JTRY, KTRY, MTRY, NTRY - CALL NMODEL_RUN(OUTPUT_FLAG,SSTATS_FLAG) - END DO ! ntry - END DO ! mtry - IF (JAC_RECOMPUTE.EQ.CONSTFULLSTEP) DEALLOCATE(fjacCOPY,fjacDCMP,fjacINDX) - END DO ! ktry - END DO ! jtry - END DO ! itry - END DO ! order_accept - END DO ! truncation_error - ! ------------------------------------------------------------------------------------- - CASE('CONV_PARAMS') - ! evaluate impact of convergence parameters in the implicit scheme - CALL DEFAULT_NUMERIX() ! get default numerix parameters - ! modify numerix parameters - MAX_TSTEP = 1. ! max step length = 1 day - SOLUTION_METHOD = IMPLICIT_EULER ! implicit euler solution - TEMPORAL_ERROR_CONTROL = TS_ADAPT ! adaptive time steps - DO TRUNCATION_ERROR=0,1 - DO ORDER_ACCEPT=0,1 - ! evaluate different parameters for step-size control - DO ITRY=0,9,2 ! play with different ERR_TRUNC_ABS parameters - ERR_TRUNC_ABS = 1. * 10.**-REAL(ITRY, KIND(SP)) - DO JTRY=0,9,2 ! play with different ERR_TRUNC_REL parameters - ERR_TRUNC_REL = 1. * 10.**-REAL(JTRY, KIND(SP)) - ! evaluate different error parameters for connvergence of implicit solution - DO MTRY=0,9,2 ! play with different ERR_ITER_FUNC parameters - ERR_ITER_FUNC = 1. * 10.**-REAL(MTRY, KIND(SP)) - DO NTRY=0,9,2 ! play with different ERR_ITER_DX parameters - ERR_ITER_DX = 1. * 10.**-REAL(NTRY, KIND(SP)) - ! run zee model - CALL NMODEL_RUN(OUTPUT_FLAG,SSTATS_FLAG) - print *, TRUNCATION_ERROR, ORDER_ACCEPT, ITRY, JTRY, MTRY, NTRY - END DO ! ntry - END DO ! mtry - END DO ! jtry - END DO ! itry - END DO ! order_accept - END DO ! truncation_error - ! ------------------------------------------------------------------------------------- - CASE('LIMIT_ITERS') - ! limit the number of iterations in the implicit scheme - CALL DEFAULT_NUMERIX() ! get default numerix parameters - ! modify numerix parameters - MAX_TSTEP = 1. ! max step length = 1 day - TEMPORAL_ERROR_CONTROL = TS_ADAPT ! adaptive time steps - DO TRUNCATION_ERROR=0,1 - DO ORDER_ACCEPT=0,1 - ! evaluate different parameters for step-size control - DO ITRY=0,9,2 ! play with different ERR_TRUNC_ABS parameters - ERR_TRUNC_ABS = 1. * 10.**-REAL(ITRY, KIND(SP)) - DO JTRY=0,9,2 ! play with different ERR_TRUNC_REL parameters - ERR_TRUNC_REL = 1. * 10.**-REAL(JTRY, KIND(SP)) - DO KTRY=0,1 - ! modify minimum step-size multiplier - IF (KTRY.EQ.0) RMIN = 0.1_sp - IF (KTRY.EQ.1) RMIN = 0.5_sp - ! loop through different number of iterations - DO NITER_TOTAL=1,10 - ! run zee model - CALL NMODEL_RUN(OUTPUT_FLAG,SSTATS_FLAG) - END DO - END DO ! ktry - END DO ! jtry - END DO ! itry - END DO - END DO - ! ------------------------------------------------------------------------------------- - CASE('FIXED_STEPS') - ! fixed time steps, different solution methods and error control - SSTATS_FLAG=.FALSE. ! don't compute statistics - !CALL DEFAULT_NUMERIX() ! get default numerix parameters - !CALL NMODEL_RUN(OUTPUT_FLAG,SSTATS_FLAG) ! base run with default parameters - ! save solution for subsequent testing - AROUTE(:)%Q_ACCURATE = AROUTE(:)%Q_ROUTED - ! modify numerix parameters - SSTATS_FLAG = .TRUE. ! compute summary statistics - MAX_TSTEP = 1. ! max step length = 1 day - TEMPORAL_ERROR_CONTROL = TS_FIXED ! fixed time steps - ! loop through different numerical methods - DO SOLUTION_METHOD=0,1 - DO TRUNCATION_ERROR=0,1 - DO ORDER_ACCEPT=0,1 - ! run zee model - CALL NMODEL_RUN(OUTPUT_FLAG,SSTATS_FLAG) - ! write summary statistics - IF (SSTATS_FLAG) THEN - CALL MEAN_STATS() ! compute summary statistics - CALL PUT_SSTATS(PCOUNT,1) ! 1 = just one model for numerix test - ENDIF - END DO - END DO - END DO - ! ------------------------------------------------------------------------------------- - CASE('ADAPT_STEPS') ! adaptive time steps for multiple parameter sets - ! get parameter bounds and random numbers - ALLOCATE(APAR(NUMPAR),BL(NUMPAR),BU(NUMPAR),URAND(NUMPAR)) - DO IPAR=1,NUMPAR - CALL GETPAR_STR(LPARAM(IPAR)%PARNAME,PARAM_META) - BL(IPAR) = PARAM_META%PARLOW - BU(IPAR) = PARAM_META%PARUPP - END DO - ! get new parameter sets - CALL I4_SOBOL(NUMPAR,ISEED,URAND) - WRITE(*,'(I4,1X,12(E10.2,1X))') ISEED-1, URAND - APAR = BL + URAND*(BU-BL) - CALL PUT_PARSET(APAR) - ! create the exact solution - SSTATS_FLAG=.FALSE. ! don't compute statistics - CALL DEFAULT_NUMERIX() ! get default numerix parameters - CALL NMODEL_RUN(OUTPUT_FLAG,SSTATS_FLAG) ! base run with default parameters - ! save solution for subsequent testing - AROUTE(:)%Q_ACCURATE = AROUTE(:)%Q_ROUTED - ! modify numerix parameters - SSTATS_FLAG = .TRUE. ! compute summary statistics - TEMPORAL_ERROR_CONTROL = TS_ADAPT ! adaptive time steps - MAX_TSTEP = DELTIM ! max step length = data interval - ! loop through different numerical methods - DO SOLUTION_METHOD=0,1 - ! evaluate different parameters for step-size control - DO ITRY=3,9,3 ! play with different ERR_TRUNC_ABS parameters - ERR_TRUNC_ABS = 1. * 10.**-REAL(ITRY, KIND(SP)) - DO JTRY=1,9 ! play with different ERR_TRUNC_REL parameters - ERR_TRUNC_REL = 1. * 10.**-REAL(JTRY, KIND(SP)) - ! run zee model - CALL NMODEL_RUN(OUTPUT_FLAG,SSTATS_FLAG) - WRITE(*,'(I4,1X,F9.4,1X,5(I1,1X))') & - ISEED-1, DELTIM, SOLUTION_METHOD, TRUNCATION_ERROR, ITRY, JTRY - ! compute and write summary statistics - IF (SSTATS_FLAG) THEN - CALL MEAN_STATS() ! compute summary statistics - CALL PUT_SSTATS(PCOUNT,1) ! 1 = just one model for numerix test - ENDIF - END DO ! (loop through different numerix parameter combinations) - END DO ! (loop through different numerix parameter combinations) - - END DO - ! for reference, include the fixed-step implicit euler method - SOLUTION_METHOD = IMPLICIT_EULER ! implicit euler solution - TEMPORAL_ERROR_CONTROL = TS_FIXED ! fixed time steps - ORDER_ACCEPT = LOWER_ORDER ! accept lower-order solutions - CALL NMODEL_RUN(OUTPUT_FLAG,SSTATS_FLAG) - ! compute and write summary statistics - IF (SSTATS_FLAG) THEN - CALL MEAN_STATS() ! compute summary statistics - CALL PUT_SSTATS(PCOUNT,1) ! 1 = just one model for numerix test - ENDIF - ! ------------------------------------------------------------------------------------- - CASE DEFAULT - STOP ' 1st command line argument must be DIAG_SMOOTH, EVAL_JACOBN, CONV_PARAMS, LIMIT_ITERS, FIXED_STEPS, or ADAPT_STEPS ' - ! ------------------------------------------------------------------------------------- -END SELECT -STOP -END PROGRAM NMX_DRIVER -! -------------------------------------------------------------------------------------- -SUBROUTINE DEFAULT_NUMERIX() -USE model_numerix -SOLUTION_METHOD = IMPLICIT_EULER ! implicit euler solution -TEMPORAL_ERROR_CONTROL = TS_ADAPT ! adaptive time steps -INITIAL_NEWTON = EXPLICIT_FULL ! initial conditions for Newton -JAC_RECOMPUTE = FULLYVARIABLE ! fully variable Jacobian -CHECK_OVERSHOOT = LINE_SEARCH ! use line search to trap/fix overshoot problems -ERR_TRUNC_ABS = 1.e-9 ! absolute temporal truncation error tolerance -ERR_TRUNC_REL = 1.e-9 ! relative temporal truncation error tolerance -ERR_ITER_FUNC = 1.e-9 ! iteration convergence tolerance for function values -ERR_ITER_DX = 1.e-9 ! iteration convergence tolerance for dx -FRACSTATE_MIN = 1.e-9 ! fractional minimum value of state (for non-zero derivatives) -SAFETY = 0.9_sp ! safety factor in step-size equation -RMIN = 0.1_sp ! minimum step size multiplier -RMAX = 4.0_sp ! maximum step size multiplier -NITER_TOTAL = 100 ! total number of iterations used in the implicit scheme -MIN_TSTEP = 0.01_sp/60._sp/24._sp ! minimum time step length (minutes --> days) -MAX_TSTEP = 60.0_sp/60._sp/24._sp ! maximum time step length (minutes --> days) -END SUBROUTINE DEFAULT_NUMERIX diff --git a/build/FUSE_SRC/FUSE_NUMERIX/.svn/text-base/sobol.f90.svn-base b/build/FUSE_SRC/FUSE_NUMERIX/.svn/text-base/sobol.f90.svn-base deleted file mode 100644 index b1f8844..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/.svn/text-base/sobol.f90.svn-base +++ /dev/null @@ -1,3649 +0,0 @@ -subroutine get_unit ( iunit ) - -!*****************************************************************************80 -! -!! GET_UNIT returns a free FORTRAN unit number. -! -! Discussion: -! -! A "free" FORTRAN unit number is an integer between 1 and 99 which -! is not currently associated with an I/O device. A free FORTRAN unit -! number is needed in order to open a file with the OPEN command. -! -! If IUNIT = 0, then no free FORTRAN unit could be found, although -! all 99 units were checked (except for units 5, 6 and 9, which -! are commonly reserved for console I/O). -! -! Otherwise, IUNIT is an integer between 1 and 99, representing a -! free FORTRAN unit. Note that GET_UNIT assumes that units 5 and 6 -! are special, and will never return those values. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 18 September 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, integer IUNIT, the free unit number. -! - implicit none - - integer i - integer ios - integer iunit - logical lopen - - iunit = 0 - - do i = 1, 99 - - if ( i /= 5 .and. i /= 6 .and. i /= 9 ) then - - inquire ( unit = i, opened = lopen, iostat = ios ) - - if ( ios == 0 ) then - if ( .not. lopen ) then - iunit = i - return - end if - end if - - end if - - end do - - return -end -function i4_bit_hi1 ( n ) - -!*****************************************************************************80 -! -!! I4_BIT_HI1 returns the position of the high 1 bit base 2 in an integer. -! -! Discussion: -! -! This routine uses the default integer precision, which is -! presumed to correspond to a KIND of 4. -! -! Example: -! -! N Binary Hi 1 -! ---- -------- ---- -! 0 0 0 -! 1 1 1 -! 2 10 2 -! 3 11 2 -! 4 100 3 -! 5 101 3 -! 6 110 3 -! 7 111 3 -! 8 1000 4 -! 9 1001 4 -! 10 1010 4 -! 11 1011 4 -! 12 1100 4 -! 13 1101 4 -! 14 1110 4 -! 15 1111 4 -! 16 10000 5 -! 17 10001 5 -! 1023 1111111111 10 -! 1024 10000000000 11 -! 1025 10000000001 11 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 May 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the integer to be measured. -! N should be nonnegative. If N is nonpositive, I4_BIT_HI1 -! will always be 0. -! -! Output, integer ( kind = 4 ) I4_BIT_HI1, the number of bits base 2. -! - implicit none - - integer ( kind = 4 ) bit - integer ( kind = 4 ) i4_bit_hi1 - integer ( kind = 4 ) i - integer ( kind = 4 ) n - - i = n - bit = 0 - - do - - if ( i <= 0 ) then - exit - end if - - bit = bit + 1 - i = i / 2 - - end do - - i4_bit_hi1 = bit - - return -end -function i4_bit_lo0 ( n ) - -!*****************************************************************************80 -! -!! I4_BIT_LO0 returns the position of the low 0 bit base 2 in an integer. -! -! Discussion: -! -! This routine uses the default integer precision, which is -! presumed to correspond to a KIND of 4. -! -! Example: -! -! N Binary Lo 0 -! ---- -------- ---- -! 0 0 1 -! 1 1 2 -! 2 10 1 -! 3 11 3 -! 4 100 1 -! 5 101 2 -! 6 110 1 -! 7 111 4 -! 8 1000 1 -! 9 1001 2 -! 10 1010 1 -! 11 1011 3 -! 12 1100 1 -! 13 1101 2 -! 14 1110 1 -! 15 1111 5 -! 16 10000 1 -! 17 10001 2 -! 1023 1111111111 1 -! 1024 10000000000 1 -! 1025 10000000001 1 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 May 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) N, the integer to be measured. -! N should be nonnegative. -! -! Output, integer ( kind = 4 ) I4_BIT_LO0, the position of the low 1 bit. -! - implicit none - - integer ( kind = 4 ) bit - integer ( kind = 4 ) i - integer ( kind = 4 ) i2 - integer ( kind = 4 ) i4_bit_lo0 - integer ( kind = 4 ) n - - bit = 0 - i = n - - do - - bit = bit + 1 - i2 = i / 2 - - if ( i == 2 * i2 ) then - exit - end if - - i = i2 - - end do - - i4_bit_lo0 = bit - - return -end -subroutine i4_sobol ( dim_num, seed, quasi ) - -!*****************************************************************************80 -! -!! I4_SOBOL generates a new quasirandom Sobol vector with each call. -! -! Discussion: -! -! The routine adapts the ideas of Antonov and Saleev. -! -! This routine uses the default integer precision, which is -! presumed to correspond to a KIND of 4. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 25 June 2008 -! -! Author: -! -! FORTRAN77 original version by Bennett Fox. -! FORTRAN90 version by John Burkardt -! -! Reference: -! -! IA Antonov, VM Saleev, -! An Economic Method of Computing LP Tau-Sequences, -! USSR Computational Mathematics and Mathematical Physics, -! Volume 19, 1980, pages 252-256. -! -! Paul Bratley, Bennett Fox, -! Algorithm 659: -! Implementing Sobol's Quasirandom Sequence Generator, -! ACM Transactions on Mathematical Software, -! Volume 14, Number 1, March 1988, pages 88-100 -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, December 1986, pages 362-376. -! -! Stephen Joe, Frances Kuo, -! Remark on Algorithm 659: -! Implementing Sobol's Quasirandom Sequence Generator, -! ACM Transactions on Mathematical Software, -! Volume 29, Number 1, March 2003, pages 49-57. -! -! Ilya Sobol, -! Uniformly Distributed Sequences with an Additional Uniform Property, -! USSR Computational Mathematics and Mathematical Physics, -! Volume 16, 1977, pages 236-242. -! -! Ilya Sobol, YL Levitan, -! The Production of Points Uniformly Distributed in a Multidimensional -! Cube (in Russian), -! Preprint IPM Akademii Nauk SSSR, -! Number 40, Moscow 1976. -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the number of spatial dimensions. -! DIM_NUM must satisfy 2 <= DIM_NUM <= 1111. -! -! Input/output, integer ( kind = 4 ) SEED, the "seed" for the sequence. -! This is essentially the index in the sequence of the quasirandom -! value to be generated. On output, SEED has been set to the -! appropriate next value, usually simply SEED+1. -! If SEED is less than 0 on input, it is treated as though it were 0. -! An input value of 0 requests the first (0-th) element of the sequence. -! -! Output, real ( kind = 4 ) QUASI(DIM_NUM), the next quasirandom vector. -! - implicit none - - integer ( kind = 4 ) dim_num - integer ( kind = 4 ), parameter :: dim_max = 1111 - integer ( kind = 4 ), parameter :: log_max = 30 - - integer ( kind = 4 ) atmost - integer ( kind = 4 ), save :: dim_num_save = 0 - integer ( kind = 4 ) i - integer ( kind = 4 ) i4_bit_hi1 - integer ( kind = 4 ) i4_bit_lo0 - integer ( kind = 4 ) inc - logical includ(log_max) - logical, save :: initialized = .false. - integer ( kind = 4 ) j - integer ( kind = 4 ) j2 - integer ( kind = 4 ) k - integer ( kind = 4 ) l - integer ( kind = 4 ), save, dimension(dim_max) :: lastq - integer ( kind = 4 ) m - integer ( kind = 4 ), save :: maxcol - integer ( kind = 4 ) newv - integer ( kind = 4 ), save, dimension(1:dim_max) :: poly - real ( kind = 4 ) quasi(dim_num) - real ( kind = 4 ), save :: recipd - integer ( kind = 4 ) seed - integer ( kind = 4 ), save :: seed_save = - 1 - integer ( kind = 4 ) seed_temp - integer ( kind = 4 ), save, dimension(1:dim_max,1:log_max) :: v - - if ( .not. initialized .or. dim_num /= dim_num_save ) then - - initialized = .true. - - v(1:dim_max,1:log_max) = 0 -! -! Initialize (part of) V. -! - v(2:1111,1) = 1 - v(3:401,2) = (/ & - 1,3,1,3,1,3,3,1,3,1,3,1,3,1,1,3,1,3,1,3, & - 1,3,3,1,1,1,3,1,3,1,3,3,1,3,1,1,1,3,1,3,1,1,1,3,3,1,3,3,1,1, & - 3,3,1,3,3,3,1,3,1,3,1,1,3,3,1,1,1,1,3,1,1,3,1,1,1,3,3,1,3,3, & - 1,3,3,3,1,3,3,3,1,3,3,1,3,3,3,1,3,1,3,1,1,3,3,1,3,3,1,1,1,3, & - 3,1,3,3,1,3,1,1,3,3,3,1,1,1,3,1,1,3,1,1,3,3,1,3,1,3,3,3,3,1, & - 1,1,3,3,1,1,3,1,1,1,1,1,1,3,1,3,1,1,1,3,1,3,1,3,3,3,1,1,3,3, & - 1,3,1,3,1,1,3,1,3,1,3,1,3,1,1,1,3,3,1,3,3,1,3,1,1,1,3,1,3,1, & - 1,3,1,1,3,3,1,1,3,3,3,1,3,3,3,1,3,1,3,1,1,1,3,1,1,1,3,1,1,1, & - 1,1,3,3,3,1,1,1,1,3,3,3,1,3,3,1,1,1,1,3,1,1,3,1,3,3,1,1,3,3, & - 1,1,1,1,3,1,3,3,1,3,3,1,1,1,3,3,3,1,3,3,1,3,3,1,3,1,3,3,3,1, & - 3,1,1,3,1,3,1,1,1,3,3,3,1,1,3,1,3,1,1,1,1,1,1,3,1,1,3,1,3,3, & - 1,1,1,1,3,1,3,1,3,1,1,1,1,3,3,1,1,1,1,1,3,3,3,1,1,3,3,3,3,3, & - 1,3,3,1,3,3,3,3,1,1,1,1,1,1,3,1,1,3,1,1,1,3,1,1,1,3,3,3,1,3, & - 1,1,3,3,3,1,3,3,1,3,1,3,3,1,3,3,3,1,1/) - v(402:800,2) = (/ & - 3,3,1,3,1,3,1,1,1,3,3,3,3,1,3,1,1,3,1, & - 3,1,1,1,3,1,3,1,3,1,3,3,3,3,3,3,3,3,1,3,3,3,3,3,1,3,1,3,3,3, & - 1,3,1,3,1,3,3,1,3,3,3,3,3,3,3,3,3,1,1,1,1,1,1,3,3,1,1,3,3,1, & - 1,1,3,3,1,1,3,3,3,3,1,1,3,1,3,3,1,3,3,1,1,1,3,3,3,1,1,3,3,3, & - 3,3,1,1,1,3,1,3,3,1,3,3,3,3,1,1,3,1,1,3,1,3,1,3,1,3,3,1,1,3, & - 3,1,3,3,1,3,3,1,1,3,1,3,3,1,1,3,1,3,1,3,1,1,3,3,1,1,1,3,3,1, & - 3,1,1,3,3,1,1,3,1,3,1,1,1,1,1,3,1,1,1,1,3,1,3,1,1,3,3,1,1,3, & - 1,3,1,3,3,3,1,3,3,3,1,1,3,3,3,1,1,1,1,3,1,3,1,3,1,1,3,3,1,1, & - 1,3,3,1,3,1,3,1,1,1,1,1,1,3,1,3,3,1,3,3,3,1,3,1,1,3,3,1,1,3, & - 3,1,1,1,3,1,3,3,1,1,3,1,1,3,1,3,1,1,1,3,3,3,3,1,1,3,3,1,1,1, & - 1,3,1,1,3,3,3,1,1,3,3,1,3,3,1,1,3,3,3,3,3,3,3,1,3,3,1,3,1,3, & - 1,1,3,3,1,1,1,3,1,3,3,1,3,3,1,3,1,1,3,3,3,1,1,1,3,1,1,1,3,3, & - 3,1,3,3,1,3,1,1,3,3,3,1,3,3,1,1,1,3,1,3,3,3,3,3,3,3,3,1,3,3, & - 1,3,1,1,3,3,3,1,3,3,3,3,3,1,3,3,3,1,1,1/) - v(801:1111,2) = (/ & - 3,3,1,3,3,1,3,1,3,1,3,1,3,3,3,3,3,3, & - 1,1,3,1,3,1,1,1,1,1,3,1,1,1,3,1,3,1,1,3,3,3,1,3,1,3,1,1,3,1, & - 3,3,1,3,1,3,3,1,3,3,1,3,3,3,3,3,3,1,3,1,1,3,3,3,1,1,3,3,3,3, & - 3,3,3,1,3,3,3,3,1,3,1,3,3,3,1,3,1,3,1,1,1,3,3,1,3,1,1,3,3,1, & - 3,1,1,1,1,3,1,3,1,1,3,1,3,1,3,3,3,3,3,3,1,3,3,3,3,1,3,3,1,3, & - 3,3,3,3,1,1,1,1,3,3,3,1,3,3,1,1,3,3,1,1,3,3,1,3,1,1,3,1,3,3, & - 3,3,3,1,3,1,1,3,3,3,3,1,3,1,1,3,3,3,3,3,3,1,1,3,1,3,1,1,3,1, & - 1,1,1,3,3,1,1,3,1,1,1,3,1,3,1,1,3,3,1,3,1,1,3,3,3,3,3,1,3,1, & - 1,1,3,1,1,1,3,1,1,3,1,3,3,3,3,3,1,1,1,3,3,3,3,1,3,3,3,3,1,1, & - 3,3,3,1,3,1,1,3,3,1,3,3,1,1,1,1,1,3,1,1,3,3,1,1,1,3,1,1,3,3, & - 1,3,3,3,3,3,3,3,3,1,1,3,3,1,1,3,1,3,3,3,3,3,1/) - v(4:402,3) = (/ & - 7,5,1,3,3,7,5,5,7,7,1,3,3,7,5,1,1,5,3,7, & - 1,7,5,1,3,7,7,1,1,1,5,7,7,5,1,3,3,7,5,5,5,3,3,3,1,1,5,1,1,5, & - 3,3,3,3,1,3,7,5,7,3,7,1,3,3,5,1,3,5,5,7,7,7,1,1,3,3,1,1,5,1, & - 5,7,5,1,7,5,3,3,1,5,7,1,7,5,1,7,3,1,7,1,7,3,3,5,7,3,3,5,1,3, & - 3,1,3,5,1,3,3,3,7,1,1,7,3,1,3,7,5,5,7,5,5,3,1,3,3,3,1,3,3,7, & - 3,3,1,7,5,1,7,7,5,7,5,1,3,1,7,3,7,3,5,7,3,1,3,3,3,1,5,7,3,3, & - 7,7,7,5,3,1,7,1,3,7,5,3,3,3,7,1,1,3,1,5,7,1,3,5,3,5,3,3,7,5, & - 5,3,3,1,3,7,7,7,1,5,7,1,3,1,1,7,1,3,1,7,1,5,3,5,3,1,1,5,5,3, & - 3,5,7,1,5,3,7,7,3,5,3,3,1,7,3,1,3,5,7,1,3,7,1,5,1,3,1,5,3,1, & - 7,1,5,5,5,3,7,1,1,7,3,1,1,7,5,7,5,7,7,3,7,1,3,7,7,3,5,1,1,7, & - 1,5,5,5,1,5,1,7,5,5,7,1,1,7,1,7,7,1,1,3,3,3,7,7,5,3,7,3,1,3, & - 7,5,3,3,5,7,1,1,5,5,7,7,1,1,1,1,5,5,5,7,5,7,1,1,3,5,1,3,3,7, & - 3,7,5,3,5,3,1,7,1,7,7,1,1,7,7,7,5,5,1,1,7,5,5,7,5,1,1,5,5,5, & - 5,5,5,1,3,1,5,7,3,3,5,7,3,7,1,7,7,1,3/) - v(403:801,3) = (/ & - 5,1,5,5,3,7,3,7,7,5,7,5,7,1,1,5,3,5,1, & - 5,3,7,1,5,7,7,3,5,1,3,5,1,5,3,3,3,7,3,5,1,3,7,7,3,7,5,3,3,1, & - 7,5,1,1,3,7,1,7,1,7,3,7,3,5,7,3,5,3,1,1,1,5,7,7,3,3,1,1,1,5, & - 5,7,3,1,1,3,3,7,3,3,5,1,3,7,3,3,7,3,5,7,5,7,7,3,3,5,1,3,5,3, & - 1,3,5,1,1,3,7,7,1,5,1,3,7,3,7,3,5,1,7,1,1,3,5,3,7,1,5,5,1,1, & - 3,1,3,3,7,1,7,3,1,7,3,1,7,3,5,3,5,7,3,3,3,5,1,7,7,1,3,1,3,7, & - 7,1,3,7,3,1,5,3,1,1,1,5,3,3,7,1,5,3,5,1,3,1,3,1,5,7,7,1,1,5, & - 3,1,5,1,1,7,7,3,5,5,1,7,1,5,1,1,3,1,5,7,5,7,7,1,5,1,1,3,5,1, & - 5,5,3,1,3,1,5,5,3,3,3,3,1,1,3,1,3,5,5,7,5,5,7,5,7,1,3,7,7,3, & - 5,5,7,5,5,3,3,3,1,7,1,5,5,5,3,3,5,1,3,1,3,3,3,7,1,7,7,3,7,1, & - 1,5,7,1,7,1,7,7,1,3,7,5,1,3,5,5,5,1,1,7,1,7,1,7,7,3,1,1,5,1, & - 5,1,5,3,5,5,5,5,5,3,3,7,3,3,5,5,3,7,1,5,7,5,1,5,5,3,5,5,7,5, & - 3,5,5,5,1,5,5,5,5,1,3,5,3,1,7,5,5,7,1,5,3,3,1,5,3,7,1,7,5,1, & - 1,3,1,1,7,1,5,5,3,7,3,7,5,3,1,1,3,1,3,5/) - v(802:1111,3) = (/ & - 5,7,5,3,7,7,7,3,7,3,7,1,3,1,7,7,1,7, & - 3,7,3,7,3,7,3,5,1,1,7,3,1,5,5,7,1,5,5,5,7,1,5,5,1,5,5,3,1,3, & - 1,7,3,1,3,5,7,7,7,1,1,7,3,1,5,5,5,1,1,1,1,1,5,3,5,1,3,5,3,1, & - 1,1,1,3,7,3,7,5,7,1,5,5,7,5,3,3,7,5,3,1,1,3,1,3,1,1,3,7,1,7, & - 1,1,5,1,7,5,3,7,3,5,3,1,1,5,5,1,7,7,3,7,3,7,1,5,1,5,3,7,3,5, & - 7,7,7,3,3,1,1,5,5,3,7,1,1,1,3,5,3,1,1,3,3,7,5,1,1,3,7,1,5,7, & - 3,7,5,5,7,3,5,3,1,5,3,1,1,7,5,1,7,3,7,5,1,7,1,7,7,1,1,7,1,5, & - 5,1,1,7,5,7,1,5,3,5,3,3,7,1,5,1,1,5,5,3,3,7,5,5,1,1,1,3,1,5, & - 7,7,1,7,5,7,3,7,3,1,3,7,3,1,5,5,3,5,1,3,5,5,5,1,1,7,7,1,5,5, & - 1,3,5,1,5,3,5,3,3,7,5,7,3,7,3,1,3,7,7,3,3,1,1,3,3,3,3,3,5,5, & - 3,3,3,1,3,5,7,7,1,5,7,3,7,1,1,3,5,7,5,3,3,3/) - v(6:357,4) = (/ & - 1,7,9,13,11,1,3,7,9,5,13,13,11,3,15,5,3, & - 15,7,9,13,9,1,11,7,5,15,1,15,11,5,11,1,7,9,7,7,1,15,15,15,13, & - 3,3,15,5,9,7,13,3,7,5,11,9,1,9,1,5,7,13,9,9,1,7,3,5,1,11,11, & - 13,7,7,9,9,1,1,3,9,15,1,5,13,1,9,9,9,9,9,13,11,3,5,11,11,13, & - 5,3,15,1,11,11,7,13,15,11,13,9,11,15,15,13,3,15,7,9,11,13,11, & - 9,9,5,13,9,1,13,7,7,7,7,7,5,9,7,13,11,9,11,15,3,13,11,1,11,3, & - 3,9,11,1,7,1,15,15,3,1,9,1,7,13,11,3,13,11,7,3,3,5,13,11,5, & - 11,1,3,9,7,15,7,5,13,7,9,13,15,13,9,7,15,7,9,5,11,11,13,13,9, & - 3,5,13,9,11,15,11,7,1,7,13,3,13,3,13,9,15,7,13,13,3,13,15,15, & - 11,9,13,9,15,1,1,15,11,11,7,1,11,13,9,13,3,5,11,13,9,9,13,1, & - 11,15,13,3,13,7,15,1,15,3,3,11,7,13,7,7,9,7,5,15,9,5,5,7,15, & - 13,15,5,15,5,3,1,11,7,1,5,7,9,3,11,1,15,1,3,15,11,13,5,13,1, & - 7,1,15,7,5,1,1,15,13,11,11,13,5,11,7,9,7,1,5,3,9,5,5,11,5,1, & - 7,1,11,7,9,13,15,13,3,1,11,13,15,1,1,11,9,13,3,13,11,15,13,9, & - 9,9,5,5,5,5,1,15,5,9/) - v(358:710,4) = (/ & - 11,7,15,5,3,13,5,3,11,5,1,11,13,9,11, & - 3,7,13,15,1,7,11,1,13,1,15,1,9,7,3,9,11,1,9,13,13,3,11,7,9,1, & - 7,15,9,1,5,13,5,11,3,9,15,11,13,5,1,7,7,5,13,7,7,9,5,11,11,1, & - 1,15,3,13,9,13,9,9,11,5,5,13,15,3,9,15,3,11,11,15,15,3,11,15, & - 15,3,1,3,1,3,3,1,3,13,1,11,5,15,7,15,9,1,7,1,9,11,15,1,13,9, & - 13,11,7,3,7,3,13,7,9,7,7,3,3,9,9,7,5,11,13,13,7,7,15,9,5,5,3, & - 3,13,3,9,3,1,11,1,3,11,15,11,11,11,9,13,7,9,15,9,11,1,3,3,9, & - 7,15,13,13,7,15,9,13,9,15,13,15,9,13,1,11,7,11,3,13,5,1,7,15, & - 3,13,7,13,13,11,3,5,3,13,11,9,9,3,11,11,7,9,13,11,7,15,13,7, & - 5,3,1,5,15,15,3,11,1,7,3,15,11,5,5,3,5,5,1,15,5,1,5,3,7,5,11, & - 3,13,9,13,15,5,3,5,9,5,3,11,1,13,9,15,3,5,11,9,1,3,15,9,9,9, & - 11,7,5,13,1,15,3,13,9,13,5,1,5,1,13,13,7,7,1,9,5,11,9,11,13, & - 3,15,15,13,15,7,5,7,9,7,9,9,9,11,9,3,11,15,13,13,5,9,15,1,1, & - 9,5,13,3,13,15,3,1,3,11,13,1,15,9,9,3,1,9,1,9,1,13,11,15,7, & - 11,15,13,15,1,9,9,7/) - v(711:1065,4) = (/ & - 3,5,11,7,3,9,5,15,7,5,3,13,7,1,1,9, & - 15,15,15,11,3,5,15,13,7,15,15,11,11,9,5,15,9,7,3,13,1,1,5,1, & - 3,1,7,1,1,5,1,11,11,9,9,5,13,7,7,7,1,1,9,9,11,11,15,7,5,5,3, & - 11,1,3,7,13,7,7,7,3,15,15,11,9,3,9,3,15,13,5,3,3,3,5,9,15,9, & - 9,1,5,9,9,15,5,15,7,9,1,9,9,5,11,5,15,15,11,7,7,7,1,1,11,11, & - 13,15,3,13,5,1,7,1,11,3,13,15,3,5,3,5,7,3,9,9,5,1,7,11,9,3,5, & - 11,13,13,13,9,15,5,7,1,15,11,9,15,15,13,13,13,1,11,9,15,9,5, & - 15,5,7,3,11,3,15,7,13,11,7,3,7,13,5,13,15,5,13,9,1,15,11,5,5, & - 1,11,3,3,7,1,9,7,15,9,9,3,11,15,7,1,3,1,1,1,9,1,5,15,15,7,5, & - 5,7,9,7,15,13,13,11,1,9,11,1,13,1,7,15,15,5,5,1,11,3,9,11,9, & - 9,9,1,9,3,5,15,1,1,9,7,3,3,1,9,9,11,9,9,13,13,3,13,11,13,5,1, & - 5,5,9,9,3,13,13,9,15,9,11,7,11,9,13,9,1,15,9,7,7,1,7,9,9,15, & - 1,11,1,13,13,15,9,13,7,15,3,9,3,1,13,7,5,9,3,1,7,1,1,13,3,3, & - 11,1,7,13,15,15,5,7,13,13,15,11,13,1,13,13,3,9,15,15,11,15,9, & - 15,1,13,15,1,1,5/) - v(1066:1111,4) = (/ & - 11,5,1,11,11,5,3,9,1,3,5,13,9,7,7,1, & - 9,9,15,7,5,5,15,13,9,7,13,3,13,11,13,7,9,13,13,13,15,9,5,5,3, & - 3,3,1,3,15/) - v(8:331,5) = (/ & - 9,3,27,15,29,21,23,19,11,25,7,13,17,1, & - 25,29,3,31,11,5,23,27,19,21,5,1,17,13,7,15,9,31,25,3,5,23,7, & - 3,17,23,3,3,21,25,25,23,11,19,3,11,31,7,9,5,17,23,17,17,25, & - 13,11,31,27,19,17,23,7,5,11,19,19,7,13,21,21,7,9,11,1,5,21, & - 11,13,25,9,7,7,27,15,25,15,21,17,19,19,21,5,11,3,5,29,31,29, & - 5,5,1,31,27,11,13,1,3,7,11,7,3,23,13,31,17,1,27,11,25,1,23, & - 29,17,25,7,25,27,17,13,17,23,5,17,5,13,11,21,5,11,5,9,31,19, & - 17,9,9,27,21,15,15,1,1,29,5,31,11,17,23,19,21,25,15,11,5,5,1, & - 19,19,19,7,13,21,17,17,25,23,19,23,15,13,5,19,25,9,7,3,21,17, & - 25,1,27,25,27,25,9,13,3,17,25,23,9,25,9,13,17,17,3,15,7,7,29, & - 3,19,29,29,19,29,13,15,25,27,1,3,9,9,13,31,29,31,5,15,29,1, & - 19,5,9,19,5,15,3,5,7,15,17,17,23,11,9,23,19,3,17,1,27,9,9,17, & - 13,25,29,23,29,11,31,25,21,29,19,27,31,3,5,3,3,13,21,9,29,3, & - 17,11,11,9,21,19,7,17,31,25,1,27,5,15,27,29,29,29,25,27,25,3, & - 21,17,25,13,15,17,13,23,9,3,11,7,9,9,7,17,7,1/) - v(332:654,5) = (/ & - 27,1,9,5,31,21,25,25,21,11,1,23,19,27, & - 15,3,5,23,9,25,7,29,11,9,13,5,11,1,3,31,27,3,17,27,11,13,15, & - 29,15,1,15,23,25,13,21,15,3,29,29,5,25,17,11,7,15,5,21,7,31, & - 13,11,23,5,7,23,27,21,29,15,7,27,27,19,7,15,27,27,19,19,9,15, & - 1,3,29,29,5,27,31,9,1,7,3,19,19,29,9,3,21,31,29,25,1,3,9,27, & - 5,27,25,21,11,29,31,27,21,29,17,9,17,13,11,25,15,21,11,19,31, & - 3,19,5,3,3,9,13,13,3,29,7,5,9,23,13,21,23,21,31,11,7,7,3,23, & - 1,23,5,9,17,21,1,17,29,7,5,17,13,25,17,9,19,9,5,7,21,19,13,9, & - 7,3,9,3,15,31,29,29,25,13,9,21,9,31,7,15,5,31,7,15,27,25,19, & - 9,9,25,25,23,1,9,7,11,15,19,15,27,17,11,11,31,13,25,25,9,7, & - 13,29,19,5,19,31,25,13,25,15,5,9,29,31,9,29,27,25,27,11,17,5, & - 17,3,23,15,9,9,17,17,31,11,19,25,13,23,15,25,21,31,19,3,11, & - 25,7,15,19,7,5,3,13,13,1,23,5,25,11,25,15,13,21,11,23,29,5, & - 17,27,9,19,15,5,29,23,19,1,27,3,23,21,19,27,11,17,13,27,11, & - 31,23,5,9,21,31,29,11,21,17,15,7,15,7,9,21,27,25/) - v(655:975,5) = (/ & - 29,11,3,21,13,23,19,27,17,29,25,17,9, & - 1,19,23,5,23,1,17,17,13,27,23,7,7,11,13,17,13,11,21,13,23,1, & - 27,13,9,7,1,27,29,5,13,25,21,3,31,15,13,3,19,13,1,27,15,17,1, & - 3,13,13,13,31,29,27,7,7,21,29,15,17,17,21,19,17,3,15,5,27,27, & - 3,31,31,7,21,3,13,11,17,27,25,1,9,7,29,27,21,23,13,25,29,15, & - 17,29,9,15,3,21,15,17,17,31,9,9,23,19,25,3,1,11,27,29,1,31, & - 29,25,29,1,23,29,25,13,3,31,25,5,5,11,3,21,9,23,7,11,23,11,1, & - 1,3,23,25,23,1,23,3,27,9,27,3,23,25,19,29,29,13,27,5,9,29,29, & - 13,17,3,23,19,7,13,3,19,23,5,29,29,13,13,5,19,5,17,9,11,11, & - 29,27,23,19,17,25,13,1,13,3,11,1,17,29,1,13,17,9,17,21,1,11, & - 1,1,25,5,7,29,29,19,19,1,29,13,3,1,31,15,13,3,1,11,19,5,29, & - 13,29,23,3,1,31,13,19,17,5,5,1,29,23,3,19,25,19,27,9,27,13, & - 15,29,23,13,25,25,17,19,17,15,27,3,25,17,27,3,27,31,23,13,31, & - 11,15,7,21,19,27,19,21,29,7,31,13,9,9,7,21,13,11,9,11,29,19, & - 11,19,21,5,29,13,7,19,19,27,23,31,1,27,21,7,3,7,11/) - v(976:1111,5) = (/ & - 23,13,29,11,31,19,1,5,5,11,5,3,27,5, & - 7,11,31,1,27,31,31,23,5,21,27,9,25,3,15,19,1,19,9,5,25,21,15, & - 25,29,15,21,11,19,15,3,7,13,11,25,17,1,5,31,13,29,23,9,5,29, & - 7,17,27,7,17,31,9,31,9,9,7,21,3,3,3,9,11,21,11,31,9,25,5,1, & - 31,13,29,9,29,1,11,19,7,27,13,31,7,31,7,25,23,21,29,11,11,13, & - 11,27,1,23,31,21,23,21,19,31,5,31,25,25,19,17,11,25,7,13,1, & - 29,17,23,15,7,29,17,13,3,17/) - v(14:324,6) = (/ & - 37,33,7,5,11,39,63,59,17,15,23,29,3,21, & - 13,31,25,9,49,33,19,29,11,19,27,15,25,63,55,17,63,49,19,41, & - 59,3,57,33,49,53,57,57,39,21,7,53,9,55,15,59,19,49,31,3,39,5, & - 5,41,9,19,9,57,25,1,15,51,11,19,61,53,29,19,11,9,21,19,43,13, & - 13,41,25,31,9,11,19,5,53,37,7,51,45,7,7,61,23,45,7,59,41,1, & - 29,61,37,27,47,15,31,35,31,17,51,13,25,45,5,5,33,39,5,47,29, & - 35,47,63,45,37,47,59,21,59,33,51,9,27,13,25,43,3,17,21,59,61, & - 27,47,57,11,17,39,1,63,21,59,17,13,31,3,31,7,9,27,37,23,31,9, & - 45,43,31,63,21,39,51,27,7,53,11,1,59,39,23,49,23,7,55,59,3, & - 19,35,13,9,13,15,23,9,7,43,55,3,19,9,27,33,27,49,23,47,19,7, & - 11,55,27,35,5,5,55,35,37,9,33,29,47,25,11,47,53,61,59,3,53, & - 47,5,19,59,5,47,23,45,53,3,49,61,47,39,29,17,57,5,17,31,23, & - 41,39,5,27,7,29,29,33,31,41,31,29,17,29,29,9,9,31,27,53,35,5, & - 61,1,49,13,57,29,5,21,43,25,57,49,37,27,11,61,37,49,5,63,63, & - 3,45,37,63,21,21,19,27,59,21,45,23,13,15,3,43,63,39,19/) - v(325:632,6) = (/ & - 63,31,41,41,15,43,63,53,1,63,31,7,17, & - 11,61,31,51,37,29,59,25,63,59,47,15,27,19,29,45,35,55,39,19, & - 43,21,19,13,17,51,37,5,33,35,49,25,45,1,63,47,9,63,15,25,25, & - 15,41,13,3,19,51,49,37,25,49,13,53,47,23,35,29,33,21,35,23,3, & - 43,31,63,9,1,61,43,3,11,55,11,35,1,63,35,49,19,45,9,57,51,1, & - 47,41,9,11,37,19,55,23,55,55,13,7,47,37,11,43,17,3,25,19,55, & - 59,37,33,43,1,5,21,5,63,49,61,21,51,15,19,43,47,17,9,53,45, & - 11,51,25,11,25,47,47,1,43,29,17,31,15,59,27,63,11,41,51,29,7, & - 27,63,31,43,3,29,39,3,59,59,1,53,63,23,63,47,51,23,61,39,47, & - 21,39,15,3,9,57,61,39,37,21,51,1,23,43,27,25,11,13,21,43,7, & - 11,33,55,1,37,35,27,61,39,5,19,61,61,57,59,21,59,61,57,25,55, & - 27,31,41,33,63,19,57,35,13,63,35,17,11,11,49,41,55,5,45,17, & - 35,5,31,31,37,17,45,51,1,39,49,55,19,41,13,5,51,5,49,1,21,13, & - 17,59,51,11,3,61,1,33,37,33,61,25,27,59,7,49,13,63,3,33,3,15, & - 9,13,35,39,11,59,59,1,57,11,5,57,13,31,13,11,55,45,9,55,55/) - v(633:942,6) = (/ & - 19,25,41,23,45,29,63,59,27,39,21,37,7, & - 61,49,35,39,9,29,7,25,23,57,5,19,15,33,49,37,25,17,45,29,15, & - 25,3,3,49,11,39,15,19,57,39,15,11,3,57,31,55,61,19,5,41,35, & - 59,61,39,41,53,53,63,31,9,59,13,35,55,41,49,5,41,25,27,43,5, & - 5,43,5,5,17,5,15,27,29,17,9,3,55,31,1,45,45,13,57,17,3,61,15, & - 49,15,47,9,37,45,9,51,61,21,33,11,21,63,63,47,57,61,49,9,59, & - 19,29,21,23,55,23,43,41,57,9,39,27,41,35,61,29,57,63,21,31, & - 59,35,49,3,49,47,49,33,21,19,21,35,11,17,37,23,59,13,37,35, & - 55,57,1,29,45,11,1,15,9,33,19,53,43,39,23,7,13,13,1,19,41,55, & - 1,13,15,59,55,15,3,57,37,31,17,1,3,21,29,25,55,9,37,33,53,41, & - 51,19,57,13,63,43,19,7,13,37,33,19,15,63,51,11,49,23,57,47, & - 51,15,53,41,1,15,37,61,11,35,29,33,23,55,11,59,19,61,61,45, & - 13,49,13,63,5,61,5,31,17,61,63,13,27,57,1,21,5,11,39,57,51, & - 53,39,25,41,39,37,23,31,25,33,17,57,29,27,23,47,41,29,19,47, & - 41,25,5,51,43,39,29,7,31,45,51,49,55,17,43,49,45,9,29,3,5,47, & - 9,15,19/) - v(943:1111,6) = (/ & - 51,45,57,63,9,21,59,3,9,13,45,23,15, & - 31,21,15,51,35,9,11,61,23,53,29,51,45,31,29,5,35,29,53,35,17, & - 59,55,27,51,59,27,47,15,29,37,7,49,55,5,19,45,29,19,57,33,53, & - 45,21,9,3,35,29,43,31,39,3,45,1,41,29,5,59,41,33,35,27,19,13, & - 25,27,43,33,35,17,17,23,7,35,15,61,61,53,5,15,23,11,13,43,55, & - 47,25,43,15,57,45,1,49,63,57,15,31,31,7,53,27,15,47,23,7,29, & - 53,47,9,53,3,25,55,45,63,21,17,23,31,27,27,43,63,55,63,45,51, & - 15,27,5,37,43,11,27,5,27,59,21,7,39,27,63,35,47,55,17,17,17, & - 3,19,21,13,49,61,39,15/) - v(20:305,7) = (/ & - 13,33,115,41,79,17,29,119,75,73,105,7, & - 59,65,21,3,113,61,89,45,107,21,71,79,19,71,61,41,57,121,87, & - 119,55,85,121,119,11,23,61,11,35,33,43,107,113,101,29,87,119, & - 97,29,17,89,5,127,89,119,117,103,105,41,83,25,41,55,69,117, & - 49,127,29,1,99,53,83,15,31,73,115,35,21,89,5,1,91,53,35,95, & - 83,19,85,55,51,101,33,41,55,45,95,61,27,37,89,75,57,61,15, & - 117,15,21,27,25,27,123,39,109,93,51,21,91,109,107,45,15,93, & - 127,3,53,81,79,107,79,87,35,109,73,35,83,107,1,51,7,59,33, & - 115,43,111,45,121,105,125,87,101,41,95,75,1,57,117,21,27,67, & - 29,53,117,63,1,77,89,115,49,127,15,79,81,29,65,103,33,73,79, & - 29,21,113,31,33,107,95,111,59,99,117,63,63,99,39,9,35,63,125, & - 99,45,93,33,93,9,105,75,51,115,11,37,17,41,21,43,73,19,93,7, & - 95,81,93,79,81,55,9,51,63,45,89,73,19,115,39,47,81,39,5,5,45, & - 53,65,49,17,105,13,107,5,5,19,73,59,43,83,97,115,27,1,69,103, & - 3,99,103,63,67,25,121,97,77,13,83,103,41,11,27,81,37,33,125, & - 71,41,41,59,41,87,123/) - v(306:589,7) = (/ & - 43,101,63,45,39,21,97,15,97,111,21,49, & - 13,17,79,91,65,105,75,1,45,67,83,107,125,87,15,81,95,105,65, & - 45,59,103,23,103,99,67,99,47,117,71,89,35,53,73,9,115,49,37, & - 1,35,9,45,81,19,127,17,17,105,89,49,101,7,37,33,11,95,95,17, & - 111,105,41,115,5,69,101,27,27,101,103,53,9,21,43,79,91,65, & - 117,87,125,55,45,63,85,83,97,45,83,87,113,93,95,5,17,77,77, & - 127,123,45,81,85,121,119,27,85,41,49,15,107,21,51,119,11,87, & - 101,115,63,63,37,121,109,7,43,69,19,77,49,71,59,35,7,13,55, & - 101,127,103,85,109,29,61,67,21,111,67,23,57,75,71,101,123,41, & - 107,101,107,125,27,47,119,41,19,127,33,31,109,7,91,91,39,125, & - 105,47,125,123,91,9,103,45,23,117,9,125,73,11,37,61,79,21,5, & - 47,117,67,53,85,33,81,121,47,61,51,127,29,65,45,41,95,57,73, & - 33,117,61,111,59,123,65,47,105,23,29,107,37,81,67,29,115,119, & - 75,73,99,103,7,57,45,61,95,49,101,101,35,47,119,39,67,31,103, & - 7,61,127,87,3,35,29,73,95,103,71,75,51,87,57,97,11,105,87,41, & - 73,109,69,35,121,39,111,1,77/) - v(590:875,7) = (/ & - 39,47,53,91,3,17,51,83,39,125,85,111, & - 21,69,85,29,55,11,117,1,47,17,65,63,47,117,17,115,51,25,33, & - 123,123,83,51,113,95,121,51,91,109,43,55,35,55,87,33,37,5,3, & - 45,21,105,127,35,17,35,37,97,97,21,77,123,17,89,53,105,75,25, & - 125,13,47,21,125,23,55,63,61,5,17,93,57,121,69,73,93,121,105, & - 75,91,67,95,75,9,69,97,99,93,11,53,19,73,5,33,79,107,65,69, & - 79,125,25,93,55,61,17,117,69,97,87,111,37,93,59,79,95,53,115, & - 53,85,85,65,59,23,75,21,67,27,99,79,27,3,95,27,69,19,75,47, & - 59,41,85,77,99,55,49,93,93,119,51,125,63,13,15,45,61,19,105, & - 115,17,83,7,7,11,61,37,63,89,95,119,113,67,123,91,33,37,99, & - 43,11,33,65,81,79,81,107,63,63,55,89,91,25,93,101,27,55,75, & - 121,79,43,125,73,27,109,35,21,71,113,89,59,95,41,45,113,119, & - 113,39,59,73,15,13,59,67,121,27,7,105,15,59,59,35,91,89,23, & - 125,97,53,41,91,111,29,31,3,103,61,71,35,7,119,29,45,49,111, & - 41,109,59,125,13,27,19,79,9,75,83,81,33,91,109,33,29,107,111, & - 101,107,109,65,59,43,37/) - v(876:1111,7) = (/ & - 1,9,15,109,37,111,113,119,79,73,65, & - 71,93,17,101,87,97,43,23,75,109,41,49,53,31,97,105,109,119, & - 51,9,53,113,97,73,89,79,49,61,105,13,99,53,71,7,87,21,101,5, & - 71,31,123,121,121,73,79,115,13,39,101,19,37,51,83,97,55,81, & - 91,127,105,89,63,47,49,75,37,77,15,49,107,23,23,35,19,69,17, & - 59,63,73,29,125,61,65,95,101,81,57,69,83,37,11,37,95,1,73,27, & - 29,57,7,65,83,99,69,19,103,43,95,25,19,103,41,125,97,71,105, & - 83,83,61,39,9,45,117,63,31,5,117,67,125,41,117,43,77,97,15, & - 29,5,59,25,63,87,39,39,77,85,37,81,73,89,29,125,109,21,23, & - 119,105,43,93,97,15,125,29,51,69,37,45,31,75,109,119,53,5, & - 101,125,121,35,29,7,63,17,63,13,69,15,105,51,127,105,9,57,95, & - 59,109,35,49,23,33,107,55,33,57,79,73,69,59,107,55,11,63,95, & - 103,23,125,91,31,91,51,65,61,75,69,107,65,101,59,35,15/) - v(38:299,8) = (/ & - 7,23,39,217,141,27,53,181,169,35,15, & - 207,45,247,185,117,41,81,223,151,81,189,61,95,185,23,73,113, & - 239,85,9,201,83,53,183,203,91,149,101,13,111,239,3,205,253, & - 247,121,189,169,179,197,175,217,249,195,95,63,19,7,5,75,217, & - 245,111,189,165,169,141,221,249,159,253,207,249,219,23,49, & - 127,237,5,25,177,37,103,65,167,81,87,119,45,79,143,57,79,187, & - 143,183,75,97,211,149,175,37,135,189,225,241,63,33,43,13,73, & - 213,57,239,183,117,21,29,115,43,205,223,15,3,159,51,101,127, & - 99,239,171,113,171,119,189,245,201,27,185,229,105,153,189,33, & - 35,137,77,97,17,181,55,197,201,155,37,197,137,223,25,179,91, & - 23,235,53,253,49,181,249,53,173,97,247,67,115,103,159,239,69, & - 173,217,95,221,247,97,91,123,223,213,129,181,87,239,85,89, & - 249,141,39,57,249,71,101,159,33,137,189,71,253,205,171,13, & - 249,109,131,199,189,179,31,99,113,41,173,23,189,197,3,135,9, & - 95,195,27,183,1,123,73,53,99,197,59,27,101,55,193,31,61,119, & - 11,7,255,233,53,157,193,97,83,65,81,239,167,69,71,109/) - v(300:559,8) = (/ & - 97,137,71,193,189,115,79,205,37,227, & - 53,33,91,229,245,105,77,229,161,103,93,13,161,229,223,69,15, & - 25,23,233,93,25,217,247,61,75,27,9,223,213,55,197,145,89,199, & - 41,201,5,149,35,119,183,53,11,13,3,179,229,43,55,187,233,47, & - 133,91,47,71,93,105,145,45,255,221,115,175,19,129,5,209,197, & - 57,177,115,187,119,77,211,111,33,113,23,87,137,41,7,83,43, & - 121,145,5,219,27,11,111,207,55,97,63,229,53,33,149,23,187, & - 153,91,193,183,59,211,93,139,59,179,163,209,77,39,111,79,229, & - 85,237,199,137,147,25,73,121,129,83,87,93,205,167,53,107,229, & - 213,95,219,109,175,13,209,97,61,147,19,13,123,73,35,141,81, & - 19,171,255,111,107,233,113,133,89,9,231,95,69,33,1,253,219, & - 253,247,129,11,251,221,153,35,103,239,7,27,235,181,5,207,53, & - 149,155,225,165,137,155,201,97,245,203,47,39,35,105,239,49, & - 15,253,7,237,213,55,87,199,27,175,49,41,229,85,3,149,179,129, & - 185,249,197,15,97,197,139,203,63,33,251,217,199,199,99,249, & - 33,229,177,13,209,147,97,31,125,177,137/) - v(560:819,8) = (/ & - 187,11,91,223,29,169,231,59,31,163,41, & - 57,87,247,25,127,101,207,187,73,61,105,27,91,171,243,33,3,1, & - 21,229,93,71,61,37,183,65,211,53,11,151,165,47,5,129,79,101, & - 147,169,181,19,95,77,139,197,219,97,239,183,143,9,13,209,23, & - 215,53,137,203,19,151,171,133,219,231,3,15,253,225,33,111, & - 183,213,169,119,111,15,201,123,121,225,113,113,225,161,165,1, & - 139,55,3,93,217,193,97,29,69,231,161,93,69,143,137,9,87,183, & - 113,183,73,215,137,89,251,163,41,227,145,57,81,57,11,135,145, & - 161,175,159,25,55,167,157,211,97,247,249,23,129,159,71,197, & - 127,141,219,5,233,131,217,101,131,33,157,173,69,207,239,81, & - 205,11,41,169,65,193,77,201,173,1,221,157,1,15,113,147,137, & - 205,225,73,45,49,149,113,253,99,17,119,105,117,129,243,75, & - 203,53,29,247,35,247,171,31,199,213,29,251,7,251,187,91,11, & - 149,13,205,37,249,137,139,9,7,113,183,205,187,39,3,79,155, & - 227,89,185,51,127,63,83,41,133,183,181,127,19,255,219,59,251, & - 3,187,57,217,115,217,229,181,185,149,83,115,11/) - v(820:1074,8) = (/ & - 123,19,109,165,103,123,219,129,155, & - 207,177,9,49,181,231,33,233,67,155,41,9,95,123,65,117,249,85, & - 169,129,241,173,251,225,147,165,69,81,239,95,23,83,227,249, & - 143,171,193,9,21,57,73,97,57,29,239,151,159,191,47,51,1,223, & - 251,251,151,41,119,127,131,33,209,123,53,241,25,31,183,107, & - 25,115,39,11,213,239,219,109,185,35,133,123,185,27,55,245,61, & - 75,205,213,169,163,63,55,49,83,195,51,31,41,15,203,41,63,127, & - 161,5,143,7,199,251,95,75,101,15,43,237,197,117,167,155,21, & - 83,205,255,49,101,213,237,135,135,21,73,93,115,7,85,223,237, & - 79,89,5,57,239,67,65,201,155,71,85,195,89,181,119,135,147, & - 237,173,41,155,67,113,111,21,183,23,103,207,253,69,219,205, & - 195,43,197,229,139,177,129,69,97,201,163,189,11,99,91,253, & - 239,91,145,19,179,231,121,7,225,237,125,191,119,59,175,237, & - 131,79,43,45,205,199,251,153,207,37,179,113,255,107,217,61,7, & - 181,247,31,13,113,145,107,233,233,43,79,23,169,137,129,183, & - 53,91,55,103,223,87,177,157,79,213,139/) - v(1075:1111,8) = (/ & - 183,231,205,143,129,243,205,93,59, & - 15,89,9,11,47,133,227,75,9,91,19,171,163,79,7,103,5,119,155, & - 75,11,71,95,17,13,243,207,187/) - v(54:299,9) = (/ & - 235,307,495,417,57,151,19,119,375,451, & - 55,449,501,53,185,317,17,21,487,13,347,393,15,391,307,189, & - 381,71,163,99,467,167,433,337,257,179,47,385,23,117,369,425, & - 207,433,301,147,333,85,221,423,49,3,43,229,227,201,383,281, & - 229,207,21,343,251,397,173,507,421,443,399,53,345,77,385,317, & - 155,187,269,501,19,169,235,415,61,247,183,5,257,401,451,95, & - 455,49,489,75,459,377,87,463,155,233,115,429,211,419,143,487, & - 195,209,461,193,157,193,363,181,271,445,381,231,135,327,403, & - 171,197,181,343,113,313,393,311,415,267,247,425,233,289,55, & - 39,247,327,141,5,189,183,27,337,341,327,87,429,357,265,251, & - 437,201,29,339,257,377,17,53,327,47,375,393,369,403,125,429, & - 257,157,217,85,267,117,337,447,219,501,41,41,193,509,131,207, & - 505,421,149,111,177,167,223,291,91,29,305,151,177,337,183, & - 361,435,307,507,77,181,507,315,145,423,71,103,493,271,469, & - 339,237,437,483,31,219,61,131,391,233,219,69,57,459,225,421, & - 7,461,111,451,277,185,193,125,251,199,73,71,7,409,417,149/) - v(300:550,9) = (/ & - 193,53,437,29,467,229,31,35,75,105, & - 503,75,317,401,367,131,365,441,433,93,377,405,465,259,283, & - 443,143,445,3,461,329,309,77,323,155,347,45,381,315,463,207, & - 321,157,109,479,313,345,167,439,307,235,473,79,101,245,19, & - 381,251,35,25,107,187,115,113,321,115,445,61,77,293,405,13, & - 53,17,171,299,41,79,3,485,331,13,257,59,201,497,81,451,199, & - 171,81,253,365,75,451,149,483,81,453,469,485,305,163,401,15, & - 91,3,129,35,239,355,211,387,101,299,67,375,405,357,267,363, & - 79,83,437,457,39,97,473,289,179,57,23,49,79,71,341,287,95, & - 229,271,475,49,241,261,495,353,381,13,291,37,251,105,399,81, & - 89,265,507,205,145,331,129,119,503,249,1,289,463,163,443,63, & - 123,361,261,49,429,137,355,175,507,59,277,391,25,185,381,197, & - 39,5,429,119,247,177,329,465,421,271,467,151,45,429,137,471, & - 11,17,409,347,199,463,177,11,51,361,95,497,163,351,127,395, & - 511,327,353,49,105,151,321,331,329,509,107,109,303,467,287, & - 161,45,385,289,363,331,265,407,37,433,315,343,63,51,185,71, & - 27,267/) - v(551:798,9) = (/ & - 503,239,293,245,281,297,75,461,371, & - 129,189,189,339,287,111,111,379,93,27,185,347,337,247,507, & - 161,231,43,499,73,327,263,331,249,493,37,25,115,3,167,197, & - 127,357,497,103,125,191,165,55,101,95,79,351,341,43,125,135, & - 173,289,373,133,421,241,281,213,177,363,151,227,145,363,239, & - 431,81,397,241,67,291,255,405,421,399,75,399,105,329,41,425, & - 7,283,375,475,427,277,209,411,3,137,195,289,509,121,55,147, & - 275,251,19,129,285,415,487,491,193,219,403,23,97,65,285,75, & - 21,373,261,339,239,495,415,333,107,435,297,213,149,463,199, & - 323,45,19,301,121,499,187,229,63,425,99,281,35,125,349,87, & - 101,59,195,511,355,73,263,243,101,165,141,11,389,219,187,449, & - 447,393,477,305,221,51,355,209,499,479,265,377,145,411,173, & - 11,433,483,135,385,341,89,209,391,33,395,319,451,119,341,227, & - 375,61,331,493,411,293,47,203,375,167,395,155,5,237,361,489, & - 127,21,345,101,371,233,431,109,119,277,125,263,73,135,123,83, & - 123,405,69,75,287,401,23,283,393,41,379,431,11,475,505,19, & - 365,265,271/) - v(799:1045,9) = (/ & - 499,489,443,165,91,83,291,319,199, & - 107,245,389,143,137,89,125,281,381,215,131,299,249,375,455, & - 43,73,281,217,297,229,431,357,81,357,171,451,481,13,387,491, & - 489,439,385,487,177,393,33,71,375,443,129,407,395,127,65,333, & - 309,119,197,435,497,373,71,379,509,387,159,265,477,463,449, & - 47,353,249,335,505,89,141,55,235,187,87,363,93,363,101,67, & - 215,321,331,305,261,411,491,479,65,307,469,415,131,315,487, & - 83,455,19,113,163,503,99,499,251,239,81,167,391,255,317,363, & - 359,395,419,307,251,267,171,461,183,465,165,163,293,477,223, & - 403,389,97,335,357,297,19,469,501,249,85,213,311,265,379,297, & - 283,393,449,463,289,159,289,499,407,129,137,221,43,89,403, & - 271,75,83,445,453,389,149,143,423,499,317,445,157,137,453, & - 163,87,23,391,119,427,323,173,89,259,377,511,249,31,363,229, & - 353,329,493,427,57,205,389,91,83,13,219,439,45,35,371,441,17, & - 267,501,53,25,333,17,201,475,257,417,345,381,377,55,403,77, & - 389,347,363,211,413,419,5,167,219,201,285,425,11,77,269,489, & - 281,403,79/) - v(1046:1111,9) = (/ & - 425,125,81,331,437,271,397,299,475, & - 271,249,413,233,261,495,171,69,27,409,21,421,367,81,483,255, & - 15,219,365,497,181,75,431,99,325,407,229,281,63,83,493,5,113, & - 15,271,37,87,451,299,83,451,311,441,47,455,47,253,13,109,369, & - 347,11,409,275,63,441,15/) - v(102:344,10) = (/ & - 519,307,931,1023,517,771,151,1023, & - 539,725,45,927,707,29,125,371,275,279,817,389,453,989,1015, & - 29,169,743,99,923,981,181,693,309,227,111,219,897,377,425, & - 609,227,19,221,143,581,147,919,127,725,793,289,411,835,921, & - 957,443,349,813,5,105,457,393,539,101,197,697,27,343,515,69, & - 485,383,855,693,133,87,743,747,475,87,469,763,721,345,479, & - 965,527,121,271,353,467,177,245,627,113,357,7,691,725,355, & - 889,635,737,429,545,925,357,873,187,351,677,999,921,477,233, & - 765,495,81,953,479,89,173,473,131,961,411,291,967,65,511,13, & - 805,945,369,827,295,163,835,259,207,331,29,315,999,133,967, & - 41,117,677,471,717,881,755,351,723,259,879,455,721,289,149, & - 199,805,987,851,423,597,129,11,733,549,153,285,451,559,377, & - 109,357,143,693,615,677,701,475,767,85,229,509,547,151,389, & - 711,785,657,319,509,99,1007,775,359,697,677,85,497,105,615, & - 891,71,449,835,609,377,693,665,627,215,911,503,729,131,19, & - 895,199,161,239,633,1013,537,255,23,149,679,1021,595,199,557, & - 659,251,829,727,439,495,647,223/) - v(345:586,10) = (/ & - 949,625,87,481,85,799,917,769,949, & - 739,115,499,945,547,225,1015,469,737,495,353,103,17,665,639, & - 525,75,447,185,43,729,577,863,735,317,99,17,477,893,537,519, & - 1017,375,297,325,999,353,343,729,135,489,859,267,141,831,141, & - 893,249,807,53,613,131,547,977,131,999,175,31,341,739,467, & - 675,241,645,247,391,583,183,973,433,367,131,467,571,309,385, & - 977,111,917,935,473,345,411,313,97,149,959,841,839,669,431, & - 51,41,301,247,1015,377,329,945,269,67,979,581,643,823,557,91, & - 405,117,801,509,347,893,303,227,783,555,867,99,703,111,797, & - 873,541,919,513,343,319,517,135,871,917,285,663,301,15,763, & - 89,323,757,317,807,309,1013,345,499,279,711,915,411,281,193, & - 739,365,315,375,809,469,487,621,857,975,537,939,585,129,625, & - 447,129,1017,133,83,3,415,661,53,115,903,49,79,55,385,261, & - 345,297,199,385,617,25,515,275,849,401,471,377,661,535,505, & - 939,465,225,929,219,955,659,441,117,527,427,515,287,191,33, & - 389,197,825,63,417,949,35,571,9,131,609,439,95,19,569,893, & - 451,397,971,801/) - v(587:824,10) = (/ & - 125,471,187,257,67,949,621,453,411, & - 621,955,309,783,893,597,377,753,145,637,941,593,317,555,375, & - 575,175,403,571,555,109,377,931,499,649,653,329,279,271,647, & - 721,665,429,957,803,767,425,477,995,105,495,575,687,385,227, & - 923,563,723,481,717,111,633,113,369,955,253,321,409,909,367, & - 33,967,453,863,449,539,781,911,113,7,219,725,1015,971,1021, & - 525,785,873,191,893,297,507,215,21,153,645,913,755,371,881, & - 113,903,225,49,587,201,927,429,599,513,97,319,331,833,325, & - 887,139,927,399,163,307,803,169,1019,869,537,907,479,335,697, & - 479,353,769,787,1023,855,493,883,521,735,297,1011,991,879, & - 855,591,415,917,375,453,553,189,841,339,211,601,57,765,745, & - 621,209,875,639,7,595,971,263,1009,201,23,77,621,33,535,963, & - 661,523,263,917,103,623,231,47,301,549,337,675,189,357,1005, & - 789,189,319,721,1005,525,675,539,191,813,917,51,167,415,579, & - 755,605,721,837,529,31,327,799,961,279,409,847,649,241,285, & - 545,407,161,591,73,313,811,17,663,269,261,37,783,127,917,231, & - 577,975,793/) - v(825:1065,10) = (/ & - 921,343,751,139,221,79,817,393,545, & - 11,781,71,1,699,767,917,9,107,341,587,903,965,599,507,843, & - 739,579,397,397,325,775,565,925,75,55,979,931,93,957,857,753, & - 965,795,67,5,87,909,97,995,271,875,671,613,33,351,69,811,669, & - 729,401,647,241,435,447,721,271,745,53,775,99,343,451,427, & - 593,339,845,243,345,17,573,421,517,971,499,435,769,75,203, & - 793,985,343,955,735,523,659,703,303,421,951,405,631,825,735, & - 433,841,485,49,749,107,669,211,497,143,99,57,277,969,107,397, & - 563,551,447,381,187,57,405,731,769,923,955,915,737,595,341, & - 253,823,197,321,315,181,885,497,159,571,981,899,785,947,217, & - 217,135,753,623,565,717,903,581,955,621,361,869,87,943,907, & - 853,353,335,197,771,433,743,195,91,1023,63,301,647,205,485, & - 927,1003,987,359,577,147,141,1017,701,273,89,589,487,859,343, & - 91,847,341,173,287,1003,289,639,983,685,697,35,701,645,911, & - 501,705,873,763,745,657,559,699,315,347,429,197,165,955,859, & - 167,303,833,531,473,635,641,195,589,821,205,3,635,371,891, & - 249,123/) - v(1066:1111,10) = (/ & - 77,623,993,401,525,427,71,655,951, & - 357,851,899,535,493,323,1003,343,515,859,1017,5,423,315,1011, & - 703,41,777,163,95,831,79,975,235,633,723,297,589,317,679,981, & - 195,399,1003,121,501,155/) - v(162:376,11) = (/ & - 7,2011,1001,49,825,415,1441,383,1581, & - 623,1621,1319,1387,619,839,217,75,1955,505,281,1629,1379,53, & - 1111,1399,301,209,49,155,1647,631,129,1569,335,67,1955,1611, & - 2021,1305,121,37,877,835,1457,669,1405,935,1735,665,551,789, & - 1543,1267,1027,1,1911,163,1929,67,1975,1681,1413,191,1711, & - 1307,401,725,1229,1403,1609,2035,917,921,1789,41,2003,187,67, & - 1635,717,1449,277,1903,1179,363,1211,1231,647,1261,1029,1485, & - 1309,1149,317,1335,171,243,271,1055,1601,1129,1653,205,1463, & - 1681,1621,197,951,573,1697,1265,1321,1805,1235,1853,1307,945, & - 1197,1411,833,273,1517,1747,1095,1345,869,57,1383,221,1713, & - 335,1751,1141,839,523,1861,1105,389,1177,1877,805,93,1591, & - 423,1835,99,1781,1515,1909,1011,303,385,1635,357,973,1781, & - 1707,1363,1053,649,1469,623,1429,1241,1151,1055,503,921,3, & - 349,1149,293,45,303,877,1565,1583,1001,663,1535,395,1141, & - 1481,1797,643,1507,465,2027,1695,367,937,719,545,1991,83,819, & - 239,1791,1461,1647,1501,1161,1629,139,1595,1921,1267,1415, & - 509,347,777,1083,363,269,1015/) - v(377:589,11) = (/ & - 1809,1105,1429,1471,2019,381,2025, & - 1223,827,1733,887,1321,803,1951,1297,1995,833,1107,1135,1181, & - 1251,983,1389,1565,273,137,71,735,1005,933,67,1471,551,457, & - 1667,1729,919,285,1629,1815,653,1919,1039,531,393,1411,359, & - 221,699,1485,471,1357,1715,595,1677,153,1903,1281,215,781, & - 543,293,1807,965,1695,443,1985,321,879,1227,1915,839,1945, & - 1993,1165,51,557,723,1491,817,1237,947,1215,1911,1225,1965, & - 1889,1503,1177,73,1767,303,177,1897,1401,321,921,217,1779, & - 327,1889,333,615,1665,1825,1639,237,1205,361,129,1655,983, & - 1089,1171,401,677,643,749,303,1407,1873,1579,1491,1393,1247, & - 789,763,49,5,1607,1891,735,1557,1909,1765,1777,1127,813,695, & - 97,731,1503,1751,333,769,865,693,377,1919,957,1359,1627,1039, & - 1783,1065,1665,1917,1947,991,1997,841,459,221,327,1595,1881, & - 1269,1007,129,1413,475,1105,791,1983,1359,503,691,659,691, & - 343,1375,1919,263,1373,603,1383,297,781,145,285,767,1739, & - 1715,715,317,1333,85,831,1615,81,1667,1467,1457,1453,1825, & - 109,387,1207,2039,213,1351,1329,1173/) - v(590:802,11) = (/ & - 57,1769,951,183,23,451,1155,1551, & - 2037,811,635,1671,1451,863,1499,1673,363,1029,1077,1525,277, & - 1023,655,665,1869,1255,965,277,1601,329,1603,1901,395,65, & - 1307,2029,21,1321,543,1569,1185,1905,1701,413,2041,1697,725, & - 1417,1847,411,211,915,1891,17,1877,1699,687,1089,1973,1809, & - 851,1495,1257,63,1323,1307,609,881,1543,177,617,1505,1747, & - 1537,925,183,77,1723,1877,1703,397,459,521,257,1177,389,1947, & - 1553,1583,1831,261,485,289,1281,1543,1591,1123,573,821,1065, & - 1933,1373,2005,905,207,173,1573,1597,573,1883,1795,1499,1743, & - 553,335,333,1645,791,871,1157,969,557,141,223,1129,1685,423, & - 1069,391,99,95,1847,531,1859,1833,1833,341,237,1997,1799,409, & - 431,1917,363,335,1039,1085,1657,1975,1527,1111,659,389,899, & - 595,1439,1861,1979,1569,1087,1009,165,1895,1481,1583,29,1193, & - 1673,1075,301,1081,1377,1747,1497,1103,1789,887,739,1577,313, & - 1367,1299,1801,1131,1837,73,1865,1065,843,635,55,1655,913, & - 1037,223,1871,1161,461,479,511,1721,1107,389,151,35,375,1099, & - 937,1185,1701,769,639,1633/) - v(803:1018,11) = (/ & - 1609,379,1613,2031,685,289,975,671, & - 1599,1447,871,647,99,139,1427,959,89,117,841,891,1959,223, & - 1697,1145,499,1435,1809,1413,1445,1675,171,1073,1349,1545, & - 2039,1027,1563,859,215,1673,1919,1633,779,411,1845,1477,1489, & - 447,1545,351,1989,495,183,1639,1385,1805,1097,1249,1431,1571, & - 591,697,1509,709,31,1563,165,513,1425,1299,1081,145,1841, & - 1211,941,609,845,1169,1865,1593,347,293,1277,157,211,93,1679, & - 1799,527,41,473,563,187,1525,575,1579,857,703,1211,647,709, & - 981,285,697,163,981,153,1515,47,1553,599,225,1147,381,135, & - 821,1965,609,1033,983,503,1117,327,453,2005,1257,343,1649, & - 1199,599,1877,569,695,1587,1475,187,973,233,511,51,1083,665, & - 1321,531,1875,1939,859,1507,1979,1203,1965,737,921,1565,1943, & - 819,223,365,167,1705,413,1577,745,1573,655,1633,1003,91,1123, & - 477,1741,1663,35,715,37,1513,815,941,1379,263,1831,1735,1111, & - 1449,353,1941,1655,1349,877,285,1723,125,1753,985,723,175, & - 439,791,1051,1261,717,1555,1757,1777,577,1583,1957,873,331, & - 1163,313,1,1963,963,1905,821/) - v(1019:1111,11) = (/ & - 1677,185,709,545,1723,215,1885, & - 1249,583,1803,839,885,485,413,1767,425,129,1035,329,1263, & - 1881,1779,1565,359,367,453,707,1419,831,1889,887,1871,1869, & - 747,223,1547,1799,433,1441,553,2021,1303,1505,1735,1619,1065, & - 1161,2047,347,867,881,1447,329,781,1065,219,589,645,1257, & - 1833,749,1841,1733,1179,1191,1025,1639,1955,1423,1685,1711, & - 493,549,783,1653,397,895,233,759,1505,677,1449,1573,1297, & - 1821,1691,791,289,1187,867,1535,575,183/) - v(338:545,12) = (/ & - 3915,97,3047,937,2897,953,127,1201, & - 3819,193,2053,3061,3759,1553,2007,2493,603,3343,3751,1059, & - 783,1789,1589,283,1093,3919,2747,277,2605,2169,2905,721,4069, & - 233,261,1137,3993,3619,2881,1275,3865,1299,3757,1193,733,993, & - 1153,2945,3163,3179,437,271,3493,3971,1005,2615,2253,1131, & - 585,2775,2171,2383,2937,2447,1745,663,1515,3767,2709,1767, & - 3185,3017,2815,1829,87,3341,793,2627,2169,1875,3745,367,3783, & - 783,827,3253,2639,2955,3539,1579,2109,379,2939,3019,1999, & - 2253,2911,3733,481,1767,1055,4019,4085,105,1829,2097,2379, & - 1567,2713,737,3423,3941,2659,3961,1755,3613,1937,1559,2287, & - 2743,67,2859,325,2601,1149,3259,2403,3947,2011,175,3389,3915, & - 1315,2447,141,359,3609,3933,729,2051,1755,2149,2107,1741, & - 1051,3681,471,1055,845,257,1559,1061,2803,2219,1315,1369, & - 3211,4027,105,11,1077,2857,337,3553,3503,3917,2665,3823,3403, & - 3711,2085,1103,1641,701,4095,2883,1435,653,2363,1597,767,869, & - 1825,1117,1297,501,505,149,873,2673,551,1499,2793,3277,2143, & - 3663,533,3991,575,1877,1009,3929,473,3009,2595,3249,675,3593/) - v(546:752,12) = (/ & - 2453,1567,973,595,1335,1715,589,85, & - 2265,3069,461,1659,2627,1307,1731,1501,1699,3545,3803,2157, & - 453,2813,2047,2999,3841,2361,1079,573,69,1363,1597,3427,2899, & - 2771,1327,1117,1523,3521,2393,2537,1979,3179,683,2453,453, & - 1227,779,671,3483,2135,3139,3381,3945,57,1541,3405,3381,2371, & - 2879,1985,987,3017,3031,3839,1401,3749,2977,681,1175,1519, & - 3355,907,117,771,3741,3337,1743,1227,3335,2755,1909,3603, & - 2397,653,87,2025,2617,3257,287,3051,3809,897,2215,63,2043, & - 1757,3671,297,3131,1305,293,3865,3173,3397,2269,3673,717, & - 3041,3341,3595,3819,2871,3973,1129,513,871,1485,3977,2473, & - 1171,1143,3063,3547,2183,3993,133,2529,2699,233,2355,231, & - 3241,611,1309,3829,1839,1495,301,1169,1613,2673,243,3601, & - 3669,2813,2671,2679,3463,2477,1795,617,2317,1855,1057,1703, & - 1761,2515,801,1205,1311,473,3963,697,1221,251,381,3887,1761, & - 3093,3721,2079,4085,379,3601,3845,433,1781,29,1897,1599,2163, & - 75,3475,3957,1641,3911,2959,2833,1279,1099,403,799,2183,2699, & - 1711,2037,727,289,1785,1575,3633,2367,1261,3953,1735,171, & - 1959/) - v(753:960,12) = (/ & - 2867,859,2951,3211,15,1279,1323,599, & - 1651,3951,1011,315,3513,3351,1725,3793,2399,287,4017,3571, & - 1007,541,3115,429,1585,1285,755,1211,3047,915,3611,2697,2129, & - 3669,81,3939,2437,915,779,3567,3701,2479,3807,1893,3927,2619, & - 2543,3633,2007,3857,3837,487,1769,3759,3105,2727,3155,2479, & - 1341,1657,2767,2541,577,2105,799,17,2871,3637,953,65,69,2897, & - 3841,3559,4067,2335,3409,1087,425,2813,1705,1701,1237,821, & - 1375,3673,2693,3925,1541,1871,2285,847,4035,1101,2029,855, & - 2733,2503,121,2855,1069,3463,3505,1539,607,1349,575,2301, & - 2321,1101,333,291,2171,4085,2173,2541,1195,925,4039,1379,699, & - 1979,275,953,1755,1643,325,101,2263,3329,3673,3413,1977,2727, & - 2313,1419,887,609,2475,591,2613,2081,3805,3435,2409,111,3557, & - 3607,903,231,3059,473,2959,2925,3861,2043,3887,351,2865,369, & - 1377,2639,1261,3625,3279,2201,2949,3049,449,1297,897,1891, & - 411,2773,749,2753,1825,853,2775,3547,3923,3923,987,3723,2189, & - 3877,3577,297,2763,1845,3083,2951,483,2169,3985,245,3655, & - 3441,1023,235,835,3693,3585,327,1003,543,3059,2637/) - v(961:1111,12) = (/ & - 2923,87,3617,1031,1043,903,2913, & - 2177,2641,3279,389,2009,525,4085,3299,987,2409,813,2683,373, & - 2695,3775,2375,1119,2791,223,325,587,1379,2877,2867,3793,655, & - 831,3425,1663,1681,2657,1865,3943,2977,1979,2271,3247,1267, & - 1747,811,159,429,2001,1195,3065,553,1499,3529,1081,2877,3077, & - 845,1793,2409,3995,2559,4081,1195,2955,1117,1409,785,287, & - 1521,1607,85,3055,3123,2533,2329,3477,799,3683,3715,337,3139, & - 3311,431,3511,2299,365,2941,3067,1331,1081,1097,2853,2299, & - 495,1745,749,3819,619,1059,3559,183,3743,723,949,3501,733, & - 2599,3983,3961,911,1899,985,2493,1795,653,157,433,2361,3093, & - 3119,3679,2367,1701,1445,1321,2397,1241,3305,3985,2349,4067, & - 3805,3073,2837,1567,3783,451,2441,1181,487,543,1201,3735, & - 2517,733,1535,2175,3613,3019/) - v(482:680,13) = (/ & - 2319,653,1379,1675,1951,7075,2087, & - 7147,1427,893,171,2019,7235,5697,3615,1961,7517,6849,2893, & - 1883,2863,2173,4543,73,381,3893,6045,1643,7669,1027,1549, & - 3983,1985,6589,7497,2745,2375,7047,1117,1171,1975,5199,3915, & - 3695,8113,4303,3773,7705,6855,1675,2245,2817,1719,569,1021, & - 2077,5945,1833,2631,4851,6371,833,7987,331,1899,8093,6719, & - 6903,5903,5657,5007,2689,6637,2675,1645,1819,689,6709,7717, & - 6295,7013,7695,3705,7069,2621,3631,6571,6259,7261,3397,7645, & - 1115,4753,2047,7579,2271,5403,4911,7629,4225,1209,6955,6951, & - 1829,5579,5231,1783,4285,7425,599,5785,3275,5643,2263,657, & - 6769,6261,1251,3249,4447,4111,3991,1215,131,4397,3487,7585, & - 5565,7199,3573,7105,7409,1671,949,3889,5971,3333,225,3647, & - 5403,3409,7459,6879,5789,6567,5581,4919,1927,4407,8085,4691, & - 611,3005,591,753,589,171,5729,5891,1033,3049,6567,5257,8003, & - 1757,4489,4923,6379,5171,1757,689,3081,1389,4113,455,2761, & - 847,7575,5829,633,6629,1103,7635,803,6175,6587,2711,3879,67, & - 1179,4761,7281,1557,3379,2459,4273,4127,7147,35/) - v(681:877,13) = (/ & - 3549,395,3735,5787,4179,5889,5057, & - 7473,4713,2133,2897,1841,2125,1029,1695,6523,1143,5105,7133, & - 3351,2775,3971,4503,7589,5155,4305,1641,4717,2427,5617,1267, & - 399,5831,4305,4241,3395,3045,4899,1713,171,411,7099,5473, & - 5209,1195,1077,1309,2953,7343,4887,3229,6759,6721,6775,675, & - 4039,2493,7511,3269,4199,6625,7943,2013,4145,667,513,2303, & - 4591,7941,2741,987,8061,3161,5951,1431,831,5559,7405,1357, & - 4319,4235,5421,2559,4415,2439,823,1725,6219,4903,6699,5451, & - 349,7703,2927,7809,6179,1417,5987,3017,4983,3479,4525,4643, & - 4911,227,5475,2287,5581,6817,1937,1421,4415,7977,1789,3907, & - 6815,6789,6003,5609,4507,337,7427,7943,3075,6427,1019,7121, & - 4763,81,3587,2929,1795,8067,2415,1265,4025,5599,4771,3025, & - 2313,6129,7611,6881,5253,4413,7869,105,3173,1629,2537,1023, & - 4409,7209,4413,7107,7469,33,1955,2881,5167,6451,4211,179, & - 5573,7879,3387,7759,5455,7157,1891,5683,5689,6535,3109,6555, & - 6873,1249,4251,6437,49,2745,1201,7327,4179,6783,623,2779, & - 5963,2585,6927,5333,4033,285,7467,4443,4917,3/) - v(878:1070,13) = (/ & - 4319,5517,3449,813,5499,2515,5771, & - 3357,2073,4395,4925,2643,7215,5817,1199,1597,1619,7535,4833, & - 609,4797,8171,6847,793,6757,8165,3371,2431,5235,4739,7703, & - 7223,6525,5891,5605,4433,3533,5267,5125,5037,225,6717,1121, & - 5741,2013,4327,4839,569,5227,7677,4315,2391,5551,859,3627, & - 6377,3903,4311,6527,7573,4905,7731,1909,1555,3279,1949,1887, & - 6675,5509,2033,5473,3539,5033,5935,6095,4761,1771,1271,1717, & - 4415,5083,6277,3147,7695,2461,4783,4539,5833,5583,651,1419, & - 2605,5511,3913,5795,2333,2329,4431,3725,6069,2699,7055,6879, & - 1017,3121,2547,4603,2385,6915,6103,5669,7833,2001,4287,6619, & - 955,2761,5711,6291,3415,3909,2841,5627,4939,7671,6059,6275, & - 6517,1931,4583,7301,1267,7509,1435,2169,6939,3515,2985,2787, & - 2123,1969,3307,353,4359,7059,5273,5873,6657,6765,6229,3179, & - 1583,6237,2155,371,273,7491,3309,6805,3015,6831,7819,713, & - 4747,3935,4109,1311,709,3089,7059,4247,2989,1509,4919,1841, & - 3045,3821,6929,4655,1333,6429,6649,2131,5265,1051,261,8057, & - 3379,2179,1993,5655,3063,6381/) - v(1071:1111,13) = (/ & - 3587,7417,1579,1541,2107,5085,2873, & - 6141,955,3537,2157,841,1999,1465,5171,5651,1535,7235,4349, & - 1263,1453,1005,6893,2919,1947,1635,3963,397,969,4569,655, & - 6737,2995,7235,7713,973,4821,2377,1673,1,6541/) -! -! Set POLY. -! - poly(1:211)= (/ & - 1,3,7,11,13,19,25,37,59,47,61,55,41,67,97,91, & - 109,103,115,131,193,137,145,143,241,157,185,167,229,171,213, & - 191,253,203,211,239,247,285,369,299,301,333,351,355,357,361, & - 391,397,425,451,463,487,501,529,539,545,557,563,601,607,617, & - 623,631,637,647,661,675,677,687,695,701,719,721,731,757,761, & - 787,789,799,803,817,827,847,859,865,875,877,883,895,901,911, & - 949,953,967,971,973,981,985,995,1001,1019,1033,1051,1063, & - 1069,1125,1135,1153,1163,1221,1239,1255,1267,1279,1293,1305, & - 1315,1329,1341,1347,1367,1387,1413,1423,1431,1441,1479,1509, & - 1527,1531,1555,1557,1573,1591,1603,1615,1627,1657,1663,1673, & - 1717,1729,1747,1759,1789,1815,1821,1825,1849,1863,1869,1877, & - 1881,1891,1917,1933,1939,1969,2011,2035,2041,2053,2071,2091, & - 2093,2119,2147,2149,2161,2171,2189,2197,2207,2217,2225,2255, & - 2257,2273,2279,2283,2293,2317,2323,2341,2345,2363,2365,2373, & - 2377,2385,2395,2419,2421,2431,2435,2447,2475,2477,2489,2503, & - 2521,2533,2551,2561,2567,2579,2581,2601,2633,2657,2669/) - poly(212:401)= (/ & - 2681,2687,2693,2705,2717,2727,2731,2739, & - 2741,2773,2783,2793,2799,2801,2811,2819,2825,2833,2867,2879, & - 2881,2891,2905,2911,2917,2927,2941,2951,2955,2963,2965,2991, & - 2999,3005,3017,3035,3037,3047,3053,3083,3085,3097,3103,3159, & - 3169,3179,3187,3205,3209,3223,3227,3229,3251,3263,3271,3277, & - 3283,3285,3299,3305,3319,3331,3343,3357,3367,3373,3393,3399, & - 3413,3417,3427,3439,3441,3475,3487,3497,3515,3517,3529,3543, & - 3547,3553,3559,3573,3589,3613,3617,3623,3627,3635,3641,3655, & - 3659,3669,3679,3697,3707,3709,3713,3731,3743,3747,3771,3791, & - 3805,3827,3833,3851,3865,3889,3895,3933,3947,3949,3957,3971, & - 3985,3991,3995,4007,4013,4021,4045,4051,4069,4073,4179,4201, & - 4219,4221,4249,4305,4331,4359,4383,4387,4411,4431,4439,4449, & - 4459,4485,4531,4569,4575,4621,4663,4669,4711,4723,4735,4793, & - 4801,4811,4879,4893,4897,4921,4927,4941,4977,5017,5027,5033, & - 5127,5169,5175,5199,5213,5223,5237,5287,5293,5331,5391,5405, & - 5453,5523,5573,5591,5597,5611,5641,5703,5717,5721,5797,5821, & - 5909,5913/) - poly(402:591)= (/ & - 5955,5957,6005,6025,6061,6067,6079,6081, & - 6231,6237,6289,6295,6329,6383,6427,6453,6465,6501,6523,6539, & - 6577,6589,6601,6607,6631,6683,6699,6707,6761,6795,6865,6881, & - 6901,6923,6931,6943,6999,7057,7079,7103,7105,7123,7173,7185, & - 7191,7207,7245,7303,7327,7333,7355,7365,7369,7375,7411,7431, & - 7459,7491,7505,7515,7541,7557,7561,7701,7705,7727,7749,7761, & - 7783,7795,7823,7907,7953,7963,7975,8049,8089,8123,8125,8137, & - 8219,8231,8245,8275,8293,8303,8331,8333,8351,8357,8367,8379, & - 8381,8387,8393,8417,8435,8461,8469,8489,8495,8507,8515,8551, & - 8555,8569,8585,8599,8605,8639,8641,8647,8653,8671,8675,8689, & - 8699,8729,8741,8759,8765,8771,8795,8797,8825,8831,8841,8855, & - 8859,8883,8895,8909,8943,8951,8955,8965,8999,9003,9031,9045, & - 9049,9071,9073,9085,9095,9101,9109,9123,9129,9137,9143,9147, & - 9185,9197,9209,9227,9235,9247,9253,9257,9277,9297,9303,9313, & - 9325,9343,9347,9371,9373,9397,9407,9409,9415,9419,9443,9481, & - 9495,9501,9505,9517,9529,9555,9557,9571,9585,9591,9607,9611, & - 9621,9625/) - poly(592:765)= (/ & - 9631,9647,9661,9669,9679,9687,9707,9731, & - 9733,9745,9773,9791,9803,9811,9817,9833,9847,9851,9863,9875, & - 9881,9905,9911,9917,9923,9963,9973,10003,10025,10043,10063, & - 10071,10077,10091,10099,10105,10115,10129,10145,10169,10183, & - 10187,10207,10223,10225,10247,10265,10271,10275,10289,10299, & - 10301,10309,10343,10357,10373,10411,10413,10431,10445,10453, & - 10463,10467,10473,10491,10505,10511,10513,10523,10539,10549, & - 10559,10561,10571,10581,10615,10621,10625,10643,10655,10671, & - 10679,10685,10691,10711,10739,10741,10755,10767,10781,10785, & - 10803,10805,10829,10857,10863,10865,10875,10877,10917,10921, & - 10929,10949,10967,10971,10987,10995,11009,11029,11043,11045, & - 11055,11063,11075,11081,11117,11135,11141,11159,11163,11181, & - 11187,11225,11237,11261,11279,11297,11307,11309,11327,11329, & - 11341,11377,11403,11405,11413,11427,11439,11453,11461,11473, & - 11479,11489,11495,11499,11533,11545,11561,11567,11575,11579, & - 11589,11611,11623,11637,11657,11663,11687,11691,11701,11747, & - 11761,11773,11783,11795,11797,11817,11849,11855,11867,11869, & - 11873,11883,11919/) - poly(766:936)= (/ & - 11921,11927,11933,11947,11955,11961, & - 11999,12027,12029,12037,12041,12049,12055,12095,12097,12107, & - 12109,12121,12127,12133,12137,12181,12197,12207,12209,12239, & - 12253,12263,12269,12277,12287,12295,12309,12313,12335,12361, & - 12367,12391,12409,12415,12433,12449,12469,12479,12481,12499, & - 12505,12517,12527,12549,12559,12597,12615,12621,12639,12643, & - 12657,12667,12707,12713,12727,12741,12745,12763,12769,12779, & - 12781,12787,12799,12809,12815,12829,12839,12857,12875,12883, & - 12889,12901,12929,12947,12953,12959,12969,12983,12987,12995, & - 13015,13019,13031,13063,13077,13103,13137,13149,13173,13207, & - 13211,13227,13241,13249,13255,13269,13283,13285,13303,13307, & - 13321,13339,13351,13377,13389,13407,13417,13431,13435,13447, & - 13459,13465,13477,13501,13513,13531,13543,13561,13581,13599, & - 13605,13617,13623,13637,13647,13661,13677,13683,13695,13725, & - 13729,13753,13773,13781,13785,13795,13801,13807,13825,13835, & - 13855,13861,13871,13883,13897,13905,13915,13939,13941,13969, & - 13979,13981,13997,14027,14035,14037,14051,14063,14085,14095, & - 14107,14113,14125,14137,14145/) - poly(937:1107)= (/ & - 14151,14163,14193,14199,14219,14229, & - 14233,14243,14277,14287,14289,14295,14301,14305,14323,14339, & - 14341,14359,14365,14375,14387,14411,14425,14441,14449,14499, & - 14513,14523,14537,14543,14561,14579,14585,14593,14599,14603, & - 14611,14641,14671,14695,14701,14723,14725,14743,14753,14759, & - 14765,14795,14797,14803,14831,14839,14845,14855,14889,14895, & - 14909,14929,14941,14945,14951,14963,14965,14985,15033,15039, & - 15053,15059,15061,15071,15077,15081,15099,15121,15147,15149, & - 15157,15167,15187,15193,15203,15205,15215,15217,15223,15243, & - 15257,15269,15273,15287,15291,15313,15335,15347,15359,15373, & - 15379,15381,15391,15395,15397,15419,15439,15453,15469,15491, & - 15503,15517,15527,15531,15545,15559,15593,15611,15613,15619, & - 15639,15643,15649,15661,15667,15669,15681,15693,15717,15721, & - 15741,15745,15765,15793,15799,15811,15825,15835,15847,15851, & - 15865,15877,15881,15887,15899,15915,15935,15937,15955,15973, & - 15977,16011,16035,16061,16069,16087,16093,16097,16121,16141, & - 16153,16159,16165,16183,16189,16195,16197,16201,16209,16215, & - 16225,16259,16265,16273,16299/) - poly(1108:1111)= (/ & - 16309,16355,16375,16381/) - - end if - - if ( dim_num /= dim_num_save ) then -! -! Check parameters. -! - if ( dim_num < 2 .or. dim_max < dim_num ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I4_SOBOL - Fatal error!' - write ( *, '(a)' ) ' The spatial dimension DIM_NUM should satisfy:' - write ( *, '(a,i8)' ) ' 2 <= DIM_NUM <= ', dim_max - write ( *, '(a,i8)' ) ' But this input value is DIM_NUM = ', dim_num - stop - end if - - dim_num_save = dim_num -! -! Set ATMOST = 2**LOG_MAX - 1. -! - atmost = 0 - do i = 1, log_max - atmost = 2 * atmost + 1 - end do -! -! Find the highest 1 bit in ATMOST (should be LOG_MAX). -! - maxcol = i4_bit_hi1 ( atmost ) -! -! Initialize row 1 of V. -! - v(1,1:maxcol) = 1 -! -! Initialize the remaining rows of V. -! - do i = 2, dim_num -! -! The bit pattern of the integer POLY(I) gives the form -! of polynomial I. -! -! Find the degree of polynomial I from binary encoding. -! - j = poly(i) - m = 0 - - do - - j = j / 2 - - if ( j <= 0 ) then - exit - end if - - m = m + 1 - - end do -! -! We expand this bit pattern to separate components -! of the logical array INCLUD. -! - j = poly(i) - do k = m, 1, - 1 - j2 = j / 2 - includ(k) = ( j /= ( 2 * j2 ) ) - j = j2 - end do -! -! Calculate the remaining elements of row I as explained -! in Bratley and Fox, section 2. -! - do j = m + 1, maxcol - - newv = v(i,j-m) - l = 1 - - do k = 1, m - - l = 2 * l - - if ( includ(k) ) then - newv = ieor ( newv, l * v(i,j-k) ) - end if - - end do - - v(i,j) = newv - - end do - - end do -! -! Multiply columns of V by appropriate power of 2. -! - l = 1 - do j = maxcol - 1, 1, - 1 - l = 2 * l - v(1:dim_num,j) = v(1:dim_num,j) * l - end do -! -! RECIPD is 1/(common denominator of the elements in V) = 1 / ( 2 * L ). -! - recipd = real ( l, kind = 4 ) - recipd = 0.5E+00 / recipd - - end if - - if ( seed < 0 ) then - seed = 0 - end if - - if ( seed == 0 ) then - - l = 1 - lastq(1:dim_num) = 0 - - else if ( seed == seed_save + 1 ) then -! -! Find the position of the right-hand zero in SEED. -! - l = i4_bit_lo0 ( seed ) - - else if ( seed <= seed_save ) then - - seed_save = 0 - l = 1 - lastq(1:dim_num) = 0 - - do seed_temp = seed_save, seed - 1 - l = i4_bit_lo0 ( seed_temp ) - lastq(1:dim_num) = ieor ( lastq(1:dim_num), v(1:dim_num,l) ) - end do - - l = i4_bit_lo0 ( seed ) - - else if ( seed_save+1 < seed ) then - - do seed_temp = seed_save+1, seed - 1 - l = i4_bit_lo0 ( seed_temp ) - lastq(1:dim_num) = ieor ( lastq(1:dim_num), v(1:dim_num,l) ) - end do - - l = i4_bit_lo0 ( seed ) - - end if - -! write ( *, * ) ' seed = ', seed, ' l = ', l -! -! Check that the user is not calling too many times! -! - if ( maxcol < l ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I4_SOBOL - Fatal error!' - write ( *, '(a)' ) ' Too many calls!' - write ( *, '(a,i12)' ) ' MAXCOL = ', maxcol - write ( *, '(a,i12)' ) ' L = ', l - stop - end if -! -! Calculate the new components of QUASI. -! - quasi(1:dim_num) = real ( lastq(1:dim_num), kind = 4 ) * recipd - lastq(1:dim_num) = ieor ( lastq(1:dim_num), v(1:dim_num,l) ) - - seed_save = seed - seed = seed + 1 - - return -end -subroutine i4_sobol_generate ( m, n, skip, r ) - -!*****************************************************************************80 -! -!! I4_SOBOL_GENERATE generates a Sobol dataset. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) M, the spatial dimension. -! -! Input, integer ( kind = 4 ) N, the number of points to generate. -! -! Input, integer ( kind = 4 ) SKIP, the number of initial points to skip. -! -! Output, real ( kind = 4 ) R(M,N), the points. -! - implicit none - - integer ( kind = 4 ) m - integer ( kind = 4 ) n - - integer ( kind = 4 ) j - real ( kind = 4 ), dimension ( m, n ) :: r - integer ( kind = 4 ) seed - integer ( kind = 4 ) skip - - do j = 1, n - seed = skip + j - 1 - call i4_sobol ( m, seed, r(1:m,j) ) - end do - - return -end -subroutine i4_sobol_write ( m, n, skip, r, file_out_name ) - -!*****************************************************************************80 -! -!! I4_SOBOL_WRITE writes a Sobol dataset to a file. -! -! Discussion: -! -! The initial lines of the file are comments, which begin with a -! '#' character. -! -! Thereafter, each line of the file contains the M-dimensional -! components of the SKIP+I-1 entry of the Sobol sequence. -! -! For the Sobol sequence, the value of SKIP is the same -! as the value of SEED used to generate the first point. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 17 January 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer M, the spatial dimension. -! -! Input, integer N, the number of (successive) points. -! -! Input, integer SKIP, the number of skipped points. -! -! Input, real R(M,N), the points. -! -! Input, character ( len = * ) FILE_OUT_NAME, the name of -! the output file. -! - implicit none - - integer ( kind = 4 ) m - integer ( kind = 4 ) n - - character ( len = * ) file_out_name - integer file_out_unit - integer ios - integer ( kind = 4 ) j - real ( kind = 4 ) r(m,n) - integer ( kind = 4 ) skip - character string - - call get_unit ( file_out_unit ) - - open ( unit = file_out_unit, file = file_out_name, status = 'replace', & - iostat = ios ) - - if ( ios /= 0 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I4_SOBOL_WRITE - Fatal error!' - write ( *, '(a)' ) ' Could not open the output file.' - stop - end if - - call timestring ( string ) - - write ( file_out_unit, '(a)' ) '# ' // trim ( file_out_name ) - write ( file_out_unit, '(a)' ) '# created by I4_SOBOL_WRITE.F90.' - write ( file_out_unit, '(a)' ) '#' - write ( file_out_unit, '(a)' ) '# File generated on ' & - // trim ( string ) - write ( file_out_unit, '(a)' ) '#' - write ( file_out_unit, '(a,i8)' ) '# Spatial dimension M = ', m - write ( file_out_unit, '(a,i8)' ) '# Number of points N = ', n - write ( file_out_unit, '(a,g14.6)' ) '# Epsilon (unit roundoff) = ', & - epsilon ( r(1,1) ) - write ( file_out_unit, '(a,i8)' ) '# Initial values skipped = ', skip - write ( file_out_unit, '(a)' ) '#' - - write ( string, '(a,i3,a)' ) '(', m, '(2x,f10.6))' - do j = 1, n - write ( file_out_unit, string ) r(1:m,j) - end do - - close ( unit = file_out_unit ) - - return -end -function i4_uniform ( a, b, seed ) - -!*****************************************************************************80 -! -!! I4_UNIFORM returns a scaled pseudorandom I4. -! -! Discussion: -! -! An I4 is an integer ( kind = 4 ) value. -! -! The pseudorandom number will be scaled to be uniformly distributed -! between A and B. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 November 2006 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Paul Bratley, Bennett Fox, Linus Schrage, -! A Guide to Simulation, -! Springer Verlag, pages 201-202, 1983. -! -! Pierre L'Ecuyer, -! Random Number Generation, -! in Handbook of Simulation, -! edited by Jerry Banks, -! Wiley Interscience, page 95, 1998. -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, pages 362-376, 1986. -! -! Peter Lewis, Allen Goodman, James Miller -! A Pseudo-Random Number Generator for the System/360, -! IBM Systems Journal, -! Volume 8, pages 136-143, 1969. -! -! Parameters: -! -! Input, integer ( kind = 4 ) A, B, the limits of the interval. -! -! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which -! should NOT be 0. On output, SEED has been updated. -! -! Output, integer ( kind = 4 ) I4_UNIFORM, a number between A and B. -! - implicit none - - integer ( kind = 4 ) a - integer ( kind = 4 ) b - integer ( kind = 4 ) i4_uniform - integer ( kind = 4 ) k - real ( kind = 4 ) r - integer ( kind = 4 ) seed - integer ( kind = 4 ) value - - if ( seed == 0 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I4_UNIFORM - Fatal error!' - write ( *, '(a)' ) ' Input value of SEED = 0.' - stop - end if - - k = seed / 127773 - - seed = 16807 * ( seed - k * 127773 ) - k * 2836 - - if ( seed < 0 ) then - seed = seed + 2147483647 - end if - - r = real ( seed, kind = 4 ) * 4.656612875E-10 -! -! Scale R to lie between A-0.5 and B+0.5. -! - r = ( 1.0E+00 - r ) * ( real ( min ( a, b ), kind = 4 ) - 0.5E+00 ) & - + r * ( real ( max ( a, b ), kind = 4 ) + 0.5E+00 ) -! -! Use rounding to convert R to an integer between A and B. -! - value = nint ( r, kind = 4 ) - - value = max ( value, min ( a, b ) ) - value = min ( value, max ( a, b ) ) - - i4_uniform = value - - return -end -function i4_xor ( i, j ) - -!*****************************************************************************80 -! -!! I4_XOR calculates the exclusive OR of two integers. -! -! Discussion: -! -! This function is NOT needed in FORTRAN90, which supplies the -! intrinsic IEOR function for this purpose. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 4 ) I, J, two values whose exclusive OR is needed. -! -! Output, integer ( kind = 4 ) I4_XOR, the exclusive OR of I and J. -! - implicit none - - integer ( kind = 4 ) i - integer ( kind = 4 ) i1 - integer ( kind = 4 ) i2 - integer ( kind = 4 ) i4_xor - integer ( kind = 4 ) j - integer ( kind = 4 ) j1 - integer ( kind = 4 ) j2 - integer ( kind = 4 ) k - integer ( kind = 4 ) l - - i1 = i - j1 = j - k = 0 - l = 1 - - do while ( i1 /= 0 .or. j1 /= 0 ) - - i2 = i1 / 2 - j2 = j1 / 2 - - if ( & - ( ( i1 == 2 * i2 ) .and. ( j1 /= 2 * j2 ) ) .or. & - ( ( i1 /= 2 * i2 ) .and. ( j1 == 2 * j2 ) ) ) then - k = k + l - end if - - i1 = i2 - j1 = j2 - l = 2 * l - - end do - - i4_xor = k - - return -end -function i8_bit_hi1 ( n ) - -!*****************************************************************************80 -! -!! I8_BIT_HI1 returns the position of the high 1 bit base 2 in an integer. -! -! Discussion: -! -! This routine uses the integer precision corresponding to a KIND of 8. -! -! Example: -! -! N Binary Hi 1 -! ---- -------- ---- -! 0 0 0 -! 1 1 1 -! 2 10 2 -! 3 11 2 -! 4 100 3 -! 5 101 3 -! 6 110 3 -! 7 111 3 -! 8 1000 4 -! 9 1001 4 -! 10 1010 4 -! 11 1011 4 -! 12 1100 4 -! 13 1101 4 -! 14 1110 4 -! 15 1111 4 -! 16 10000 5 -! 17 10001 5 -! 1023 1111111111 10 -! 1024 10000000000 11 -! 1025 10000000001 11 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 May 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 8 ) N, the integer to be measured. -! N should be nonnegative. If N is nonpositive, I8_BIT_HI1 -! will always be 0. -! -! Output, integer ( kind = 8 ) I8_BIT_HI1, the number of bits base 2. -! - implicit none - - integer ( kind = 8 ) :: bit - integer ( kind = 8 ) :: i8_bit_hi1 - integer ( kind = 8 ) :: i - integer ( kind = 8 ) :: n - - i = n - bit = 0 - - do - - if ( i <= 0 ) then - exit - end if - - bit = bit + 1 - i = i / 2 - - end do - - i8_bit_hi1 = bit - - return -end -function i8_bit_lo0 ( n ) - -!*****************************************************************************80 -! -!! I8_BIT_LO0 returns the position of the low 0 bit base 2 in an integer. -! -! Discussion: -! -! This routine uses the integer precision corresponding to a KIND of 8. -! -! Example: -! -! N Binary Lo 0 -! ---- -------- ---- -! 0 0 1 -! 1 1 2 -! 2 10 1 -! 3 11 3 -! 4 100 1 -! 5 101 2 -! 6 110 1 -! 7 111 4 -! 8 1000 1 -! 9 1001 2 -! 10 1010 1 -! 11 1011 3 -! 12 1100 1 -! 13 1101 2 -! 14 1110 1 -! 15 1111 5 -! 16 10000 1 -! 17 10001 2 -! 1023 1111111111 1 -! 1024 10000000000 1 -! 1025 10000000001 1 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 28 May 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 8 ) N, the integer to be measured. -! N should be nonnegative. -! -! Output, integer ( kind = 8 ) I8_BIT_LO0, the position of the low 1 bit. -! - implicit none - - integer ( kind = 8 ) :: bit - integer ( kind = 8 ) :: i - integer ( kind = 8 ) :: i2 - integer ( kind = 8 ) :: i8_bit_lo0 - integer ( kind = 8 ) :: n - - bit = 0 - i = n - - do - - bit = bit + 1 - i2 = i / 2 - - if ( i == 2 * i2 ) then - exit - end if - - i = i2 - - end do - - i8_bit_lo0 = bit - - return -end -subroutine i8_sobol ( dim_num, seed, quasi ) - -!*****************************************************************************80 -! -!! I8_SOBOL generates a new quasirandom Sobol vector with each call. -! -! Discussion: -! -! The routine adapts the ideas of Antonov and Saleev. -! -! This routine uses the integer and real precisions corresponding -! to a KIND of 8. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 25 June 2008 -! -! Author: -! -! FORTRAN77 original version by Bennett Fox -! FORTRAN90 version by John Burkardt -! -! Reference: -! -! IA Antonov, VM Saleev, -! An Economic Method of Computing LP Tau-Sequences, -! USSR Computational Mathematics and Mathematical Physics, -! Volume 19, 1980, pages 252-256. -! -! Paul Bratley, Bennett Fox, -! Algorithm 659: -! Implementing Sobol's Quasirandom Sequence Generator, -! ACM Transactions on Mathematical Software, -! Volume 14, Number 1, March 1988, pages 88-100 -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, December 1986, pages 362-376. -! -! Stephen Joe, Frances Kuo, -! Remark on Algorithm 659: -! Implementing Sobol's Quasirandom Sequence Generator, -! ACM Transactions on Mathematical Software, -! Volume 29, Number 1, March 2003, pages 49-57. -! -! Ilya Sobol, -! Uniformly Distributed Sequences with an Additional Uniform Property, -! USSR Computational Mathematics and Mathematical Physics, -! Volume 16, 1977, pages 236-242. -! -! Ilya Sobol, YL Levitan, -! The Production of Points Uniformly Distributed in a Multidimensional -! Cube (in Russian), -! Preprint IPM Akademii Nauk SSSR, -! Number 40, Moscow 1976. -! -! Parameters: -! -! Input, integer ( kind = 8 ) DIM_NUM, the number of spatial dimensions. -! DIM_NUM must satisfy 2 <= DIM_NUM <= 1111. -! -! Input/output, integer ( kind = 8 ) SEED, the "seed" for the sequence. -! This is essentially the index in the sequence of the quasirandom -! value to be generated. On output, SEED has been set to the -! appropriate next value, usually simply SEED+1. -! If SEED is less than 0 on input, it is treated as though it were 0. -! An input value of 0 requests the first (0-th) element of the sequence. -! -! Output, real ( kind = 8 ) QUASI(DIM_NUM), the next quasirandom vector. -! - implicit none - - integer ( kind = 8 ) :: dim_num - integer ( kind = 8 ), parameter :: dim_max = 1111 - integer ( kind = 8 ), parameter :: log_max = 62 - - integer ( kind = 8 ) :: atmost - integer ( kind = 8 ), save :: dim_num_save = 0 - integer ( kind = 8 ) :: i - integer ( kind = 8 ) :: i8_bit_hi1 - integer ( kind = 8 ) :: i8_bit_lo0 - integer ( kind = 8 ) :: inc - logical includ(log_max) - logical, save :: initialized = .false. - integer ( kind = 8 ) :: j - integer ( kind = 8 ) :: j2 - integer ( kind = 8 ) :: k - integer ( kind = 8 ) :: l - integer ( kind = 8 ), save, dimension(dim_max) :: lastq - integer ( kind = 8 ) :: m - integer ( kind = 8 ), save :: maxcol - integer ( kind = 8 ) :: newv - integer ( kind = 8 ), save, dimension(1:dim_max) :: poly - real ( kind = 8 ), dimension ( dim_num ) :: quasi - real ( kind = 8 ), save :: recipd - integer ( kind = 8 ) :: seed - integer ( kind = 8 ), save :: seed_save = - 1 - integer ( kind = 8 ) :: seed_temp - integer ( kind = 8 ), save, dimension(1:dim_max,1:log_max) :: v - - if ( .not. initialized .or. dim_num /= dim_num_save ) then - - initialized = .true. - - v(1:dim_max,1:log_max) = 0 -! -! Initialize (part of) V. -! - v(2:1111,1) = 1 - v(3:401,2) = (/ & - 1,3,1,3,1,3,3,1,3,1,3,1,3,1,1,3,1,3,1,3, & - 1,3,3,1,1,1,3,1,3,1,3,3,1,3,1,1,1,3,1,3,1,1,1,3,3,1,3,3,1,1, & - 3,3,1,3,3,3,1,3,1,3,1,1,3,3,1,1,1,1,3,1,1,3,1,1,1,3,3,1,3,3, & - 1,3,3,3,1,3,3,3,1,3,3,1,3,3,3,1,3,1,3,1,1,3,3,1,3,3,1,1,1,3, & - 3,1,3,3,1,3,1,1,3,3,3,1,1,1,3,1,1,3,1,1,3,3,1,3,1,3,3,3,3,1, & - 1,1,3,3,1,1,3,1,1,1,1,1,1,3,1,3,1,1,1,3,1,3,1,3,3,3,1,1,3,3, & - 1,3,1,3,1,1,3,1,3,1,3,1,3,1,1,1,3,3,1,3,3,1,3,1,1,1,3,1,3,1, & - 1,3,1,1,3,3,1,1,3,3,3,1,3,3,3,1,3,1,3,1,1,1,3,1,1,1,3,1,1,1, & - 1,1,3,3,3,1,1,1,1,3,3,3,1,3,3,1,1,1,1,3,1,1,3,1,3,3,1,1,3,3, & - 1,1,1,1,3,1,3,3,1,3,3,1,1,1,3,3,3,1,3,3,1,3,3,1,3,1,3,3,3,1, & - 3,1,1,3,1,3,1,1,1,3,3,3,1,1,3,1,3,1,1,1,1,1,1,3,1,1,3,1,3,3, & - 1,1,1,1,3,1,3,1,3,1,1,1,1,3,3,1,1,1,1,1,3,3,3,1,1,3,3,3,3,3, & - 1,3,3,1,3,3,3,3,1,1,1,1,1,1,3,1,1,3,1,1,1,3,1,1,1,3,3,3,1,3, & - 1,1,3,3,3,1,3,3,1,3,1,3,3,1,3,3,3,1,1/) - v(402:800,2) = (/ & - 3,3,1,3,1,3,1,1,1,3,3,3,3,1,3,1,1,3,1, & - 3,1,1,1,3,1,3,1,3,1,3,3,3,3,3,3,3,3,1,3,3,3,3,3,1,3,1,3,3,3, & - 1,3,1,3,1,3,3,1,3,3,3,3,3,3,3,3,3,1,1,1,1,1,1,3,3,1,1,3,3,1, & - 1,1,3,3,1,1,3,3,3,3,1,1,3,1,3,3,1,3,3,1,1,1,3,3,3,1,1,3,3,3, & - 3,3,1,1,1,3,1,3,3,1,3,3,3,3,1,1,3,1,1,3,1,3,1,3,1,3,3,1,1,3, & - 3,1,3,3,1,3,3,1,1,3,1,3,3,1,1,3,1,3,1,3,1,1,3,3,1,1,1,3,3,1, & - 3,1,1,3,3,1,1,3,1,3,1,1,1,1,1,3,1,1,1,1,3,1,3,1,1,3,3,1,1,3, & - 1,3,1,3,3,3,1,3,3,3,1,1,3,3,3,1,1,1,1,3,1,3,1,3,1,1,3,3,1,1, & - 1,3,3,1,3,1,3,1,1,1,1,1,1,3,1,3,3,1,3,3,3,1,3,1,1,3,3,1,1,3, & - 3,1,1,1,3,1,3,3,1,1,3,1,1,3,1,3,1,1,1,3,3,3,3,1,1,3,3,1,1,1, & - 1,3,1,1,3,3,3,1,1,3,3,1,3,3,1,1,3,3,3,3,3,3,3,1,3,3,1,3,1,3, & - 1,1,3,3,1,1,1,3,1,3,3,1,3,3,1,3,1,1,3,3,3,1,1,1,3,1,1,1,3,3, & - 3,1,3,3,1,3,1,1,3,3,3,1,3,3,1,1,1,3,1,3,3,3,3,3,3,3,3,1,3,3, & - 1,3,1,1,3,3,3,1,3,3,3,3,3,1,3,3,3,1,1,1/) - v(801:1111,2) = (/ & - 3,3,1,3,3,1,3,1,3,1,3,1,3,3,3,3,3,3, & - 1,1,3,1,3,1,1,1,1,1,3,1,1,1,3,1,3,1,1,3,3,3,1,3,1,3,1,1,3,1, & - 3,3,1,3,1,3,3,1,3,3,1,3,3,3,3,3,3,1,3,1,1,3,3,3,1,1,3,3,3,3, & - 3,3,3,1,3,3,3,3,1,3,1,3,3,3,1,3,1,3,1,1,1,3,3,1,3,1,1,3,3,1, & - 3,1,1,1,1,3,1,3,1,1,3,1,3,1,3,3,3,3,3,3,1,3,3,3,3,1,3,3,1,3, & - 3,3,3,3,1,1,1,1,3,3,3,1,3,3,1,1,3,3,1,1,3,3,1,3,1,1,3,1,3,3, & - 3,3,3,1,3,1,1,3,3,3,3,1,3,1,1,3,3,3,3,3,3,1,1,3,1,3,1,1,3,1, & - 1,1,1,3,3,1,1,3,1,1,1,3,1,3,1,1,3,3,1,3,1,1,3,3,3,3,3,1,3,1, & - 1,1,3,1,1,1,3,1,1,3,1,3,3,3,3,3,1,1,1,3,3,3,3,1,3,3,3,3,1,1, & - 3,3,3,1,3,1,1,3,3,1,3,3,1,1,1,1,1,3,1,1,3,3,1,1,1,3,1,1,3,3, & - 1,3,3,3,3,3,3,3,3,1,1,3,3,1,1,3,1,3,3,3,3,3,1/) - v(4:402,3) = (/ & - 7,5,1,3,3,7,5,5,7,7,1,3,3,7,5,1,1,5,3,7, & - 1,7,5,1,3,7,7,1,1,1,5,7,7,5,1,3,3,7,5,5,5,3,3,3,1,1,5,1,1,5, & - 3,3,3,3,1,3,7,5,7,3,7,1,3,3,5,1,3,5,5,7,7,7,1,1,3,3,1,1,5,1, & - 5,7,5,1,7,5,3,3,1,5,7,1,7,5,1,7,3,1,7,1,7,3,3,5,7,3,3,5,1,3, & - 3,1,3,5,1,3,3,3,7,1,1,7,3,1,3,7,5,5,7,5,5,3,1,3,3,3,1,3,3,7, & - 3,3,1,7,5,1,7,7,5,7,5,1,3,1,7,3,7,3,5,7,3,1,3,3,3,1,5,7,3,3, & - 7,7,7,5,3,1,7,1,3,7,5,3,3,3,7,1,1,3,1,5,7,1,3,5,3,5,3,3,7,5, & - 5,3,3,1,3,7,7,7,1,5,7,1,3,1,1,7,1,3,1,7,1,5,3,5,3,1,1,5,5,3, & - 3,5,7,1,5,3,7,7,3,5,3,3,1,7,3,1,3,5,7,1,3,7,1,5,1,3,1,5,3,1, & - 7,1,5,5,5,3,7,1,1,7,3,1,1,7,5,7,5,7,7,3,7,1,3,7,7,3,5,1,1,7, & - 1,5,5,5,1,5,1,7,5,5,7,1,1,7,1,7,7,1,1,3,3,3,7,7,5,3,7,3,1,3, & - 7,5,3,3,5,7,1,1,5,5,7,7,1,1,1,1,5,5,5,7,5,7,1,1,3,5,1,3,3,7, & - 3,7,5,3,5,3,1,7,1,7,7,1,1,7,7,7,5,5,1,1,7,5,5,7,5,1,1,5,5,5, & - 5,5,5,1,3,1,5,7,3,3,5,7,3,7,1,7,7,1,3/) - v(403:801,3) = (/ & - 5,1,5,5,3,7,3,7,7,5,7,5,7,1,1,5,3,5,1, & - 5,3,7,1,5,7,7,3,5,1,3,5,1,5,3,3,3,7,3,5,1,3,7,7,3,7,5,3,3,1, & - 7,5,1,1,3,7,1,7,1,7,3,7,3,5,7,3,5,3,1,1,1,5,7,7,3,3,1,1,1,5, & - 5,7,3,1,1,3,3,7,3,3,5,1,3,7,3,3,7,3,5,7,5,7,7,3,3,5,1,3,5,3, & - 1,3,5,1,1,3,7,7,1,5,1,3,7,3,7,3,5,1,7,1,1,3,5,3,7,1,5,5,1,1, & - 3,1,3,3,7,1,7,3,1,7,3,1,7,3,5,3,5,7,3,3,3,5,1,7,7,1,3,1,3,7, & - 7,1,3,7,3,1,5,3,1,1,1,5,3,3,7,1,5,3,5,1,3,1,3,1,5,7,7,1,1,5, & - 3,1,5,1,1,7,7,3,5,5,1,7,1,5,1,1,3,1,5,7,5,7,7,1,5,1,1,3,5,1, & - 5,5,3,1,3,1,5,5,3,3,3,3,1,1,3,1,3,5,5,7,5,5,7,5,7,1,3,7,7,3, & - 5,5,7,5,5,3,3,3,1,7,1,5,5,5,3,3,5,1,3,1,3,3,3,7,1,7,7,3,7,1, & - 1,5,7,1,7,1,7,7,1,3,7,5,1,3,5,5,5,1,1,7,1,7,1,7,7,3,1,1,5,1, & - 5,1,5,3,5,5,5,5,5,3,3,7,3,3,5,5,3,7,1,5,7,5,1,5,5,3,5,5,7,5, & - 3,5,5,5,1,5,5,5,5,1,3,5,3,1,7,5,5,7,1,5,3,3,1,5,3,7,1,7,5,1, & - 1,3,1,1,7,1,5,5,3,7,3,7,5,3,1,1,3,1,3,5/) - v(802:1111,3) = (/ & - 5,7,5,3,7,7,7,3,7,3,7,1,3,1,7,7,1,7, & - 3,7,3,7,3,7,3,5,1,1,7,3,1,5,5,7,1,5,5,5,7,1,5,5,1,5,5,3,1,3, & - 1,7,3,1,3,5,7,7,7,1,1,7,3,1,5,5,5,1,1,1,1,1,5,3,5,1,3,5,3,1, & - 1,1,1,3,7,3,7,5,7,1,5,5,7,5,3,3,7,5,3,1,1,3,1,3,1,1,3,7,1,7, & - 1,1,5,1,7,5,3,7,3,5,3,1,1,5,5,1,7,7,3,7,3,7,1,5,1,5,3,7,3,5, & - 7,7,7,3,3,1,1,5,5,3,7,1,1,1,3,5,3,1,1,3,3,7,5,1,1,3,7,1,5,7, & - 3,7,5,5,7,3,5,3,1,5,3,1,1,7,5,1,7,3,7,5,1,7,1,7,7,1,1,7,1,5, & - 5,1,1,7,5,7,1,5,3,5,3,3,7,1,5,1,1,5,5,3,3,7,5,5,1,1,1,3,1,5, & - 7,7,1,7,5,7,3,7,3,1,3,7,3,1,5,5,3,5,1,3,5,5,5,1,1,7,7,1,5,5, & - 1,3,5,1,5,3,5,3,3,7,5,7,3,7,3,1,3,7,7,3,3,1,1,3,3,3,3,3,5,5, & - 3,3,3,1,3,5,7,7,1,5,7,3,7,1,1,3,5,7,5,3,3,3/) - v(6:357,4) = (/ & - 1,7,9,13,11,1,3,7,9,5,13,13,11,3,15,5,3, & - 15,7,9,13,9,1,11,7,5,15,1,15,11,5,11,1,7,9,7,7,1,15,15,15,13, & - 3,3,15,5,9,7,13,3,7,5,11,9,1,9,1,5,7,13,9,9,1,7,3,5,1,11,11, & - 13,7,7,9,9,1,1,3,9,15,1,5,13,1,9,9,9,9,9,13,11,3,5,11,11,13, & - 5,3,15,1,11,11,7,13,15,11,13,9,11,15,15,13,3,15,7,9,11,13,11, & - 9,9,5,13,9,1,13,7,7,7,7,7,5,9,7,13,11,9,11,15,3,13,11,1,11,3, & - 3,9,11,1,7,1,15,15,3,1,9,1,7,13,11,3,13,11,7,3,3,5,13,11,5, & - 11,1,3,9,7,15,7,5,13,7,9,13,15,13,9,7,15,7,9,5,11,11,13,13,9, & - 3,5,13,9,11,15,11,7,1,7,13,3,13,3,13,9,15,7,13,13,3,13,15,15, & - 11,9,13,9,15,1,1,15,11,11,7,1,11,13,9,13,3,5,11,13,9,9,13,1, & - 11,15,13,3,13,7,15,1,15,3,3,11,7,13,7,7,9,7,5,15,9,5,5,7,15, & - 13,15,5,15,5,3,1,11,7,1,5,7,9,3,11,1,15,1,3,15,11,13,5,13,1, & - 7,1,15,7,5,1,1,15,13,11,11,13,5,11,7,9,7,1,5,3,9,5,5,11,5,1, & - 7,1,11,7,9,13,15,13,3,1,11,13,15,1,1,11,9,13,3,13,11,15,13,9, & - 9,9,5,5,5,5,1,15,5,9/) - v(358:710,4) = (/ & - 11,7,15,5,3,13,5,3,11,5,1,11,13,9,11, & - 3,7,13,15,1,7,11,1,13,1,15,1,9,7,3,9,11,1,9,13,13,3,11,7,9,1, & - 7,15,9,1,5,13,5,11,3,9,15,11,13,5,1,7,7,5,13,7,7,9,5,11,11,1, & - 1,15,3,13,9,13,9,9,11,5,5,13,15,3,9,15,3,11,11,15,15,3,11,15, & - 15,3,1,3,1,3,3,1,3,13,1,11,5,15,7,15,9,1,7,1,9,11,15,1,13,9, & - 13,11,7,3,7,3,13,7,9,7,7,3,3,9,9,7,5,11,13,13,7,7,15,9,5,5,3, & - 3,13,3,9,3,1,11,1,3,11,15,11,11,11,9,13,7,9,15,9,11,1,3,3,9, & - 7,15,13,13,7,15,9,13,9,15,13,15,9,13,1,11,7,11,3,13,5,1,7,15, & - 3,13,7,13,13,11,3,5,3,13,11,9,9,3,11,11,7,9,13,11,7,15,13,7, & - 5,3,1,5,15,15,3,11,1,7,3,15,11,5,5,3,5,5,1,15,5,1,5,3,7,5,11, & - 3,13,9,13,15,5,3,5,9,5,3,11,1,13,9,15,3,5,11,9,1,3,15,9,9,9, & - 11,7,5,13,1,15,3,13,9,13,5,1,5,1,13,13,7,7,1,9,5,11,9,11,13, & - 3,15,15,13,15,7,5,7,9,7,9,9,9,11,9,3,11,15,13,13,5,9,15,1,1, & - 9,5,13,3,13,15,3,1,3,11,13,1,15,9,9,3,1,9,1,9,1,13,11,15,7, & - 11,15,13,15,1,9,9,7/) - v(711:1065,4) = (/ & - 3,5,11,7,3,9,5,15,7,5,3,13,7,1,1,9, & - 15,15,15,11,3,5,15,13,7,15,15,11,11,9,5,15,9,7,3,13,1,1,5,1, & - 3,1,7,1,1,5,1,11,11,9,9,5,13,7,7,7,1,1,9,9,11,11,15,7,5,5,3, & - 11,1,3,7,13,7,7,7,3,15,15,11,9,3,9,3,15,13,5,3,3,3,5,9,15,9, & - 9,1,5,9,9,15,5,15,7,9,1,9,9,5,11,5,15,15,11,7,7,7,1,1,11,11, & - 13,15,3,13,5,1,7,1,11,3,13,15,3,5,3,5,7,3,9,9,5,1,7,11,9,3,5, & - 11,13,13,13,9,15,5,7,1,15,11,9,15,15,13,13,13,1,11,9,15,9,5, & - 15,5,7,3,11,3,15,7,13,11,7,3,7,13,5,13,15,5,13,9,1,15,11,5,5, & - 1,11,3,3,7,1,9,7,15,9,9,3,11,15,7,1,3,1,1,1,9,1,5,15,15,7,5, & - 5,7,9,7,15,13,13,11,1,9,11,1,13,1,7,15,15,5,5,1,11,3,9,11,9, & - 9,9,1,9,3,5,15,1,1,9,7,3,3,1,9,9,11,9,9,13,13,3,13,11,13,5,1, & - 5,5,9,9,3,13,13,9,15,9,11,7,11,9,13,9,1,15,9,7,7,1,7,9,9,15, & - 1,11,1,13,13,15,9,13,7,15,3,9,3,1,13,7,5,9,3,1,7,1,1,13,3,3, & - 11,1,7,13,15,15,5,7,13,13,15,11,13,1,13,13,3,9,15,15,11,15,9, & - 15,1,13,15,1,1,5/) - v(1066:1111,4) = (/ & - 11,5,1,11,11,5,3,9,1,3,5,13,9,7,7,1, & - 9,9,15,7,5,5,15,13,9,7,13,3,13,11,13,7,9,13,13,13,15,9,5,5,3, & - 3,3,1,3,15/) - v(8:331,5) = (/ & - 9,3,27,15,29,21,23,19,11,25,7,13,17,1, & - 25,29,3,31,11,5,23,27,19,21,5,1,17,13,7,15,9,31,25,3,5,23,7, & - 3,17,23,3,3,21,25,25,23,11,19,3,11,31,7,9,5,17,23,17,17,25, & - 13,11,31,27,19,17,23,7,5,11,19,19,7,13,21,21,7,9,11,1,5,21, & - 11,13,25,9,7,7,27,15,25,15,21,17,19,19,21,5,11,3,5,29,31,29, & - 5,5,1,31,27,11,13,1,3,7,11,7,3,23,13,31,17,1,27,11,25,1,23, & - 29,17,25,7,25,27,17,13,17,23,5,17,5,13,11,21,5,11,5,9,31,19, & - 17,9,9,27,21,15,15,1,1,29,5,31,11,17,23,19,21,25,15,11,5,5,1, & - 19,19,19,7,13,21,17,17,25,23,19,23,15,13,5,19,25,9,7,3,21,17, & - 25,1,27,25,27,25,9,13,3,17,25,23,9,25,9,13,17,17,3,15,7,7,29, & - 3,19,29,29,19,29,13,15,25,27,1,3,9,9,13,31,29,31,5,15,29,1, & - 19,5,9,19,5,15,3,5,7,15,17,17,23,11,9,23,19,3,17,1,27,9,9,17, & - 13,25,29,23,29,11,31,25,21,29,19,27,31,3,5,3,3,13,21,9,29,3, & - 17,11,11,9,21,19,7,17,31,25,1,27,5,15,27,29,29,29,25,27,25,3, & - 21,17,25,13,15,17,13,23,9,3,11,7,9,9,7,17,7,1/) - v(332:654,5) = (/ & - 27,1,9,5,31,21,25,25,21,11,1,23,19,27, & - 15,3,5,23,9,25,7,29,11,9,13,5,11,1,3,31,27,3,17,27,11,13,15, & - 29,15,1,15,23,25,13,21,15,3,29,29,5,25,17,11,7,15,5,21,7,31, & - 13,11,23,5,7,23,27,21,29,15,7,27,27,19,7,15,27,27,19,19,9,15, & - 1,3,29,29,5,27,31,9,1,7,3,19,19,29,9,3,21,31,29,25,1,3,9,27, & - 5,27,25,21,11,29,31,27,21,29,17,9,17,13,11,25,15,21,11,19,31, & - 3,19,5,3,3,9,13,13,3,29,7,5,9,23,13,21,23,21,31,11,7,7,3,23, & - 1,23,5,9,17,21,1,17,29,7,5,17,13,25,17,9,19,9,5,7,21,19,13,9, & - 7,3,9,3,15,31,29,29,25,13,9,21,9,31,7,15,5,31,7,15,27,25,19, & - 9,9,25,25,23,1,9,7,11,15,19,15,27,17,11,11,31,13,25,25,9,7, & - 13,29,19,5,19,31,25,13,25,15,5,9,29,31,9,29,27,25,27,11,17,5, & - 17,3,23,15,9,9,17,17,31,11,19,25,13,23,15,25,21,31,19,3,11, & - 25,7,15,19,7,5,3,13,13,1,23,5,25,11,25,15,13,21,11,23,29,5, & - 17,27,9,19,15,5,29,23,19,1,27,3,23,21,19,27,11,17,13,27,11, & - 31,23,5,9,21,31,29,11,21,17,15,7,15,7,9,21,27,25/) - v(655:975,5) = (/ & - 29,11,3,21,13,23,19,27,17,29,25,17,9, & - 1,19,23,5,23,1,17,17,13,27,23,7,7,11,13,17,13,11,21,13,23,1, & - 27,13,9,7,1,27,29,5,13,25,21,3,31,15,13,3,19,13,1,27,15,17,1, & - 3,13,13,13,31,29,27,7,7,21,29,15,17,17,21,19,17,3,15,5,27,27, & - 3,31,31,7,21,3,13,11,17,27,25,1,9,7,29,27,21,23,13,25,29,15, & - 17,29,9,15,3,21,15,17,17,31,9,9,23,19,25,3,1,11,27,29,1,31, & - 29,25,29,1,23,29,25,13,3,31,25,5,5,11,3,21,9,23,7,11,23,11,1, & - 1,3,23,25,23,1,23,3,27,9,27,3,23,25,19,29,29,13,27,5,9,29,29, & - 13,17,3,23,19,7,13,3,19,23,5,29,29,13,13,5,19,5,17,9,11,11, & - 29,27,23,19,17,25,13,1,13,3,11,1,17,29,1,13,17,9,17,21,1,11, & - 1,1,25,5,7,29,29,19,19,1,29,13,3,1,31,15,13,3,1,11,19,5,29, & - 13,29,23,3,1,31,13,19,17,5,5,1,29,23,3,19,25,19,27,9,27,13, & - 15,29,23,13,25,25,17,19,17,15,27,3,25,17,27,3,27,31,23,13,31, & - 11,15,7,21,19,27,19,21,29,7,31,13,9,9,7,21,13,11,9,11,29,19, & - 11,19,21,5,29,13,7,19,19,27,23,31,1,27,21,7,3,7,11/) - v(976:1111,5) = (/ & - 23,13,29,11,31,19,1,5,5,11,5,3,27,5, & - 7,11,31,1,27,31,31,23,5,21,27,9,25,3,15,19,1,19,9,5,25,21,15, & - 25,29,15,21,11,19,15,3,7,13,11,25,17,1,5,31,13,29,23,9,5,29, & - 7,17,27,7,17,31,9,31,9,9,7,21,3,3,3,9,11,21,11,31,9,25,5,1, & - 31,13,29,9,29,1,11,19,7,27,13,31,7,31,7,25,23,21,29,11,11,13, & - 11,27,1,23,31,21,23,21,19,31,5,31,25,25,19,17,11,25,7,13,1, & - 29,17,23,15,7,29,17,13,3,17/) - v(14:324,6) = (/ & - 37,33,7,5,11,39,63,59,17,15,23,29,3,21, & - 13,31,25,9,49,33,19,29,11,19,27,15,25,63,55,17,63,49,19,41, & - 59,3,57,33,49,53,57,57,39,21,7,53,9,55,15,59,19,49,31,3,39,5, & - 5,41,9,19,9,57,25,1,15,51,11,19,61,53,29,19,11,9,21,19,43,13, & - 13,41,25,31,9,11,19,5,53,37,7,51,45,7,7,61,23,45,7,59,41,1, & - 29,61,37,27,47,15,31,35,31,17,51,13,25,45,5,5,33,39,5,47,29, & - 35,47,63,45,37,47,59,21,59,33,51,9,27,13,25,43,3,17,21,59,61, & - 27,47,57,11,17,39,1,63,21,59,17,13,31,3,31,7,9,27,37,23,31,9, & - 45,43,31,63,21,39,51,27,7,53,11,1,59,39,23,49,23,7,55,59,3, & - 19,35,13,9,13,15,23,9,7,43,55,3,19,9,27,33,27,49,23,47,19,7, & - 11,55,27,35,5,5,55,35,37,9,33,29,47,25,11,47,53,61,59,3,53, & - 47,5,19,59,5,47,23,45,53,3,49,61,47,39,29,17,57,5,17,31,23, & - 41,39,5,27,7,29,29,33,31,41,31,29,17,29,29,9,9,31,27,53,35,5, & - 61,1,49,13,57,29,5,21,43,25,57,49,37,27,11,61,37,49,5,63,63, & - 3,45,37,63,21,21,19,27,59,21,45,23,13,15,3,43,63,39,19/) - v(325:632,6) = (/ & - 63,31,41,41,15,43,63,53,1,63,31,7,17, & - 11,61,31,51,37,29,59,25,63,59,47,15,27,19,29,45,35,55,39,19, & - 43,21,19,13,17,51,37,5,33,35,49,25,45,1,63,47,9,63,15,25,25, & - 15,41,13,3,19,51,49,37,25,49,13,53,47,23,35,29,33,21,35,23,3, & - 43,31,63,9,1,61,43,3,11,55,11,35,1,63,35,49,19,45,9,57,51,1, & - 47,41,9,11,37,19,55,23,55,55,13,7,47,37,11,43,17,3,25,19,55, & - 59,37,33,43,1,5,21,5,63,49,61,21,51,15,19,43,47,17,9,53,45, & - 11,51,25,11,25,47,47,1,43,29,17,31,15,59,27,63,11,41,51,29,7, & - 27,63,31,43,3,29,39,3,59,59,1,53,63,23,63,47,51,23,61,39,47, & - 21,39,15,3,9,57,61,39,37,21,51,1,23,43,27,25,11,13,21,43,7, & - 11,33,55,1,37,35,27,61,39,5,19,61,61,57,59,21,59,61,57,25,55, & - 27,31,41,33,63,19,57,35,13,63,35,17,11,11,49,41,55,5,45,17, & - 35,5,31,31,37,17,45,51,1,39,49,55,19,41,13,5,51,5,49,1,21,13, & - 17,59,51,11,3,61,1,33,37,33,61,25,27,59,7,49,13,63,3,33,3,15, & - 9,13,35,39,11,59,59,1,57,11,5,57,13,31,13,11,55,45,9,55,55/) - v(633:942,6) = (/ & - 19,25,41,23,45,29,63,59,27,39,21,37,7, & - 61,49,35,39,9,29,7,25,23,57,5,19,15,33,49,37,25,17,45,29,15, & - 25,3,3,49,11,39,15,19,57,39,15,11,3,57,31,55,61,19,5,41,35, & - 59,61,39,41,53,53,63,31,9,59,13,35,55,41,49,5,41,25,27,43,5, & - 5,43,5,5,17,5,15,27,29,17,9,3,55,31,1,45,45,13,57,17,3,61,15, & - 49,15,47,9,37,45,9,51,61,21,33,11,21,63,63,47,57,61,49,9,59, & - 19,29,21,23,55,23,43,41,57,9,39,27,41,35,61,29,57,63,21,31, & - 59,35,49,3,49,47,49,33,21,19,21,35,11,17,37,23,59,13,37,35, & - 55,57,1,29,45,11,1,15,9,33,19,53,43,39,23,7,13,13,1,19,41,55, & - 1,13,15,59,55,15,3,57,37,31,17,1,3,21,29,25,55,9,37,33,53,41, & - 51,19,57,13,63,43,19,7,13,37,33,19,15,63,51,11,49,23,57,47, & - 51,15,53,41,1,15,37,61,11,35,29,33,23,55,11,59,19,61,61,45, & - 13,49,13,63,5,61,5,31,17,61,63,13,27,57,1,21,5,11,39,57,51, & - 53,39,25,41,39,37,23,31,25,33,17,57,29,27,23,47,41,29,19,47, & - 41,25,5,51,43,39,29,7,31,45,51,49,55,17,43,49,45,9,29,3,5,47, & - 9,15,19/) - v(943:1111,6) = (/ & - 51,45,57,63,9,21,59,3,9,13,45,23,15, & - 31,21,15,51,35,9,11,61,23,53,29,51,45,31,29,5,35,29,53,35,17, & - 59,55,27,51,59,27,47,15,29,37,7,49,55,5,19,45,29,19,57,33,53, & - 45,21,9,3,35,29,43,31,39,3,45,1,41,29,5,59,41,33,35,27,19,13, & - 25,27,43,33,35,17,17,23,7,35,15,61,61,53,5,15,23,11,13,43,55, & - 47,25,43,15,57,45,1,49,63,57,15,31,31,7,53,27,15,47,23,7,29, & - 53,47,9,53,3,25,55,45,63,21,17,23,31,27,27,43,63,55,63,45,51, & - 15,27,5,37,43,11,27,5,27,59,21,7,39,27,63,35,47,55,17,17,17, & - 3,19,21,13,49,61,39,15/) - v(20:305,7) = (/ & - 13,33,115,41,79,17,29,119,75,73,105,7, & - 59,65,21,3,113,61,89,45,107,21,71,79,19,71,61,41,57,121,87, & - 119,55,85,121,119,11,23,61,11,35,33,43,107,113,101,29,87,119, & - 97,29,17,89,5,127,89,119,117,103,105,41,83,25,41,55,69,117, & - 49,127,29,1,99,53,83,15,31,73,115,35,21,89,5,1,91,53,35,95, & - 83,19,85,55,51,101,33,41,55,45,95,61,27,37,89,75,57,61,15, & - 117,15,21,27,25,27,123,39,109,93,51,21,91,109,107,45,15,93, & - 127,3,53,81,79,107,79,87,35,109,73,35,83,107,1,51,7,59,33, & - 115,43,111,45,121,105,125,87,101,41,95,75,1,57,117,21,27,67, & - 29,53,117,63,1,77,89,115,49,127,15,79,81,29,65,103,33,73,79, & - 29,21,113,31,33,107,95,111,59,99,117,63,63,99,39,9,35,63,125, & - 99,45,93,33,93,9,105,75,51,115,11,37,17,41,21,43,73,19,93,7, & - 95,81,93,79,81,55,9,51,63,45,89,73,19,115,39,47,81,39,5,5,45, & - 53,65,49,17,105,13,107,5,5,19,73,59,43,83,97,115,27,1,69,103, & - 3,99,103,63,67,25,121,97,77,13,83,103,41,11,27,81,37,33,125, & - 71,41,41,59,41,87,123/) - v(306:589,7) = (/ & - 43,101,63,45,39,21,97,15,97,111,21,49, & - 13,17,79,91,65,105,75,1,45,67,83,107,125,87,15,81,95,105,65, & - 45,59,103,23,103,99,67,99,47,117,71,89,35,53,73,9,115,49,37, & - 1,35,9,45,81,19,127,17,17,105,89,49,101,7,37,33,11,95,95,17, & - 111,105,41,115,5,69,101,27,27,101,103,53,9,21,43,79,91,65, & - 117,87,125,55,45,63,85,83,97,45,83,87,113,93,95,5,17,77,77, & - 127,123,45,81,85,121,119,27,85,41,49,15,107,21,51,119,11,87, & - 101,115,63,63,37,121,109,7,43,69,19,77,49,71,59,35,7,13,55, & - 101,127,103,85,109,29,61,67,21,111,67,23,57,75,71,101,123,41, & - 107,101,107,125,27,47,119,41,19,127,33,31,109,7,91,91,39,125, & - 105,47,125,123,91,9,103,45,23,117,9,125,73,11,37,61,79,21,5, & - 47,117,67,53,85,33,81,121,47,61,51,127,29,65,45,41,95,57,73, & - 33,117,61,111,59,123,65,47,105,23,29,107,37,81,67,29,115,119, & - 75,73,99,103,7,57,45,61,95,49,101,101,35,47,119,39,67,31,103, & - 7,61,127,87,3,35,29,73,95,103,71,75,51,87,57,97,11,105,87,41, & - 73,109,69,35,121,39,111,1,77/) - v(590:875,7) = (/ & - 39,47,53,91,3,17,51,83,39,125,85,111, & - 21,69,85,29,55,11,117,1,47,17,65,63,47,117,17,115,51,25,33, & - 123,123,83,51,113,95,121,51,91,109,43,55,35,55,87,33,37,5,3, & - 45,21,105,127,35,17,35,37,97,97,21,77,123,17,89,53,105,75,25, & - 125,13,47,21,125,23,55,63,61,5,17,93,57,121,69,73,93,121,105, & - 75,91,67,95,75,9,69,97,99,93,11,53,19,73,5,33,79,107,65,69, & - 79,125,25,93,55,61,17,117,69,97,87,111,37,93,59,79,95,53,115, & - 53,85,85,65,59,23,75,21,67,27,99,79,27,3,95,27,69,19,75,47, & - 59,41,85,77,99,55,49,93,93,119,51,125,63,13,15,45,61,19,105, & - 115,17,83,7,7,11,61,37,63,89,95,119,113,67,123,91,33,37,99, & - 43,11,33,65,81,79,81,107,63,63,55,89,91,25,93,101,27,55,75, & - 121,79,43,125,73,27,109,35,21,71,113,89,59,95,41,45,113,119, & - 113,39,59,73,15,13,59,67,121,27,7,105,15,59,59,35,91,89,23, & - 125,97,53,41,91,111,29,31,3,103,61,71,35,7,119,29,45,49,111, & - 41,109,59,125,13,27,19,79,9,75,83,81,33,91,109,33,29,107,111, & - 101,107,109,65,59,43,37/) - v(876:1111,7) = (/ & - 1,9,15,109,37,111,113,119,79,73,65, & - 71,93,17,101,87,97,43,23,75,109,41,49,53,31,97,105,109,119, & - 51,9,53,113,97,73,89,79,49,61,105,13,99,53,71,7,87,21,101,5, & - 71,31,123,121,121,73,79,115,13,39,101,19,37,51,83,97,55,81, & - 91,127,105,89,63,47,49,75,37,77,15,49,107,23,23,35,19,69,17, & - 59,63,73,29,125,61,65,95,101,81,57,69,83,37,11,37,95,1,73,27, & - 29,57,7,65,83,99,69,19,103,43,95,25,19,103,41,125,97,71,105, & - 83,83,61,39,9,45,117,63,31,5,117,67,125,41,117,43,77,97,15, & - 29,5,59,25,63,87,39,39,77,85,37,81,73,89,29,125,109,21,23, & - 119,105,43,93,97,15,125,29,51,69,37,45,31,75,109,119,53,5, & - 101,125,121,35,29,7,63,17,63,13,69,15,105,51,127,105,9,57,95, & - 59,109,35,49,23,33,107,55,33,57,79,73,69,59,107,55,11,63,95, & - 103,23,125,91,31,91,51,65,61,75,69,107,65,101,59,35,15/) - v(38:299,8) = (/ & - 7,23,39,217,141,27,53,181,169,35,15, & - 207,45,247,185,117,41,81,223,151,81,189,61,95,185,23,73,113, & - 239,85,9,201,83,53,183,203,91,149,101,13,111,239,3,205,253, & - 247,121,189,169,179,197,175,217,249,195,95,63,19,7,5,75,217, & - 245,111,189,165,169,141,221,249,159,253,207,249,219,23,49, & - 127,237,5,25,177,37,103,65,167,81,87,119,45,79,143,57,79,187, & - 143,183,75,97,211,149,175,37,135,189,225,241,63,33,43,13,73, & - 213,57,239,183,117,21,29,115,43,205,223,15,3,159,51,101,127, & - 99,239,171,113,171,119,189,245,201,27,185,229,105,153,189,33, & - 35,137,77,97,17,181,55,197,201,155,37,197,137,223,25,179,91, & - 23,235,53,253,49,181,249,53,173,97,247,67,115,103,159,239,69, & - 173,217,95,221,247,97,91,123,223,213,129,181,87,239,85,89, & - 249,141,39,57,249,71,101,159,33,137,189,71,253,205,171,13, & - 249,109,131,199,189,179,31,99,113,41,173,23,189,197,3,135,9, & - 95,195,27,183,1,123,73,53,99,197,59,27,101,55,193,31,61,119, & - 11,7,255,233,53,157,193,97,83,65,81,239,167,69,71,109/) - v(300:559,8) = (/ & - 97,137,71,193,189,115,79,205,37,227, & - 53,33,91,229,245,105,77,229,161,103,93,13,161,229,223,69,15, & - 25,23,233,93,25,217,247,61,75,27,9,223,213,55,197,145,89,199, & - 41,201,5,149,35,119,183,53,11,13,3,179,229,43,55,187,233,47, & - 133,91,47,71,93,105,145,45,255,221,115,175,19,129,5,209,197, & - 57,177,115,187,119,77,211,111,33,113,23,87,137,41,7,83,43, & - 121,145,5,219,27,11,111,207,55,97,63,229,53,33,149,23,187, & - 153,91,193,183,59,211,93,139,59,179,163,209,77,39,111,79,229, & - 85,237,199,137,147,25,73,121,129,83,87,93,205,167,53,107,229, & - 213,95,219,109,175,13,209,97,61,147,19,13,123,73,35,141,81, & - 19,171,255,111,107,233,113,133,89,9,231,95,69,33,1,253,219, & - 253,247,129,11,251,221,153,35,103,239,7,27,235,181,5,207,53, & - 149,155,225,165,137,155,201,97,245,203,47,39,35,105,239,49, & - 15,253,7,237,213,55,87,199,27,175,49,41,229,85,3,149,179,129, & - 185,249,197,15,97,197,139,203,63,33,251,217,199,199,99,249, & - 33,229,177,13,209,147,97,31,125,177,137/) - v(560:819,8) = (/ & - 187,11,91,223,29,169,231,59,31,163,41, & - 57,87,247,25,127,101,207,187,73,61,105,27,91,171,243,33,3,1, & - 21,229,93,71,61,37,183,65,211,53,11,151,165,47,5,129,79,101, & - 147,169,181,19,95,77,139,197,219,97,239,183,143,9,13,209,23, & - 215,53,137,203,19,151,171,133,219,231,3,15,253,225,33,111, & - 183,213,169,119,111,15,201,123,121,225,113,113,225,161,165,1, & - 139,55,3,93,217,193,97,29,69,231,161,93,69,143,137,9,87,183, & - 113,183,73,215,137,89,251,163,41,227,145,57,81,57,11,135,145, & - 161,175,159,25,55,167,157,211,97,247,249,23,129,159,71,197, & - 127,141,219,5,233,131,217,101,131,33,157,173,69,207,239,81, & - 205,11,41,169,65,193,77,201,173,1,221,157,1,15,113,147,137, & - 205,225,73,45,49,149,113,253,99,17,119,105,117,129,243,75, & - 203,53,29,247,35,247,171,31,199,213,29,251,7,251,187,91,11, & - 149,13,205,37,249,137,139,9,7,113,183,205,187,39,3,79,155, & - 227,89,185,51,127,63,83,41,133,183,181,127,19,255,219,59,251, & - 3,187,57,217,115,217,229,181,185,149,83,115,11/) - v(820:1074,8) = (/ & - 123,19,109,165,103,123,219,129,155, & - 207,177,9,49,181,231,33,233,67,155,41,9,95,123,65,117,249,85, & - 169,129,241,173,251,225,147,165,69,81,239,95,23,83,227,249, & - 143,171,193,9,21,57,73,97,57,29,239,151,159,191,47,51,1,223, & - 251,251,151,41,119,127,131,33,209,123,53,241,25,31,183,107, & - 25,115,39,11,213,239,219,109,185,35,133,123,185,27,55,245,61, & - 75,205,213,169,163,63,55,49,83,195,51,31,41,15,203,41,63,127, & - 161,5,143,7,199,251,95,75,101,15,43,237,197,117,167,155,21, & - 83,205,255,49,101,213,237,135,135,21,73,93,115,7,85,223,237, & - 79,89,5,57,239,67,65,201,155,71,85,195,89,181,119,135,147, & - 237,173,41,155,67,113,111,21,183,23,103,207,253,69,219,205, & - 195,43,197,229,139,177,129,69,97,201,163,189,11,99,91,253, & - 239,91,145,19,179,231,121,7,225,237,125,191,119,59,175,237, & - 131,79,43,45,205,199,251,153,207,37,179,113,255,107,217,61,7, & - 181,247,31,13,113,145,107,233,233,43,79,23,169,137,129,183, & - 53,91,55,103,223,87,177,157,79,213,139/) - v(1075:1111,8) = (/ & - 183,231,205,143,129,243,205,93,59, & - 15,89,9,11,47,133,227,75,9,91,19,171,163,79,7,103,5,119,155, & - 75,11,71,95,17,13,243,207,187/) - v(54:299,9) = (/ & - 235,307,495,417,57,151,19,119,375,451, & - 55,449,501,53,185,317,17,21,487,13,347,393,15,391,307,189, & - 381,71,163,99,467,167,433,337,257,179,47,385,23,117,369,425, & - 207,433,301,147,333,85,221,423,49,3,43,229,227,201,383,281, & - 229,207,21,343,251,397,173,507,421,443,399,53,345,77,385,317, & - 155,187,269,501,19,169,235,415,61,247,183,5,257,401,451,95, & - 455,49,489,75,459,377,87,463,155,233,115,429,211,419,143,487, & - 195,209,461,193,157,193,363,181,271,445,381,231,135,327,403, & - 171,197,181,343,113,313,393,311,415,267,247,425,233,289,55, & - 39,247,327,141,5,189,183,27,337,341,327,87,429,357,265,251, & - 437,201,29,339,257,377,17,53,327,47,375,393,369,403,125,429, & - 257,157,217,85,267,117,337,447,219,501,41,41,193,509,131,207, & - 505,421,149,111,177,167,223,291,91,29,305,151,177,337,183, & - 361,435,307,507,77,181,507,315,145,423,71,103,493,271,469, & - 339,237,437,483,31,219,61,131,391,233,219,69,57,459,225,421, & - 7,461,111,451,277,185,193,125,251,199,73,71,7,409,417,149/) - v(300:550,9) = (/ & - 193,53,437,29,467,229,31,35,75,105, & - 503,75,317,401,367,131,365,441,433,93,377,405,465,259,283, & - 443,143,445,3,461,329,309,77,323,155,347,45,381,315,463,207, & - 321,157,109,479,313,345,167,439,307,235,473,79,101,245,19, & - 381,251,35,25,107,187,115,113,321,115,445,61,77,293,405,13, & - 53,17,171,299,41,79,3,485,331,13,257,59,201,497,81,451,199, & - 171,81,253,365,75,451,149,483,81,453,469,485,305,163,401,15, & - 91,3,129,35,239,355,211,387,101,299,67,375,405,357,267,363, & - 79,83,437,457,39,97,473,289,179,57,23,49,79,71,341,287,95, & - 229,271,475,49,241,261,495,353,381,13,291,37,251,105,399,81, & - 89,265,507,205,145,331,129,119,503,249,1,289,463,163,443,63, & - 123,361,261,49,429,137,355,175,507,59,277,391,25,185,381,197, & - 39,5,429,119,247,177,329,465,421,271,467,151,45,429,137,471, & - 11,17,409,347,199,463,177,11,51,361,95,497,163,351,127,395, & - 511,327,353,49,105,151,321,331,329,509,107,109,303,467,287, & - 161,45,385,289,363,331,265,407,37,433,315,343,63,51,185,71, & - 27,267/) - v(551:798,9) = (/ & - 503,239,293,245,281,297,75,461,371, & - 129,189,189,339,287,111,111,379,93,27,185,347,337,247,507, & - 161,231,43,499,73,327,263,331,249,493,37,25,115,3,167,197, & - 127,357,497,103,125,191,165,55,101,95,79,351,341,43,125,135, & - 173,289,373,133,421,241,281,213,177,363,151,227,145,363,239, & - 431,81,397,241,67,291,255,405,421,399,75,399,105,329,41,425, & - 7,283,375,475,427,277,209,411,3,137,195,289,509,121,55,147, & - 275,251,19,129,285,415,487,491,193,219,403,23,97,65,285,75, & - 21,373,261,339,239,495,415,333,107,435,297,213,149,463,199, & - 323,45,19,301,121,499,187,229,63,425,99,281,35,125,349,87, & - 101,59,195,511,355,73,263,243,101,165,141,11,389,219,187,449, & - 447,393,477,305,221,51,355,209,499,479,265,377,145,411,173, & - 11,433,483,135,385,341,89,209,391,33,395,319,451,119,341,227, & - 375,61,331,493,411,293,47,203,375,167,395,155,5,237,361,489, & - 127,21,345,101,371,233,431,109,119,277,125,263,73,135,123,83, & - 123,405,69,75,287,401,23,283,393,41,379,431,11,475,505,19, & - 365,265,271/) - v(799:1045,9) = (/ & - 499,489,443,165,91,83,291,319,199, & - 107,245,389,143,137,89,125,281,381,215,131,299,249,375,455, & - 43,73,281,217,297,229,431,357,81,357,171,451,481,13,387,491, & - 489,439,385,487,177,393,33,71,375,443,129,407,395,127,65,333, & - 309,119,197,435,497,373,71,379,509,387,159,265,477,463,449, & - 47,353,249,335,505,89,141,55,235,187,87,363,93,363,101,67, & - 215,321,331,305,261,411,491,479,65,307,469,415,131,315,487, & - 83,455,19,113,163,503,99,499,251,239,81,167,391,255,317,363, & - 359,395,419,307,251,267,171,461,183,465,165,163,293,477,223, & - 403,389,97,335,357,297,19,469,501,249,85,213,311,265,379,297, & - 283,393,449,463,289,159,289,499,407,129,137,221,43,89,403, & - 271,75,83,445,453,389,149,143,423,499,317,445,157,137,453, & - 163,87,23,391,119,427,323,173,89,259,377,511,249,31,363,229, & - 353,329,493,427,57,205,389,91,83,13,219,439,45,35,371,441,17, & - 267,501,53,25,333,17,201,475,257,417,345,381,377,55,403,77, & - 389,347,363,211,413,419,5,167,219,201,285,425,11,77,269,489, & - 281,403,79/) - v(1046:1111,9) = (/ & - 425,125,81,331,437,271,397,299,475, & - 271,249,413,233,261,495,171,69,27,409,21,421,367,81,483,255, & - 15,219,365,497,181,75,431,99,325,407,229,281,63,83,493,5,113, & - 15,271,37,87,451,299,83,451,311,441,47,455,47,253,13,109,369, & - 347,11,409,275,63,441,15/) - v(102:344,10) = (/ & - 519,307,931,1023,517,771,151,1023, & - 539,725,45,927,707,29,125,371,275,279,817,389,453,989,1015, & - 29,169,743,99,923,981,181,693,309,227,111,219,897,377,425, & - 609,227,19,221,143,581,147,919,127,725,793,289,411,835,921, & - 957,443,349,813,5,105,457,393,539,101,197,697,27,343,515,69, & - 485,383,855,693,133,87,743,747,475,87,469,763,721,345,479, & - 965,527,121,271,353,467,177,245,627,113,357,7,691,725,355, & - 889,635,737,429,545,925,357,873,187,351,677,999,921,477,233, & - 765,495,81,953,479,89,173,473,131,961,411,291,967,65,511,13, & - 805,945,369,827,295,163,835,259,207,331,29,315,999,133,967, & - 41,117,677,471,717,881,755,351,723,259,879,455,721,289,149, & - 199,805,987,851,423,597,129,11,733,549,153,285,451,559,377, & - 109,357,143,693,615,677,701,475,767,85,229,509,547,151,389, & - 711,785,657,319,509,99,1007,775,359,697,677,85,497,105,615, & - 891,71,449,835,609,377,693,665,627,215,911,503,729,131,19, & - 895,199,161,239,633,1013,537,255,23,149,679,1021,595,199,557, & - 659,251,829,727,439,495,647,223/) - v(345:586,10) = (/ & - 949,625,87,481,85,799,917,769,949, & - 739,115,499,945,547,225,1015,469,737,495,353,103,17,665,639, & - 525,75,447,185,43,729,577,863,735,317,99,17,477,893,537,519, & - 1017,375,297,325,999,353,343,729,135,489,859,267,141,831,141, & - 893,249,807,53,613,131,547,977,131,999,175,31,341,739,467, & - 675,241,645,247,391,583,183,973,433,367,131,467,571,309,385, & - 977,111,917,935,473,345,411,313,97,149,959,841,839,669,431, & - 51,41,301,247,1015,377,329,945,269,67,979,581,643,823,557,91, & - 405,117,801,509,347,893,303,227,783,555,867,99,703,111,797, & - 873,541,919,513,343,319,517,135,871,917,285,663,301,15,763, & - 89,323,757,317,807,309,1013,345,499,279,711,915,411,281,193, & - 739,365,315,375,809,469,487,621,857,975,537,939,585,129,625, & - 447,129,1017,133,83,3,415,661,53,115,903,49,79,55,385,261, & - 345,297,199,385,617,25,515,275,849,401,471,377,661,535,505, & - 939,465,225,929,219,955,659,441,117,527,427,515,287,191,33, & - 389,197,825,63,417,949,35,571,9,131,609,439,95,19,569,893, & - 451,397,971,801/) - v(587:824,10) = (/ & - 125,471,187,257,67,949,621,453,411, & - 621,955,309,783,893,597,377,753,145,637,941,593,317,555,375, & - 575,175,403,571,555,109,377,931,499,649,653,329,279,271,647, & - 721,665,429,957,803,767,425,477,995,105,495,575,687,385,227, & - 923,563,723,481,717,111,633,113,369,955,253,321,409,909,367, & - 33,967,453,863,449,539,781,911,113,7,219,725,1015,971,1021, & - 525,785,873,191,893,297,507,215,21,153,645,913,755,371,881, & - 113,903,225,49,587,201,927,429,599,513,97,319,331,833,325, & - 887,139,927,399,163,307,803,169,1019,869,537,907,479,335,697, & - 479,353,769,787,1023,855,493,883,521,735,297,1011,991,879, & - 855,591,415,917,375,453,553,189,841,339,211,601,57,765,745, & - 621,209,875,639,7,595,971,263,1009,201,23,77,621,33,535,963, & - 661,523,263,917,103,623,231,47,301,549,337,675,189,357,1005, & - 789,189,319,721,1005,525,675,539,191,813,917,51,167,415,579, & - 755,605,721,837,529,31,327,799,961,279,409,847,649,241,285, & - 545,407,161,591,73,313,811,17,663,269,261,37,783,127,917,231, & - 577,975,793/) - v(825:1065,10) = (/ & - 921,343,751,139,221,79,817,393,545, & - 11,781,71,1,699,767,917,9,107,341,587,903,965,599,507,843, & - 739,579,397,397,325,775,565,925,75,55,979,931,93,957,857,753, & - 965,795,67,5,87,909,97,995,271,875,671,613,33,351,69,811,669, & - 729,401,647,241,435,447,721,271,745,53,775,99,343,451,427, & - 593,339,845,243,345,17,573,421,517,971,499,435,769,75,203, & - 793,985,343,955,735,523,659,703,303,421,951,405,631,825,735, & - 433,841,485,49,749,107,669,211,497,143,99,57,277,969,107,397, & - 563,551,447,381,187,57,405,731,769,923,955,915,737,595,341, & - 253,823,197,321,315,181,885,497,159,571,981,899,785,947,217, & - 217,135,753,623,565,717,903,581,955,621,361,869,87,943,907, & - 853,353,335,197,771,433,743,195,91,1023,63,301,647,205,485, & - 927,1003,987,359,577,147,141,1017,701,273,89,589,487,859,343, & - 91,847,341,173,287,1003,289,639,983,685,697,35,701,645,911, & - 501,705,873,763,745,657,559,699,315,347,429,197,165,955,859, & - 167,303,833,531,473,635,641,195,589,821,205,3,635,371,891, & - 249,123/) - v(1066:1111,10) = (/ & - 77,623,993,401,525,427,71,655,951, & - 357,851,899,535,493,323,1003,343,515,859,1017,5,423,315,1011, & - 703,41,777,163,95,831,79,975,235,633,723,297,589,317,679,981, & - 195,399,1003,121,501,155/) - v(162:376,11) = (/ & - 7,2011,1001,49,825,415,1441,383,1581, & - 623,1621,1319,1387,619,839,217,75,1955,505,281,1629,1379,53, & - 1111,1399,301,209,49,155,1647,631,129,1569,335,67,1955,1611, & - 2021,1305,121,37,877,835,1457,669,1405,935,1735,665,551,789, & - 1543,1267,1027,1,1911,163,1929,67,1975,1681,1413,191,1711, & - 1307,401,725,1229,1403,1609,2035,917,921,1789,41,2003,187,67, & - 1635,717,1449,277,1903,1179,363,1211,1231,647,1261,1029,1485, & - 1309,1149,317,1335,171,243,271,1055,1601,1129,1653,205,1463, & - 1681,1621,197,951,573,1697,1265,1321,1805,1235,1853,1307,945, & - 1197,1411,833,273,1517,1747,1095,1345,869,57,1383,221,1713, & - 335,1751,1141,839,523,1861,1105,389,1177,1877,805,93,1591, & - 423,1835,99,1781,1515,1909,1011,303,385,1635,357,973,1781, & - 1707,1363,1053,649,1469,623,1429,1241,1151,1055,503,921,3, & - 349,1149,293,45,303,877,1565,1583,1001,663,1535,395,1141, & - 1481,1797,643,1507,465,2027,1695,367,937,719,545,1991,83,819, & - 239,1791,1461,1647,1501,1161,1629,139,1595,1921,1267,1415, & - 509,347,777,1083,363,269,1015/) - v(377:589,11) = (/ & - 1809,1105,1429,1471,2019,381,2025, & - 1223,827,1733,887,1321,803,1951,1297,1995,833,1107,1135,1181, & - 1251,983,1389,1565,273,137,71,735,1005,933,67,1471,551,457, & - 1667,1729,919,285,1629,1815,653,1919,1039,531,393,1411,359, & - 221,699,1485,471,1357,1715,595,1677,153,1903,1281,215,781, & - 543,293,1807,965,1695,443,1985,321,879,1227,1915,839,1945, & - 1993,1165,51,557,723,1491,817,1237,947,1215,1911,1225,1965, & - 1889,1503,1177,73,1767,303,177,1897,1401,321,921,217,1779, & - 327,1889,333,615,1665,1825,1639,237,1205,361,129,1655,983, & - 1089,1171,401,677,643,749,303,1407,1873,1579,1491,1393,1247, & - 789,763,49,5,1607,1891,735,1557,1909,1765,1777,1127,813,695, & - 97,731,1503,1751,333,769,865,693,377,1919,957,1359,1627,1039, & - 1783,1065,1665,1917,1947,991,1997,841,459,221,327,1595,1881, & - 1269,1007,129,1413,475,1105,791,1983,1359,503,691,659,691, & - 343,1375,1919,263,1373,603,1383,297,781,145,285,767,1739, & - 1715,715,317,1333,85,831,1615,81,1667,1467,1457,1453,1825, & - 109,387,1207,2039,213,1351,1329,1173/) - v(590:802,11) = (/ & - 57,1769,951,183,23,451,1155,1551, & - 2037,811,635,1671,1451,863,1499,1673,363,1029,1077,1525,277, & - 1023,655,665,1869,1255,965,277,1601,329,1603,1901,395,65, & - 1307,2029,21,1321,543,1569,1185,1905,1701,413,2041,1697,725, & - 1417,1847,411,211,915,1891,17,1877,1699,687,1089,1973,1809, & - 851,1495,1257,63,1323,1307,609,881,1543,177,617,1505,1747, & - 1537,925,183,77,1723,1877,1703,397,459,521,257,1177,389,1947, & - 1553,1583,1831,261,485,289,1281,1543,1591,1123,573,821,1065, & - 1933,1373,2005,905,207,173,1573,1597,573,1883,1795,1499,1743, & - 553,335,333,1645,791,871,1157,969,557,141,223,1129,1685,423, & - 1069,391,99,95,1847,531,1859,1833,1833,341,237,1997,1799,409, & - 431,1917,363,335,1039,1085,1657,1975,1527,1111,659,389,899, & - 595,1439,1861,1979,1569,1087,1009,165,1895,1481,1583,29,1193, & - 1673,1075,301,1081,1377,1747,1497,1103,1789,887,739,1577,313, & - 1367,1299,1801,1131,1837,73,1865,1065,843,635,55,1655,913, & - 1037,223,1871,1161,461,479,511,1721,1107,389,151,35,375,1099, & - 937,1185,1701,769,639,1633/) - v(803:1018,11) = (/ & - 1609,379,1613,2031,685,289,975,671, & - 1599,1447,871,647,99,139,1427,959,89,117,841,891,1959,223, & - 1697,1145,499,1435,1809,1413,1445,1675,171,1073,1349,1545, & - 2039,1027,1563,859,215,1673,1919,1633,779,411,1845,1477,1489, & - 447,1545,351,1989,495,183,1639,1385,1805,1097,1249,1431,1571, & - 591,697,1509,709,31,1563,165,513,1425,1299,1081,145,1841, & - 1211,941,609,845,1169,1865,1593,347,293,1277,157,211,93,1679, & - 1799,527,41,473,563,187,1525,575,1579,857,703,1211,647,709, & - 981,285,697,163,981,153,1515,47,1553,599,225,1147,381,135, & - 821,1965,609,1033,983,503,1117,327,453,2005,1257,343,1649, & - 1199,599,1877,569,695,1587,1475,187,973,233,511,51,1083,665, & - 1321,531,1875,1939,859,1507,1979,1203,1965,737,921,1565,1943, & - 819,223,365,167,1705,413,1577,745,1573,655,1633,1003,91,1123, & - 477,1741,1663,35,715,37,1513,815,941,1379,263,1831,1735,1111, & - 1449,353,1941,1655,1349,877,285,1723,125,1753,985,723,175, & - 439,791,1051,1261,717,1555,1757,1777,577,1583,1957,873,331, & - 1163,313,1,1963,963,1905,821/) - v(1019:1111,11) = (/ & - 1677,185,709,545,1723,215,1885, & - 1249,583,1803,839,885,485,413,1767,425,129,1035,329,1263, & - 1881,1779,1565,359,367,453,707,1419,831,1889,887,1871,1869, & - 747,223,1547,1799,433,1441,553,2021,1303,1505,1735,1619,1065, & - 1161,2047,347,867,881,1447,329,781,1065,219,589,645,1257, & - 1833,749,1841,1733,1179,1191,1025,1639,1955,1423,1685,1711, & - 493,549,783,1653,397,895,233,759,1505,677,1449,1573,1297, & - 1821,1691,791,289,1187,867,1535,575,183/) - v(338:545,12) = (/ & - 3915,97,3047,937,2897,953,127,1201, & - 3819,193,2053,3061,3759,1553,2007,2493,603,3343,3751,1059, & - 783,1789,1589,283,1093,3919,2747,277,2605,2169,2905,721,4069, & - 233,261,1137,3993,3619,2881,1275,3865,1299,3757,1193,733,993, & - 1153,2945,3163,3179,437,271,3493,3971,1005,2615,2253,1131, & - 585,2775,2171,2383,2937,2447,1745,663,1515,3767,2709,1767, & - 3185,3017,2815,1829,87,3341,793,2627,2169,1875,3745,367,3783, & - 783,827,3253,2639,2955,3539,1579,2109,379,2939,3019,1999, & - 2253,2911,3733,481,1767,1055,4019,4085,105,1829,2097,2379, & - 1567,2713,737,3423,3941,2659,3961,1755,3613,1937,1559,2287, & - 2743,67,2859,325,2601,1149,3259,2403,3947,2011,175,3389,3915, & - 1315,2447,141,359,3609,3933,729,2051,1755,2149,2107,1741, & - 1051,3681,471,1055,845,257,1559,1061,2803,2219,1315,1369, & - 3211,4027,105,11,1077,2857,337,3553,3503,3917,2665,3823,3403, & - 3711,2085,1103,1641,701,4095,2883,1435,653,2363,1597,767,869, & - 1825,1117,1297,501,505,149,873,2673,551,1499,2793,3277,2143, & - 3663,533,3991,575,1877,1009,3929,473,3009,2595,3249,675,3593/) - v(546:752,12) = (/ & - 2453,1567,973,595,1335,1715,589,85, & - 2265,3069,461,1659,2627,1307,1731,1501,1699,3545,3803,2157, & - 453,2813,2047,2999,3841,2361,1079,573,69,1363,1597,3427,2899, & - 2771,1327,1117,1523,3521,2393,2537,1979,3179,683,2453,453, & - 1227,779,671,3483,2135,3139,3381,3945,57,1541,3405,3381,2371, & - 2879,1985,987,3017,3031,3839,1401,3749,2977,681,1175,1519, & - 3355,907,117,771,3741,3337,1743,1227,3335,2755,1909,3603, & - 2397,653,87,2025,2617,3257,287,3051,3809,897,2215,63,2043, & - 1757,3671,297,3131,1305,293,3865,3173,3397,2269,3673,717, & - 3041,3341,3595,3819,2871,3973,1129,513,871,1485,3977,2473, & - 1171,1143,3063,3547,2183,3993,133,2529,2699,233,2355,231, & - 3241,611,1309,3829,1839,1495,301,1169,1613,2673,243,3601, & - 3669,2813,2671,2679,3463,2477,1795,617,2317,1855,1057,1703, & - 1761,2515,801,1205,1311,473,3963,697,1221,251,381,3887,1761, & - 3093,3721,2079,4085,379,3601,3845,433,1781,29,1897,1599,2163, & - 75,3475,3957,1641,3911,2959,2833,1279,1099,403,799,2183,2699, & - 1711,2037,727,289,1785,1575,3633,2367,1261,3953,1735,171, & - 1959/) - v(753:960,12) = (/ & - 2867,859,2951,3211,15,1279,1323,599, & - 1651,3951,1011,315,3513,3351,1725,3793,2399,287,4017,3571, & - 1007,541,3115,429,1585,1285,755,1211,3047,915,3611,2697,2129, & - 3669,81,3939,2437,915,779,3567,3701,2479,3807,1893,3927,2619, & - 2543,3633,2007,3857,3837,487,1769,3759,3105,2727,3155,2479, & - 1341,1657,2767,2541,577,2105,799,17,2871,3637,953,65,69,2897, & - 3841,3559,4067,2335,3409,1087,425,2813,1705,1701,1237,821, & - 1375,3673,2693,3925,1541,1871,2285,847,4035,1101,2029,855, & - 2733,2503,121,2855,1069,3463,3505,1539,607,1349,575,2301, & - 2321,1101,333,291,2171,4085,2173,2541,1195,925,4039,1379,699, & - 1979,275,953,1755,1643,325,101,2263,3329,3673,3413,1977,2727, & - 2313,1419,887,609,2475,591,2613,2081,3805,3435,2409,111,3557, & - 3607,903,231,3059,473,2959,2925,3861,2043,3887,351,2865,369, & - 1377,2639,1261,3625,3279,2201,2949,3049,449,1297,897,1891, & - 411,2773,749,2753,1825,853,2775,3547,3923,3923,987,3723,2189, & - 3877,3577,297,2763,1845,3083,2951,483,2169,3985,245,3655, & - 3441,1023,235,835,3693,3585,327,1003,543,3059,2637/) - v(961:1111,12) = (/ & - 2923,87,3617,1031,1043,903,2913, & - 2177,2641,3279,389,2009,525,4085,3299,987,2409,813,2683,373, & - 2695,3775,2375,1119,2791,223,325,587,1379,2877,2867,3793,655, & - 831,3425,1663,1681,2657,1865,3943,2977,1979,2271,3247,1267, & - 1747,811,159,429,2001,1195,3065,553,1499,3529,1081,2877,3077, & - 845,1793,2409,3995,2559,4081,1195,2955,1117,1409,785,287, & - 1521,1607,85,3055,3123,2533,2329,3477,799,3683,3715,337,3139, & - 3311,431,3511,2299,365,2941,3067,1331,1081,1097,2853,2299, & - 495,1745,749,3819,619,1059,3559,183,3743,723,949,3501,733, & - 2599,3983,3961,911,1899,985,2493,1795,653,157,433,2361,3093, & - 3119,3679,2367,1701,1445,1321,2397,1241,3305,3985,2349,4067, & - 3805,3073,2837,1567,3783,451,2441,1181,487,543,1201,3735, & - 2517,733,1535,2175,3613,3019/) - v(482:680,13) = (/ & - 2319,653,1379,1675,1951,7075,2087, & - 7147,1427,893,171,2019,7235,5697,3615,1961,7517,6849,2893, & - 1883,2863,2173,4543,73,381,3893,6045,1643,7669,1027,1549, & - 3983,1985,6589,7497,2745,2375,7047,1117,1171,1975,5199,3915, & - 3695,8113,4303,3773,7705,6855,1675,2245,2817,1719,569,1021, & - 2077,5945,1833,2631,4851,6371,833,7987,331,1899,8093,6719, & - 6903,5903,5657,5007,2689,6637,2675,1645,1819,689,6709,7717, & - 6295,7013,7695,3705,7069,2621,3631,6571,6259,7261,3397,7645, & - 1115,4753,2047,7579,2271,5403,4911,7629,4225,1209,6955,6951, & - 1829,5579,5231,1783,4285,7425,599,5785,3275,5643,2263,657, & - 6769,6261,1251,3249,4447,4111,3991,1215,131,4397,3487,7585, & - 5565,7199,3573,7105,7409,1671,949,3889,5971,3333,225,3647, & - 5403,3409,7459,6879,5789,6567,5581,4919,1927,4407,8085,4691, & - 611,3005,591,753,589,171,5729,5891,1033,3049,6567,5257,8003, & - 1757,4489,4923,6379,5171,1757,689,3081,1389,4113,455,2761, & - 847,7575,5829,633,6629,1103,7635,803,6175,6587,2711,3879,67, & - 1179,4761,7281,1557,3379,2459,4273,4127,7147,35/) - v(681:877,13) = (/ & - 3549,395,3735,5787,4179,5889,5057, & - 7473,4713,2133,2897,1841,2125,1029,1695,6523,1143,5105,7133, & - 3351,2775,3971,4503,7589,5155,4305,1641,4717,2427,5617,1267, & - 399,5831,4305,4241,3395,3045,4899,1713,171,411,7099,5473, & - 5209,1195,1077,1309,2953,7343,4887,3229,6759,6721,6775,675, & - 4039,2493,7511,3269,4199,6625,7943,2013,4145,667,513,2303, & - 4591,7941,2741,987,8061,3161,5951,1431,831,5559,7405,1357, & - 4319,4235,5421,2559,4415,2439,823,1725,6219,4903,6699,5451, & - 349,7703,2927,7809,6179,1417,5987,3017,4983,3479,4525,4643, & - 4911,227,5475,2287,5581,6817,1937,1421,4415,7977,1789,3907, & - 6815,6789,6003,5609,4507,337,7427,7943,3075,6427,1019,7121, & - 4763,81,3587,2929,1795,8067,2415,1265,4025,5599,4771,3025, & - 2313,6129,7611,6881,5253,4413,7869,105,3173,1629,2537,1023, & - 4409,7209,4413,7107,7469,33,1955,2881,5167,6451,4211,179, & - 5573,7879,3387,7759,5455,7157,1891,5683,5689,6535,3109,6555, & - 6873,1249,4251,6437,49,2745,1201,7327,4179,6783,623,2779, & - 5963,2585,6927,5333,4033,285,7467,4443,4917,3/) - v(878:1070,13) = (/ & - 4319,5517,3449,813,5499,2515,5771, & - 3357,2073,4395,4925,2643,7215,5817,1199,1597,1619,7535,4833, & - 609,4797,8171,6847,793,6757,8165,3371,2431,5235,4739,7703, & - 7223,6525,5891,5605,4433,3533,5267,5125,5037,225,6717,1121, & - 5741,2013,4327,4839,569,5227,7677,4315,2391,5551,859,3627, & - 6377,3903,4311,6527,7573,4905,7731,1909,1555,3279,1949,1887, & - 6675,5509,2033,5473,3539,5033,5935,6095,4761,1771,1271,1717, & - 4415,5083,6277,3147,7695,2461,4783,4539,5833,5583,651,1419, & - 2605,5511,3913,5795,2333,2329,4431,3725,6069,2699,7055,6879, & - 1017,3121,2547,4603,2385,6915,6103,5669,7833,2001,4287,6619, & - 955,2761,5711,6291,3415,3909,2841,5627,4939,7671,6059,6275, & - 6517,1931,4583,7301,1267,7509,1435,2169,6939,3515,2985,2787, & - 2123,1969,3307,353,4359,7059,5273,5873,6657,6765,6229,3179, & - 1583,6237,2155,371,273,7491,3309,6805,3015,6831,7819,713, & - 4747,3935,4109,1311,709,3089,7059,4247,2989,1509,4919,1841, & - 3045,3821,6929,4655,1333,6429,6649,2131,5265,1051,261,8057, & - 3379,2179,1993,5655,3063,6381/) - v(1071:1111,13) = (/ & - 3587,7417,1579,1541,2107,5085,2873, & - 6141,955,3537,2157,841,1999,1465,5171,5651,1535,7235,4349, & - 1263,1453,1005,6893,2919,1947,1635,3963,397,969,4569,655, & - 6737,2995,7235,7713,973,4821,2377,1673,1,6541/) -! -! Set POLY. -! - poly(1:211)= (/ & - 1,3,7,11,13,19,25,37,59,47,61,55,41,67,97,91, & - 109,103,115,131,193,137,145,143,241,157,185,167,229,171,213, & - 191,253,203,211,239,247,285,369,299,301,333,351,355,357,361, & - 391,397,425,451,463,487,501,529,539,545,557,563,601,607,617, & - 623,631,637,647,661,675,677,687,695,701,719,721,731,757,761, & - 787,789,799,803,817,827,847,859,865,875,877,883,895,901,911, & - 949,953,967,971,973,981,985,995,1001,1019,1033,1051,1063, & - 1069,1125,1135,1153,1163,1221,1239,1255,1267,1279,1293,1305, & - 1315,1329,1341,1347,1367,1387,1413,1423,1431,1441,1479,1509, & - 1527,1531,1555,1557,1573,1591,1603,1615,1627,1657,1663,1673, & - 1717,1729,1747,1759,1789,1815,1821,1825,1849,1863,1869,1877, & - 1881,1891,1917,1933,1939,1969,2011,2035,2041,2053,2071,2091, & - 2093,2119,2147,2149,2161,2171,2189,2197,2207,2217,2225,2255, & - 2257,2273,2279,2283,2293,2317,2323,2341,2345,2363,2365,2373, & - 2377,2385,2395,2419,2421,2431,2435,2447,2475,2477,2489,2503, & - 2521,2533,2551,2561,2567,2579,2581,2601,2633,2657,2669/) - poly(212:401)= (/ & - 2681,2687,2693,2705,2717,2727,2731,2739, & - 2741,2773,2783,2793,2799,2801,2811,2819,2825,2833,2867,2879, & - 2881,2891,2905,2911,2917,2927,2941,2951,2955,2963,2965,2991, & - 2999,3005,3017,3035,3037,3047,3053,3083,3085,3097,3103,3159, & - 3169,3179,3187,3205,3209,3223,3227,3229,3251,3263,3271,3277, & - 3283,3285,3299,3305,3319,3331,3343,3357,3367,3373,3393,3399, & - 3413,3417,3427,3439,3441,3475,3487,3497,3515,3517,3529,3543, & - 3547,3553,3559,3573,3589,3613,3617,3623,3627,3635,3641,3655, & - 3659,3669,3679,3697,3707,3709,3713,3731,3743,3747,3771,3791, & - 3805,3827,3833,3851,3865,3889,3895,3933,3947,3949,3957,3971, & - 3985,3991,3995,4007,4013,4021,4045,4051,4069,4073,4179,4201, & - 4219,4221,4249,4305,4331,4359,4383,4387,4411,4431,4439,4449, & - 4459,4485,4531,4569,4575,4621,4663,4669,4711,4723,4735,4793, & - 4801,4811,4879,4893,4897,4921,4927,4941,4977,5017,5027,5033, & - 5127,5169,5175,5199,5213,5223,5237,5287,5293,5331,5391,5405, & - 5453,5523,5573,5591,5597,5611,5641,5703,5717,5721,5797,5821, & - 5909,5913/) - poly(402:591)= (/ & - 5955,5957,6005,6025,6061,6067,6079,6081, & - 6231,6237,6289,6295,6329,6383,6427,6453,6465,6501,6523,6539, & - 6577,6589,6601,6607,6631,6683,6699,6707,6761,6795,6865,6881, & - 6901,6923,6931,6943,6999,7057,7079,7103,7105,7123,7173,7185, & - 7191,7207,7245,7303,7327,7333,7355,7365,7369,7375,7411,7431, & - 7459,7491,7505,7515,7541,7557,7561,7701,7705,7727,7749,7761, & - 7783,7795,7823,7907,7953,7963,7975,8049,8089,8123,8125,8137, & - 8219,8231,8245,8275,8293,8303,8331,8333,8351,8357,8367,8379, & - 8381,8387,8393,8417,8435,8461,8469,8489,8495,8507,8515,8551, & - 8555,8569,8585,8599,8605,8639,8641,8647,8653,8671,8675,8689, & - 8699,8729,8741,8759,8765,8771,8795,8797,8825,8831,8841,8855, & - 8859,8883,8895,8909,8943,8951,8955,8965,8999,9003,9031,9045, & - 9049,9071,9073,9085,9095,9101,9109,9123,9129,9137,9143,9147, & - 9185,9197,9209,9227,9235,9247,9253,9257,9277,9297,9303,9313, & - 9325,9343,9347,9371,9373,9397,9407,9409,9415,9419,9443,9481, & - 9495,9501,9505,9517,9529,9555,9557,9571,9585,9591,9607,9611, & - 9621,9625/) - poly(592:765)= (/ & - 9631,9647,9661,9669,9679,9687,9707,9731, & - 9733,9745,9773,9791,9803,9811,9817,9833,9847,9851,9863,9875, & - 9881,9905,9911,9917,9923,9963,9973,10003,10025,10043,10063, & - 10071,10077,10091,10099,10105,10115,10129,10145,10169,10183, & - 10187,10207,10223,10225,10247,10265,10271,10275,10289,10299, & - 10301,10309,10343,10357,10373,10411,10413,10431,10445,10453, & - 10463,10467,10473,10491,10505,10511,10513,10523,10539,10549, & - 10559,10561,10571,10581,10615,10621,10625,10643,10655,10671, & - 10679,10685,10691,10711,10739,10741,10755,10767,10781,10785, & - 10803,10805,10829,10857,10863,10865,10875,10877,10917,10921, & - 10929,10949,10967,10971,10987,10995,11009,11029,11043,11045, & - 11055,11063,11075,11081,11117,11135,11141,11159,11163,11181, & - 11187,11225,11237,11261,11279,11297,11307,11309,11327,11329, & - 11341,11377,11403,11405,11413,11427,11439,11453,11461,11473, & - 11479,11489,11495,11499,11533,11545,11561,11567,11575,11579, & - 11589,11611,11623,11637,11657,11663,11687,11691,11701,11747, & - 11761,11773,11783,11795,11797,11817,11849,11855,11867,11869, & - 11873,11883,11919/) - poly(766:936)= (/ & - 11921,11927,11933,11947,11955,11961, & - 11999,12027,12029,12037,12041,12049,12055,12095,12097,12107, & - 12109,12121,12127,12133,12137,12181,12197,12207,12209,12239, & - 12253,12263,12269,12277,12287,12295,12309,12313,12335,12361, & - 12367,12391,12409,12415,12433,12449,12469,12479,12481,12499, & - 12505,12517,12527,12549,12559,12597,12615,12621,12639,12643, & - 12657,12667,12707,12713,12727,12741,12745,12763,12769,12779, & - 12781,12787,12799,12809,12815,12829,12839,12857,12875,12883, & - 12889,12901,12929,12947,12953,12959,12969,12983,12987,12995, & - 13015,13019,13031,13063,13077,13103,13137,13149,13173,13207, & - 13211,13227,13241,13249,13255,13269,13283,13285,13303,13307, & - 13321,13339,13351,13377,13389,13407,13417,13431,13435,13447, & - 13459,13465,13477,13501,13513,13531,13543,13561,13581,13599, & - 13605,13617,13623,13637,13647,13661,13677,13683,13695,13725, & - 13729,13753,13773,13781,13785,13795,13801,13807,13825,13835, & - 13855,13861,13871,13883,13897,13905,13915,13939,13941,13969, & - 13979,13981,13997,14027,14035,14037,14051,14063,14085,14095, & - 14107,14113,14125,14137,14145/) - poly(937:1107)= (/ & - 14151,14163,14193,14199,14219,14229, & - 14233,14243,14277,14287,14289,14295,14301,14305,14323,14339, & - 14341,14359,14365,14375,14387,14411,14425,14441,14449,14499, & - 14513,14523,14537,14543,14561,14579,14585,14593,14599,14603, & - 14611,14641,14671,14695,14701,14723,14725,14743,14753,14759, & - 14765,14795,14797,14803,14831,14839,14845,14855,14889,14895, & - 14909,14929,14941,14945,14951,14963,14965,14985,15033,15039, & - 15053,15059,15061,15071,15077,15081,15099,15121,15147,15149, & - 15157,15167,15187,15193,15203,15205,15215,15217,15223,15243, & - 15257,15269,15273,15287,15291,15313,15335,15347,15359,15373, & - 15379,15381,15391,15395,15397,15419,15439,15453,15469,15491, & - 15503,15517,15527,15531,15545,15559,15593,15611,15613,15619, & - 15639,15643,15649,15661,15667,15669,15681,15693,15717,15721, & - 15741,15745,15765,15793,15799,15811,15825,15835,15847,15851, & - 15865,15877,15881,15887,15899,15915,15935,15937,15955,15973, & - 15977,16011,16035,16061,16069,16087,16093,16097,16121,16141, & - 16153,16159,16165,16183,16189,16195,16197,16201,16209,16215, & - 16225,16259,16265,16273,16299/) - poly(1108:1111)= (/ & - 16309,16355,16375,16381/) - - end if - - if ( dim_num /= dim_num_save ) then -! -! Check parameters. -! - if ( dim_num < 2 .or. dim_max < dim_num ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I8_SOBOL - Fatal error!' - write ( *, '(a)' ) ' The spatial dimension DIM_NUM should satisfy:' - write ( *, '(a,i8)' ) ' 2 <= DIM_NUM <= ', dim_max - write ( *, '(a,i8)' ) ' But this input value is DIM_NUM = ', dim_num - stop - end if - - dim_num_save = dim_num -! -! Set ATMOST = 2**LOG_MAX - 1. -! - atmost = 0 - do i = 1, log_max - atmost = 2 * atmost + 1 - end do -! -! Find the highest 1 bit in ATMOST (should be LOG_MAX). -! - maxcol = i8_bit_hi1 ( atmost ) -! -! Initialize row 1 of V. -! - v(1,1:maxcol) = 1 -! -! Initialize the remaining rows of V. -! - do i = 2, dim_num -! -! The bit pattern of the integer POLY(I) gives the form -! of polynomial I. -! -! Find the degree of polynomial I from binary encoding. -! - j = poly(i) - m = 0 - - do - - j = j / 2 - - if ( j <= 0 ) then - exit - end if - - m = m + 1 - - end do -! -! We expand this bit pattern to separate components -! of the logical array INCLUD. -! - j = poly(i) - do k = m, 1, - 1 - j2 = j / 2 - includ(k) = ( j /= ( 2 * j2 ) ) - j = j2 - end do -! -! Calculate the remaining elements of row I as explained -! in Bratley and Fox, section 2. -! - do j = m + 1, maxcol - - newv = v(i,j-m) - l = 1 - - do k = 1, m - - l = 2 * l - - if ( includ(k) ) then - newv = ieor ( newv, l * v(i,j-k) ) - end if - - end do - - v(i,j) = newv - - end do - - end do -! -! Multiply columns of V by appropriate power of 2. -! - l = 1 - do j = maxcol - 1, 1, - 1 - l = 2 * l - v(1:dim_num,j) = v(1:dim_num,j) * l - end do -! -! RECIPD is 1/(common denominator of the elements in V) = 1 / ( 2 * L ). -! - recipd = real ( l, kind = 8 ) - recipd = 0.5D+00 / recipd - - end if - - if ( seed < 0 ) then - seed = 0 - end if - - if ( seed == 0 ) then - - l = 1 - lastq(1:dim_num) = 0 - - else if ( seed == seed_save + 1 ) then -! -! Find the position of the right-hand zero in SEED. -! - l = i8_bit_lo0 ( seed ) - - else if ( seed <= seed_save ) then - - seed_save = 0 - l = 1 - lastq(1:dim_num) = 0 - - do seed_temp = seed_save, seed - 1 - l = i8_bit_lo0 ( seed_temp ) - lastq(1:dim_num) = ieor ( lastq(1:dim_num), v(1:dim_num,l) ) - end do - - l = i8_bit_lo0 ( seed ) - - else if ( seed_save+1 < seed ) then - - do seed_temp = seed_save+1, seed - 1 - l = i8_bit_lo0 ( seed_temp ) - lastq(1:dim_num) = ieor ( lastq(1:dim_num), v(1:dim_num,l) ) - end do - - l = i8_bit_lo0 ( seed ) - - end if -! -! Check that the user is not calling too many times! -! - if ( maxcol < l ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I8_SOBOL - Fatal error!' - write ( *, '(a)' ) ' Too many calls!' - write ( *, '(a,i12)' ) ' MAXCOL = ', maxcol - write ( *, '(a,i12)' ) ' L = ', l - stop - end if -! -! Calculate the new components of QUASI. -! - quasi(1:dim_num) = real ( lastq(1:dim_num), kind = 8 ) * recipd - lastq(1:dim_num) = ieor ( lastq(1:dim_num), v(1:dim_num,l) ) - - seed_save = seed - seed = seed + 1 - - return -end -subroutine i8_sobol_generate ( m, n, skip, r ) - -!*****************************************************************************80 -! -!! I8_SOBOL_GENERATE generates a Sobol dataset. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 03 August 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer M, the spatial dimension. -! -! Input, integer N, the number of points to generate. -! -! Input, integer ( kind = 8 ) SKIP, the number of initial points to skip. -! -! Output, real ( kind = 8 ) R(M,N), the points. -! - implicit none - - integer ( kind = 8 ) m - integer ( kind = 8 ) n - - integer ( kind = 8 ) j - real ( kind = 8 ), dimension ( m, n ) :: r - integer ( kind = 8 ) seed - integer ( kind = 8 ) skip - - do j = 1, n - seed = skip + j - 1 - call i8_sobol ( m, seed, r(1:m,j) ) - end do - - return -end -subroutine i8_sobol_write ( m, n, skip, r, file_out_name ) - -!*****************************************************************************80 -! -!! I8_SOBOL_WRITE writes a Sobol dataset to a file. -! -! Discussion: -! -! The initial lines of the file are comments, which begin with a -! '#' character. -! -! Thereafter, each line of the file contains the M-dimensional -! components of the SKIP+I-1 entry of the Sobol sequence. -! -! For the Sobol sequence, the value of SKIP is the same -! as the value of SEED used to generate the first point. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 04 June 2004 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 8 ) M, the spatial dimension. -! -! Input, integer ( kind = 8 ) N, the number of (successive) points. -! -! Input, integer ( kind = 8 ) SKIP, the number of skipped points. -! -! Input, real ( kind = 8 ) R(M,N), the points. -! -! Input, character ( len = * ) FILE_OUT_NAME, the name of -! the output file. -! - implicit none - - integer ( kind = 8 ) m - integer ( kind = 8 ) n - - character ( len = * ) file_out_name - integer file_out_unit - integer ios - integer ( kind = 8 ) j - real ( kind = 8 ) r(m,n) - integer ( kind = 8 ) skip - character ( len = 40 ) string - - call get_unit ( file_out_unit ) - - open ( unit = file_out_unit, file = file_out_name, status = 'replace', & - iostat = ios ) - - if ( ios /= 0 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I8_SOBOL_WRITE - Fatal error!' - write ( *, '(a)' ) ' Could not open the output file.' - stop - end if - - call timestring ( string ) - - write ( file_out_unit, '(a)' ) '# ' // trim ( file_out_name ) - write ( file_out_unit, '(a)' ) '# created by I8_SOBOL_WRITE.F90.' - write ( file_out_unit, '(a)' ) '#' - write ( file_out_unit, '(a)' ) '# File generated on ' & - // trim ( string ) - write ( file_out_unit, '(a)' ) '#' - write ( file_out_unit, '(a,i8)' ) '# Spatial dimension M = ', m - write ( file_out_unit, '(a,i8)' ) '# Number of points N = ', n - write ( file_out_unit, '(a,g14.6)' ) '# Epsilon (unit roundoff) = ', & - epsilon ( r(1,1) ) - write ( file_out_unit, '(a,i8)' ) '# Initial values skipped = ', skip - write ( file_out_unit, '(a)' ) '#' - - write ( string, '(a,i3,a)' ) '(', m, '(2x,f10.6))' - do j = 1, n - write ( file_out_unit, string ) r(1:m,j) - end do - - close ( unit = file_out_unit ) - - return -end -function i8_uniform ( a, b, seed ) - -!*****************************************************************************80 -! -!! I8_UNIFORM returns a scaled pseudorandom I8. -! -! Discussion: -! -! An I8 is an integer ( kind = 8 ) value. -! -! Note that ALL integer variables in this routine are -! of type integer ( kind = 8 )! -! -! The pseudorandom number should be uniformly distributed -! between A and B. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 12 November 2006 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Paul Bratley, Bennett Fox, Linus Schrage, -! A Guide to Simulation, -! Springer Verlag, pages 201-202, 1983. -! -! Pierre L'Ecuyer, -! Random Number Generation, -! in Handbook of Simulation, -! edited by Jerry Banks, -! Wiley Interscience, page 95, 1998. -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, pages 362-376, 1986. -! -! Peter Lewis, Allen Goodman, James Miller -! A Pseudo-Random Number Generator for the System/360, -! IBM Systems Journal, -! Volume 8, pages 136-143, 1969. -! -! Parameters: -! -! Input, integer ( kind = 8 ) A, B, the limits of the interval. -! -! Input/output, integer ( kind = 8 ) SEED, the "seed" value, which -! should NOT be 0. On output, SEED has been updated. -! -! Output, integer ( kind = 8 ) I8_UNIFORM, a number between A and B. -! - implicit none - - integer ( kind = 8 ) a - integer ( kind = 8 ) b - integer ( kind = 8 ) i8_uniform - real ( kind = 8 ) r - real ( kind = 8 ) r8i8_uniform_01 - integer ( kind = 8 ) seed - integer ( kind = 8 ) value - - if ( seed == 0 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'I8_UNIFORM - Fatal error!' - write ( *, '(a)' ) ' Input value of SEED = 0.' - stop - end if - - r = r8i8_uniform_01 ( seed ) -! -! Scale R to lie between A-0.5 and B+0.5. -! - r = ( 1.0D+00 - r ) * ( real ( min ( a, b ), kind = 8 ) - 0.5D+00 ) & - + r * ( real ( max ( a, b ), kind = 8 ) + 0.5D+00 ) -! -! Use rounding to convert R to an integer between A and B. -! - value = nint ( r, kind = 8 ) - - value = max ( value, min ( a, b ) ) - value = min ( value, max ( a, b ) ) - - i8_uniform = value - - return -end -function i8_xor ( i, j ) - -!*****************************************************************************80 -! -!! I8_XOR calculates the exclusive OR of two integers. -! -! Discussion: -! -! This function is NOT needed in FORTRAN90, which supplies the -! intrinsic IEOR function for this purpose. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 16 February 2005 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Input, integer ( kind = 8 ) I, J, two values whose exclusive OR is needed. -! -! Output, integer ( kind = 8 ) I8_XOR, the exclusive OR of I and J. -! - implicit none - - integer ( kind = 8 ) i - integer ( kind = 8 ) i1 - integer ( kind = 8 ) i2 - integer ( kind = 8 ) i8_xor - integer ( kind = 8 ) j - integer ( kind = 8 ) j1 - integer ( kind = 8 ) j2 - integer ( kind = 8 ) k - integer ( kind = 8 ) l - - i1 = i - j1 = j - k = 0 - l = 1 - - do while ( i1 /= 0 .or. j1 /= 0 ) - - i2 = i1 / 2 - j2 = j1 / 2 - - if ( & - ( ( i1 == 2 * i2 ) .and. ( j1 /= 2 * j2 ) ) .or. & - ( ( i1 /= 2 * i2 ) .and. ( j1 == 2 * j2 ) ) ) then - k = k + l - end if - - i1 = i2 - j1 = j2 - l = 2 * l - - end do - - i8_xor = k - - return -end -function r8i8_uniform_01 ( seed ) - -!*****************************************************************************80 -! -!! R8I8_UNIFORM_01 returns a unit pseudorandom R8 using an I8 seed. -! -! Discussion: -! -! An R8 is a real ( kind = 8 ) value. -! -! An I8 is an integer ( kind = 8 ) value. -! -! This routine implements the recursion -! -! seed = 16807 * seed mod ( 2**31 - 1 ) -! r8_uniform_01 = seed / ( 2**31 - 1 ) -! -! The integer arithmetic never requires more than 32 bits, -! including a sign bit. -! -! If the initial seed is 12345, then the first three computations are -! -! Input Output R8I8_UNIFORM_01 -! SEED SEED -! -! 12345 207482415 0.096616 -! 207482415 1790989824 0.833995 -! 1790989824 2035175616 0.947702 -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 20 September 2006 -! -! Author: -! -! John Burkardt -! -! Reference: -! -! Paul Bratley, Bennett Fox, Linus Schrage, -! A Guide to Simulation, -! Springer Verlag, pages 201-202, 1983. -! -! Pierre L'Ecuyer, -! Random Number Generation, -! in Handbook of Simulation, -! edited by Jerry Banks, -! Wiley Interscience, page 95, 1998. -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, pages 362-376, 1986. -! -! Peter Lewis, Allen Goodman, James Miller -! A Pseudo-Random Number Generator for the System/360, -! IBM Systems Journal, -! Volume 8, pages 136-143, 1969. -! -! Parameters: -! -! Input/output, integer ( kind = 8 ) SEED, the "seed" value, which should -! NOT be 0. On output, SEED has been updated. -! -! Output, real ( kind = 8 ) R8I8_UNIFORM_01, a new pseudorandom variate, -! strictly between 0 and 1. -! - implicit none - - integer ( kind = 8 ) k - real ( kind = 8 ) r8i8_uniform_01 - integer ( kind = 8 ) seed - - if ( seed == 0 ) then - write ( *, '(a)' ) ' ' - write ( *, '(a)' ) 'R8I8_UNIFORM_01 - Fatal error!' - write ( *, '(a)' ) ' Input value of SEED = 0.' - stop - end if - - k = seed / 127773 - - seed = 16807 * ( seed - k * 127773 ) - k * 2836 - - if ( seed < 0 ) then - seed = seed + huge ( seed ) - end if - - r8i8_uniform_01 = real ( seed, kind = 8 ) * 4.656612875D-10 - - return -end -function tau_sobol ( dim_num ) - -!*****************************************************************************80 -! -!! TAU_SOBOL defines favorable starting seeds for Sobol sequences. -! -! Discussion: -! -! For spatial dimensions 1 through 13, this routine returns -! a "favorable" value TAU by which an appropriate starting point -! in the Sobol sequence can be determined. -! -! These starting points have the form N = 2**K, where -! for integration problems, it is desirable that -! TAU + DIM_NUM - 1 <= K -! while for optimization problems, it is desirable that -! TAU < K. -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 02 July 2006 -! -! Author: -! -! FORTRAN77 original version by Bennett Fox. -! FORTRAN90 version by John Burkardt -! -! Reference: -! -! IA Antonov, VM Saleev, -! USSR Computational Mathematics and Mathematical Physics, -! Volume 19, 1980, pages 252 - 256. -! -! Paul Bratley, Bennett Fox, -! Algorithm 659: -! Implementing Sobol's Quasirandom Sequence Generator, -! ACM Transactions on Mathematical Software, -! Volume 14, Number 1, pages 88-100, 1988. -! -! Bennett Fox, -! Algorithm 647: -! Implementation and Relative Efficiency of Quasirandom -! Sequence Generators, -! ACM Transactions on Mathematical Software, -! Volume 12, Number 4, pages 362-376, 1986. -! -! Stephen Joe, Frances Kuo -! Remark on Algorithm 659: -! Implementing Sobol's Quasirandom Sequence Generator, -! ACM Transactions on Mathematical Software, -! Volume 29, Number 1, pages 49-57, March 2003. -! -! Ilya Sobol, -! USSR Computational Mathematics and Mathematical Physics, -! Volume 16, pages 236-242, 1977. -! -! Ilya Sobol, YL Levitan, -! The Production of Points Uniformly Distributed in a Multidimensional -! Cube (in Russian), -! Preprint IPM Akad. Nauk SSSR, -! Number 40, Moscow 1976. -! -! Parameters: -! -! Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension. Only values -! of 1 through 13 will result in useful responses. -! -! Output, integer ( kind = 4 ) TAU_SOBOL, the value TAU. -! - implicit none - - integer ( kind = 4 ), parameter :: dim_max = 13 - - integer ( kind = 4 ) dim_num - integer ( kind = 4 ), save, dimension ( dim_max ) :: tau = (/ & - 0, 0, 1, 3, 5, & - 8, 11, 15, 19, 23, & - 27, 31, 35 /) - integer ( kind = 4 ) tau_sobol - - if ( 1 <= dim_num .and. dim_num <= dim_max ) then - tau_sobol = tau(dim_num) - else - tau_sobol = - 1 - end if - - return -end -subroutine timestamp ( ) - -!*****************************************************************************80 -! -!! TIMESTAMP prints the current YMDHMS date as a time stamp. -! -! Example: -! -! May 31 2001 9:45:54.872 AM -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 31 May 2001 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! None -! - implicit none - - character ( len = 8 ) ampm - integer d - character ( len = 8 ) date - integer h - integer m - integer mm - character ( len = 9 ), parameter, dimension(12) :: month = (/ & - 'January ', 'February ', 'March ', 'April ', & - 'May ', 'June ', 'July ', 'August ', & - 'September', 'October ', 'November ', 'December ' /) - integer n - integer s - character ( len = 10 ) time - integer values(8) - integer y - character ( len = 5 ) zone - - call date_and_time ( date, time, zone, values ) - - y = values(1) - m = values(2) - d = values(3) - h = values(5) - n = values(6) - s = values(7) - mm = values(8) - - if ( h < 12 ) then - ampm = 'AM' - else if ( h == 12 ) then - if ( n == 0 .and. s == 0 ) then - ampm = 'Noon' - else - ampm = 'PM' - end if - else - h = h - 12 - if ( h < 12 ) then - ampm = 'PM' - else if ( h == 12 ) then - if ( n == 0 .and. s == 0 ) then - ampm = 'Midnight' - else - ampm = 'AM' - end if - end if - end if - - write ( *, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & - trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm ) - - return -end -subroutine timestring ( string ) - -!*****************************************************************************80 -! -!! TIMESTRING writes the current YMDHMS date into a string. -! -! Example: -! -! STRING = 'May 31 2001 9:45:54.872 AM' -! -! Licensing: -! -! This code is distributed under the GNU LGPL license. -! -! Modified: -! -! 15 March 2003 -! -! Author: -! -! John Burkardt -! -! Parameters: -! -! Output, character ( len = * ) STRING, contains the date information. -! A character length of 40 should always be sufficient. -! - implicit none - - character ( len = 8 ) ampm - integer d - character ( len = 8 ) date - integer h - integer m - integer mm - character ( len = 9 ), parameter, dimension(12) :: month = (/ & - 'January ', 'February ', 'March ', 'April ', & - 'May ', 'June ', 'July ', 'August ', & - 'September', 'October ', 'November ', 'December ' /) - integer n - integer s - character ( len = * ) string - character ( len = 10 ) time - integer values(8) - integer y - character ( len = 5 ) zone - - call date_and_time ( date, time, zone, values ) - - y = values(1) - m = values(2) - d = values(3) - h = values(5) - n = values(6) - s = values(7) - mm = values(8) - - if ( h < 12 ) then - ampm = 'AM' - else if ( h == 12 ) then - if ( n == 0 .and. s == 0 ) then - ampm = 'Noon' - else - ampm = 'PM' - end if - else - h = h - 12 - if ( h < 12 ) then - ampm = 'PM' - else if ( h == 12 ) then - if ( n == 0 .and. s == 0 ) then - ampm = 'Midnight' - else - ampm = 'AM' - end if - end if - end if - - write ( string, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & - trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm ) - - return -end diff --git a/build/FUSE_SRC/FUSE_PARSENS/.svn/all-wcprops b/build/FUSE_SRC/FUSE_PARSENS/.svn/all-wcprops deleted file mode 100644 index 54f9b7e..0000000 --- a/build/FUSE_SRC/FUSE_PARSENS/.svn/all-wcprops +++ /dev/null @@ -1,11 +0,0 @@ -K 25 -svn:wc:ra_dav:version-url -V 64 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/41/trunk/FUSE_SRC/FUSE_DRIVERS -END -qnewt_mcmc__driver.f90 -K 25 -svn:wc:ra_dav:version-url -V 87 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/41/trunk/FUSE_SRC/FUSE_DRIVERS/qnewt_mcmc__driver.f90 -END diff --git a/build/FUSE_SRC/FUSE_PARSENS/.svn/entries b/build/FUSE_SRC/FUSE_PARSENS/.svn/entries deleted file mode 100644 index bc61e83..0000000 --- a/build/FUSE_SRC/FUSE_PARSENS/.svn/entries +++ /dev/null @@ -1,62 +0,0 @@ -10 - -dir -63 -https://venture1.projectlocker.com/UoNEnvEngGroup/FUSE/svn/trunk/FUSE_SRC/FUSE_DRIVERS -https://venture1.projectlocker.com/UoNEnvEngGroup/FUSE/svn - - - -2012-03-31T03:00:04.873654Z -41 -kavetski - - - - - - - - - - - - - - -7fd0be38-6417-4f01-9cbe-fd474d0c6e94 - -qnewt_mcmc__driver.f90 -file - - - - -2013-06-12T18:10:48.079572Z -4a21ed7ba8e32ac139839e4c76d506a8 -2012-03-31T03:00:04.873654Z -41 -kavetski - - - - - - - - - - - - - - - - - - - - - -22827 - diff --git a/build/FUSE_SRC/FUSE_PARSENS/.svn/text-base/qnewt_mcmc__driver.f90.svn-base b/build/FUSE_SRC/FUSE_PARSENS/.svn/text-base/qnewt_mcmc__driver.f90.svn-base deleted file mode 100644 index aca9591..0000000 --- a/build/FUSE_SRC/FUSE_PARSENS/.svn/text-base/qnewt_mcmc__driver.f90.svn-base +++ /dev/null @@ -1,406 +0,0 @@ - -!****************************************************************** -!module softwareData -! Purpose: -! Programmer: Dmitri Kavetski -! Last modified: -! Comments: -!use DFWIN,only:GetCurrentProcessId -!implicit none -! type definitions -! variable definitions -!integer(INT_PTR_KIND())::myProcID -!---------------------------------------------------- -!contains -!---------------------------------------------------- -!function getMyProcID() -! Purpose: Returns the processID of the callling process. -! Programmer: Dmitri Kavetski -! Last modified: -! Performance -! IN: -! OUT: -! Comments: -!use DFWIN,only:GetCurrentProcessId -!implicit none -! dummies -!integer(INT_PTR_KIND())::getMyProcID -! Start procedure here -!getMyProcID=GetCurrentProcessId() -! End procedure here -!endfunction getMyProcID -!---------------------------------------------------- -!endmodule softwareData -!****************************************************************** - - - -PROGRAM QNEWT_MCMC__DRIVER -! --------------------------------------------------------------------------------------- -! Creator: -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! Driver program for multi-start quasi-newton optimization -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE fuse_fileManager,only:FORCINGINFO,OUTPUT_PATH ! directory for data files -! data modules -USE model_defn,nstateFUSE=>nstate ! model definition structures -USE multiforce, ONLY: DELTIM ! data interval = maximum model time step -USE multiparam, ONLY: LPARAM, PARATT, NUMPAR ! parameter metadata structures -USE multiroute ! model routing structures -USE multistats ! model statistics structures -! informational modules -USE selectmodl_module ! reads model control file -USE getpar_str_module ! extracts parameter metadata -USE par_insert_module ! inserts model parameters -USE get_objfnc_module ! wrapper to get objective function from NetCDF output files -USE metaoutput, ONLY: Q_ONLY ! Q_ONLY=.TRUE. to restrict write to streamflow time series -! model numerix -USE model_numerix ! defines decisions on model numerix -! access to qnewton and model simulation modules -USE dmsl_wrapper_module ! wrapper for dmsl -USE fuse_rmse_module ! run model and compute the root mean squared error -! software settings (Windows only) -!use softwareData -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -! (0) GET COMMAND-LINE ARGUMENTS... -! --------------------------------------------------------------------------------------- -LOGICAL(LGT) :: READ_ARG ! .true. to read command-line arguments -CHARACTER(LEN=12) :: MBASIN_ID=' ' ! MOPEX basin ID -CHARACTER(LEN=6) :: FMODEL_ID=' ' ! integer defining FUSE model -CHARACTER(LEN=6) :: NSOLUTION=' ' ! numerical solution (0=implicit, 1=explicit) -CHARACTER(LEN=6) :: FADAPTIVE=' ' ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -CHARACTER(LEN=6) :: TRUNC_ABS=' ' ! absolute temporal truncation error tolerance -CHARACTER(LEN=6) :: TRUNC_REL=' ' ! relative temporal truncation error tolerance -CHARACTER(LEN=6) :: NUM_MULTI=' ' ! number of multiple re-starts -CHARACTER(LEN=6) :: SOBOLSEED=' ' ! starting seed in the Sobol sequence -CHARACTER(LEN=6) :: NUMDIGITS=' ' ! number of reliable digits in function evaluation -CHARACTER(LEN=6) :: DO_QNEWTN=' ' ! T means do the quasi-Newton -! --------------------------------------------------------------------------------------- -! (1) SETUP MODELS FOR SIMULATION -- POPULATE DATA STRUCTURES -! --------------------------------------------------------------------------------------- -! get model forcing data -INTEGER(I4B) :: NTIM ! number of time steps -INTEGER(I4B) :: INFERN_START ! start of inference period -! get model setup -INTEGER(I4B) :: FUSE_ID ! integer defining FUSE model -INTEGER(I4B) :: I,J,K ! looping -INTEGER(I4B) :: NMOD ! number of models -INTEGER(I4B) :: ERR ! error code -CHARACTER(LEN=256) :: MESSAGE ! error message -! define model output -LOGICAL(LGT) :: OUTPUT_FLAG ! .TRUE. = write time series output -! --------------------------------------------------------------------------------------- -! (2) MULTI-START QUASI-NETWON OPTIMIZATION -! --------------------------------------------------------------------------------------- -! Check if there is a need to run the multi-start qNewton method -LOGICAL(LGT) :: QNEW_FLAG ! .TRUE. means run multi-start qNewton -CHARACTER(LEN=32) :: OF_NAME ! name of the desired objective function -REAL(SP), DIMENSION(:), ALLOCATABLE :: OF_VALS ! objective functioni values -! Control of the multi-start method -INTEGER(I4B) :: NMULTI ! number of multiple re-starts -INTEGER(I4B) :: IBEGIN ! starting seed in the Sobol sequence -! Define file unit -INTEGER(I4B), PARAMETER :: UOUT_QNEW=21 ! output unit for run-time information (quasi-newton) -! Looping variables -INTEGER(I4B) :: ISEED ! loop through seeds in the Sobol sequence -INTEGER(I4B) :: IPAR ! loop through model parameters -! Identify the initial parameter set -INTEGER(KIND=4) :: JSEED ! index in the Sobol sequence -REAL(KIND=4),DIMENSION(:),ALLOCATABLE :: URAND ! vector of uniform random numbers (from the Sobol sequence) -TYPE(PARATT) :: PARAM_META ! parameter metadata (model parameters) -REAL(SP),PARAMETER :: PSELECT=0.9_SP ! fraction of parameter space to select initial seed -INTEGER(I4B) :: ONEMOD ! index of the model used (=1) -! Input to qNewton -REAL(SP),DIMENSION(:),ALLOCATABLE :: X0I ! initial estimate of solution -REAL(SP),DIMENSION(:),ALLOCATABLE :: XLO ! lower bound on solution, either none or both bounds must be present -REAL(SP),DIMENSION(:),ALLOCATABLE :: XHI ! upper bound on solution, either none or both bounds must be present -REAL(SP),DIMENSION(:),ALLOCATABLE :: XSC ! typical scale of the parameters -INTEGER(I4B) :: FDIGITS ! number of reliable digits in function evaluation -!***** ! (-2=estimate,-1=full machine precision) -! Approximate optimal solution -REAL(SP),DIMENSION(:),ALLOCATABLE :: XOPT ! optimum value of "x", for which f(x) takes its minimum value -REAL(SP) :: FOPT ! function value at optimum -! Computational cost report -INTEGER(I4B) :: ITER ! number of steps (iterations) -INTEGER(I4B) :: FCALLS ! number of function calls -INTEGER(I4B) :: GCALLS ! number of gradient calls -INTEGER(I4B) :: HCALLS ! number of Hessian calls -! --------------------------------------------------------------------------------------- -! (2) MONTE-CARLO MARKOV CHAINS -! --------------------------------------------------------------------------------------- -! Define initial sample and diagonal of the covariance matrix -real(mrk),dimension(:),allocatable :: sample0,sdevDiag0 -! Define files -CHARACTER(LEN=256) :: FNAME_PRODKT ! name of MCMC production file -LOGICAL(LGT) :: LEXIST ! logical flag if the file exists -INTEGER(I4B), PARAMETER :: UIN_MCMC=31 ! input unit for MCMC production files -LOGICAL(LGT) :: JUMP_FLAG ! flag to denote a jump in MCMC -INTEGER(I4B), DIMENSION(1) :: IMIN ! index of seed with highest OF value -REAL(SP),DIMENSION(:,:),ALLOCATABLE :: XPAR ! parameter sets for all local optima -! auxiliaries -character(50)::string(0:9) -integer(I4B)::parSetHow - -!MyProcID=GetCurrentProcessId() -! --------------------------------------------------------------------------------------- -! (1) READ COMMAND LINE ARGUMENTS -! --------------------------------------------------------------------------------------- -! read command-line arguments -read_arg=.false. -if(read_arg)then - CALL GETARG( 1,MBASIN_ID) ! MOPEX basin ID - CALL GETARG( 2,FMODEL_ID) ! integer defining FUSE model - CALL GETARG( 3,NSOLUTION) ! numerical solution (0=explicit, 1=implicit) - CALL GETARG( 4,FADAPTIVE) ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) - CALL GETARG( 5,TRUNC_ABS) ! absolute temporal truncation error tolerance - CALL GETARG( 6,TRUNC_REL) ! relative temporal truncation error tolerance - CALL GETARG( 7,NUM_MULTI) ! number of re-starts - CALL GETARG( 8,SOBOLSEED) ! starting seed in the Sobol sequence - CALL GETARG( 9,NUMDIGITS) ! number of reliable digits in function evaluation - CALL GETARG(10,DO_QNEWTN) ! T = run multi-start quasi-Newton -else - MBASIN_ID="mahurangi" - FMODEL_ID="070" - NSOLUTION="3" ! 0=explicit Euler, 1=explicit Heun, 2=implicit Euler, 3=imp Heun, 4=semi-implicit Euler - FADAPTIVE="1" ! 0=fixed-step, 1=adaptive - TRUNC_ABS="1.e-2" - TRUNC_REL="1.e-2" - NUM_MULTI="2" - SOBOLSEED="1" - NUMDIGITS="10" - DO_QNEWTN="F" -endif -! check command-line arguments -IF (LEN_TRIM(MBASIN_ID).EQ.0) STOP '1st command-line argument is missing (MBASIN_ID)' -IF (LEN_TRIM(FMODEL_ID).EQ.0) STOP '2nd command-line argument is missing (FMODEL_ID)' -IF (LEN_TRIM(NSOLUTION).EQ.0) STOP '3rd command-line argument is missing (NSOLUTION)' -IF (LEN_TRIM(FADAPTIVE).EQ.0) STOP '4th command-line argument is missing (FADAPTIVE)' -IF (LEN_TRIM(TRUNC_ABS).EQ.0) STOP '5th command-line argument is missing (TRUNC_ABS)' -IF (LEN_TRIM(TRUNC_REL).EQ.0) STOP '6th command-line argument is missing (TRUNC_REL)' -IF (LEN_TRIM(NUM_MULTI).EQ.0) STOP '7th command-line argument is missing (NUM_MULTI)' -IF (LEN_TRIM(SOBOLSEED).EQ.0) STOP '8th command-line argument is missing (SOBOLSEED)' -IF (LEN_TRIM(NUMDIGITS).EQ.0) STOP '9th command-line argument is missing (NUMDIGITS)' -! define basin desired -FORCINGINFO = 'forcinginfo.'//TRIM(MBASIN_ID)//'.txt' -! convert command-line arguments to integer flags and real numbers -CALL GETNUMERIX(err,message) ! defines method/parameters used for numerical solution -IF (ERR.NE.0) THEN - PRINT *, TRIM(MESSAGE); STOP -ENDIF -READ(FMODEL_ID,*) FUSE_ID ! integer definining FUSE model -READ(NSOLUTION,*) SOLUTION_METHOD ! numerical solution (0=implicit, 1=explicit) -READ(FADAPTIVE,*) TEMPORAL_ERROR_CONTROL ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -READ(TRUNC_ABS,*) ERR_TRUNC_ABS ! absolute temporal truncation error tolerance -READ(TRUNC_REL,*) ERR_TRUNC_REL ! relative temporal truncation error tolerance -READ(NUM_MULTI,*) NMULTI ! define the number of re-starts -READ(SOBOLSEED,*) IBEGIN ! starting seed in the Sobol sequence -READ(NUMDIGITS,*) FDIGITS ! number of reliable digits in function evaluation -!MAX_TSTEP = 0.1_sp ! forces dense substeps (eg, when checking solutions) -! check if there is a need to run the multi-start quasi-Newton method -QNEW_FLAG=.FALSE. -IF (LEN_TRIM(DO_QNEWTN).EQ.1) THEN - IF (DO_QNEWTN.EQ.'T') QNEW_FLAG=.TRUE. -ENDIF -! additional checks -SELECT CASE(SOLUTION_METHOD); CASE(EXPLICIT_EULER,EXPLICIT_HEUN,IMPLICIT_EULER,IMPLICIT_HEUN,SEMI_IMPLICIT) -CASE DEFAULT - PRINT *, 'solution method (1st command line argument) must equal 0 (explicit_euler), 1 (explicit heun), '//& - '2 (implicit_euler), 3 (implicit_heun), or 4 (semi_implicit)' - STOP -END SELECT -SELECT CASE(TEMPORAL_ERROR_CONTROL); CASE(TS_FIXED,TS_ADAPT); CASE DEFAULT; - STOP 'temporal error control (2nd command line argument) must equal 0 (fixed steps) or 1 (adaptive steps)' -END SELECT -IF (NMULTI.LE.0) STOP 'number of re-starts (6th command line argument) must be > 0' -IF (IBEGIN.LE.0) STOP 'starting seed in the Sobol sequence must be greater > 0' -write(*,'(A5,1X,2(I1,1X),2(E12.5,1X),I6,1X,A11,1X,2(I6,1X))') 'FUSE ', & -SOLUTION_METHOD, TEMPORAL_ERROR_CONTROL, ERR_TRUNC_ABS, ERR_TRUNC_REL, & -NMULTI, TRIM(SOBOLSEED), IBEGIN, FDIGITS -! --------------------------------------------------------------------------------------- -! (1) GET MODEL SETUP -- MODEL DEFINITION, AND PARAMETER AND VARIABLE INFO FOR ALL MODELS -! --------------------------------------------------------------------------------------- -! Read data from the "BATEA-compliant" ASCII files -CALL GETFORCING(INFERN_START,NTIM) -! Define model attributes (valid for all models) -CALL UNIQUEMODL(NMOD,ERR,MESSAGE) ! get nmod unique models -IF (ERR.NE.0) THEN - PRINT *, TRIM(MESSAGE); STOP -ENDIF -CALL GETPARMETA(ERR,MESSAGE) ! read parameter metadata (parameter bounds etc.) -IF (ERR.NE.0) THEN - PRINT *, TRIM(MESSAGE); STOP -ENDIF -! Identify a single model (use FUSE_ID instead of reading ../input/m_decisions.txt) -CALL SELECTMODL(FUSE_ID,ISTATUS=ERR,MESSAGE=MESSAGE) -IF (ERR.NE.0) THEN - PRINT *, TRIM(MESSAGE); STOP -ENDIF -! Define list of states and parameters for the current model -CALL ASSIGN_STT() ! state definitions are stored in module model_defn -CALL ASSIGN_PAR() ! parameter defintions are stored in module multiparam -CALL ASSIGN_FLX() ! flux definitions stored in module model_defn -! compute derived model parameters (bucket sizes, etc.) -CALL PAR_DERIVE(ERR,MESSAGE) -IF (ERR.NE.0) THEN - PRINT *, TRIM(MESSAGE); STOP -ENDIF -! allocate arrays for quasi-Newton -ALLOCATE(X0I(NUMPAR),XLO(NUMPAR),XHI(NUMPAR),XSC(NUMPAR),URAND(NUMPAR),XOPT(NUMPAR)) -! allocate arrays for MCMC -allocate(sample0(0:numpar),sdevDiag0(0:numpar)) -!DK-note 31 March 2012: I do not recall why sample0 and sdevDiag0 are (0:) rather than (1:) -! get parameter bounds and random numbers -DO IPAR=1,NUMPAR - CALL GETPAR_STR(LPARAM(IPAR)%PARNAME,PARAM_META) - XLO(IPAR) = PARAM_META%PARLOW ! lower bound - XHI(IPAR) = PARAM_META%PARUPP ! upper bound - XSC(IPAR) = PARAM_META%PARSCL ! typical scale -END DO -! -------------------------------------------------------------------------------------- -! (2) MULTI START QUASI-NEWTON... -! -------------------------------------------------------------------------------------- -! define the desired objective function and allocate space for the objective function values -OF_NAME = 'raw_rmse'; ALLOCATE(OF_VALS(NMULTI),XPAR(NUMPAR,NMULTI)) -! loop through different starting positions (use the Sobol sequence) -DO ISEED=IBEGIN,(IBEGIN+NMULTI)-1 - ! get the seed as a character string - WRITE(SOBOLSEED,'(i3.3)') ISEED - ! define file prefix (add seeds) - FNAME_PREFIX = TRIM(OUTPUT_PATH)//'DMSL_'//TRIM(MBASIN_ID)//'__'//TRIM(SMODL%MNAME)//'__'//TRIM(SOBOLSEED)//'__'//& - TRIM(NSOLUTION)//'-'//TRIM(FADAPTIVE)//'__'//TRIM(NUMDIGITS)//'__'//& - TRIM(TRUNC_ABS)//'__'//TRIM(TRUNC_REL) - ! define NetCDF files (filename shared in MODULE model_defn) - FNAME_NETCDF = TRIM(FNAME_PREFIX)//'__qnewton.nc' - ONEMOD=1 ! one file per model (i.e., model dimension = 1) - - ! check if there is a need to run quasi-Newton - IF (QNEW_FLAG) THEN ! need to run quasi-Newton - PCOUNT=0 ! counter for parameter sets in output file (shared in MODULE multistats) - FCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) - OUTPUT_FLAG = .TRUE. ! write model time series - Q_ONLY = .TRUE. ! restrict output time series to simulated runofff - CALL DEF_PARAMS(ONEMOD) ! define model parameters (initial CREATE) - IF (OUTPUT_FLAG) CALL DEF_OUTPUT(NTIM) ! define model time series (REDEF) - CALL DEF_SSTATS() ! define summary statistics (REDEF) - ! define ASCII files (filename shared in MODULE model_defn) - FNAME_ASCII = TRIM(FNAME_PREFIX)//'__qnewton.txt' - ! open ASCII file (unit 21) - OPEN(UOUT_QNEW,FILE=FNAME_ASCII, STATUS='unknown') - ! get new parameter sets - JSEED=ISEED; CALL I4_SOBOL(NUMPAR,JSEED,URAND) - WRITE(*,'(2(I4,1X),20(E10.2,1X))') ISEED, JSEED-1, URAND - X0I = XLO + ((1._SP - PSELECT)/2._SP)*(XHI-XLO) + (PSELECT*REAL(URAND,KIND(SP)))*(XHI-XLO) - ! find local optimum in the vicinity of the starting point - CALL QNEWTON_WRAPPER(X0I,XLO,XHI,XSC,FDIGITS,UOUT_QNEW,XOPT,FOPT,ITER,FCALLS,GCALLS,HCALLS,& - ERR,MESSAGE) - IF (ERR.NE.0) PRINT *, TRIM(MESSAGE) - WRITE(*,'(5(I6,1X),20(F9.3,1X))') FCOUNT,ITER,FCALLS,GCALLS,HCALLS,FOPT,XOPT - ! run model again with optimum parameter set (to populate structures and write model output) - CALL FUSE_RMSE(XOPT,FOPT,OUTPUT_FLAG) - ! write model parameters and summary statistics - CALL PUT_PARAMS(PCOUNT,ONEMOD) ! PCOUNT = index for parameter set; ONEMOD=1 (just one model structure) - CALL PUT_SSTATS(PCOUNT,ONEMOD) - CLOSE(UOUT_QNEW) - ENDIF - ! get objective function value for the first parameter set - PCOUNT=1; CALL GET_OBJFNC(FNAME_NETCDF,OF_NAME,ONEMOD,PCOUNT,FOPT,XOPT) - OF_VALS(ISEED) = FOPT - XPAR(:,ISEED) = XOPT(:) - write(*,'(20(f12.6,1x))') OF_VALS(ISEED), XPAR(:,ISEED) -END DO -! -------------------------------------------------------------------------------------- -! (3a) MCMC... -! -------------------------------------------------------------------------------------- -! identify the maximum seed and retrieve model parameter set -IMIN = MINLOC(OF_VALS) -FOPT = OF_VALS(IMIN(1)) -XOPT(:) = XPAR(:,IMIN(1)) -write(*,'(i3,1x,20(f12.6,1x))') IMIN(1), FOPT, XOPT -! define write parameters for model output -PCOUNT=0 ! counter for parameter sets in output file (shared in MODULE multistats) -FCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) -OUTPUT_FLAG = .TRUE. ! write model time series -Q_ONLY = .TRUE. ! restrict output time series to simulated runofff -! define file prefix (no seeds in the filename) -FNAME_PREFIX = TRIM(OUTPUT_PATH)//'DMSL_'//TRIM(MBASIN_ID)//'__'//TRIM(SMODL%MNAME)//'__'//& - TRIM(NSOLUTION)//'-'//TRIM(FADAPTIVE)//'__'//TRIM(NUMDIGITS)//'__'//& - TRIM(TRUNC_ABS)//'__'//TRIM(TRUNC_REL) -! define NetCDF files (filename shared in MODULE model_defn) -FNAME_NETCDF = TRIM(FNAME_PREFIX)//'__mcmc.nc' -CALL DEF_PARAMS(ONEMOD) ! define model parameters (initial CREATE) -IF (OUTPUT_FLAG) CALL DEF_OUTPUT(NTIM) ! define model time series (REDEF) -CALL DEF_SSTATS() ! define summary statistics (REDEF) -! get MCMC samples -parSetHow=1 -selectcase(parSetHow) -case default - sample0(0) = log10(FOPT**2) ! variance - sample0(1:) = XOPT(1:) -case(1) ! 9/10/2009: checking MCMC method - sample0=(/-1.09935261642738E-001_mrk,& - 1.01300120353699E+000_mrk,& - 9.49999988079071E-001_mrk,& - 2.24372955322266E+002_mrk,& - 5.00000000000000E+003_mrk,& - 1.48710086941719E-002_mrk,& - 1.20471649169922E+001_mrk,& - 2.00000000000000E+001_mrk,& - 8.33424106240273E-002_mrk,& - 8.67173850536346E-001_mrk /) - sdevDiag0=-666.6_mrk - string=(/"BFBC24B7A16EC99A",& - "3FF03540C0000000","3FEE666660000000","406C0BEF40000000",& - "40B3880000000000","3F8E74B100000000","4028182600000000",& - "4034000000000000","3FB555EDA0000000","3FEBBFE360000000"/) - do i=0,9 - read(string(i),'(Z16.16)',iostat=err)sdevDiag0(i) - enddo -! sample0=sdevDiag0 -case(2) ! 9/10/2009: checking against FUSE visualdriver - sample0(0)=0._mrk ! log10(VAR), assume VAR=1 - do ipar=1,numpar - call getpar_str(lparam(ipar)%parname,param_meta) - sample0(ipar)=param_meta%pardef - end do -endselect -sdevDiag0(0) = 0.1_mrk*max(abs(sample0(0)),1._mrk) -sdevDiag0(1:) = 0.1_mrk*max(abs(sample0(1:)),xsc) -!DK 31/03/2012: since we switched from var to sdev, this now means 10% sdev rather than 10% var, -! but this is just initialisation of MCMC, so its ok. -CALL MCMC_WRAPPER(sample0=sample0,sdevDiag0=sdevDiag0,ierr=err,message=message) -if(err/=0)then - write(*,*)trim(message) - stop -endif -! read the ASCII production MCMC output file and re-run for each of the parameter sets -FNAME_PRODKT = TRIM(FNAME_PREFIX)//'__prodkt.sam' -!FNAME_PRODKT = TRIM(FNAME_PREFIX)//'__testin.sam' -INQUIRE(FILE=TRIM(FNAME_PRODKT),EXIST=LEXIST) -IF (.NOT.LEXIST) STOP ' PRODKT FILE DOES NOT EXIST ' -OPEN(UIN_MCMC,FILE=TRIM(FNAME_PRODKT),IOSTAT=ERR) -IF (ERR.NE.0) THEN; PRINT *, ERR, ' PROBLEM OPENING FILE '; STOP; ENDIF - DO ! continuous do loop with exit clause - ! read a parameter set - READ(UIN_MCMC,*,IOSTAT=ERR) sample0, MSTATS%LOGP_SIMULN, JUMP_FLAG; IF (ERR.NE.0) EXIT - MSTATS%JUMP_TAKEN = 0._SP; IF (JUMP_FLAG) MSTATS%JUMP_TAKEN = 1._SP ! (convert flag to real) - !print *, 'sampled variance = ', sample0(0) - ! run FUSE - CALL FUSE_RMSE(sample0(1:),FOPT,OUTPUT_FLAG) - !print *, 'rmse**2 = ', FOPT**2 - - !pause - ! write model parameters and summary statistics - CALL PUT_PARAMS(PCOUNT,ONEMOD) ! PCOUNT = index for parameter set; ONEMOD=1 (just one model structure) - CALL PUT_SSTATS(PCOUNT,ONEMOD) - END DO -CLOSE(UIN_MCMC) -! -------------------------------------------------------------------------------------- -! deallocate parameter vectors -DEALLOCATE(X0I,XLO,XHI,XSC,URAND,XOPT,sample0,sdevDiag0) -STOP -END PROGRAM QNEWT_MCMC__DRIVER -! -------------------------------------------------------------------------------------- diff --git a/build/FUSE_SRC/FUSE_SCE/.svn/all-wcprops b/build/FUSE_SRC/FUSE_SCE/.svn/all-wcprops deleted file mode 100644 index c433fde..0000000 --- a/build/FUSE_SRC/FUSE_SCE/.svn/all-wcprops +++ /dev/null @@ -1,29 +0,0 @@ -K 25 -svn:wc:ra_dav:version-url -V 60 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/10/trunk/FUSE_SRC/FUSE_SCE -END -sce_driver.f90 -K 25 -svn:wc:ra_dav:version-url -V 75 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/10/trunk/FUSE_SRC/FUSE_SCE/sce_driver.f90 -END -fuse_rmse.f90 -K 25 -svn:wc:ra_dav:version-url -V 74 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/10/trunk/FUSE_SRC/FUSE_SCE/fuse_rmse.f90 -END -functn.f90 -K 25 -svn:wc:ra_dav:version-url -V 70 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_SCE/functn.f90 -END -sce.f -K 25 -svn:wc:ra_dav:version-url -V 65 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_SCE/sce.f -END diff --git a/build/FUSE_SRC/FUSE_SCE/.svn/entries b/build/FUSE_SRC/FUSE_SCE/.svn/entries deleted file mode 100644 index 5156800..0000000 --- a/build/FUSE_SRC/FUSE_SCE/.svn/entries +++ /dev/null @@ -1,164 +0,0 @@ -10 - -dir -63 -https://venture1.projectlocker.com/UoNEnvEngGroup/FUSE/svn/trunk/FUSE_SRC/FUSE_SCE -https://venture1.projectlocker.com/UoNEnvEngGroup/FUSE/svn - - - -2009-11-20T05:52:33.882819Z -10 -kavetski - - - - - - - - - - - - - - -7fd0be38-6417-4f01-9cbe-fd474d0c6e94 - -sce_driver.f90 -file - - - - -2013-06-12T18:10:49.631579Z -a2fdc330ba319a850514ea704f01c5ac -2009-11-20T05:52:33.882819Z -10 -kavetski - - - - - - - - - - - - - - - - - - - - - -9920 - -fuse_rmse.f90 -file - - - - -2013-06-12T18:10:49.631579Z -ca2524c36a464657e7597132ddad098f -2009-11-20T05:52:33.882819Z -10 -kavetski - - - - - - - - - - - - - - - - - - - - - -7641 - -functn.f90 -file - - - - -2013-06-12T18:10:49.631579Z -9da148d7bd380cec5dee1b4affbf2f1b -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1870 - -sce.f -file - - - - -2013-06-12T18:10:49.631579Z -59464d84267974a50cb08b957793582a -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -23830 - diff --git a/build/FUSE_SRC/FUSE_SCE/.svn/text-base/functn.f90.svn-base b/build/FUSE_SRC/FUSE_SCE/.svn/text-base/functn.f90.svn-base deleted file mode 100644 index 5255e08..0000000 --- a/build/FUSE_SRC/FUSE_SCE/.svn/text-base/functn.f90.svn-base +++ /dev/null @@ -1,36 +0,0 @@ -FUNCTION FUNCTN(NOPT,A) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Wrapper for SCE (used to compute the objective function) -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE fuse_rmse_module ! run model and compute the root mean squared error -IMPLICIT NONE -! input -INTEGER(I4B) :: NOPT ! number of parameters -REAL(MSP), DIMENSION(16), INTENT(IN) :: A ! parameter set -! internal -REAL(SP), DIMENSION(:), ALLOCATABLE :: SCE_PAR ! sce parameter set -INTEGER(I4B) :: IERR ! error code for allocate/deallocate -LOGICAL(LGT) :: OUTPUT_FLAG ! .TRUE. = write model time series -REAL(SP) :: RMSE ! root mean squared error -! output -REAL(MSP) :: FUNCTN ! objective function value -! --------------------------------------------------------------------------------------- -! get SCE parameter set -ALLOCATE(SCE_PAR(NOPT), STAT=IERR); IF (IERR.NE.0) STOP ' problem allocating space ' -SCE_PAR(1:NOPT) = A(1:NOPT) ! convert from MSP used in SCE to SP used in FUSE -! compute RMSE -OUTPUT_FLAG=.FALSE. ! .TRUE. = write model time series -CALL FUSE_RMSE(SCE_PAR,RMSE,OUTPUT_FLAG) -! deallocate parameter set -DEALLOCATE(SCE_PAR, STAT=IERR); IF (IERR.NE.0) STOP ' problem deallocating space ' -! save objective function value -FUNCTN = RMSE -! --------------------------------------------------------------------------------------- -END FUNCTION FUNCTN diff --git a/build/FUSE_SRC/FUSE_SCE/.svn/text-base/fuse_rmse.f90.svn-base b/build/FUSE_SRC/FUSE_SCE/.svn/text-base/fuse_rmse.f90.svn-base deleted file mode 100644 index 58bb014..0000000 --- a/build/FUSE_SRC/FUSE_SCE/.svn/text-base/fuse_rmse.f90.svn-base +++ /dev/null @@ -1,152 +0,0 @@ -MODULE FUSE_RMSE_MODULE ! have as a module because of dynamic arrays -IMPLICIT NONE -CONTAINS -SUBROUTINE FUSE_RMSE(XPAR,RMSE,OUTPUT_FLAG,MPARAM_FLAG) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Calculate the RMSE for single FUSE model and single parameter set -! input: model parameter set -! output: root mean squared error -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -! data modules -USE model_defn, ONLY:NSTATE,SMODL ! number of state variables -USE multiparam, ONLY:LPARAM,NUMPAR,MPARAM ! list of model parameters -USE multiforce, ONLY:MFORCE,AFORCE,DELTIM,ISTART,& ! model forcing data - NUMTIM ! model forcing data (continued) -USE multistate, ONLY:fracstate0,TSTATE,MSTATE,FSTATE,& ! model states - HSTATE ! model states (continued) -USE multiroute, ONLY:MROUTE,AROUTE ! routed runoff -USE multistats, ONLY:MSTATS,PCOUNT,MOD_IX ! access model statistics; counter for param set -! informational modules -USE par_insert_module ! insert parameters into data structures -USE str_2_xtry_module ! provide access to the routine str_2_xtry -! 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) :: OUTPUT_FLAG ! .TRUE. if desire time series output -LOGICAL(LGT), INTENT(IN), OPTIONAL :: MPARAM_FLAG ! .FALSE. (used to turn off writing statistics) -! output -REAL(SP),INTENT(OUT) :: RMSE ! root mean squared error -! internal -REAL(SP) :: T1,T2 ! CPU time -INTEGER(I4B) :: ITIM ! loop through time series -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 -CHARACTER(LEN=CLEN) :: MESSAGE ! error message -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_rmse ' -! increment parameter counter for model output (shared in module MULTISTATS) -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) -!DO IPAR=1,NUMPAR; WRITE(*,'(A11,1X,F9.3)') LPARAM(IPAR), XPAR(IPAR); END DO -! compute derived model parameters (bucket sizes, etc.) -CALL PAR_DERIVE() -! initialize model states and model time step -CALL INIT_STATE(fracState0) ! fracState0 is shared in MODULE multistate -CALL STR_2_XTRY(FSTATE,STATE0) ! get the vector of states from the FSTATE structure -DT_SUB = DELTIM ! init stepsize to full step (DELTIM shared in module multiforce) -DT_FULL = DELTIM ! init stepsize to full step (DELTIM shared in module multiforce) -! initialize summary statistics -CALL INIT_STATS() -CALL CPU_TIME(T1) -! loop through time -DO ITIM=1,NUMTIM ! (NUMTIM is shared in MODULE multiforce) - ! run model for one time step - MFORCE = AFORCE(ITIM) ! assign model forcing data - MSTATE = FSTATE ! refresh model states - CALL INITFLUXES() ! set weighted sum of fluxes to zero - ! testing - !if (itim.eq.392) then - !allocate(j(2,2),dsdt(2)) - !do itest=695000,696000 - ! do jtest=544000,545000 - !do itest=5500,7500,5 - ! do jtest=4500,6500,5 - !test_a = real(itest,kind(sp))/10000._dp; test_b=real(jtest,kind(sp))/10000._dp - !test_a = real(itest,kind(sp))/100._dp; test_b=real(jtest,kind(sp))/100._dp - !state1 = (/test_a,test_b/) - !dsdt = fuse_deriv(state1) - !call fdjac_ode(state1,dsdt,j) - !state1 = (/test_a,test_b/) ! (modified in fdjac_ode) - !write(*,'(10(f14.10,1x))') state0, state1, dsdt, state1 - (state0 + dsdt), j(1,1), j(2,2) - !end do - !end do - !deallocate(j,dsdt) - !stop - !endif - ! 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() - ! save state - STATE0=STATE1 - ! save instantaneous and routed runoff - AROUTE(ITIM)%Q_INSTNT = MROUTE%Q_INSTNT ! save instantaneous runoff - AROUTE(ITIM)%Q_ROUTED = MROUTE%Q_ROUTED ! save routed runoff - !if (itim.ge.300) & - !WRITE(*,'(I10,1X,I4,1X,4(I2,1X),F9.3,1X,F20.1,1X,4(F11.3,1X),I7)') & - ! ITIM, AFORCE(ITIM), AROUTE(ITIM)%Q_ROUTED, NUM_FUNCS - !if (itim.gt.400) stop - !WRITE(*,'(I10,1X,4(F15.8,1X))') ITIM, FSTATE%WATR_1, FSTATE%WATR_2, MPARAM%MAXWATR_1, MPARAM%MAXWATR_2 - IF (AROUTE(ITIM)%Q_ROUTED.LT.0._sp) STOP ' Q_ROUTED is less than zero ' - IF (AROUTE(ITIM)%Q_ROUTED.GT.1000._sp) STOP ' Q_ROUTED is enormous ' - ! compute summary statistics - CALL COMP_STATS() - ! write model output - IF (OUTPUT_FLAG) THEN - CALL PUT_OUTPUT(PCOUNT,MOD_IX,ITIM) - !WRITE(*,'(I10,1X,2(F15.8,1X))') ITIM, FSTATE%WATR_1, FSTATE%WATR_2 - !WRITE(*,'(I10,1X,I4,1X,4(I2,1X),F9.3,1X,F20.1,1X,4(F11.3,1X))') ITIM, AFORCE(ITIM), AROUTE(ITIM)%Q_ROUTED - ENDIF -END DO ! (itim) -CALL CPU_TIME(T2) -!print *, t2-t1 -! calculate mean summary statistics -CALL MEAN_STATS() -RMSE = MSTATS%RAW_RMSE -WRITE(unt,'(2(I6,1X),3(F20.15,1X))') MOD_IX, PCOUNT, MSTATS%RAW_RMSE, MSTATS%NASH_SUTT, MSTATS%NUM_FUNCS -! write model parameters and summary statistics -IF (.NOT.PRESENT(MPARAM_FLAG)) THEN - CALL PUT_PARAMS(PCOUNT,MOD_IX) ! PCOUNT = index for parameter set; ONEMOD=1 (just one model structure) - CALL PUT_SSTATS(PCOUNT,MOD_IX) -ELSE - IF (MPARAM_FLAG) THEN - CALL PUT_PARAMS(PCOUNT,MOD_IX) ! PCOUNT = index for parameter set; ONEMOD=1 (just one model structure) - CALL PUT_SSTATS(PCOUNT,MOD_IX) - ENDIF -ENDIF -! deallocate state vectors -DEALLOCATE(STATE0,STATE1,STAT=IERR); IF (IERR.NE.0) STOP ' problem deallocating state vectors in fuse_rmse ' -! --------------------------------------------------------------------------------------- -END SUBROUTINE FUSE_RMSE -END MODULE FUSE_RMSE_MODULE diff --git a/build/FUSE_SRC/FUSE_SCE/.svn/text-base/sce.f.svn-base b/build/FUSE_SRC/FUSE_SCE/.svn/text-base/sce.f.svn-base deleted file mode 100644 index 9810b66..0000000 --- a/build/FUSE_SRC/FUSE_SCE/.svn/text-base/sce.f.svn-base +++ /dev/null @@ -1,850 +0,0 @@ - SUBROUTINE SCEUA(A,AF,BL,BU,NOPT,MAXN,KSTOP,PCENTO,ISEED, - & NGS,NPG,NPS,NSPL,MINGS,INIFLG,IPRINT,ISCE) -C -C -C SHUFFLED COMPLEX EVOLUTION METHOD FOR GLOBAL OPTIMIZATION -C -- VERSION 2.1 -C -C BY QINGYUN DUAN -C DEPARTMENT OF HYDROLOGY & WATER RESOURCES -C UNIVERSITY OF ARIZONA, TUCSON, AZ 85721 -C (602) 621-9360, EMAIL: DUAN@HWR.ARIZONA.EDU -C -C WRITTEN IN OCTOBER 1990. -C REVISED IN AUGUST 1991 -C REVISED IN APRIL 1992 -C -C STATEMENT BY AUTHOR: -C -------------------- -C -C THIS GENERAL PURPOSE GLOBAL OPTIMIZATION PROGRAM IS DEVELOPED AT -C THE DEPARTMENT OF HYDROLOGY & WATER RESOURCES OF THE UNIVERSITY -C OF ARIZONA. FURTHER INFORMATION REGARDING THE SCE-UA METHOD CAN -C BE OBTAINED FROM DR. Q. DUAN, DR. S. SOROOSHIAN OR DR. V.K. GUPTA -C AT THE ADDRESS AND PHONE NUMBER LISTED ABOVE. WE REQUEST ALL -C USERS OF THIS PROGRAM MAKE PROPER REFERENCE TO THE PAPER ENTITLED -C 'EFFECTIVE AND EFFICIENT GLOBAL OPTIMIZATION FOR CONCEPTUAL -C RAINFALL-RUNOFF MODELS' BY DUAN, Q., S. SOROOSHIAN, AND V.K. GUPTA, -C WATER RESOURCES RESEARCH, VOL 28(4), PP.1015-1031, 1992. -C -C -C LIST OF INPUT ARGUEMENT VARIABLES -C -C A(.) = INITIAL PARAMETER SET -C BL(.) = LOWER BOUND ON PARAMETERS -C BU(.) = UPPER BOUND ON PARAMETERS -C NOPT = NUMBER OF PARAMETERS TO BE OPTIMIZED -C -C -C LIST OF SCE ALGORITHMIC CONTROL PARAMETERS: -C -C NGS = NUMBER OF COMPLEXES IN THE INITIAL POPULATION -C NPG = NUMBER OF POINTS IN EACH COMPLEX -C NPT = TOTAL NUMBER OF POINTS IN INITIAL POPULATION (NPT=NGS*NPG) -C NPS = NUMBER OF POINTS IN A SUB-COMPLEX -C NSPL = NUMBER OF EVOLUTION STEPS ALLOWED FOR EACH COMPLEX BEFORE -C COMPLEX SHUFFLING -C MINGS = MINIMUM NUMBER OF COMPLEXES REQUIRED, IF THE NUMBER OF -C COMPLEXES IS ALLOWED TO REDUCE AS THE OPTIMIZATION PROCEEDS -C ISEED = INITIAL RANDOM SEED -C INIFLG = FLAG ON WHETHER TO INCLUDE THE INITIAL POINT IN POPULATION -C = 0, NOT INCLUDED -C = 1, INCLUDED -C IPRINT = FLAG FOR CONTROLLING PRINT-OUT AFTER EACH SHUFFLING LOOP -C = 0, PRINT INFORMATION ON THE BEST POINT OF THE POPULATION -C = 1, PRINT INFORMATION ON EVERY POINT OF THE POPULATION -C -C -C MPC ADDITION -C -C ISCE = UNIT NUMBER FOR SCE OUTPUT -C -C -C CONVERGENCE CHECK PARAMETERS -C -C MAXN = MAX NO. OF TRIALS ALLOWED BEFORE OPTIMIZATION IS TERMINATED -C KSTOP = NUMBER OF SHUFFLING LOOPS IN WHICH THE CRITERION VALUE MUST -C CHANG BY THE GIVEN PERCENTAGE BEFORE OPTIMIZATION IS TERMINATED -C PCENTO = PERCENTAGE BY WHICH THE CRITERION VALUE MUST CHANGE IN -C GIVEN NUMBER OF SHUFFLING LOOPS -C IPCNVG = FLAG INDICATING WHETHER PARAMETER CONVERGENCE IS REACHED -C (I.E., CHECK IF GNRNG IS LESS THAN 0.001) -C = 0, PARAMETER CONVERGENCE NOT SATISFIED -C = 1, PARAMETER CONVERGENCE SATISFIED -C -C -C LIST OF LOCAL VARIABLES -C X(.,.) = COORDINATES OF POINTS IN THE POPULATION -C XF(.) = FUNCTION VALUES OF X(.,.) -C XX(.) = COORDINATES OF A SINGLE POINT IN X -C CX(.,.) = COORDINATES OF POINTS IN A COMPLEX -C CF(.) = FUNCTION VALUES OF CX(.,.) -C S(.,.) = COORDINATES OF POINTS IN THE CURRENT SIMPLEX -C SF(.) = FUNCTION VALUES OF S(.,.) -C BESTX(.) = BEST POINT AT CURRENT SHUFFLING LOOP -C BESTF = FUNCTION VALUE OF BESTX(.) -C WORSTX(.) = WORST POINT AT CURRENT SHUFFLING LOOP -C WORSTF = FUNCTION VALUE OF WORSTX(.) -C XNSTD(.) = STANDARD DEVIATION OF PARAMETERS IN THE POPULATION -C GNRNG = NORMALIZED GEOMETRIC MEAN OF PARAMETER RANGES -C LCS(.) = INDICES LOCATING POSITION OF S(.,.) IN X(.,.) -C BOUND(.) = BOUND ON ITH VARIABLE BEING OPTIMIZED -C NGS1 = NUMBER OF COMPLEXES IN CURRENT POPULATION -C NGS2 = NUMBER OF COMPLEXES IN LAST POPULATION -C ISEED1 = CURRENT RANDOM SEED -C CRITER(.) = VECTOR CONTAINING THE BEST CRITERION VALUES OF THE LAST -C 10 SHUFFLING LOOPS -C - CHARACTER*4 XNAME(16) -C -C ARRAYS FROM THE INPUT DATA - DIMENSION A(16),BL(16),BU(16) -C -C LOCAL ARRAYS - DIMENSION X(2000,16),XX(16),BESTX(16),WORSTX(16),XF(2000) - DIMENSION S(50,16),SF(50),LCS(50),CX(2000,16),CF(2000) - DIMENSION XNSTD(16),BOUND(16),CRITER(10) - DIMENSION DIST(2000),XI(16) -C -C -C MPC REMOVE -- ISCE IS NOW AN ARGUMENT TO THE SUBROUTINE, OTHER VARS NOT USED -C -C COMMON/IOPARS/ICNTRL,IOUT,IDAT,IWBAL,ISCE,IPE,IPC,IDET -C - DATA XNAME /' X1',' X2',' X3',' X4',' X5',' X6',' X7', - &' X8',' X9',' X10',' X11',' X12',' X13',' X14',' X15',' X16'/ -C -C INITIALIZE VARIABLES - WRITE(ISCE,400) - 400 FORMAT(//,2X,50(1H=),/,2X,'ENTER THE SHUFFLED COMPLEX EVOLUTION', - & ' GLOBAL SEARCH',/,2X,50(1H=)) - WRITE(*,400) - NLOOP = 0 - LOOP = 0 - IGS = 0 -C -C INITIALIZE RANDOM SEED TO A NEGATIVE INTEGER - ISEED1 = -ABS(ISEED) -C -C COMPUTE THE TOTAL NUMBER OF POINTS IN INITIAL POPUALTION - NPT = NGS * NPG - NGS1 = NGS - NPT1 = NPT -C -C COMPUTE THE BOUND FOR PARAMETERS BEING OPTIMIZED - DO J = 1, NOPT - BOUND(J) = BU(J) - BL(J) - XI(J) = A(J) - END DO -C -C COMPUTE THE FUNCTION VALUE OF THE INITIAL POINT - FA = FUNCTN(NOPT,A) -C -C PRINT THE INITIAL POINT AND ITS CRITERION VALUE - WRITE(ISCE,500) - WRITE(*, 500) - WRITE(ISCE,510) (XNAME(J),J=1,NOPT) - WRITE(*, 510) (XNAME(J),J=1,NOPT) - WRITE(ISCE,520) FA,(A(J),J=1,NOPT) - WRITE(*, 520) FA,(A(J),J=1,NOPT) - IF (MAXN .EQ. 1) GO TO 10000 -C -C GENERATE AN INITIAL SET OF NPT1 POINTS IN THE PARAMETER SPACE -C IF INIFLG IS EQUAL TO 1, SET X(1,.) TO INITIAL POINT A(.) - IF (INIFLG .EQ. 1) THEN - DO J = 1, NOPT - X(1,J) = A(J) - END DO - XF(1) = FA -C -C ELSE, GENERATE A POINT RANDOMLY AND SET IT EQUAL TO X(1,.) - ELSE - DO J = 1, NOPT - RAND = RAN1(ISEED1) - X(1,J) = BL(J) + BOUND(J) * RAND - XX(J) = X(1,J) - END DO - XF(1) = FUNCTN(NOPT,XX) - END IF - ICALL = 1 - IF (ICALL .GE. MAXN) GO TO 9000 -C -C GENERATE NPT1-1 RANDOM POINTS DISTRIBUTED UNIFORMLY IN THE PARAMETER -C SPACE, AND COMPUTE THE CORRESPONDING FUNCTION VALUES - DO I = 2, NPT1 - DO J = 1, NOPT - RAND = RAN1(ISEED1) - X(I,J) = BL(J) + BOUND(J) * RAND - XX(J) = X(I,J) - END DO - XF(I) = FUNCTN(NOPT,XX) - ICALL = ICALL + 1 - IF (ICALL .GE. MAXN) THEN - NPT1 = I - GO TO 45 - END IF - END DO -C -C ARRANGE THE POINTS IN ORDER OF INCREASING FUNCTION VALUE - 45 CALL SORT(NPT1,NOPT,X,XF) -C -C RECORD THE BEST AND WORST POINTS - DO J = 1, NOPT - BESTX(J) = X(1,J) - WORSTX(J) = X(NPT1,J) - END DO - BESTF = XF(1) - WORSTF = XF(NPT1) -C -C COMPUTE THE PARAMETER RANGE FOR THE INITIAL POPULATION - CALL PARSTT(NPT1,NOPT,X,XNSTD,BOUND,GNRNG,IPCNVG) -C -C COMPUTE THE PARAMETER DISTANCE FROM THE INITIAL POPULATION - CALL NORMDIST(NPT,NOPT,X,XI,DIST,BOUND) -C -C PRINT THE RESULTS FOR THE INITIAL POPULATION - WRITE(ISCE,600) - WRITE(*, 600) - WRITE(ISCE,610) (XNAME(J),J=1,NOPT) - WRITE(*, 610) (XNAME(J),J=1,NOPT) - WRITE(ISCE,630) NLOOP,ICALL,NGS1,BESTF,WORSTF,DIST(1), - & (BESTX(J),J=1,NOPT) - WRITE(*, 630) NLOOP,ICALL,NGS1,BESTF,WORSTF,DIST(1), - & (BESTX(J),J=1,NOPT) - IF (IPRINT .EQ. 1) THEN - WRITE(ISCE,650) NLOOP - DO I = 1, NPT1 - WRITE(ISCE,660) XF(I),DIST(I),(X(I,J),J=1,NOPT) - END DO - END IF -C - IF (ICALL .GE. MAXN) GO TO 9000 - IF (IPCNVG .EQ. 1) GO TO 9200 -C -C BEGIN THE MAIN LOOP ---------------- - 1000 CONTINUE - NLOOP = NLOOP + 1 -C -C BEGIN LOOP ON COMPLEXES - DO IGS = 1, NGS1 -C -C ASSIGN POINTS INTO COMPLEXES - DO K1 = 1, NPG - K2 = (K1-1) * NGS1 + IGS - DO J = 1, NOPT - CX(K1,J) = X(K2,J) - END DO - CF(K1) = XF(K2) - END DO -C -C BEGIN INNER LOOP - RANDOM SELECTION OF SUB-COMPLEXES --------------- - DO 2000 LOOP = 1, NSPL -C -C CHOOSE A SUB-COMPLEX (NPS POINTS) ACCORDING TO A LINEAR -C PROBABILITY DISTRIBUTION - IF (NPS .EQ. NPG) THEN - DO K = 1, NPS - LCS(K) = K - END DO - GO TO 85 - END IF -C - RAND = RAN1(ISEED1) - LCS(1) = 1 + INT(NPG + 0.5 - SQRT( (NPG+.5)**2 - - & NPG * (NPG+1) * RAND )) - DO K = 2, NPS - 60 RAND = RAN1(ISEED1) - LPOS = 1 + INT(NPG + 0.5 - SQRT((NPG+.5)**2 - - & NPG * (NPG+1) * RAND )) - DO K1 = 1, K-1 - IF (LPOS .EQ. LCS(K1)) GO TO 60 - END DO - LCS(K) = LPOS - END DO -C -C ARRANGE THE SUB-COMPLEX IN ORDER OF INCEASING FUNCTION VALUE - CALL SORT1(NPS,LCS) -C -C CREATE THE SUB-COMPLEX ARRAYS - 85 DO K = 1, NPS - DO J = 1, NOPT - S(K,J) = CX(LCS(K),J) - END DO - SF(K) = CF(LCS(K)) - END DO -C -C USE THE SUB-COMPLEX TO GENERATE NEW POINT(S) - CALL CCE(NOPT,NPS,S,SF,BL,BU,XNSTD,ICALL,MAXN,ISEED1) - -C -C MPC ADDITION - !print *, nloop, igs, loop, icall - -C -C IF THE SUB-COMPLEX IS ACCEPTED, REPLACE THE NEW SUB-COMPLEX -C INTO THE COMPLEX - DO K = 1, NPS - DO J = 1, NOPT - CX(LCS(K),J) = S(K,J) - END DO - CF(LCS(K)) = SF(K) - END DO -C -C SORT THE POINTS - CALL SORT(NPG,NOPT,CX,CF) -C -C IF MAXIMUM NUMBER OF RUNS EXCEEDED, BREAK OUT OF THE LOOP - IF (ICALL .GE. MAXN) GO TO 2222 -C -C END OF INNER LOOP ------------ - 2000 CONTINUE - 2222 CONTINUE -C -C REPLACE THE NEW COMPLEX INTO ORIGINAL ARRAY X(.,.) - DO K1 = 1, NPG - K2 = (K1-1) * NGS1 + IGS - DO J = 1, NOPT - X(K2,J) = CX(K1,J) - END DO - XF(K2) = CF(K1) - END DO - IF (ICALL .GE. MAXN) GO TO 3333 -C -C END LOOP ON COMPLEXES - END DO - 3333 CONTINUE -C -C RE-SORT THE POINTS - CALL SORT(NPT1,NOPT,X,XF) -C -C RECORD THE BEST AND WORST POINTS - DO J = 1, NOPT - BESTX(J) = X(1,J) - WORSTX(J) = X(NPT1,J) - END DO - BESTF = XF(1) - WORSTF = XF(NPT1) -C -C TEST THE POPULATION FOR PARAMETER CONVERGENCE - CALL PARSTT(NPT1,NOPT,X,XNSTD,BOUND,GNRNG,IPCNVG) -C -C COMPUTE THE PARAMETER DISTANCE FROM THE INITIAL POPULATION - CALL NORMDIST(NPT,NOPT,X,XI,DIST,BOUND) -C -C PRINT THE RESULTS FOR CURRENT POPULATION - WRITE(ISCE,630) NLOOP,ICALL,NGS1,BESTF,WORSTF,DIST(1), - & (BESTX(J),J=1,NOPT) - WRITE(*,630) NLOOP,ICALL,NGS1,BESTF,WORSTF,DIST(1), - & (BESTX(J),J=1,NOPT) - IF (IPRINT .EQ. 1) THEN - WRITE(ISCE,650) NLOOP - DO I = 1, NPT1 - WRITE(ISCE,660) XF(I),DIST(I),(X(I,J),J=1,NOPT) - END DO - END IF -C -C TEST IF MAXIMUM NUMBER OF FUNCTION EVALUATIONS EXCEEDED - IF (ICALL .GE. MAXN) GO TO 9000 -C -C COMPUTE THE COUNT ON SUCCESSIVE LOOPS W/O FUNCTION IMPROVEMENT - CRITER(10) = BESTF - IF (NLOOP .LT. (KSTOP+1)) GO TO 132 - DENOMI = ABS(CRITER(10-KSTOP) + CRITER(10)) / 2. - TIMEOU = ABS(CRITER(10-KSTOP) - CRITER(10)) / DENOMI - IF (TIMEOU .LT. PCENTO) GO TO 9100 - 132 CONTINUE - DO L = 1, 9 - CRITER(L) = CRITER(L+1) - END DO -C -C IF POPULATION IS CONVERGED INTO A SUFFICIENTLY SMALL SPACE - IF (IPCNVG .EQ. 1) GO TO 9200 -C -C NONE OF THE STOPPING CRITERIA IS SATISFIED, CONTINUE SEARCH -C -C CHECK FOR COMPLEX NUMBER REDUCTION - IF (NGS1 .GT .MINGS) THEN - NGS2 = NGS1 - NGS1 = NGS1 - 1 - NPT1 = NGS1 * NPG - CALL COMP(NOPT,NPT1,NGS1,NGS2,NPG,X,XF,CX,CF) - END IF -C -C END OF MAIN LOOP ----------- - GO TO 1000 -C -C SEARCH TERMINATED - 9000 CONTINUE - WRITE(ISCE,800) MAXN,LOOP,IGS,NLOOP - WRITE(*,800) MAXN,LOOP,IGS,NLOOP - GO TO 9999 - 9100 CONTINUE - WRITE(ISCE,810) PCENTO*100.,KSTOP - WRITE(*,810) PCENTO*100.,KSTOP - GO TO 9999 - 9200 WRITE(ISCE,820) GNRNG*100. - WRITE(*,820) GNRNG*100. - 9999 CONTINUE -C -C PRINT THE FINAL PARAMETER ESTIMATE AND ITS FUNCTION VALUE - WRITE(ISCE,830) - WRITE(ISCE,510) (XNAME(J),J=1,NOPT) - WRITE(ISCE,520) BESTF,(BESTX(J),J=1,NOPT) - WRITE(*,830) - WRITE(*,510) (XNAME(J),J=1,NOPT) - WRITE(*,520) BESTF,(BESTX(J),J=1,NOPT) - AF = BESTF - DO J = 1, NOPT - A(J) = BESTX(J) - END DO -10000 CONTINUE -C -C END OF SUBROUTINE SCEUA - RETURN - 500 FORMAT(//,'*** PRINT THE INITIAL POINT AND ITS CRITERION ', - & 'VALUE ***') - 510 FORMAT(/,' CRITERION',16(2X,A4,2X),/1X,80(1H-)) - 520 FORMAT(F8.3,17F8.3) - 600 FORMAT(//,1X,'*** PRINT THE RESULTS OF THE SCE SEARCH ***') - 610 FORMAT(/,1X,'LOOP',1X,'TRIALS',1X,'COMPLXS',1X,'BEST F',1X, - & 'WORST F',1X,'PAR RNG',1X,16(2X,A4,2X)) - 630 FORMAT(I5,1X,I5,3X,I5,3F8.3,17(F8.3)) - 650 FORMAT(/,1X,'POPULATION AT LOOP ',I3,/,1X,22(1H-)) - 660 FORMAT(F8.3,17(F8.3)) - 800 FORMAT(//,1X,'*** OPTIMIZATION SEARCH TERMINATED BECAUSE THE', - & ' LIMIT ON THE MAXIMUM',/,5X,'NUMBER OF TRIALS ',I5, - & ' EXCEEDED. SEARCH WAS STOPPED AT',/,5X,'SUB-COMPLEX ', - & I3,' OF COMPLEX ',I3,' IN SHUFFLING LOOP ',I3,' ***') - 810 FORMAT(//,1X,'*** OPTIMIZATION TERMINATED BECAUSE THE CRITERION', - & ' VALUE HAS NOT CHANGED ',/,5X,F5.2,' PERCENT IN',I3, - & ' SHUFFLING LOOPS ***') - 820 FORMAT(//,1X,'*** OPTIMIZATION TERMINATED BECAUSE THE POPULATION', - & ' HAS CONVERGED INTO ',/,4X,F5.2,' PERCENT OF THE', - & ' FEASIBLE SPACE ***') - 830 FORMAT(//,'*** PRINT THE FINAL PARAMETER ESTIMATE AND ITS', - & ' CRITERION VALUE ***') - END -C -C -C -C==================================================================== - SUBROUTINE CCE(NOPT,NPS,S,SF,BL,BU,XNSTD,ICALL,MAXN,ISEED) -C -C ALGORITHM GENERATE A NEW POINT(S) FROM A SUB-COMPLEX -C -C SUB-COMPLEX VARIABLES - DIMENSION S(50,16),SF(50),BU(16),BL(16),XNSTD(16) -C -C LIST OF LOCAL VARIABLES -C WO(.) = THE WORST POINT OF THE SIMPLEX -C FW = FUNCTION VALUE OF THE WORST POINT -C CE(.) = THE CENTROID OF THE SIMPLEX EXCLUDING WO -C SNEW(.) = NEW POINT GENERATED FROM THE SIMPLEX -C STEP(.) = VECTOR FROM WO TO CE -C - DIMENSION WO(16),CE(16),SNEW(16),STEP(16) -C -C EQUIVALENCE OF VARIABLES FOR READABILTY OF CODE - N = NPS - M = NOPT -C -C IDENTIFY THE WORST POINT WO OF THE SUB-COMPLEX S -C COMPUTE THE CENTROID CE OF THE REMAINING POINTS -C COMPUTE STEP, THE VECTOR BETWEEN WO AND CE -C IDENTIFY THE WORST FUNCTION VALUE FW - DO J = 1, M - WO(J) = S(N,J) - CE(J) = 0.0 - DO I = 1, N-1 - CE(J) = CE(J) + S(I,J) - END DO - CE(J) = CE(J)/DBLE(N-1) - STEP(J) = CE(J) - WO(J) - END DO - FW = SF(N) -C -C COMPUTE THE NEW POINT SNEW -C -C FIRST TRY A REFLECTION STEP - DO J = 1, M - SNEW(J) = WO(J) + 2. * STEP(J) - END DO -C -C CHECK IF SNEW IS WITHIN BOUND OR NOT - IBOUND = 0 - DO J = 1, M - IF (SNEW(J) .GT. BU(J) .OR. SNEW(J) .LT. BL(J)) THEN - IBOUND = 1 - GO TO 50 - END IF - END DO - 50 CONTINUE -C -C -C SNEW IS OUTSIDE THE BOUND, -C CHOOSE A POINT AT RANDOM WITHIN FEASIBLE REGION ACCORDING TO -C A NORMAL DISTRIBUTION WITH BEST POINT OF THE SUB-COMPLEX -C AS MEAN AND STANDARD DEVIATION OF THE POPULATION AS STD - IF (IBOUND .EQ. 1) THEN - DO J = 1, M - 60 R = GASDEV(ISEED) - SNEW(J) = S(1,J) + XNSTD(J)*R*(BU(J)-BL(J)) - IF (SNEW(J) .GT. BU(J) .OR. SNEW(J) .LT. BL(J)) GO TO 60 - END DO - END IF -C -C -C COMPUTE THE FUNCTION VALUE AT SNEW - FNEW = FUNCTN(NOPT,SNEW) - ICALL = ICALL + 1 -C -C COMPARE FNEW WITH THE WORST FUNCTION VALUE FW -C -C FNEW IS LESS THAN FW, ACCEPT THE NEW POINT SNEW AND RETURN - IF (FNEW .LE. FW) GO TO 9000 - IF (ICALL .GE. MAXN) GO TO 9100 -C -C -C FNEW IS GREATER THAN FW, SO TRY A CONTRACTION STEP - DO J = 1, M - SNEW(J) = WO(J) + 0.5 * STEP(J) - END DO -C -C COMPUTE THE FUNCTION VALUE OF THE CONTRACTED POINT - FNEW = FUNCTN(NOPT,SNEW) - ICALL = ICALL + 1 -C -C COMPARE FNEW TO THE WORST VALUE FW -C IF FNEW IS LESS THAN OR EQUAL TO FW, THEN ACCEPT THE POINT AND RETURN - IF (FNEW .LE. FW) GO TO 9000 - IF (ICALL .GE. MAXN) GO TO 9100 -C -C -C IF BOTH REFLECTION AND CONTRACTION FAIL, CHOOSE ANOTHER POINT -C ACCORDING TO A NORMAL DISTRIBUTION WITH BEST POINT OF THE SUB-COMPLEX -C AS MEAN AND STANDARD DEVIATION OF THE POPULATION AS STD - DO J = 1, M - 140 R = GASDEV(ISEED) - SNEW(J) = S(1,J) + XNSTD(J)*R*(BU(J)-BL(J)) - IF (SNEW(J) .GT. BU(J) .OR. SNEW(J) .LT. BL(J)) GO TO 140 - END DO -C -C COMPUTE THE FUNCTION VALUE AT THE RANDOM POINT - FNEW = FUNCTN(NOPT,SNEW) - ICALL = ICALL + 1 -C -C -C REPLACE THE WORST POINT BY THE NEW POINT - 9000 CONTINUE - DO J = 1, M - S(N,J) = SNEW(J) - END DO - SF(N) = FNEW - 9100 CONTINUE -C -C END OF SUBROUTINE CCE - RETURN - END -C -C -C -C=================================================================== - SUBROUTINE PARSTT(NPT,NOPT,X,XNSTD,BOUND,GNRNG,IPCNVG) -C -C SUBROUTINE CHECKING FOR PARAMETER CONVERGENCE - DIMENSION X(2000,16),XMAX(16),XMIN(16) - DIMENSION XMEAN(16),XNSTD(16),BOUND(16) - PARAMETER (DELTA = 1.0D-20,PEPS=1.0D-3) -C -C COMPUTE MAXIMUM, MINIMUM AND STANDARD DEVIATION OF PARAMETER VALUES - GSUM = 0.D0 - DO K = 1, NOPT - XMAX(K) = -1.0D+20 - XMIN(K) = 1.0D+20 - XSUM1 = 0.D0 - XSUM2 = 0.D0 - DO I = 1, NPT - XMAX(K) = AMAX1(X(I,K), XMAX(K)) - XMIN(K) = AMIN1(X(I,K), XMIN(K)) - XSUM1 = XSUM1 + X(I,K) - XSUM2 = XSUM2 + X(I,K)*X(I,K) - END DO - XMEAN(K) = XSUM1 / DBLE(NPT) - XNSTD(K) = (XSUM2 / DBLE(NPT) - XMEAN(K)*XMEAN(K)) - IF (XNSTD(K) .LE. DELTA) XNSTD(K) = DELTA - XNSTD(K) = SQRT(XNSTD(K)) - XNSTD(K) = XNSTD(K) / BOUND(K) - GSUM = GSUM + LOG( DELTA + (XMAX(K)-XMIN(K))/BOUND(K) ) - END DO - GNRNG = DEXP(GSUM/DBLE(NOPT)) -C -C CHECK IF NORMALIZED STANDARD DEVIATION OF PARAMETER IS <= EPS - IPCNVG = 0 - IF (GNRNG .LE. PEPS) THEN - IPCNVG = 1 - END IF -C -C END OF SUBROUTINE PARSTT - RETURN - END -C -C -C -C=================================================================== - SUBROUTINE NORMDIST(NPT,NOPT,X,XI,DIST,BOUND) -C -C SUBROUTINE COMPUTING NORMAILZIED DISTANCE FROM INITIAL POINT -C X(.,.) - POPULATION -C XI(.) - INITIAL POINT -C DIST(.) - NORMALIZED DISTANCE FROM INITIAL POINT - DIMENSION X(2000,16),XI(16),DIST(2000),BOUND(16) -C -C COMPUTE MAXIMUM, MINIMUM AND STANDARD DEVIATION OF PARAMETER VALUES - DO K = 1, NPT - DIST(K) = 0. - DO I = 1, NOPT - DIST(K) = DIST(K) + ABS(X(K,I) - XI(I))/BOUND(I) - END DO - DIST(K) = DIST(K) / NOPT - END DO -C -C END OF SUBROUTINE NORMDIST - RETURN - END -C -C -C -C==================================================================== - SUBROUTINE COMP(N,NPT,NGS1,NGS2,NPG,A,AF,B,BF) -C -C -C THIS SUBROUTINE REDUCE INPUT MATRIX A(N,NGS2*NPG) TO MATRIX -C B(N,NGS1*NPG) AND VECTOR AF(NGS2*NPG) TO VECTOR BF(NGS1*NPG) - DIMENSION A(2000,16),AF(2000),B(2000,16),BF(2000) - DO IGS=1, NGS1 - DO IPG=1, NPG - K1=(IPG-1)*NGS2 + IGS - K2=(IPG-1)*NGS1 + IGS - DO I=1, N - B(K2,I) = A(K1,I) - END DO - BF(K2) = AF(K1) - END DO - END DO -C - DO J=1, NPT - DO I=1, N - A(J,I) = B(J,I) - END DO - AF(J) = BF(J) - END DO -C -C END OF SUBROUTINE COMP - RETURN - END -C -C -C -C=================================================================== - SUBROUTINE SORT(N,M,RB,RA) -C -C -C SORTING SUBROUTINE ADAPTED FROM "NUMERICAL RECIPES" -C BY W.H. PRESS ET AL., PP. 233-234 -C -C LIST OF VARIABLES -C RA(.) = ARRAY TO BE SORTED -C RB(.,.) = ARRAYS ORDERED CORRESPONDING TO REARRANGEMENT OF RA(.) -C WK(.,.), IWK(.) = LOCAL VARIBLES -C - DIMENSION RA(2000),RB(2000,16),WK(2000,16),IWK(2000) -C - CALL INDEXX(N, RA, IWK) - DO I = 1, N - WK(I,1) = RA(I) - END DO - DO I = 1, N - RA(I) = WK(IWK(I),1) - END DO - DO J = 1, M - DO I = 1, N - WK(I,J) = RB(I,J) - END DO - END DO - DO J = 1, M - DO I = 1, N - RB(I,J) = WK(IWK(I),J) - END DO - END DO -C -C END OF SUBROUTINE SORT - RETURN - END -C -C -C=========================================================== - SUBROUTINE SORT1(N,RA) -C -C -C SORTING SUBROUTINE ADAPTED FROM "NUMERICAL RECIPES" -C BY W.H. PRESS ET AL., PP. 231 -C -C LIST OF VARIABLES -C RA(.) = INTEGER ARRAY TO BE SORTED -C - DIMENSION RA(N) -C - INTEGER RA, RRA -C - L = (N / 2) + 1 - IR = N - 10 CONTINUE - IF (L .GT. 1) THEN - L = L - 1 - RRA = RA(L) - ELSE - RRA = RA(IR) - RA(IR) = RA(1) - IR = IR - 1 - IF (IR .EQ. 1) THEN - RA(1) = RRA - RETURN - END IF - END IF - I = L - J = L + L - 20 IF (J .LE. IR) THEN - IF (J .LT. IR) THEN - IF (RA(J) .LT. RA(J + 1)) J = J + 1 - END IF - IF (RRA .LT. RA(J)) THEN - RA(I) = RA(J) - I = J - J = J + J - ELSE - J = IR + 1 - END IF - GOTO 20 - END IF - RA(I) = RRA - GOTO 10 -C -C END OF SUBROUTINE SORT1 - END -C -C -C -C======================================================= - SUBROUTINE INDEXX(N, ARRIN, INDX) -C -C -C THIS SUBROUTINE IS FROM "NUMERICAL RECIPES" BY PRESS ET AL. - DIMENSION ARRIN(N), INDX(N) -C - DO J = 1, N - INDX(J) = J - END DO - L = (N / 2) + 1 - IR = N - 10 CONTINUE - IF (L .GT. 1) THEN - L = L - 1 - INDXT = INDX(L) - Q = ARRIN(INDXT) - ELSE - INDXT = INDX(IR) - Q = ARRIN(INDXT) - INDX(IR) = INDX(1) - IR = IR - 1 - IF (IR .EQ. 1) THEN - INDX(1) = INDXT - RETURN - END IF - END IF - I = L - J = L + L - 20 IF (J .LE. IR) THEN - IF (J .LT. IR) THEN - IF (ARRIN(INDX(J)) .LT. ARRIN(INDX(J + 1))) J = J + 1 - END IF - IF (Q .LT. ARRIN(INDX(J))) THEN - INDX(I) = INDX(J) - I = J - J = J + J - ELSE - J = IR + 1 - END IF - GOTO 20 - END IF - INDX(I) = INDXT - GOTO 10 -C -C END OF SUBROUTINE INDEXX - END -C -C -C -C============================================================== - FUNCTION RAN1(IDUM) -C -C -C THIS SUBROUTINE IS FROM "NUMERICAL RECIPES" BY PRESS ET AL. - DIMENSION R(97) - PARAMETER (M1 = 259200, IA1 = 7141, IC1 = 54773, RM1 = - &3.8580247E-6) - PARAMETER (M2 = 134456, IA2 = 8121, IC2 = 28411, RM2 = - &7.4373773E-6) - PARAMETER (M3 = 243000, IA3 = 4561, IC3 = 51349) - SAVE - DATA IFF / 0 / - IF ((IDUM .LT. 0) .OR. (IFF .EQ. 0)) THEN - IFF = 1 - IX1 = MOD(IC1 - IDUM,M1) - IX1 = MOD((IA1 * IX1) + IC1,M1) - IX2 = MOD(IX1,M2) - IX1 = MOD((IA1 * IX1) + IC1,M1) - IX3 = MOD(IX1,M3) - DO J = 1, 97 - IX1 = MOD((IA1 * IX1) + IC1,M1) - IX2 = MOD((IA2 * IX2) + IC2,M2) - R(J) = (DBLE(IX1) + (DBLE(IX2) * RM2)) * RM1 - END DO - IDUM = 1 - END IF - IX1 = MOD((IA1 * IX1) + IC1,M1) - IX2 = MOD((IA2 * IX2) + IC2,M2) - IX3 = MOD((IA3 * IX3) + IC3,M3) - J = 1 + ((97 * IX3) / M3) - IF ((J .GT. 97) .OR. (J .LT. 1)) PAUSE - RAN1 = R(J) - R(J) = (DBLE(IX1) + (DBLE(IX2) * RM2)) * RM1 -C -C END OF SUBROUTINE RAN1 - RETURN - END -C -C -C -C=============================================================== - FUNCTION GASDEV(IDUM) -C -C -C THIS SUBROUTINE IS FROM "NUMERICAL RECIPES" BY PRESS ET AL. - DATA ISET / 0 / - IF (ISET .EQ. 0) THEN - 1 V1 = (2. * RAN1(IDUM)) - 1. - V2 = (2. * RAN1(IDUM)) - 1. - R = (V1 ** 2) + (V2 ** 2) - IF (R .GE. 1.) GOTO 1 - FAC = SQRT(- ((2. * LOG(R)) / R)) - GSET = V1 * FAC - GASDEV = V2 * FAC - ISET = 1 - ELSE - GASDEV = GSET - ISET = 0 - END IF -C -C END OF SUBROUTINE GASDEV - RETURN - END diff --git a/build/FUSE_SRC/FUSE_SCE/.svn/text-base/sce_driver.f90.svn-base b/build/FUSE_SRC/FUSE_SCE/.svn/text-base/sce_driver.f90.svn-base deleted file mode 100644 index b19a857..0000000 --- a/build/FUSE_SRC/FUSE_SCE/.svn/text-base/sce_driver.f90.svn-base +++ /dev/null @@ -1,155 +0,0 @@ -PROGRAM sce_driver -! --------------------------------------------------------------------------------------- -! Creator: -! Martyn Clark, 2008 -! --------------------------------------------------------------------------------------- -! Purpose: -! Driver program for SCE -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE ddirectory ! directory for data files -! data modules -USE model_defn ! model definition structures -USE multiparam, ONLY: PARATT, LPARAM, NUMPAR ! parameter metadata structures -USE multistats ! model statistics structures -USE model_numerix ! model numerix structures -! informational modules -USE selectmodl_module ! reads model control file -USE getpar_str_module ! extracts parameter metadata -IMPLICIT NONE -! command-line arguments -CHARACTER(LEN=6) :: FMODEL_ID=' ' ! integer defining FUSE model -CHARACTER(LEN=6) :: NSOLUTION=' ' ! numerical solution (0=implicit, 1=explicit) -CHARACTER(LEN=6) :: FADAPTIVE=' ' ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -CHARACTER(LEN=6) :: TRUNC_ABS=' ' ! absolute temporal truncation error tolerance -CHARACTER(LEN=6) :: TRUNC_REL=' ' ! relative temporal truncation error tolerance -! forcing data -INTEGER(I4B) :: INFERN_START ! start of inference period -INTEGER(I4B) :: NTIM ! number of time steps -! model setup -INTEGER(I4B) :: FUSE_ID ! integer definining FUSE model -INTEGER(I4B) :: I,J,K ! looping -INTEGER(I4B) :: NMOD ! number of models -INTEGER(I4B) :: ERR ! error code -CHARACTER(LEN=256) :: MESSAGE ! error message -TYPE(PARATT) :: PARAM_META ! parameter metadata -! define output files -INTEGER(I4B) :: ONEMOD ! index for defining output file (one file per model) -! SCE variables -REAL(MSP), DIMENSION(16) :: A ! parameter set -REAL(MSP) :: AF ! objective function value -REAL(MSP), DIMENSION(16) :: BL ! lower bound of model parameters -REAL(MSP), DIMENSION(16) :: BU ! upper bound of model parameters -INTEGER(I4B) :: NOPT ! number of parameters to be optimized -INTEGER(I4B) :: MAXN ! maximum number of trials before optimization is terminated -INTEGER(I4B) :: KSTOP ! number of shuffling loops the value must change by PCENTO -REAL(MSP) :: PCENTO ! the percentage -INTEGER(I4B) :: ISEED ! starting seed for the random sequence -CHARACTER(LEN=3) :: CSEED ! starting seed converted to a character -INTEGER(I4B) :: NGS ! # complexes in the initial population -INTEGER(I4B) :: NPG ! # points in each complex -INTEGER(I4B) :: NPS ! # points in a sub-complex -INTEGER(I4B) :: NSPL ! # evolution steps allowed for each complex before shuffling -INTEGER(I4B) :: MINGS ! minimum number of complexes required -INTEGER(I4B) :: INIFLG ! 1 = include initial point in the population -INTEGER(I4B) :: IPRINT ! 0 = supress printing -INTEGER(I4B) :: ISCE ! unit number for SCE write -REAL(MSP) :: FUNCTN ! function name for the model run -! --------------------------------------------------------------------------------------- -! (1) GET COMMAND-LINE ARGUMENTS... -! --------------------------------------------------------------------------------------- -! read command-line arguments -CALL GETARG(1,FMODEL_ID) ! integer defining FUSE model -CALL GETARG(2,NSOLUTION) ! numerical solution (0=explicit, 1=implicit) -CALL GETARG(3,FADAPTIVE) ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -CALL GETARG(4,TRUNC_ABS) ! absolute temporal truncation error tolerance -CALL GETARG(5,TRUNC_REL) ! relative temporal truncation error tolerance -! check command-line arguments -IF (LEN_TRIM(FMODEL_ID).EQ.0) STOP '1st command-line argument is missing (FMODEL_ID)' -IF (LEN_TRIM(NSOLUTION).EQ.0) STOP '2nd command-line argument is missing (NSOLUTION)' -IF (LEN_TRIM(FADAPTIVE).EQ.0) STOP '3rd command-line argument is missing (FADAPTIVE)' -IF (LEN_TRIM(TRUNC_ABS).EQ.0) STOP '4th command-line argument is missing (TRUNC_ABS)' -IF (LEN_TRIM(TRUNC_REL).EQ.0) STOP '5th command-line argument is missing (TRUNC_REL)' -! read model numerix parameters -CALL GETNUMERIX() ! defines method/parameters used for numerical solution -! process command-line arguments -READ(FMODEL_ID,*) FUSE_ID ! integer definining FUSE model -READ(NSOLUTION,*) SOLUTION_METHOD ! numerical solution (0=implicit, 1=explicit) -READ(FADAPTIVE,*) TEMPORAL_ERROR_CONTROL ! identifier for adaptive sub-steps (0=fixed, 1=adaptive) -READ(TRUNC_ABS,*) ERR_TRUNC_ABS ! absolute temporal truncation error tolerance -READ(TRUNC_REL,*) ERR_TRUNC_REL ! relative temporal truncation error tolerance -! --------------------------------------------------------------------------------------- -! (2) GET MODEL SETUP -- MODEL DEFINITION, AND PARAMETER AND VARIABLE INFO FOR ALL MODELS -! --------------------------------------------------------------------------------------- -! Read data from the "BATEA-compliant" ASCII files -CALL GETFORCING(INFERN_START,NTIM) -! Define model attributes (valid for all models) -CALL UNIQUEMODL(NMOD) ! get nmod unique models -CALL GETPARMETA() ! parameter meta data (parameter bounds, etc.) -! Identify a single model -CALL SELECTMODL(FUSE_ID,ISTATUS=ERR,MESSAGE=MESSAGE) -IF (ERR.NE.0) THEN - PRINT *, TRIM(MESSAGE); STOP -ENDIF -! Define list of states and parameters for the current model -CALL ASSIGN_STT() ! state definitions are stored in module model_defn -CALL ASSIGN_FLX() ! flux definitions are stored in module model_defn -CALL ASSIGN_PAR() ! parameter defintions are stored in module multiparam -! Get parameter bounds and a default parameter set -IF (NUMPAR.GT.16) STOP ' NUMBER OF PARAMETERS MUST NOT EXCEED 16 IN SCE ' -DO I=1,NUMPAR - CALL GETPAR_STR(TRIM(LPARAM(I)%PARNAME),PARAM_META) - BL(I) = PARAM_META%PARLOW - BU(I) = PARAM_META%PARUPP - A(I) = PARAM_META%PARDEF -END DO -! -------------------------------------------------------------------------------------- -! -------------------------------------------------------------------------------------- -! -------------------------------------------------------------------------------------- -! loop through different starting seeds -DO ISEED=10,100,10 - ! get the seed as a character string - WRITE(CSEED,'(i3.3)') ISEED - ! -------------------------------------------------------------------------------------- - ! (3) DEFINE NETCDF OUTPUT FILES - ! -------------------------------------------------------------------------------------- - ! Define output file names - FNAME_NETCDF = TRIM(OUTPUT_PATH)//TRIM(SMODL%MNAME)//'__'//& - TRIM(NSOLUTION)//'-'//TRIM(FADAPTIVE)//'_SCE_'//CSEED//'.nc' ! shared in MODULE model_defn - FNAME_ASCII = TRIM(OUTPUT_PATH)//TRIM(SMODL%MNAME)//'__'//& - TRIM(NSOLUTION)//'-'//TRIM(FADAPTIVE)//'_SCE_'//CSEED//'.dat' ! shared in MODULE model_defn - ! Define NetCDF output files (only write parameters and summary statistics) - ONEMOD=1 ! one file per model (i.e., model dimension = 1) - PCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) - CALL DEF_PARAMS(ONEMOD) ! define model parameters (initial CREATE) - !CALL DEF_OUTPUT(NTIM) ! define model output (REDEF) - CALL DEF_SSTATS() ! define summary statistics (REDEF) - ! -------------------------------------------------------------------------------------- - ! (4) SCE WRAPPER - ! -------------------------------------------------------------------------------------- - ! assign algorithmic control parameters for SCE - NOPT = NUMPAR ! number of parameters to be optimized (NUMPAR in module multiparam) - MAXN = 1000 ! maximum number of trials before optimization is terminated - KSTOP = 9 ! number of shuffling loops the value must change by PCENTO (MAX=9) - PCENTO = 0.001 ! the percentage - NGS = 10 ! number of complexes in the initial population - NPG = 2*NOPT + 1 ! number of points in each complex - NPS = NOPT + 1 ! number of points in a sub-complex - NSPL = 2*NOPT + 1 ! number of evolution steps allowed for each complex before shuffling - MINGS = NGS ! minimum number of complexes required - INIFLG = 1 ! 1 = include initial point in the population - IPRINT = 1 ! 0 = supress printing - ! open up ASCII output file - ISCE = 96; OPEN(ISCE,FILE=TRIM(FNAME_ASCII)) - ! optimize (returns A and AF) - CALL SCEUA(A,AF,BL,BU,NOPT,MAXN,KSTOP,PCENTO,ISEED,& - NGS,NPG,NPS,NSPL,MINGS,INIFLG,IPRINT,ISCE) - ! close ASCII output file - CLOSE(ISCE) - ! call the function again with the optimized parameter set (to ensure the last parameter set is the optimum( - AF = FUNCTN(NOPT,A) - ! -------------------------------------------------------------------------------------- -END DO ! looping through seeds -! --------------------------------------------------------------------------------------- -STOP -END diff --git a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/all-wcprops b/build/FUSE_SRC/FUSE_TESTFUNC/.svn/all-wcprops deleted file mode 100644 index aa4a9c2..0000000 --- a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/all-wcprops +++ /dev/null @@ -1,65 +0,0 @@ -K 25 -svn:wc:ra_dav:version-url -V 64 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_TESTFUNC -END -interfaceb.f90 -K 25 -svn:wc:ra_dav:version-url -V 79 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_TESTFUNC/interfaceb.f90 -END -driver_testfunc.f90 -K 25 -svn:wc:ra_dav:version-url -V 84 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_TESTFUNC/driver_testfunc.f90 -END -model_numerix.f90 -K 25 -svn:wc:ra_dav:version-url -V 82 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_TESTFUNC/model_numerix.f90 -END -test_modvar.f90 -K 25 -svn:wc:ra_dav:version-url -V 80 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_TESTFUNC/test_modvar.f90 -END -test_solve.f90 -K 25 -svn:wc:ra_dav:version-url -V 79 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_TESTFUNC/test_solve.f90 -END -test_deriv.f90 -K 25 -svn:wc:ra_dav:version-url -V 79 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_TESTFUNC/test_deriv.f90 -END -impl_error.f90 -K 25 -svn:wc:ra_dav:version-url -V 79 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_TESTFUNC/impl_error.f90 -END -rtnewt_sub.f90 -K 25 -svn:wc:ra_dav:version-url -V 79 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_TESTFUNC/rtnewt_sub.f90 -END -substepper.f90 -K 25 -svn:wc:ra_dav:version-url -V 79 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_TESTFUNC/substepper.f90 -END -ode_int.f90 -K 25 -svn:wc:ra_dav:version-url -V 76 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_TESTFUNC/ode_int.f90 -END diff --git a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/entries b/build/FUSE_SRC/FUSE_TESTFUNC/.svn/entries deleted file mode 100644 index 45d3444..0000000 --- a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/entries +++ /dev/null @@ -1,368 +0,0 @@ -10 - -dir -63 -https://venture1.projectlocker.com/UoNEnvEngGroup/FUSE/svn/trunk/FUSE_SRC/FUSE_TESTFUNC -https://venture1.projectlocker.com/UoNEnvEngGroup/FUSE/svn - - - -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - -7fd0be38-6417-4f01-9cbe-fd474d0c6e94 - -interfaceb.f90 -file - - - - -2013-06-12T18:10:49.639579Z -799b828aae07f23e0ffae3a2e6b4bd10 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -5400 - -driver_testfunc.f90 -file - - - - -2013-06-12T18:10:49.639579Z -6f1b52b2ea19f906542bc64a664f2584 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -5289 - -model_numerix.f90 -file - - - - -2013-06-12T18:10:49.639579Z -6533753ee70d1d6794f9a604fe3cffa1 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -4100 - -test_modvar.f90 -file - - - - -2013-06-12T18:10:49.639579Z -8886926639a5d89fe288d9c60ac7036c -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1829 - -test_solve.f90 -file - - - - -2013-06-12T18:10:49.639579Z -13c846b4638f345eb57ac1d6dd8a1b81 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -10696 - -test_deriv.f90 -file - - - - -2013-06-12T18:10:49.639579Z -24012ed134112690fbe699938bea1e40 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1321 - -impl_error.f90 -file - - - - -2013-06-12T18:10:49.639579Z -561dcd9263f146787a0a380c1843ddf0 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -2311 - -rtnewt_sub.f90 -file - - - - -2013-06-12T18:10:49.639579Z -faf081010da359f1f9d446e2d4025a4e -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1146 - -substepper.f90 -file - - - - -2013-06-12T18:10:49.639579Z -c16aac04ce9bed645cf82ea449042f21 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -25354 - -ode_int.f90 -file - - - - -2013-06-12T18:10:49.639579Z -a42c6267783b23b69038d3946bc312a5 -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -19229 - diff --git a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/driver_testfunc.f90.svn-base b/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/driver_testfunc.f90.svn-base deleted file mode 100644 index 17b3e60..0000000 --- a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/driver_testfunc.f90.svn-base +++ /dev/null @@ -1,90 +0,0 @@ -PROGRAM driver_testfunc -! Used to test the routine for temporal integration of ordinary differential equations -! with the test function dS/dt = -sqrt(S) -USE nrtype ! numerical recipes data types -USE interfaceb, ONLY: ODE_INT,TEST_SOLVE -USE test_modvar, ONLY: MS_MIN,MS_MAX,MSTATE,& ! model variables - FSTATE,W_FLUX ! model variables (continued) -USE model_numerix, ONLY: SOLUTION_METHOD,ERR_TRUNC_ABS,ERR_TRUNC_REL -IMPLICIT NONE -REAL(SP), DIMENSION(1) :: STATE0 ! initial state -REAL(SP), DIMENSION(1) :: STATE1 ! final state -REAL(SP) :: DT_SUB ! length of sub-step -REAL(SP) :: DT_FULL ! length of full step -INTEGER(I4B) :: IERR ! error code -CHARACTER(LEN=1024) :: MESSAGE ! error message -INTEGER(I4B) :: ITIME ! time index (loop through time steps) -INTEGER(I4B), PARAMETER :: NTIME=5 ! number of time steps -INTEGER(I4B) :: ITNC ! loop through truncation errors -INTEGER(I4B) :: ITYP ! loop through solution methods -CHARACTER(LEN=4) :: CH ! character string for output -CHARACTER(LEN=14) :: CTYP ! character string for output -! -------------------------------------------------------------------------------------- -! define numerical solution methods -CALL DEFAULT_NUMERIX() -DO ITYP=0,1 - SOLUTION_METHOD=ITYP - IF (ITYP.EQ.0) CTYP='EXPLICIT_EULER' - IF (ITYP.EQ.1) CTYP='IMPLICIT_EULER' - DO ITNC=1,4 - IF (ITNC.EQ.1) THEN; ERR_TRUNC_ABS = 1.e-1; ERR_TRUNC_REL = 1.e-1; CH='_e-1'; ENDIF - IF (ITNC.EQ.2) THEN; ERR_TRUNC_ABS = 1.e-2; ERR_TRUNC_REL = 1.e-2; CH='_e-2'; ENDIF - IF (ITNC.EQ.3) THEN; ERR_TRUNC_ABS = 1.e-3; ERR_TRUNC_REL = 1.e-3; CH='_e-3'; ENDIF - IF (ITNC.EQ.4) THEN; ERR_TRUNC_ABS = 1.e-4; ERR_TRUNC_REL = 1.e-4; CH='_e-4'; ENDIF - ! initialize variables - STATE0 = 1._SP ! state at the start of the time step - STATE1 = -9999._SP ! state at the end of the time step - MS_MIN%WATR_1 = 1.E-10_SP ! minimum values of model states (shared in MODULE test_modvar) - MS_MAX%WATR_1 = 1.E+00_SP ! maximum values of model states (shared in MODULE test_modvar) - FSTATE%WATR_1 = 1._SP ! initial value of model states (shared in MODULE test_modvar) - DT_SUB = 1._SP ! length of sub-step - DT_FULL = 1._SP ! length of full step - print *, '*********************************************************************************' - print *, '*********************************************************************************' - print *, 'in driver', state0, ityp, itnc - DO ITIME=1,NTIME - ! open files - if (itime.eq.1) open(21,file=CTYP//'1'//CH//'.dat',status='unknown') - if (itime.eq.2) open(21,file=CTYP//'2'//CH//'.dat',status='unknown') - if (itime.eq.3) open(21,file=CTYP//'3'//CH//'.dat',status='unknown') - if (itime.eq.4) open(21,file=CTYP//'4'//CH//'.dat',status='unknown') - if (itime.eq.5) open(21,file=CTYP//'5'//CH//'.dat',status='unknown') - ! initialize states and fluxes - MSTATE%WATR_1 = FSTATE%WATR_1 - W_FLUX%DRAINAGE = 0._SP - W_FLUX%CHECKTIM = 0._SP - ! temporally integrate the ode - CALL ODE_INT(TEST_SOLVE,STATE0,STATE1,DT_SUB,DT_FULL,IERR,MESSAGE) - - - - STATE0 = STATE1 - print *, '***** in driver *****', itime - close(21) - END DO - END DO -END DO -STOP -END PROGRAM DRIVER_TESTFUNC -! -------------------------------------------------------------------------------------- -SUBROUTINE DEFAULT_NUMERIX() -USE model_numerix -SOLUTION_METHOD = IMPLICIT_EULER ! implicit euler solution -TEMPORAL_ERROR_CONTROL = TS_ADAPT ! adaptive time steps -TRUNCATION_ERROR = EMBEDDED_ERR ! embedded error control -ORDER_ACCEPT = HIGHER_ORDER ! accept higher-order solutions -INITIAL_NEWTON = EXPLICIT_FULL ! initial conditions for Newton -JAC_RECOMPUTE = FULLYVARIABLE ! fully variable Jacobian -CHECK_OVERSHOOT = LINE_SEARCH ! use line search to trap/fix overshoot problems -ERR_TRUNC_ABS = 1.e-3 ! absolute temporal truncation error tolerance -ERR_TRUNC_REL = 1.e-3 ! relative temporal truncation error tolerance -ERR_ITER_FUNC = 1.e-9 ! iteration convergence tolerance for function values -ERR_ITER_DX = 1.e-9 ! iteration convergence tolerance for dx -FRACSTATE_MIN = 1.e-9 ! fractional minimum value of state (for non-zero derivatives) -SAFETY = 0.9_sp ! safety factor in step-size equation -RMIN = 0.1_sp ! minimum step size multiplier -RMAX = 4.0_sp ! maximum step size multiplier -NITER_TOTAL = 100 ! total number of iterations used in the implicit scheme -MIN_TSTEP = 0.01_sp/60._sp/24._sp ! minimum time step length (minutes --> days) -MAX_TSTEP = 1440._sp/60._sp/24._sp ! maximum time step length (minutes --> days) -END SUBROUTINE DEFAULT_NUMERIX diff --git a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/impl_error.f90.svn-base b/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/impl_error.f90.svn-base deleted file mode 100644 index 429cb26..0000000 --- a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/impl_error.f90.svn-base +++ /dev/null @@ -1,37 +0,0 @@ -SUBROUTINE IMPL_ERROR(S,F,DF) -! Used to calculate the error for the implicit scheme -! S(n+1) = S(n) + dS(n+1)/dt * delT -! F = S(try) - (S(n) + dS(try)/dt * delT) -USE nrtype ! numerical recipes data types -USE model_numerix, ONLY: NUM_JACOBIAN ! number of times calculate the derivative -USE test_modvar, ONLY: MSTATE,MDS_DT,DT_SUB ! model variables -USE test_deriv__module ! provide access to model derivatives function -IMPLICIT NONE -! input/output -REAL(SP), INTENT(IN) :: S ! storage -REAL(SP), INTENT(OUT) :: F ! function value -REAL(SP), INTENT(OUT) :: DF ! function derivative -! internal -REAL(SP) :: S0 ! state at the start of the sub-step -REAL(SP), PARAMETER :: RH=1.e-4_sp ! relative step size for finite difference -REAL(SP) :: H ! step size for finite difference -REAL(SP) :: SPH ! perturbed state -REAL(SP), DIMENSION(1) :: DSDT ! state derivative (NOTE, pass as vector) -REAL(SP) :: FTRY ! perturbed function value -! keep track of the number of times calculate the derivative -NUM_JACOBIAN = NUM_JACOBIAN + 1 -! extract state at the start of the time step -S0 = MSTATE%WATR_1 -! calculate perturbed function value -H = RH*S ! step size -SPH = S+H ! perturbed state -H = SPH-S ! actual step size (trick to account for roundoff errors) -DSDT = TEST_DERIV((/SPH/)) ! calculate state derivative (NOTE, pass as vector) -FTRY = SPH - (S0 + DSDT(1)*DT_SUB) ! perturbed function value -! calculate function value -DSDT = TEST_DERIV((/S/)) ! calculate state derivative (NOTE, pass as vector) -F = S - (S0 + DSDT(1)*DT_SUB) ! calculate function value -MDS_DT%WATR_1 = DSDT(1) ! save state derivative -! calculate function derivative -DF = (FTRY-F)/H ! function derivative -END SUBROUTINE IMPL_ERROR diff --git a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/interfaceb.f90.svn-base b/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/interfaceb.f90.svn-base deleted file mode 100644 index 091ec89..0000000 --- a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/interfaceb.f90.svn-base +++ /dev/null @@ -1,67 +0,0 @@ -MODULE INTERFACEB -! ------------------------------------------------------------------------------------------------- -INTERFACE - SUBROUTINE ODE_INT(MODL_SOLVE,STATE_START,STATE_END,DT_SUB,DT_FULL,IERR,MESSAGE) - USE nrtype ! variable definitions, etc. - IMPLICIT NONE - REAL(SP), DIMENSION(:), INTENT(IN) :: STATE_START ! state vector at the start of the full step - REAL(SP), DIMENSION(:), INTENT(OUT) :: STATE_END ! state vector at the end of the full step - REAL(SP), INTENT(INOUT) :: DT_SUB ! length of the sub-step - REAL(SP), INTENT(IN) :: DT_FULL ! length of the full step - INTEGER(I4B), INTENT(OUT) :: IERR ! error code - CHARACTER(LEN=*), INTENT(OUT) :: MESSAGE ! error message - INTERFACE - SUBROUTINE MODL_SOLVE(CALCDSDT,IE_SOLVE,B_IMPOSE,AVG_FLUX,ADD_FLUX,NEWSTATE, & ! define functionality of the routine - DT,S0,S1,DSDT,NEWSTEP,CONVCHECK,NITER,SOLUTION,HBOUND, & ! input/output - IERR,MESSAGE) ! error control - USE nrtype ! variable definitions, etc. - IMPLICIT NONE - LOGICAL(LGT), INTENT(IN),OPTIONAL :: CALCDSDT ! FLAG to calculate derivatives at S0 - LOGICAL(LGT), INTENT(IN),OPTIONAL :: IE_SOLVE ! FLAG to compute the implicit Euler solution - LOGICAL(LGT), INTENT(IN),OPTIONAL :: B_IMPOSE ! FLAG to impose bounds on model states - LOGICAL(LGT), INTENT(IN),OPTIONAL :: AVG_FLUX ! FLAG to average fluxes from start & end states - LOGICAL(LGT), INTENT(IN),OPTIONAL :: ADD_FLUX ! FLAG to add accepted fluxes to the total flux - LOGICAL(LGT), INTENT(IN),OPTIONAL :: NEWSTATE ! FLAG to use weighted fluxes to compute end state - REAL(SP), INTENT(IN), OPTIONAL :: DT ! length of the sub-step - REAL(SP), DIMENSION(:),INTENT(IN), OPTIONAL :: S0 ! input state vector - REAL(SP), DIMENSION(:), INTENT(OUT),OPTIONAL :: S1 ! state vector from the implicit euler solution - REAL(SP), DIMENSION(:),INTENT(INOUT),OPTIONAL :: DSDT ! state derivatives - LOGICAL(LGT), INTENT(IN),OPTIONAL :: NEWSTEP ! FLAG to denote a new model time step - LOGICAL(LGT), INTENT(IN),OPTIONAL :: CONVCHECK ! FLAG to check for convergence of the implicit scheme - INTEGER(I4B), INTENT(OUT), OPTIONAL :: NITER ! number of iterations - INTEGER(I4B), INTENT(IN), OPTIONAL :: SOLUTION ! solution is at start (0) or end (1) of sub-step - LOGICAL(LGT), INTENT(OUT),OPTIONAL :: HBOUND ! FLAG to denote if the states were out of bounds - INTEGER(I4B), INTENT(OUT) :: IERR ! error code - CHARACTER(LEN=*), INTENT(OUT) :: MESSAGE ! error message - END SUBROUTINE MODL_SOLVE - END INTERFACE - END SUBROUTINE ODE_INT -END INTERFACE -! ------------------------------------------------------------------------------------------------- -INTERFACE - SUBROUTINE TEST_SOLVE(CALCDSDT,IE_SOLVE,B_IMPOSE,AVG_FLUX,ADD_FLUX,NEWSTATE, & ! define functionality of the routine - DT,S0,S1,DSDT,NEWSTEP,CONVCHECK,NITER,SOLUTION,HBOUND, & ! input/output - IERR,MESSAGE) ! error control - USE nrtype ! variable definitions, etc. - IMPLICIT NONE - LOGICAL(LGT), INTENT(IN),OPTIONAL :: CALCDSDT ! FLAG to calculate derivatives at S0 - LOGICAL(LGT), INTENT(IN),OPTIONAL :: IE_SOLVE ! FLAG to compute the implicit Euler solution - LOGICAL(LGT), INTENT(IN),OPTIONAL :: B_IMPOSE ! FLAG to impose bounds on model states - LOGICAL(LGT), INTENT(IN),OPTIONAL :: AVG_FLUX ! FLAG to average fluxes from start & end states - LOGICAL(LGT), INTENT(IN),OPTIONAL :: ADD_FLUX ! FLAG to add accepted fluxes to the total flux - LOGICAL(LGT), INTENT(IN),OPTIONAL :: NEWSTATE ! FLAG to use weighted fluxes to compute end state - REAL(SP), INTENT(IN), OPTIONAL :: DT ! length of the sub-step - REAL(SP), DIMENSION(:),INTENT(IN), OPTIONAL :: S0 ! input state vector - REAL(SP), DIMENSION(:), INTENT(OUT),OPTIONAL :: S1 ! state vector from the implicit euler solution - REAL(SP), DIMENSION(:),INTENT(INOUT),OPTIONAL :: DSDT ! state derivatives - LOGICAL(LGT), INTENT(IN),OPTIONAL :: NEWSTEP ! FLAG to denote a new model time step - LOGICAL(LGT), INTENT(IN),OPTIONAL :: CONVCHECK ! FLAG to check for convergence of the implicit scheme - INTEGER(I4B), INTENT(OUT), OPTIONAL :: NITER ! number of iterations - INTEGER(I4B), INTENT(IN), OPTIONAL :: SOLUTION ! solution is at start (0) or end (1) of sub-step - LOGICAL(LGT), INTENT(OUT),OPTIONAL :: HBOUND ! FLAG to denote if the states were out of bounds - INTEGER(I4B), INTENT(OUT) :: IERR ! error code - CHARACTER(LEN=*), INTENT(OUT) :: MESSAGE ! error message - END SUBROUTINE TEST_SOLVE -END INTERFACE -! ------------------------------------------------------------------------------------------------- -END MODULE INTERFACEB diff --git a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/model_numerix.f90.svn-base b/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/model_numerix.f90.svn-base deleted file mode 100644 index 270781a..0000000 --- a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/model_numerix.f90.svn-base +++ /dev/null @@ -1,64 +0,0 @@ -!****************************************************************** -MODULE model_numerix -! Purpose: To define method/parameters used for numerical solution -! Programmer: Dmitri Kavetski and Martyn Clark -! Last modified: -! Comments: -USE nrtype -implicit none -! --------------------------------------------------------------------------------------- -! (A) METHODS -! --------------------------------------------------------------------------------------- -! 1. Solution technique -INTEGER(I4B), PARAMETER :: EXPLICIT_EULER=0, IMPLICIT_EULER=1 -INTEGER(I4B) :: SOLUTION_METHOD -! 2. Temporal error control -INTEGER(I4B), PARAMETER :: TS_FIXED=0, TS_ADAPT=1 -INTEGER(I4B) :: TEMPORAL_ERROR_CONTROL -! 3. Method used to estimate temporal truncation error -INTEGER(I4B), PARAMETER :: STEP_HALVING=0, EMBEDDED_ERR=1 -INTEGER(I4B) :: TRUNCATION_ERROR -! 4. Order of solution that is accepted -INTEGER(I4B), PARAMETER :: HIGHER_ORDER=0, LOWER_ORDER=1 -INTEGER(I4B) :: ORDER_ACCEPT -! 5. Method used to estimate the initial conditions for the Newton scheme -INTEGER(I4B), PARAMETER :: STATE_OLD=0, EXPLICIT_MID=1, EXPLICIT_FULL=2 -INTEGER(I4B) :: INITIAL_NEWTON -! 6. Jacobian re-evaluation strategy -INTEGER(I4B), PARAMETER :: FULLYVARIABLE=0, CONST_SUBSTEP=1, CONSTFULLSTEP=2 -INTEGER(I4B) :: JAC_RECOMPUTE -REAL(SP), ALLOCATABLE :: fjacDCMP(:,:), fjacCOPY(:,:), fjacINDX(:) ! (temporary arrays) -! 7. Method used to trap/fix errors in Newton -INTEGER(I4B), PARAMETER :: FULL_NEWTON=0, LINE_SEARCH=1 -INTEGER(I4B) :: CHECK_OVERSHOOT -! 8. 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 -! --------------------------------------------------------------------------------------- -! (B) PARAMETERS -! --------------------------------------------------------------------------------------- -REAL(SP) :: ERR_TRUNC_ABS ! Absolute temporal truncation error tolerance -REAL(SP) :: ERR_TRUNC_REL ! Relative temporal truncation error tolerance -REAL(SP) :: ERR_ITER_FUNC ! Iteration convergence tolerance for function values -REAL(SP) :: ERR_ITER_DX ! Iteration convergence tolerance for dx -REAL(SP) :: FRACSTATE_MIN ! Fractional minimum value of state (for non-zero derivatives) -REAL(SP) :: SAFETY ! Safety factor in step-size equation -REAL(SP) :: RMIN ! Minimum step size multiplier -REAL(SP) :: RMAX ! Maximum step size multiplier -INTEGER(I4B) :: NITER_TOTAL ! Total number of iterations used in the implicit scheme -REAL(SP) :: MIN_TSTEP ! Minimum time step length -REAL(SP) :: MAX_TSTEP ! Maximum time step length -! --------------------------------------------------------------------------------------- -! (C) DIAGNOSTIX -! --------------------------------------------------------------------------------------- -INTEGER(I4B) :: NUM_FUNCS ! number of function calls -INTEGER(I4B) :: NUM_JACOBIAN ! number of times Jacobian is calculated -INTEGER(I4B) :: NUMSUB_ACCEPT ! number of sub-steps accepted (taken) -INTEGER(I4B) :: NUMSUB_REJECT ! number of sub-steps tried but rejected -INTEGER(I4B) :: NUMSUB_NOCONV ! number of sub-steps tried that did not converge -INTEGER(I4B) :: MAXNUM_ITERNS ! maximum number of iterations in the implicit scheme -INTEGER(I4B),DIMENSION(20) :: ORD_NSUBS = (/ 1, 2, 5, 10, 20, 30, 50, 75, 100, 200, & - 300,500,750,1000,2000,5000,10000,20000,50000,100000/) -INTEGER(I4B),DIMENSION(20) :: PRB_NSUBS ! cumulative probability for number of substeps taken -! --------------------------------------------------------------------------------------- -END MODULE MODEL_NUMERIX diff --git a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/ode_int.f90.svn-base b/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/ode_int.f90.svn-base deleted file mode 100644 index 4e4ca9b..0000000 --- a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/ode_int.f90.svn-base +++ /dev/null @@ -1,318 +0,0 @@ -SUBROUTINE ODE_INT(MODL_SOLVE,STATE_START,STATE_END,DT_SUB,DT_FULL,IERR,MESSAGE) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! -! Used for the temporal integration of ordinary differential equations, using different -! numerical methods -! -! Based on the FUSE "sub-stepper" routine, but all FUSE-specific data structures have -! been stripped out to call a simple test function -! -! --------------------------------------------------------------------------------------- -USE nrtype ! variable definitions, etc. -USE model_numerix ! define method/parameters used for numerical solution -IMPLICIT NONE -! input/output variables -REAL(SP), DIMENSION(:), INTENT(IN) :: STATE_START ! state vector at the start of the full step -REAL(SP), DIMENSION(:), INTENT(OUT) :: STATE_END ! state vector at the end of the full step -REAL(SP), INTENT(INOUT) :: DT_SUB ! length of the sub-step -REAL(SP), INTENT(IN) :: DT_FULL ! length of the full step -INTEGER(I4B), INTENT(OUT) :: IERR ! error code -CHARACTER(LEN=*), INTENT(OUT) :: MESSAGE ! error message -! internal variables -REAL(SP) :: STEP ! new step size -REAL(SP) :: ETIME ! part of the time step completed -REAL(SP) :: PREVSTEP ! save pen-ultimate step size so small steps not carried over -LOGICAL(LGT) :: NEWSTEP ! .TRUE. if new step (determine if a new Jacobian is needed) -LOGICAL(LGT) :: NEW_SUBSTEP ! .TRUE. if new sub-step (determine if need to calculate derivatives) -LOGICAL(LGT) :: STEP_INCREASE ! FLAG to determine if the end time step has been increased -REAL(SP), DIMENSION(SIZE(STATE_START)) :: STATE0 ! state vector at the start of the sub-step -REAL(SP), DIMENSION(SIZE(STATE_START)) :: STATE1_LO ! state vector at the end of the sub-step (lower-order solution) -REAL(SP), DIMENSION(SIZE(STATE_START)) :: STATE1_HI ! state vector at the end of the sub-step (higher-order solution) -REAL(SP), DIMENSION(SIZE(STATE_START)) :: STATE1_LO_S ! safeguarded explicit Euler solution, used in explicit Heun -REAL(SP), DIMENSION(SIZE(STATE_START)) :: STATE1_INIT ! initial state vector used in the implicit solution -REAL(SP), DIMENSION(SIZE(STATE_START)) :: STATE1_SELECT ! states selected at the end of the sub-step -REAL(SP), DIMENSION(SIZE(STATE_START)) :: STATE1_RETAIN ! states retained at the end of the sub-step -REAL(SP), DIMENSION(SIZE(STATE_START)) :: DYDT_0 ! model derivatives at the start of the sub-step -REAL(SP), DIMENSION(SIZE(STATE_START)) :: DYDT_1 ! model derivatives at the end of the sub-step -REAL(SP), DIMENSION(SIZE(STATE_START)) :: DYDT_AVG ! average derivatives from the start and end of the sub-step -REAL(SP), DIMENSION(SIZE(STATE_START)) :: EVEC ! error estimate for each state -REAL(SP), DIMENSION(SIZE(STATE_START)) :: TVEC ! error threshold for each state -REAL(SP) :: MULT ! multiplier for new step size -REAL(SP), PARAMETER :: EPS=1.E-10_SP ! machine constant to prevent floating point errors -INTEGER(I4B), DIMENSION(1) :: IMAX ! index of maximum error -INTEGER(I4B) :: NITER ! number of iterations in newtoniter -LOGICAL(LGT) :: CHECK ! convergence check in SUBROUTINE newtoniter -LOGICAL(LGT) :: FEXCESS ! FLAG to denote if states are corrected for excessive extrapolation -REAL(SP) :: TEMPSTEP ! suggested new time step, for case of non-convergence -! ------------------------------------------------------------------------------------------------- -INTERFACE - SUBROUTINE MODL_SOLVE(CALCDSDT,IE_SOLVE,B_IMPOSE,AVG_FLUX,ADD_FLUX,NEWSTATE, & ! define functionality of the routine - DT,S0,S1,DSDT,NEWSTEP,CONVCHECK,NITER,SOLUTION,HBOUND, & ! input/output - IERR,MESSAGE) ! error control - USE nrtype ! variable definitions, etc. - IMPLICIT NONE - LOGICAL(LGT), INTENT(IN),OPTIONAL :: CALCDSDT ! FLAG to calculate derivatives at S0 - LOGICAL(LGT), INTENT(IN),OPTIONAL :: IE_SOLVE ! FLAG to compute the implicit Euler solution - LOGICAL(LGT), INTENT(IN),OPTIONAL :: B_IMPOSE ! FLAG to impose bounds on model states - LOGICAL(LGT), INTENT(IN),OPTIONAL :: AVG_FLUX ! FLAG to average fluxes from start & end states - LOGICAL(LGT), INTENT(IN),OPTIONAL :: ADD_FLUX ! FLAG to add accepted fluxes to the total flux - LOGICAL(LGT), INTENT(IN),OPTIONAL :: NEWSTATE ! FLAG to use weighted fluxes to compute end state - REAL(SP), INTENT(IN), OPTIONAL :: DT ! length of the sub-step - REAL(SP), DIMENSION(:),INTENT(IN), OPTIONAL :: S0 ! input state vector - REAL(SP), DIMENSION(:), INTENT(OUT),OPTIONAL :: S1 ! state vector from the implicit euler solution - REAL(SP), DIMENSION(:),INTENT(INOUT),OPTIONAL :: DSDT ! state derivatives - LOGICAL(LGT), INTENT(IN),OPTIONAL :: NEWSTEP ! FLAG to denote a new model time step - LOGICAL(LGT), INTENT(IN),OPTIONAL :: CONVCHECK ! FLAG to check for convergence of the implicit scheme - INTEGER(I4B), INTENT(OUT), OPTIONAL :: NITER ! number of iterations - INTEGER(I4B), INTENT(IN), OPTIONAL :: SOLUTION ! solution is at start (0) or end (1) of sub-step - LOGICAL(LGT), INTENT(IN),OPTIONAL :: HBOUND ! FLAG to denote if the states were out of bounds - INTEGER(I4B), INTENT(OUT) :: IERR ! error code - CHARACTER(LEN=*), INTENT(OUT) :: MESSAGE ! error message - END SUBROUTINE MODL_SOLVE -END INTERFACE -! --------------------------------------------------------------------------------------- -! (0) INITIALIZATION -! --------------------------------------------------------------------------------------- -! intilize states and counters -NITER = 0 ! number of iterations -ETIME = 0._sp ! part of the time step completed -CHECK = .FALSE. ! convergence check for the newton scheme -STATE0 = STATE_START ! save model states at the start of the full step -STATE1_RETAIN = STATE_START ! initial state (needed for rejected steps) -newStep = .true. ! initialize newstep (force re-calculation of Jacobian) -NEW_SUBSTEP = .TRUE. ! initialize new sub-step (check if need new derivatives) -! initialize diagnostix -NUM_FUNCS = 0 ! number of function calls -NUM_JACOBIAN = 0 ! number of times Jacobian is calculated -NUMSUB_ACCEPT = 0 ! number of sub-steps accepted (taken) -NUMSUB_REJECT = 0 ! number of sub-steps tried but rejected -NUMSUB_NOCONV = 0 ! number of sub-steps tried that did not converge -MAXNUM_ITERNS = 0 ! maximum number of iterations taken in the newton method -! --------------------------------------------------------------------------------------- -! DT_SUB (sub-step length) is carried over from previous step; ensure that it is in bounds -DT_SUB = MIN( MAX(MIN_TSTEP,DT_SUB), MAX_TSTEP) ! (MIN_TSTEP < stepsize < MAX_TSTEP) -PREVSTEP = DT_SUB ! initialize the previous time step (tracked to avoid using small interval at end of step) -STEP_INCREASE = .FALSE. ! used to check if the final sub-step has been increased - -SUBSTEPS: DO ! continuous (recursive) loop over sub-steps - - ! --------------------------------------------------------------------------------------- - ! (0) SAVE VECTOR OF STATES AND DERIVATIVES AT THE START OF THE SUB-STEP - ! --------------------------------------------------------------------------------------- - - ! refresh model states at the start of the sub-step - IF (NEW_SUBSTEP .AND. .NOT.newStep) STATE0 = STATE1_RETAIN - - ! calculate new derivatives - IF (NEW_SUBSTEP) THEN - CALL MODL_SOLVE(CALCDSDT=.TRUE.,S0=STATE0,DSDT=DYDT_0,SOLUTION=0,IERR=IERR,MESSAGE=MESSAGE) - IF (IERR.NE.0) THEN; PRINT *, IERR, MESSAGE; STOP; ENDIF - ENDIF - - ! select solution method - SELECT CASE(SOLUTION_METHOD) - - ! --------------------------------------------------------------------------------------- - ! (1) CALCULATE EXPLICIT EULER SOLUTIONS - ! --------------------------------------------------------------------------------------- - CASE (EXPLICIT_EULER) - ! calculate explicit Euler solution - STATE1_LO = STATE0 + DYDT_0*DT_SUB ! explicit solution (can be out of range, but OK for error control) - ! get a safegaurded solution to account for excessive extrapolation (includes flux disaggregation) - CALL MODL_SOLVE(B_IMPOSE=.TRUE.,S0=STATE1_LO,S1=STATE1_LO_S,DT=DT_SUB,HBOUND=FEXCESS,& - IERR=IERR,MESSAGE=MESSAGE) - newStep=.false. - IF (IERR.NE.0) THEN; PRINT *, IERR, TRIM(MESSAGE); STOP; ENDIF - ! EXIT here if lower-order solution with fixed steps - IF (TEMPORAL_ERROR_CONTROL.EQ.TS_FIXED .AND. ORDER_ACCEPT.EQ.LOWER_ORDER) THEN - ! (add fluxes in the model data structures to total timestep fluxes) - CALL MODL_SOLVE(ADD_FLUX=.TRUE.,S1=STATE1_LO_S,DT=DT_SUB,IERR=IERR,MESSAGE=MESSAGE) - IF (IERR.NE.0) THEN; PRINT *, IERR, MESSAGE; STOP; ENDIF - EXIT SUBSTEPS ! EXIT the sub-steps loop - ENDIF - ! calculate explicit Heun solution (NOTE: using safeguarded states) - CALL MODL_SOLVE(CALCDSDT=.TRUE.,S0=STATE1_LO_S,DSDT=DYDT_1,SOLUTION=1,IERR=IERR,MESSAGE=MESSAGE) - IF (IERR.NE.0) THEN; PRINT *, IERR, MESSAGE; STOP; ENDIF - - ! -------------------------------------------------------------------------------------- - ! (2) CALCULATE IMPLICIT EULER SOLUTION - ! -------------------------------------------------------------------------------------- - CASE (IMPLICIT_EULER) - ! estimate the initial conditions used in the Newton scheme - SELECT CASE (INITIAL_NEWTON) - CASE (STATE_OLD); STATE1_INIT = STATE0 - CASE (EXPLICIT_MID); STATE1_INIT = STATE0 + DYDT_0*DT_SUB/2.0_SP ! estimate at mid-point - CASE (EXPLICIT_FULL); STATE1_INIT = STATE0 + DYDT_0*DT_SUB ! estimate at end - END SELECT - ! estimate state vector at end of time step - CALL MODL_SOLVE(IE_SOLVE=.TRUE.,S0=STATE1_INIT,S1=STATE1_LO,DSDT=DYDT_1,DT=DT_SUB,& - NEWSTEP=newStep,CONVCHECK=CHECK,NITER=NITER,& - IERR=IERR,MESSAGE=MESSAGE) - IF (IERR.NE.0) THEN; PRINT *, IERR, TRIM(MESSAGE); STOP; ENDIF - IF (NITER > MAXNUM_ITERNS) MAXNUM_ITERNS=NITER - newStep=.false. - ! just use this solution if no adaptive time steps - IF (TEMPORAL_ERROR_CONTROL.EQ.TS_FIXED .AND. ORDER_ACCEPT.EQ.LOWER_ORDER) THEN - CALL MODL_SOLVE(ADD_FLUX=.TRUE.,S1=STATE1_LO,DT=DT_SUB,IERR=IERR,MESSAGE=MESSAGE) - IF (IERR.NE.0) THEN; PRINT *, IERR, TRIM(MESSAGE); STOP; ENDIF - EXIT SUBSTEPS ! EXIT the sub-steps loop - ENDIF - ! check for non-convergence - IF (CHECK) THEN - NUMSUB_NOCONV = NUMSUB_NOCONV + 1 - STEP = MAX(MIN_TSTEP, DT_SUB*RMIN) ! (avoid stepsize < MIN_TSTEP) - TEMPSTEP = REVISE_STEP() ! avoid small steps at the end of a time interval - IF (TEMPSTEP.NE.STEP) THEN; PREVSTEP=STEP; ELSE; PREVSTEP=TEMPSTEP; ENDIF - ! avoid the case of a continuous do loop where TEMPSTEP is at a minimum - IF (TEMPSTEP.LT.DT_SUB) THEN ! TEMPSTEP may equal DT_SUB (MIN_TSTEP, or end of interval) - newStep = .true. - DT_SUB = TEMPSTEP - CYCLE SUBSTEPS - ENDIF - IERR=10; MESSAGE='newton did not converge, and unable to make steps small enough'; RETURN - ENDIF - - ! check that the solution method is OK - CASE DEFAULT - IERR=20; MESSAGE='SOLUTION_METHOD must be either EXPLICIT_EULER or IMPLICIT_EULER'; RETURN - - END SELECT - - ! -------------------------------------------------------------------------------------- - ! (3) CALCULATE ERROR, CHECK IF ACCEPT/REJECT THE CURRENT STEP, AND NEW STEP SIZE - ! -------------------------------------------------------------------------------------- - ! alternative solution (NOTE: DYDT_1 can come from either the implicit or explicit solution) - DYDT_AVG = 0.5_SP*(DYDT_0+DYDT_1) - STATE1_HI = STATE0 + DYDT_AVG*DT_SUB - ! calculate the maximum error over all states - EVEC = ABS(STATE1_HI - STATE1_LO) ! error estimate - TVEC = ERR_TRUNC_REL*ABS(STATE1_HI) + ERR_TRUNC_ABS ! error thresholds - IMAX = MAXLOC(EVEC - TVEC) ! index of maximum error - ! -------------------------------------------------------------------------------------- - ! check to accept time step - IF (TEMPORAL_ERROR_CONTROL.EQ.TS_FIXED .OR. & ! (accept if using fixed time steps) - EVEC(IMAX(1)) < TVEC(IMAX(1)) .OR. & ! (accept if error is less than critical threshold) - DT_SUB <= MIN_TSTEP) THEN ! (accept if time step is already minimum allowable) - NEW_SUBSTEP = .TRUE. - ! accept step -- calculate new (increased) step size - ! NOTE: step size not necessarily increased because of the safety factor - IF (TEMPORAL_ERROR_CONTROL.EQ.TS_ADAPT) THEN - MULT = SAFETY * SQRT( TVEC(IMAX(1)) / MAX(EVEC(IMAX(1)),EPS) ) - STEP = MIN( MAX(MIN_TSTEP, DT_SUB * MIN(MULT,RMAX) ), MAX_TSTEP) ! (MIN_TSTEP < stepsize < MAX_TSTEP) - ELSE - STEP = MAX_TSTEP - ENDIF - ! average fluxes (average fluxes before imposing bounds) - IF (ORDER_ACCEPT.EQ.HIGHER_ORDER) & - CALL MODL_SOLVE(AVG_FLUX=.TRUE.,IERR=IERR,MESSAGE=MESSAGE) - ! if lower order, just accept flux for the appropriate solution - IF (ORDER_ACCEPT.EQ.LOWER_ORDER) THEN - IF (SOLUTION_METHOD.EQ.EXPLICIT_EULER) & - CALL MODL_SOLVE(AVG_FLUX=.FALSE.,SOLUTION=0,IERR=IERR,MESSAGE=MESSAGE) ! start of sub-step - IF (SOLUTION_METHOD.EQ.IMPLICIT_EULER) & - CALL MODL_SOLVE(AVG_FLUX=.FALSE.,SOLUTION=1,IERR=IERR,MESSAGE=MESSAGE) ! end of sub-step - ENDIF - IF (IERR.NE.0) THEN; PRINT *, IERR, TRIM(MESSAGE); STOP; ENDIF - ! save desired state - IF (ORDER_ACCEPT.EQ.LOWER_ORDER) STATE1_SELECT = STATE1_LO - IF (ORDER_ACCEPT.EQ.HIGHER_ORDER) STATE1_SELECT = STATE1_HI - ! modify fluxes to account for excessive extrapolation (modifies average fluxes) - CALL MODL_SOLVE(B_IMPOSE=.TRUE.,S0=STATE1_SELECT,S1=STATE1_RETAIN,DT=DT_SUB,HBOUND=FEXCESS,& - IERR=IERR,MESSAGE=MESSAGE) - IF (IERR.NE.0) THEN; PRINT *, IERR, TRIM(MESSAGE); STOP; ENDIF - ! add contribution of sub-step flux to the timestep-average flux - CALL MODL_SOLVE(ADD_FLUX=.TRUE.,S1=STATE1_RETAIN,DT=DT_SUB,IERR=IERR,MESSAGE=MESSAGE) - IF (IERR.NE.0) THEN; PRINT *, IERR, TRIM(MESSAGE); STOP; ENDIF - - NUMSUB_ACCEPT = NUMSUB_ACCEPT + 1 - ! compute fraction of big step that is finished, and check for exit criteria - ETIME = ETIME + DT_SUB ! identify position within the time step - IF (ETIME.GE.DT_FULL) THEN - ! print progress - WRITE(21,'(2(F10.6,1X),5(I6,1X),2(F10.4,1X))') DT_SUB,ETIME,& - NUMSUB_ACCEPT,NUMSUB_REJECT,NUM_FUNCS,NUM_JACOBIAN,NITER,STATE0,STATE1_RETAIN - EXIT SUBSTEPS ! exit the substeps loop - ENDIF - ! revise the length of time steps to avoid small steps at the end of a time interval - DT_SUB = REVISE_STEP() ! avoid small steps at the end of a time interval - IF (DT_SUB.NE.STEP) THEN; PREVSTEP=STEP; ELSE; PREVSTEP=DT_SUB; ENDIF - ! -------------------------------------------------------------------------------------- - ELSE ! REJECT STEP AND DECREASE STEP SIZE - NEW_SUBSTEP = .FALSE. - ! calculate new (decreased) step size - NUMSUB_REJECT = NUMSUB_REJECT + 1 - MULT = SAFETY * SQRT( TVEC(IMAX(1)) / MAX(EVEC(IMAX(1)),EPS) ) - STEP = MAX(MIN_TSTEP, DT_SUB * MAX(MULT,RMIN) ) ! (avoid stepsize < MIN_TSTEP) - DT_SUB = REVISE_STEP() ! avoid small steps at the end of a time interval - IF (DT_SUB.NE.STEP) THEN; PREVSTEP=STEP; ELSE; PREVSTEP=DT_SUB; ENDIF - ENDIF - ! print progress - WRITE(21,'(2(F10.6,1X),5(I6,1X),2(F10.4,1X))') DT_SUB,ETIME,& - NUMSUB_ACCEPT,NUMSUB_REJECT,NUM_FUNCS,NUM_JACOBIAN,NITER,STATE0,STATE1_RETAIN - - ! (keep looping) -END DO SUBSTEPS ! continuous (recursive) do loop - -! --------------------------------------------------------------------------------------- -! (9) RE-COMPUTE STATES AT THE END OF THE FULL STEP -! --------------------------------------------------------------------------------------- -! The implicit solution is not exact. To conserve mass, we uses the weighted average of -! model fluxes throughout the time step to re-compute states at the end of the time step -! --------------------------------------------------------------------------------------- -! update model states (note use of DT_FULL) -CALL MODL_SOLVE(NEWSTATE=.TRUE.,S1=STATE_END,DT=DT_FULL,IERR=IERR,MESSAGE=MESSAGE) -IF (IERR.NE.0) THEN; PRINT *, IERR, TRIM(MESSAGE); STOP; ENDIF -! NOTE: may need to modify diagnostic variables that do not have time units, e.g., satarea = satarea/dt_full -DT_SUB=PREVSTEP ! ensure stepsize is not equal to the small remainder - - -! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -CONTAINS - FUNCTION REVISE_STEP() - REAL(SP) :: REVISE_STEP - REAL(SP) :: T_MGN - SELECT CASE(SMALL_ENDSTEP) - ! ------------------------------------------------------------------------------------- - CASE(STEP_TRUNC) ! truncate the time step if near the end - IF (ETIME + STEP .GE. DT_FULL) REVISE_STEP = DT_FULL - ETIME - IF (ETIME + STEP .LT. DT_FULL) REVISE_STEP = STEP - ! ------------------------------------------------------------------------------------- - CASE(LOOK_AHEAD) ! the look-ahead method of Shampine (1994) - IF (ETIME + STEP .GE. DT_FULL) THEN - REVISE_STEP = DT_FULL - ETIME - ELSE - IF (ETIME + STEP*2._SP .GE. DT_FULL) THEN - REVISE_STEP = (DT_FULL - ETIME)/2._SP - ELSE - REVISE_STEP = STEP - ENDIF - ENDIF - ! ------------------------------------------------------------------------------------- - CASE(STEP_ABSORB) ! the step-absorption method - IF (STEP_INCREASE) THEN ! only try and increase step size once - REVISE_STEP = STEP - ELSE - T_MGN = STEP/SAFETY - STEP ! margin of error - IF (ETIME + STEP + T_MGN .GE. DT_FULL) THEN - REVISE_STEP = DT_FULL - ETIME - STEP_INCREASE = .TRUE. - ELSE - IF (ETIME + STEP + T_MGN*2._SP .GE. DT_FULL) THEN - REVISE_STEP = STEP + T_MGN*(1._SP - (DT_FULL-(ETIME+STEP))/T_MGN) - STEP_INCREASE = .TRUE. - ELSE - REVISE_STEP = STEP - ENDIF - ENDIF - ENDIF - CASE DEFAULT; STOP ' must use the STEP_TRUNC, LOOK_AHEAD, or STEP_ABSORB methods ' - END SELECT - END FUNCTION REVISE_STEP -END SUBROUTINE ODE_INT diff --git a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/rtnewt_sub.f90.svn-base b/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/rtnewt_sub.f90.svn-base deleted file mode 100644 index 0adc435..0000000 --- a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/rtnewt_sub.f90.svn-base +++ /dev/null @@ -1,35 +0,0 @@ -SUBROUTINE rtnewt_sub(funcd,xold,x1,x2,xacc,xnew,niter) -! From Numerical Recipes, but converted from a function to a subroutine -USE nrtype; USE nrutil, ONLY : nrerror -IMPLICIT NONE -REAL(SP), INTENT(IN) :: xold,x1,x2,xacc -REAL(SP), INTENT(OUT) :: xnew -INTEGER(I4B), INTENT(OUT) :: niter -INTERFACE - SUBROUTINE funcd(x,fval,fderiv) - USE nrtype - IMPLICIT NONE - REAL(SP), INTENT(IN) :: x - REAL(SP), INTENT(OUT) :: fval,fderiv - END SUBROUTINE funcd -END INTERFACE -INTEGER(I4B), PARAMETER :: MAXIT=20 -INTEGER(I4B) :: j -REAL(SP) :: df,dx,f,xsave -xnew = xold -if (xnew < x1) xnew=x1 -if (xnew > x2) xnew=x2 -do j=1,MAXIT - call funcd(xnew,f,df) ! calculate function and derivative - dx =f/df ! calculate dx - xsave=xnew ! save last trial value - xnew =xsave-dx ! calculate next trial value - if (xnew < x1) xnew=x1 ! check > minimum - if (xnew > x2) xnew=x2 ! check < maximum - if (abs(xnew-xsave) < xacc .or. abs(dx) < xacc) then ! check for convergence - niter=j ! save number of iterations - RETURN - endif -end do -call nrerror('rtnewt exceeded maximum iterations') -END SUBROUTINE rtnewt_sub diff --git a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/substepper.f90.svn-base b/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/substepper.f90.svn-base deleted file mode 100644 index 7faf48f..0000000 --- a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/substepper.f90.svn-base +++ /dev/null @@ -1,409 +0,0 @@ -SUBROUTINE SUBSTEPPER() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Run a given model and model parameter set for one time step, with adaptive sub-steps. -! -! The implicit solution is computed in the routine NEWTONITER, which finds the state vector "X_TRY" -! so that -! X_TRY(:) = X_NEW(:) -! X_NEW(:) = X_OLD(:) + DYDX(:) * HSTATE%STEP, with DYDX(:) evaluated at X_TRY(:) -! -! The "business=end" of the model is all within NEWTONITER (in the FUNCTION funcv) which computes -! model derivatives (DYDX) and model states (X_NEW) for a given state vector X_TRY(:) -! -! --------------------------------------------------------------------------------------- -USE nrtype ! variable definitions, etc. -USE newtoniter_mod, ONLY : newtoniter ! interface block for NEWTONITER -USE model_defn ! model definitions -USE multiforce ! model forcing data -USE multi_flux ! model fluxes -USE multistate ! model states -USE multiparam ! model parameters -USE xtry_2_str_module ! puts state vector into structure in multistate -USE str_2_xtry_module ! gets state vector from structure in multistate -use model_numerix ! define method/parameters used for numerical solution -IMPLICIT NONE -! internal variables -REAL(SP) :: STEP ! new step size -REAL(SP) :: ETIME ! part of the time step completed -REAL(SP) :: PREVSTEP ! save pen-ultimate step size so small steps not carried over -REAL(SP), DIMENSION(:), ALLOCATABLE :: X_START ! state vector at start of time interval -REAL(SP), DIMENSION(:), ALLOCATABLE :: X0_DYDT ! derivative at X0 (start) -REAL(SP), DIMENSION(:), ALLOCATABLE :: XM_DYDT ! derivative at XM (middle) -REAL(SP), DIMENSION(:), ALLOCATABLE :: X1_DYDT ! derivative at X1 (end) -REAL(SP), DIMENSION(:), ALLOCATABLE :: XC_DYDT ! corrected derivatives -REAL(SP), DIMENSION(:), ALLOCATABLE :: X_END0 ! explicit one-step solution, end of time interval -REAL(SP), DIMENSION(:), ALLOCATABLE :: X_END1 ! implicit one-step solution, end of time interval -REAL(SP), DIMENSION(:), ALLOCATABLE :: X_MID2 ! implicit two-step solution, middle of time interval -REAL(SP), DIMENSION(:), ALLOCATABLE :: X_END2 ! implicit two-step solution, end of time interval -REAL(SP), DIMENSION(:), ALLOCATABLE :: EVEC ! error estimate for each state -REAL(SP), DIMENSION(:), ALLOCATABLE :: TVEC ! error threshold for each state -REAL(SP) :: DT ! time step used in explicit euler -LOGICAL(LGT) :: ERROR_FLAG ! .TRUE. if extrapolation error -LOGICAL(LGT) :: NEW_DERIVS ! .TRUE. if need to calculate new derivatives -REAL(SP) :: STEPSAVE ! save the time step (HSTATE%STEP altered for two-step solution) -REAL(SP) :: MULT ! multiplier for new step size -REAL(SP), PARAMETER :: EPS=1.E-10_SP ! machine constant to prevent floating point errors -INTEGER(I4B) :: IERR ! error code for allocate/deallocate -INTEGER(I4B), DIMENSION(1) :: IMAX ! index of maximum error -LOGICAL(LGT) :: CHECK ! convergence check in SUBROUTINE newtoniter -INTEGER(I4B) :: NITER ! number of iterations in newtoniter -REAL(SP) :: TEMPSTEP ! suggested new time step, for case of non-convergence -REAL(SP) :: FTIM ! fraction of model time interval to advance states -LOGICAL(LGT) :: NEWSTEP ! FLAG to determine if a new Jacobian is needed -LOGICAL(LGT) :: STEP_INCREASE ! FLAG to determine if the end time step has been increased -INTEGER(I4B) :: I ! looping variable -! interface blocks -INTERFACE - SUBROUTINE limit_xtry(x) - USE nrtype - IMPLICIT NONE - REAL(SP), DIMENSION(:), INTENT(INOUT) :: x - END SUBROUTINE limit_xtry -END INTERFACE -! --------------------------------------------------------------------------------------- -! (0) INITIALIZATION -! --------------------------------------------------------------------------------------- -ALLOCATE(X_START(NSTATE),X0_DYDT(NSTATE),XM_DYDT(NSTATE),X1_DYDT(NSTATE),XC_DYDT(NSTATE),& - X_END0(NSTATE),X_END1(NSTATE),X_MID2(NSTATE),X_END2(NSTATE),& - EVEC(NSTATE),TVEC(NSTATE), STAT=IERR) -IF (IERR.NE.0) STOP ' PROBLEM ALLOCATING SPACE IN MODEL1STEP ' -ETIME = 0._sp ! part of the time step completed -ASTATE = FSTATE ! save model states at the start of the full step -newStep = .true. ! initialize newstep (force re-calculation of Jacobian) -PREVSTEP = HSTATE%STEP ! initialize the previous time step (used in next iteration) -STEP_INCREASE = .FALSE. ! used to check if the final sub-step has been increased -NUM_FUNCS = 0 ! number of function calls -NUM_JACOBIAN = 0 ! number of times Jacobian is calculated -NUMSUB_ACCEPT = 0 ! number of sub-steps accepted (taken) -NUMSUB_REJECT = 0 ! number of sub-steps tried but rejected -NUMSUB_NOCONV = 0 ! number of sub-steps tried that did not converge -MAXNUM_ITERNS = 0 ! maximum number of iterations taken in the newton method -! --------------------------------------------------------------------------------------- -! ensure time step is within bounds (can be out of bounds when processing remainder of last sub-step) -HSTATE%STEP = MIN( MAX(MIN_TSTEP,HSTATE%STEP), MAX_TSTEP) ! (MIN_TSTEP < stepsize < MAX_TSTEP) - -SUBSTEPS: DO ! continuous (recursive) loop over sub-steps - - ! --------------------------------------------------------------------------------------- - ! (0) SAVE VECTOR OF STATES AND DERIVATIVES AT THE START OF THE SUB-STEP - ! --------------------------------------------------------------------------------------- - MSTATE = FSTATE ! model states at start of sub-step - TSTATE = FSTATE; CALL STR_2_XTRY(X_START) ! copy states (here TSTATE) to X_START - ! determine if there is a need to calculate derivatives - NEW_DERIVS=.FALSE. - IF (ETIME.EQ.0._SP) THEN - NEW_DERIVS=.TRUE. - ELSE - IF (SOLUTION_METHOD.EQ.EXPLICIT_EULER) NEW_DERIVS=.TRUE. - IF (SOLUTION_METHOD.EQ.IMPLICIT_EULER .AND. & ! test for Crank-Nicholson - TRUNCATION_ERROR.EQ.EMBEDDED_ERR .AND. ORDER_ACCEPT.EQ.HIGHER_ORDER) NEW_DERIVS=.TRUE. - ENDIF - ! calculate new derivatives - IF (NEW_DERIVS) THEN - CALL MOD_DERIVS() ! model derivatives at start of sub-step - FLUX_0 = M_FLUX ! save fluxes from explicit solution - TSTATE=DY_DT; CALL STR_2_XTRY(X0_DYDT) ! copy derivatives (here TSTATE) to X0_DYDT - ELSE - TSTATE=DYDT_OLD; CALL STR_2_XTRY(X0_DYDT) ! copy derivatives (here TSTATE) to X0_DYDT - ENDIF - ! select solution method - SELECT CASE(SOLUTION_METHOD) - - ! --------------------------------------------------------------------------------------- - ! (1A) EXPLICIT ONE-STEP SOLUTION - ! --------------------------------------------------------------------------------------- - CASE (EXPLICIT_EULER) - DT = HSTATE%STEP ! define time step - X_END1 = X_START + X0_DYDT*DT ! explicit solution (can be out of range, but OK for error control) - IF (ORDER_ACCEPT.EQ.LOWER_ORDER) THEN - ! modify fluxes (M_FLUX) so that states (X_END1) are within bounds - CALL XTRY_2_STR(X_START); BSTATE=TSTATE ! populate state structure BSTATE with values of X_START - CALL XTRY_2_STR(X_END1) ; ESTATE=TSTATE ! populate state structure ESTATE with values of X_END1 - CALL FIX_STATES(DT,ERROR_FLAG) ! ensure states are in bounds and disaggregate fluxes - TSTATE=ESTATE; CALL STR_2_XTRY(X_END1) ! copy states (here TSTATE) to X_END1 - ! EXIT here if there are no adaptive sub-steps - IF (TEMPORAL_ERROR_CONTROL.EQ.TS_FIXED) THEN - CALL WGT_FLUXES() ! just use W_FLUX=M_FLUX if no adaptive time steps - EXIT SUBSTEPS ! EXIT the sub-steps loop - ENDIF - ! save M_FLUX, because modified below in MOD_DERIVS() - FLUX_0 = M_FLUX ! NOTE: unmodified FLUX_0 for higher-order solution is saved above - ENDIF - - ! ------------------------------------------------------------------------------------- - ! (1B) EXPLICIT ERROR ESTIMATE - ! ------------------------------------------------------------------------------------- - DT = HSTATE%STEP/2.0_SP ! define the time step - X_MID2 = X_START + X0_DYDT*DT ! explicit solution at the mid-point - CALL XTRY_2_STR(X_START); BSTATE=TSTATE ! populate state structure BSTATE with values of X_START - ! ensure states are within range, and (if HIGHER_ORDER STEP_HALVING) make appropriate modifications - IF (TRUNCATION_ERROR.EQ.STEP_HALVING .AND. ORDER_ACCEPT.EQ.HIGHER_ORDER) THEN - CALL XTRY_2_STR(X_MID2) ; ESTATE=TSTATE ! populate state structure ESTATE with values of X_MID2 - CALL FIX_STATES(DT,ERROR_FLAG) ! ensure states are in bounds and disaggregate fluxes - BSTATE=ESTATE ! set end state to start state - TSTATE=ESTATE; CALL STR_2_XTRY(X_MID2) ! copy states (here TSTATE) to X_MID2 - FLUX_1 = M_FLUX ! save fluxes - ELSE - CALL LIMIT_XTRY(X_MID2) ! ensure states are in bounds (no need to disagg fluxes) - CALL XTRY_2_STR(X_MID2) ! populate state structure TSTATE with values of X_MID2 - ENDIF - ! calculate derivative at the mid-point (TSTATE set above, TSTATE=ESTATE, or XTRY_2_STR(X_MID2)) - CALL MOD_DERIVS() ! evaluate dxdt for state vector TSTATE - TSTATE = DY_DT; CALL STR_2_XTRY(XM_DYDT) ! copy derivatives (here TSTATE) to XM_DYDT - ! calculate different estimates of X_END2 - SELECT CASE(TRUNCATION_ERROR) - CASE (STEP_HALVING) - DT = HSTATE%STEP/2.0_SP - X_END2 = X_MID2 + XM_DYDT*DT ! two-step method - CASE (EMBEDDED_ERR) - DT = HSTATE%STEP - X_END2 = X_START + XM_DYDT*DT ! mid-point method - CASE DEFAULT; STOP ' TRUNCATION_ERROR methods must be either STEP_HALVING or EMBEDDED_ERR ' - END SELECT ! select method for estimating temporal truncation error - ! ensure states are within range, and make appropriate modifications (modifies M_FLUX) - IF (ORDER_ACCEPT.EQ.HIGHER_ORDER) THEN - CALL XTRY_2_STR(X_END2) ; ESTATE=TSTATE ! populate state structure ESTATE with values of X_END2 - CALL FIX_STATES(DT,ERROR_FLAG) ! ensure states are in bounds and disaggregate fluxes - TSTATE=ESTATE; CALL STR_2_XTRY(X_END2) ! copy states (here TSTATE) to X_END2 - ELSE - M_FLUX = FLUX_0 ! solution over the full step (saved earlier) - ENDIF - ! average fluxes for the two-step solution - IF (TRUNCATION_ERROR.EQ.STEP_HALVING .AND. ORDER_ACCEPT.EQ.HIGHER_ORDER) THEN - FLUX_2 = M_FLUX ! solution for the second half of the time step - CALL MEANFLUXES() ! M_FLUX = FLUX_1 (first half) + FLUX_2 (second half) - ENDIF - - ! -------------------------------------------------------------------------------------- - ! (2A) IMPLICIT ONE-STEP SOLUTION - ! -------------------------------------------------------------------------------------- - CASE (IMPLICIT_EULER) - ! if use embedded error control, the "higher-order" solution is Crank-Nicholson, so - ! need fluxes at the start of the current sub-step (calculated above) - IF (TRUNCATION_ERROR.EQ.EMBEDDED_ERR) FLUX_1 = FLUX_0 - ! estimate the initial conditions used in the Newton scheme - SELECT CASE (INITIAL_NEWTON) - CASE (STATE_OLD); X_END1 = X_START - CASE (EXPLICIT_MID); X_END1 = X_START + X0_DYDT*HSTATE%STEP/2.0_SP ! estimate at mid-point - CASE (EXPLICIT_FULL); X_END1 = X_START + X0_DYDT*HSTATE%STEP ! estimate at end - END SELECT - ! estimate state vector at end of time step - CALL NEWTONITER(X_END1,newStep,CHECK,NITER) ! try different values of X until converge - IF (NITER > MAXNUM_ITERNS) MAXNUM_ITERNS=NITER - newStep=.false. - ! just use this solution if no adaptive time steps - IF (TEMPORAL_ERROR_CONTROL.EQ.TS_FIXED .AND. ORDER_ACCEPT.EQ.LOWER_ORDER) THEN - CALL WGT_FLUXES() ! just use this solution if no adaptive time steps - EXIT SUBSTEPS ! EXIT the sub-steps loop - ENDIF - ! save fluxes, if using lower-order solution - IF (ORDER_ACCEPT.EQ.LOWER_ORDER) FLUX_0 = M_FLUX - ! save fluxes at end of the current time step - IF (TRUNCATION_ERROR.EQ.EMBEDDED_ERR) FLUX_2 = M_FLUX - ! check for non-convergence - IF (CHECK) THEN - NUMSUB_NOCONV = NUMSUB_NOCONV + 1 - STEP = MAX(MIN_TSTEP, HSTATE%STEP*RMIN) ! (avoid stepsize < MIN_TSTEP) - TEMPSTEP = REVISE_STEP() ! avoid small steps at the end of a time interval - IF (TEMPSTEP.NE.STEP) THEN; PREVSTEP=STEP; ELSE; PREVSTEP=TEMPSTEP; ENDIF - ! avoid the case of a continuous do loop where TEMPSTEP is at a minimum - IF (TEMPSTEP.LT.HSTATE%STEP) THEN ! TEMPSTEP may equal HSTATE%STEP (MIN_TSTEP, or end of interval) - newStep=.true. - HSTATE%STEP=TEMPSTEP - CYCLE SUBSTEPS - ENDIF - pause ' did not converge, and unable to make steps small enough ' - ENDIF - ! ------------------------------------------------------------------------------------- - ! (2B) IMPLICIT ERROR ESTIMATE - ! ------------------------------------------------------------------------------------- - SELECT CASE(TRUNCATION_ERROR) - ! ------------------------------------------------------------------------------------ - ! temporal truncation error estimate = step halving - CASE (STEP_HALVING) - STEPSAVE=HSTATE%STEP ! need to alter HSTATE%STEP because used in FUNCV - HSTATE%STEP = HSTATE%STEP/2._sp ! new HSTATE%STEP for use in FUNCV - ! implicit solution over the first half of the sub-step - MSTATE = FSTATE ! model states at start of sub-step - X_MID2 = X_START + X0_DYDT*HSTATE%STEP ! explicit solution - CALL NEWTONITER(X_MID2,newStep,CHECK,NITER) ! solve for X_MID - IF (NITER > MAXNUM_ITERNS) MAXNUM_ITERNS=NITER - IF (NITER.GT.NITER_TOTAL) pause ' did not converge, two-step solution) ' - FLUX_1 = M_FLUX ! save fluxes over the first half of the time step - ! implicit solution over the second half of the sub-step - MSTATE = TSTATE ! model states at start of next sub-step (TSTATE = X_MID2) - TSTATE = DY_DT ! temporarily populate TSTATE with derivatives - CALL STR_2_XTRY(XM_DYDT) ! copy derivatives (here TSTATE) to XM_DYDT - X_END2 = X_MID2 + XM_DYDT*HSTATE%STEP ! explicit solution - CALL NEWTONITER(X_END2,newStep,CHECK,NITER) ! try different values of X_END2 until converge - IF (NITER > MAXNUM_ITERNS) MAXNUM_ITERNS=NITER - IF (NITER.GT.NITER_TOTAL) pause ' did not converge, two-step solution ' - FLUX_2 = M_FLUX ! save fluxes over the second half of the time step - ! calculate fluxes used in WGT_FLUXES() - IF (ORDER_ACCEPT.EQ.HIGHER_ORDER) THEN - CALL MEANFLUXES() ! M_FLUX = average explicit (FLUX_1) + implicit (FLUX_2) solution - ELSE - M_FLUX = FLUX_0 ! just use implicit one-step solution - DYDT_OLD = DY_DT ! save derivatives - ENDIF - HSTATE%STEP = STEPSAVE ! re-set time step again (used in FUNCV) - ! ------------------------------------------------------------------------------------- - ! temporal truncation error estimate = embedded error estimate - CASE (EMBEDDED_ERR) - ! get derivative vector at the end of the time step (NOTE: don't enter two-step case) - TSTATE = DY_DT ! temporarily populate TSTATE with derivatives - CALL STR_2_XTRY(X1_DYDT) ! copy derivatives (here TSTATE) to X1_DYDT - ! alternative solution - DT = HSTATE%STEP - X_END2 = X_START + 0.5_SP*(X0_DYDT+X1_DYDT)*DT - ! ensure states are within range, and make appropriate modifications - IF (ORDER_ACCEPT.EQ.HIGHER_ORDER) THEN - CALL MEANFLUXES() ! M_FLUX = average explicit (FLUX_1) + implicit (FLUX_2) solution - CALL XTRY_2_STR(X_START); BSTATE=TSTATE ! populate state structure BSTATE with values of X_START - CALL XTRY_2_STR(X_END2) ; ESTATE=TSTATE ! populate state structure ESTATE with values of X_END2 - CALL FIX_STATES(DT,ERROR_FLAG) ! ensure states are in bounds and disaggregate fluxes (M_FLUX) - TSTATE=ESTATE; CALL STR_2_XTRY(X_END2) ! copy states (here TSTATE) to X_END2 - ENDIF - CASE DEFAULT - STOP ' TRUNCATION_ERROR methods must be either STEP_HALVING or EMBEDDED_ERR ' - END SELECT ! select method for estimating temporal truncation error - CASE DEFAULT; STOP ' SOLUTION_METHOD must be either EXPLICIT_EULER or IMPLICIT_EULER ' - END SELECT ! select method for numerical solution - - ! -------------------------------------------------------------------------------------- - ! (4) CALCULATE ERROR, CHECK IF ACCEPT/REJECT THE CURRENT STEP, AND NEW STEP SIZE - ! -------------------------------------------------------------------------------------- - ! calculate the maximum error over all states - EVEC = ABS(X_END2-X_END1) ! error estimate - TVEC = ERR_TRUNC_REL*ABS(X_END2) + ERR_TRUNC_ABS ! error thresholds - IMAX = MAXLOC(EVEC - TVEC) ! index of maximum error - !WRITE(*,'(A10,1X,10(E12.5,1X))') 'X_START', ETIME, HSTATE%STEP, X_START - !WRITE(*,'(A10,1X,10(E12.5,1X))') 'X_END0', ETIME, HSTATE%STEP, X_END0 - !WRITE(*,'(A10,1X,10(E12.5,1X))') 'X_MID2', ETIME, HSTATE%STEP, X_MID2 - !WRITE(*,'(A10,1X,10(E12.5,1X))') 'X_END1', ETIME, HSTATE%STEP, X_END1 - !WRITE(*,'(A10,1X,10(E12.5,1X))') 'X_END2', ETIME, HSTATE%STEP, X_END2 - !WRITE(*,'(A10,1X,10(E12.5,1X))') 'EVEC', ETIME, HSTATE%STEP, EVEC - !WRITE(*,'(A10,1X,10(E12.5,1X))') 'TVEC', ETIME, HSTATE%STEP, TVEC - ! -------------------------------------------------------------------------------------- - ! check to accept time step - IF (TEMPORAL_ERROR_CONTROL.EQ.TS_FIXED .OR. & ! (accept if using fixed time steps) - EVEC(IMAX(1)) < TVEC(IMAX(1)) .OR. & ! (accept if error is less than critical threshold) - HSTATE%STEP <= MIN_TSTEP) THEN ! (accept if time step is already minimum allowable) - ! accept step -- calculate new (increased) step size - ! NOTE: step size not necessarily increased because of the safety factor - IF (TEMPORAL_ERROR_CONTROL.EQ.TS_ADAPT) THEN - MULT = SAFETY * SQRT( TVEC(IMAX(1)) / MAX(EVEC(IMAX(1)),EPS) ) - STEP = MIN( MAX(MIN_TSTEP, HSTATE%STEP * MIN(MULT,RMAX) ), MAX_TSTEP) ! (MIN_TSTEP < stepsize < MAX_TSTEP) - ELSE - STEP = MAX_TSTEP - ENDIF - ! add contribution of sub-step flux to the timestep-average flux - !print *, 'm_flux%qbase_2a = ', m_flux%qbase_2a - CALL WGT_FLUXES() ! add M_FLUX to W_FLUX - ! save states at the end of the sub-step - SELECT CASE (ORDER_ACCEPT) - CASE (LOWER_ORDER); CALL XTRY_2_STR(X_END1) ! populate TSTATE with X_END1 - CASE (HIGHER_ORDER); CALL XTRY_2_STR(X_END2) ! populate TSTATE with X_END2 - END SELECT - FSTATE = TSTATE ! states at the end of the sub-step - ! save derivatives at the end of the sub-step - ! NOTE: explicit euler solution calculated at start of SUBSTEP loop (no need to save derivatives) - IF (SOLUTION_METHOD.EQ.IMPLICIT_EULER) THEN - ! NOTE: derivatives for implicit one-step solution saved earlier - IF (TRUNCATION_ERROR.EQ.STEP_HALVING .AND. ORDER_ACCEPT.EQ.HIGHER_ORDER) DYDT_OLD = DY_DT - ! NOTE: implicit Crank-Nicholson solution also calculated at start of SUBSTEP loop - IF (TRUNCATION_ERROR.EQ.EMBEDDED_ERR .AND. ORDER_ACCEPT.EQ. LOWER_ORDER) DYDT_OLD = DY_DT - ENDIF - ! keep track of the number of sub-steps taken - NUMSUB_ACCEPT = NUMSUB_ACCEPT + 1 - !print *, 'accept step ', numsub_accept - ! compute fraction of big step that is finished, and check for exit criteria - ETIME = ETIME + HSTATE%STEP ! identify position within the time step - IF (ETIME.GE.DELTIM) EXIT - ! revise the length of time steps to avoid small steps at the end of a time interval - HSTATE%STEP = REVISE_STEP() ! avoid small steps at the end of a time interval - IF (HSTATE%STEP.NE.STEP) THEN; PREVSTEP=STEP; ELSE; PREVSTEP=HSTATE%STEP; ENDIF - ! -------------------------------------------------------------------------------------- - ELSE ! REJECT STEP AND DECREASE STEP SIZE - ! calculate new (decreased) step size - !print *, 'reject step ', numsub_reject - NUMSUB_REJECT = NUMSUB_REJECT + 1 - MULT = SAFETY * SQRT( TVEC(IMAX(1)) / MAX(EVEC(IMAX(1)),EPS) ) - STEP = MAX(MIN_TSTEP, HSTATE%STEP * MAX(MULT,RMIN) ) ! (avoid stepsize < MIN_TSTEP) - HSTATE%STEP = REVISE_STEP() ! avoid small steps at the end of a time interval - IF (HSTATE%STEP.NE.STEP) THEN; PREVSTEP=STEP; ELSE; PREVSTEP=HSTATE%STEP; ENDIF - ENDIF - !print *, prevstep, step - !IF (NUMSUB_REJECT.GT.10000) PAUSE - ! (keep looping) - -END DO SUBSTEPS ! continuous (recursive) do loop - -! --------------------------------------------------------------------------------------- -! (9) RE-COMPUTE STATES AT THE END OF THE FULL STEP -! --------------------------------------------------------------------------------------- -! The implicit solution is not exact. To conserve mass, we uses the weighted average of -! model fluxes throughout the time step to re-compute states at the end of the time step -! --------------------------------------------------------------------------------------- -!WRITE(*,'(A15,1X,5(E15.8,1X))') 'FINAL FLUXES = ', & -! W_FLUX%QSURF, W_FLUX%OFLOW_1, W_FLUX%QINTF_1, W_FLUX%OFLOW_2, W_FLUX%QBASE_2 -! update model states -FTIM = DELTIM ! fraction of time step in subroutine updatstate -M_FLUX = W_FLUX ! SUBROUTINE mstate_eqn uses M_FLUX -FSTATE = ASTATE ! state at the start of the time step -CALL MSTATE_EQN() ! use time-step-average fluxes to compute model derivatives -CALL UPDATSTATE(FTIM) ! update model states -W_FLUX%SATAREA = W_FLUX%SATAREA/DELTIM ! normalize saturated area (weighted sum over sub-steps) -HSTATE%STEP=PREVSTEP ! ensure stepsize is not equal to the small remainder -! --------------------------------------------------------------------------------------- -DEALLOCATE(X_START,X0_DYDT,XM_DYDT,X1_DYDT,XC_DYDT,X_END0,X_END1,X_MID2,X_END2,EVEC,TVEC, & - STAT=IERR); IF (IERR.NE.0) STOP ' PROBLEM DEALLOCATING SPACE IN MODEL1STEP ' -! --------------------------------------------------------------------------------------- -CONTAINS - FUNCTION REVISE_STEP() - REAL(SP) :: REVISE_STEP - REAL(SP) :: T_MGN - SELECT CASE(SMALL_ENDSTEP) - ! ------------------------------------------------------------------------------------- - CASE(STEP_TRUNC) ! truncate the time step if near the end - IF (ETIME + STEP .GE. DELTIM) REVISE_STEP = DELTIM - ETIME - IF (ETIME + STEP .LT. DELTIM) REVISE_STEP = STEP - ! ------------------------------------------------------------------------------------- - CASE(LOOK_AHEAD) ! the look-ahead method of Shampine (1994) - IF (ETIME + STEP .GE. DELTIM) THEN - REVISE_STEP = DELTIM - ETIME - ELSE - IF (ETIME + STEP*2._SP .GE. DELTIM) THEN - REVISE_STEP = (DELTIM - ETIME)/2._SP - ELSE - REVISE_STEP = STEP - ENDIF - ENDIF - ! ------------------------------------------------------------------------------------- - CASE(STEP_ABSORB) ! the step-absorption method - IF (STEP_INCREASE) THEN ! only try and increase step size once - REVISE_STEP = STEP - ELSE - T_MGN = STEP/SAFETY - STEP ! margin of error - IF (ETIME + STEP + T_MGN .GE. DELTIM) THEN - REVISE_STEP = DELTIM - ETIME - STEP_INCREASE = .TRUE. - ELSE - IF (ETIME + STEP + T_MGN*2._SP .GE. DELTIM) THEN - REVISE_STEP = STEP + T_MGN*(1._SP - (DELTIM-(ETIME+STEP))/T_MGN) - STEP_INCREASE = .TRUE. - ELSE - REVISE_STEP = STEP - ENDIF - ENDIF - ENDIF - CASE DEFAULT; STOP ' must use the STEP_TRUNC, LOOK_AHEAD, or STEP_ABSORB methods ' - END SELECT - END FUNCTION REVISE_STEP -END SUBROUTINE SUBSTEPPER diff --git a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/test_deriv.f90.svn-base b/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/test_deriv.f90.svn-base deleted file mode 100644 index 6ed9da2..0000000 --- a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/test_deriv.f90.svn-base +++ /dev/null @@ -1,26 +0,0 @@ -MODULE TEST_DERIV__MODULE -IMPLICIT NONE -CONTAINS -! --------------------------------------------------------------------------------------- -FUNCTION TEST_DERIV(S) -! Used to calculate derivatives using the simple test function -! dS/dt = -sqrt(S) -! For generality, includes -! (1) Put state vector in model data structures -! (2) Compute fluxes -! (3) Compute derivatives -! (4) Extract derivatives from model structure -USE nrtype ! numerical recipes data types -USE test_modvar, ONLY: TSTATE,M_FLUX,MDS_DT ! model data structures -USE model_numerix, ONLY: NUM_FUNCS ! number of function calls -IMPLICIT NONE -REAL(SP), DIMENSION(:), INTENT(IN) :: S ! storage -REAL(SP), DIMENSION(SIZE(S)) :: TEST_DERIV ! FUNCTION name -NUM_FUNCS = NUM_FUNCS + 1 ! (0) Keep track of the number of function calls -TSTATE%WATR_1 = S(1) ! (1) Put state vector in model data structures -M_FLUX%DRAINAGE = SQRT(TSTATE%WATR_1) ! (2) Compute fluxes -MDS_DT%WATR_1 = -M_FLUX%DRAINAGE ! (3) Compute derivatives -TEST_DERIV(1) = MDS_DT%WATR_1 ! (4) Extract derivatives from model structure -END FUNCTION TEST_DERIV -! --------------------------------------------------------------------------------------- -END MODULE TEST_DERIV__MODULE diff --git a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/test_modvar.f90.svn-base b/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/test_modvar.f90.svn-base deleted file mode 100644 index 0c48121..0000000 --- a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/test_modvar.f90.svn-base +++ /dev/null @@ -1,32 +0,0 @@ -MODULE test_modvar - USE nrtype - ! define model fluxes - TYPE FLUXES - REAL(SP) :: DRAINAGE ! drainage rate (mm day-1) - REAL(SP) :: CHECKTIM ! time (day) - END TYPE FLUXES - ! define model states - TYPE STATES - REAL(SP) :: WATR_1 ! total storage in layer1 - END TYPE STATES - ! define state names - TYPE SNAMES - CHARACTER(LEN=6) :: SNAME ! state name - END TYPE SNAMES - ! define data structures - TYPE(FLUXES) :: FLUX_0 ! model fluxes at the start of the sub-step - TYPE(FLUXES) :: FLUX_1 ! model fluxes at the end of the sub-step - TYPE(FLUXES) :: M_FLUX ! model fluxes - TYPE(FLUXES) :: W_FLUX ! weighted fluxes - TYPE(STATES) :: DSDT_0 ! model derivatives at the start of the sub-step - TYPE(STATES) :: DSDT_1 ! model derivatives at the end of the sub-step - TYPE(STATES) :: MDS_DT ! model derivatives - TYPE(STATES) :: MSTATE ! model states - TYPE(STATES) :: TSTATE ! temporary model states (used to compute derivatives) - TYPE(STATES) :: FSTATE ! final model states (at the start/end of a full step) - TYPE(STATES) :: MS_MIN ! minimum values for model states - TYPE(STATES) :: MS_MAX ! maximum values for model states - TYPE(SNAMES),DIMENSION(1) :: CSTATE ! state names - REAL(SP) :: DT_SUB ! length of sub-step - REAL(SP) :: DT_FULL ! length of full step -END MODULE test_modvar diff --git a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/test_solve.f90.svn-base b/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/test_solve.f90.svn-base deleted file mode 100644 index 30b532b..0000000 --- a/build/FUSE_SRC/FUSE_TESTFUNC/.svn/text-base/test_solve.f90.svn-base +++ /dev/null @@ -1,193 +0,0 @@ -!MODULE TEST_SOLVE__MODULE -!IMPLICIT NONE -!CONTAINS -! --------------------------------------------------------------------------------------- -SUBROUTINE TEST_SOLVE(CALCDSDT,IE_SOLVE,B_IMPOSE,AVG_FLUX,ADD_FLUX,NEWSTATE, & ! define functionality of the routine - DT,S0,S1,DSDT,NEWSTEP,CONVCHECK,NITER,SOLUTION,HBOUND, & ! input/output - IERR,MESSAGE) ! error control -! Used to -! (1) calculate dS/dt for the input vector S0 -! (2) solve for S using the implicit Euler method -! (3) add fluxes from accepted sub-steps to the total timestep flux -USE nrtype ! variable definitions, etc. -USE test_modvar, ONLY : DT_SUB,MS_MIN,MS_MAX,TSTATE,CSTATE,& ! model variables - M_FLUX,FLUX_0,FLUX_1,W_FLUX,& ! model variables (continued) - MDS_DT,DSDT_0,DSDT_1,& ! model variables (continued) - MSTATE,FSTATE ! model variables (continued) -USE test_deriv__module ! provide access to derivatives -IMPLICIT NONE -! input/output variables -LOGICAL(LGT), INTENT(IN),OPTIONAL :: CALCDSDT ! FLAG to calculate derivatives at S0 -LOGICAL(LGT), INTENT(IN),OPTIONAL :: IE_SOLVE ! FLAG to compute the implicit Euler solution -LOGICAL(LGT), INTENT(IN),OPTIONAL :: B_IMPOSE ! FLAG to impose bounds on model state -LOGICAL(LGT), INTENT(IN),OPTIONAL :: AVG_FLUX ! FLAG to average fluxes from start & end states -LOGICAL(LGT), INTENT(IN),OPTIONAL :: ADD_FLUX ! FLAG to add accepted fluxes to the total flux -LOGICAL(LGT), INTENT(IN),OPTIONAL :: NEWSTATE ! FLAG to use weighted fluxes to compute end state -REAL(SP), INTENT(IN), OPTIONAL :: DT ! length of the sub-step -REAL(SP), DIMENSION(:),INTENT(IN), OPTIONAL :: S0 ! input state vector -REAL(SP), DIMENSION(:), INTENT(OUT),OPTIONAL :: S1 ! state vector from the implicit euler solution -REAL(SP), DIMENSION(:),INTENT(INOUT),OPTIONAL :: DSDT ! state derivatives -LOGICAL(LGT), INTENT(IN),OPTIONAL :: NEWSTEP ! FLAG to denote a new model time step -LOGICAL(LGT), INTENT(OUT),OPTIONAL :: CONVCHECK ! FLAG to check for convergence of the implicit scheme -INTEGER(I4B), INTENT(OUT), OPTIONAL :: NITER ! number of iterations -INTEGER(I4B), INTENT(IN), OPTIONAL :: SOLUTION ! solution is at start (0) or end (1) of sub-step -LOGICAL(LGT), INTENT(OUT),OPTIONAL :: HBOUND ! FLAG to denote if the states were out of bounds -INTEGER(I4B), INTENT(OUT) :: IERR ! error code -CHARACTER(LEN=*), INTENT(OUT) :: MESSAGE ! error message -! internal variables -REAL(SP), PARAMETER :: XACC=1.E-10 ! accuracy of implicit estimate -REAL(SP) :: ERROR_LOSS ! extrapolation error -REAL(SP) :: TOTAL_FLUX ! total fluxes involved in extrapolation -! --------------------------------------------------------------------------------------- -INTERFACE - SUBROUTINE IMPL_ERROR(S,F,DF) - ! Calculates the error for the implicit scheme (used in RTNEWT_SUB) - ! S(n+1) = S(n) + dS(n+1)/dt * delT - ! F = S(try) - (S(n) + dS(try)/dt * delT) - USE nrtype ! numerical recipes data types - IMPLICIT NONE - REAL(SP), INTENT(IN) :: S ! storage - REAL(SP), INTENT(OUT) :: F ! function value - REAL(SP), INTENT(OUT) :: DF ! function derivative - END SUBROUTINE IMPL_ERROR -END INTERFACE -! --------------------------------------------------------------------------------------- -IERR=0; MESSAGE='test_solve, just started' -! --------------------------------------------------------------------------------------- -! (1) CALCULATE DERIVATIVES -! --------------------------------------------------------------------------------------- -IF (PRESENT(CALCDSDT)) THEN - ! check that we have passed what we need - IF (.NOT.PRESENT(S0) .OR. .NOT.PRESENT(DSDT) .OR. .NOT.PRESENT(SOLUTION) ) THEN - IF (.NOT.PRESENT(S0)) MESSAGE='need S0 to calculate model derivatives' - IF (.NOT.PRESENT(DSDT)) MESSAGE='need DSDT to calculate model derivatives' - IF (.NOT.PRESENT(SOLUTION)) MESSAGE='need SOLUTION to calculate model derivatives' - IERR=20; RETURN - ENDIF - ! calculate derivatives - IF (CALCDSDT) DSDT = TEST_DERIV(S0) ! calculate derivatives - ! save information in model structures - SELECT CASE(SOLUTION) - CASE(0) - FLUX_0 = M_FLUX ! save fluxes at the start of the sub-step - DSDT_0 = MDS_DT ! save derivatives at the start of the sub-step - CASE(1) - FLUX_1 = M_FLUX ! save fluxes at the end of the sub-step - DSDT_1 = MDS_DT ! save derivatives at the start of the sub-step - END SELECT -ENDIF -! --------------------------------------------------------------------------------------- -! (2) ESTIMATE NEW VECTOR OF STATES USING THE IMPLICIT EULER METHOD -! --------------------------------------------------------------------------------------- -IF (PRESENT(IE_SOLVE)) THEN - IF (IE_SOLVE) THEN - ! check that we have passed what we need - IF (.NOT.PRESENT(S1) .OR. .NOT.PRESENT(DSDT) .OR. .NOT.PRESENT(DT) .OR. & - .NOT.PRESENT(NEWSTEP) .OR. .NOT.PRESENT(CONVCHECK) .OR. .NOT.PRESENT(NITER)) THEN - IF (.NOT.PRESENT(S1)) MESSAGE='need S1 for the implicit euler solution' - IF (.NOT.PRESENT(DT)) MESSAGE='need DT for the implicit euler solution' - IF (.NOT.PRESENT(DSDT)) MESSAGE='need DYDT for the implicit euler solution' - IF (.NOT.PRESENT(NEWSTEP)) MESSAGE='need NEWSTEP for the implicit euler solution' - IF (.NOT.PRESENT(CONVCHECK)) MESSAGE='need CONVCHECK for the implicit euler solution' - IF (.NOT.PRESENT(NITER)) MESSAGE='need NITER for the implicit euler solution' - IERR=20; RETURN - ENDIF - ! compute the IE solution - DT_SUB = DT ! DT_SUB is stored in MODULE test_modvar - CALL RTNEWT_SUB(IMPL_ERROR,S0(1),MS_MIN%WATR_1,MS_MAX%WATR_1,XACC,S1(1),NITER) - FLUX_1 = M_FLUX ! save fluxes at the end of the sub-step (save in model structure) - DSDT_1 = MDS_DT ! save derivatives at the end of the sub-step (save in model structure) - DSDT(1) = MDS_DT%WATR_1 ! extract derivatives from model structure (return to ODE_INT routine) - CONVCHECK = .FALSE. ! no check for convergence - ENDIF -ENDIF -! --------------------------------------------------------------------------------------- -! (3) AVERAGE FLUXES FROM START & END OF STEP (NECESSARY IF ACCEPT HIGHER ORDER SOLUTION) -! --------------------------------------------------------------------------------------- -IF (PRESENT(AVG_FLUX)) THEN - IF (AVG_FLUX) THEN ! Case 1: Higher-order solution accepted - ! average fluxes and derivatives from the start and end of the step - M_FLUX%DRAINAGE = (FLUX_0%DRAINAGE + FLUX_1%DRAINAGE)/2._SP - MDS_DT%WATR_1 = (DSDT_0%WATR_1 + DSDT_1%WATR_1)/2._SP - ELSE ! Case 2: Lower-order solution accepted - ! check that the solution argument is present - IF (.NOT.PRESENT(SOLUTION)) THEN - MESSAGE='need SOLUTION to assign fluxes and derivatives'; IERR=20; RETURN - ENDIF - ! assign fluxes from the appropriate solution - SELECT CASE(SOLUTION) - CASE(0) ! explicit euler: save fluxes and derivatives at start of sub-step - M_FLUX = FLUX_0 - MDS_DT = DSDT_0 - CASE(1) ! implicit euler: save fluxes and derivatives at end of sub-step - M_FLUX = FLUX_1 - MDS_DT = DSDT_1 - END SELECT - ENDIF -ENDIF -! --------------------------------------------------------------------------------------- -! (4) IMPOSE BOUNDS ON MODEL STATES (AND DISAGGREGATE FLUXES) -! --------------------------------------------------------------------------------------- -IF (PRESENT(B_IMPOSE)) THEN - IF (B_IMPOSE) THEN - ! check that we have passed what we need - IF (.NOT.PRESENT(S0) .OR. .NOT.PRESENT(S1) .OR. .NOT.PRESENT(DT) .OR. & - .NOT.PRESENT(HBOUND)) THEN - IF (.NOT.PRESENT(S0)) MESSAGE='need S0 to impose bounds on model states' - IF (.NOT.PRESENT(S1)) MESSAGE='need S1 to impose bounds on model states' - IF (.NOT.PRESENT(DT)) MESSAGE='need DT to impose bounds on model states' - IF (.NOT.PRESENT(HBOUND)) MESSAGE='need HBOUND to impose bounds on model states' - IERR=20; RETURN - ENDIF - S1 = S0 ! get copy of S0 - HBOUND = .FALSE. ! initialize bounds - ! only need to constrain minimum - IF (S1(1).LT.MS_MIN%WATR_1) THEN - ERROR_LOSS = (S1(1) - MS_MIN%WATR_1)/DT ! error (L/T) - TOTAL_FLUX = M_FLUX%DRAINAGE ! total flux (L/T) - M_FLUX%DRAINAGE = M_FLUX%DRAINAGE + (M_FLUX%DRAINAGE/TOTAL_FLUX)*ERROR_LOSS - S1(1) = MS_MIN%WATR_1 - HBOUND = .TRUE. - print *, 'dude, hit zee bounds' - ENDIF - ENDIF -ENDIF -! --------------------------------------------------------------------------------------- -! (5) ADD FLUXES FROM ACCEPTED SUB-STEPS TO THE TOTAL TIMESTEP FLUX -! --------------------------------------------------------------------------------------- -IF (PRESENT(ADD_FLUX)) THEN - IF (ADD_FLUX) THEN - ! check that S1 and DT are present - IF (.NOT.PRESENT(S1) .OR. .NOT.PRESENT(DT)) THEN - IF (.NOT.PRESENT(S1)) MESSAGE='need S1 to aggregate fluxes and save states' - IF (.NOT.PRESENT(DT)) MESSAGE='need DT to aggregate fluxes and save states' - IERR=20; RETURN - ENDIF - ! aggregate fluxes and save states - W_FLUX%DRAINAGE = W_FLUX%DRAINAGE + M_FLUX%DRAINAGE*DT - W_FLUX%CHECKTIM = W_FLUX%CHECKTIM + DT - MSTATE%WATR_1 = S1(1) - ENDIF -ENDIF -! --------------------------------------------------------------------------------------- -! (6) COMPUTE STATE AT THE END OF THE TIME INTERVAL -! --------------------------------------------------------------------------------------- -IF (PRESENT(NEWSTATE)) THEN - ! check that S1 and DT are present - IF (.NOT.PRESENT(S1) .OR. .NOT.PRESENT(DT)) THEN - IF (.NOT.PRESENT(S1)) MESSAGE='need S1 to aggregate fluxes and save states' - IF (.NOT.PRESENT(DT)) MESSAGE='need DT to aggregate fluxes and save states' - IERR=20; RETURN - ENDIF - ! update state - IF (NEWSTATE) THEN - MDS_DT%WATR_1 = -W_FLUX%DRAINAGE - FSTATE%WATR_1 = FSTATE%WATR_1 + MDS_DT%WATR_1*DT - MSTATE%WATR_1 = FSTATE%WATR_1 - S1(1) = FSTATE%WATR_1 - print *, 'newstate ', S1(1), W_FLUX%CHECKTIM, W_FLUX%DRAINAGE, DT - ENDIF -ENDIF -! --------------------------------------------------------------------------------------- -END SUBROUTINE TEST_SOLVE -!END MODULE TEST_SOLVE__MODULE From 35de9a5abda4b24e906685fa067f2b4c2b170c5f Mon Sep 17 00:00:00 2001 From: Martyn Clark Date: Tue, 23 Dec 2025 08:29:49 -0700 Subject: [PATCH 15/16] clean up directories --- .../FUSE_NUMERIX/adjust_stt__genmod.f90 | 7 --- .../FUSE_NUMERIX/assign_flx__genmod.f90 | 7 --- .../FUSE_NUMERIX/assign_par__genmod.f90 | 7 --- .../FUSE_NUMERIX/assign_stt__genmod.f90 | 7 --- .../FUSE_NUMERIX/bucketsize__genmod.f90 | 7 --- .../FUSE_NUMERIX/caldatss__genmod.f90 | 14 ------ .../FUSE_NUMERIX/comp_stats__genmod.f90 | 7 --- .../FUSE_NUMERIX/evap_lower__genmod.f90 | 7 --- .../FUSE_NUMERIX/evap_upper__genmod.f90 | 7 --- .../FUSE_NUMERIX/extractor__genmod.f90 | 12 ----- .../FUSE_NUMERIX/fix_states__genmod.f90 | 9 ---- .../FUSE_NUMERIX/flux_deriv__genmod.f90 | 9 ---- .../FUSE_NUMERIX/fuse_solve__genmod.f90 | 27 ------------ .../FUSE_NUMERIX/gammln_s__genmod.f90 | 9 ---- .../FUSE_NUMERIX/gammln_v__genmod.f90 | 9 ---- .../FUSE_SRC/FUSE_NUMERIX/gammp_s__genmod.f90 | 10 ----- .../FUSE_SRC/FUSE_NUMERIX/gammp_v__genmod.f90 | 10 ----- build/FUSE_SRC/FUSE_NUMERIX/gcf_s__genmod.f90 | 11 ----- build/FUSE_SRC/FUSE_NUMERIX/gcf_v__genmod.f90 | 11 ----- .../FUSE_NUMERIX/getforcing__genmod.f90 | 9 ---- .../FUSE_NUMERIX/getnumerix__genmod.f90 | 9 ---- .../FUSE_NUMERIX/getparmeta__genmod.f90 | 9 ---- .../FUSE_SRC/FUSE_NUMERIX/gser_s__genmod.f90 | 11 ----- .../FUSE_SRC/FUSE_NUMERIX/gser_v__genmod.f90 | 11 ----- .../FUSE_NUMERIX/init_state__genmod.f90 | 8 ---- .../FUSE_NUMERIX/init_stats__genmod.f90 | 7 --- .../FUSE_NUMERIX/initfluxes__genmod.f90 | 7 --- .../FUSE_NUMERIX/juldayss__genmod.f90 | 12 ----- .../FUSE_SRC/FUSE_NUMERIX/lnsrch__genmod.f90 | 21 --------- .../FUSE_NUMERIX/logismooth__genmod.f90 | 11 ----- .../FUSE_SRC/FUSE_NUMERIX/lubksb__genmod.f90 | 10 ----- .../FUSE_SRC/FUSE_NUMERIX/ludcmp__genmod.f90 | 10 ----- .../FUSE_NUMERIX/mean_stats__genmod.f90 | 7 --- .../FUSE_NUMERIX/mean_tipow__genmod.f90 | 7 --- .../FUSE_NUMERIX/meanfluxes__genmod.f90 | 7 --- .../FUSE_NUMERIX/mod_derivs__genmod.f90 | 7 --- .../FUSE_NUMERIX/mstate_eqn__genmod.f90 | 7 --- .../FUSE_SRC/FUSE_NUMERIX/ode_int__genmod.f90 | 38 ---------------- .../FUSE_NUMERIX/par_derive__genmod.f90 | 9 ---- .../FUSE_NUMERIX/pythag_sp__genmod.f90 | 10 ----- .../FUSE_NUMERIX/q_baseflow__genmod.f90 | 7 --- .../FUSE_NUMERIX/q_misscell__genmod.f90 | 7 --- .../FUSE_NUMERIX/q_overland__genmod.f90 | 7 --- .../FUSE_NUMERIX/qbsaturatn__genmod.f90 | 7 --- .../FUSE_NUMERIX/qinterflow__genmod.f90 | 7 --- .../FUSE_NUMERIX/qpercolate__genmod.f90 | 7 --- .../FUSE_NUMERIX/qrainerror__genmod.f90 | 7 --- .../FUSE_NUMERIX/qsatexcess__genmod.f90 | 7 --- .../FUSE_NUMERIX/qtimedelay__genmod.f90 | 9 ---- .../FUSE_NUMERIX/svbksb_sp__genmod.f90 | 12 ----- .../FUSE_NUMERIX/svdcmp_sp__genmod.f90 | 10 ----- .../FUSE_NUMERIX/uniquemodl__genmod.f90 | 10 ----- .../FUSE_NUMERIX/updatstate__genmod.f90 | 8 ---- .../FUSE_NUMERIX/wgt_fluxes__genmod.f90 | 7 --- .../{ => deprecated}/FUSE_DMSL/URS_driver.f90 | 0 .../FUSE_DMSL/URS_driver_run.f90 | 0 .../FUSE_DMSL/adapt_test__driver.f90 | 0 .../FUSE_DMSL/dmsl_wrapper.f90 | 0 .../FUSE_DMSL/nfunc_test__driver.f90 | 0 .../FUSE_DMSL/niter_test__driver.f90 | 0 .../optimiser_miniDmsl_qnewton_kit.f90 | 0 .../FUSE_DMSL/pargrid_driver-copy.f90 | 0 .../FUSE_DMSL/pargrid_driver-slice.f90 | 0 .../FUSE_DMSL/pargrid_driver.f90 | 0 .../FUSE_DMSL/parslice_optim.f90 | 0 .../FUSE_DMSL/program read_para_file.f90 | 0 .../FUSE_DMSL/qnewton_mcmc__driver.f90 | 0 .../FUSE_DMSL/read_para_file.f90 | 0 .../{ => deprecated}/FUSE_DMSL/sce_merge.f90 | 0 .../FUSE_DMSL/sce_merge_snow.f90 | 0 .../{ => deprecated}/FUSE_DMSL/sobol.f90 | 0 .../FUSE_DMSL/sobol_driver.f90 | 0 .../FUSE_DMSL/test_fidelity.f90 | 0 .../FUSE_ENGINE/batea_file.f90 | 0 .../{ => deprecated}/FUSE_ENGINE/fdjac.f90 | 0 .../FUSE_ENGINE/frac_error.f90 | 0 .../{ => deprecated}/FUSE_ENGINE/funcv.f90 | 0 .../FUSE_ENGINE/get_limits.f90 | 0 .../FUSE_ENGINE/getf_ascii.f90 | 0 .../FUSE_ENGINE/getforcing.f90 | 0 .../{ => deprecated}/FUSE_MAIN/batea_test.f90 | 0 .../FUSE_MAIN/driver_ascii.f90 | 0 .../FUSE_MAIN/driver_netcdf.f90 | 0 .../FUSE_MAIN/fmodel_run_ascii.f90 | 0 .../FUSE_MAIN/fmodel_run_netcdf.f90 | 0 .../{ => deprecated}/FUSE_MAIN/sobol.f90 | 0 .../FUSE_NETCDF__DUMMY}/caldatss.f90 | 0 .../FUSE_NETCDF__DUMMY/def_output.f90 | 0 .../FUSE_NETCDF__DUMMY/def_params.f90 | 0 .../FUSE_NETCDF__DUMMY/def_sstats.f90 | 0 .../FUSE_NETCDF__DUMMY}/extractor.f90 | 0 .../FUSE_NETCDF__DUMMY/get_fparam.f90 | 0 .../FUSE_NETCDF__DUMMY/get_objfnc.f90 | 0 .../FUSE_NETCDF__DUMMY/get_smodel.f90 | 0 .../FUSE_NETCDF__DUMMY/getmahudat.f90 | 0 .../FUSE_NETCDF__DUMMY/handle_err.f90 | 0 .../FUSE_NETCDF__DUMMY}/juldayss.f90 | 0 .../FUSE_NETCDF__DUMMY/put_output.f90 | 0 .../FUSE_NETCDF__DUMMY/put_params.f90 | 0 .../FUSE_NETCDF__DUMMY/put_sstats.f90 | 0 .../FUSE_NUMERIX/nmodel_run.f90 | 0 .../FUSE_NUMERIX/numerix_driver.f90 | 0 .../{ => deprecated}/FUSE_NUMERIX/sobol.f90 | 0 .../FUSE_PARSENS/URS_driver.f90 | 0 .../FUSE_PARSENS/qnewt_mcmc__driver.f90 | 0 .../{ => deprecated}/FUSE_PARSENS/sobol.f90 | 0 .../FUSE_TESTFUNC/driver_testfunc.f90 | 0 .../FUSE_TESTFUNC/impl_error.f90 | 0 .../FUSE_TESTFUNC/interfaceb.f90 | 0 .../FUSE_TESTFUNC/model_numerix.f90 | 0 .../FUSE_TESTFUNC/ode_int.f90 | 0 .../FUSE_TESTFUNC/rtnewt_sub.f90 | 0 .../FUSE_TESTFUNC/substepper.f90 | 0 .../FUSE_TESTFUNC/test_deriv.f90 | 0 .../FUSE_TESTFUNC/test_modvar.f90 | 0 .../FUSE_TESTFUNC/test_solve.f90 | 0 .../fuse_fileManager.f90 | 0 .../kinds_dmsl_kit_FUSE.f90 | 0 .../utilities_dmsl_kit_FUSE.f90 | 0 .../caldatss.f90 | 0 .../{FUSE_NETCDF => netcdf}/def_output.f90 | 0 .../{FUSE_NETCDF => netcdf}/def_params.f90 | 0 .../{FUSE_NETCDF => netcdf}/def_sstats.f90 | 0 .../extractor.f90 | 0 .../{FUSE_NETCDF => netcdf}/get_fparam.f90 | 0 .../{FUSE_NETCDF => netcdf}/get_gforce.f90 | 0 .../{FUSE_NETCDF => netcdf}/get_objfnc.f90 | 0 .../{FUSE_NETCDF => netcdf}/get_smodel.f90 | 0 .../get_smodel__notUpdated.f90 | 0 .../{FUSE_NETCDF => netcdf}/getmahudat.f90 | 0 .../{FUSE_NETCDF => netcdf}/handle_err.f90 | 0 .../juldayss.f90 | 0 .../{FUSE_NETCDF => netcdf}/put_output.f90 | 0 .../{FUSE_NETCDF => netcdf}/put_params.f90 | 0 .../{FUSE_NETCDF => netcdf}/put_sstats.f90 | 0 build/FUSE_SRC/{FUSE_NETCDF => netcdf}/slob | Bin .../{FUSE_NETCDF => netcdf}/test_netcdf.f90 | 0 .../{FUSE_TIME => netcdf}/time_io.f90 | 0 build/FUSE_SRC/{FUSE_NR => numrec}/gammln.f90 | 0 build/FUSE_SRC/{FUSE_NR => numrec}/gammp.f90 | 0 build/FUSE_SRC/{FUSE_NR => numrec}/gcf.f90 | 0 build/FUSE_SRC/{FUSE_NR => numrec}/gser.f90 | 0 build/FUSE_SRC/{FUSE_NR => numrec}/lubksb.f90 | 0 build/FUSE_SRC/{FUSE_NR => numrec}/ludcmp.f90 | 0 build/FUSE_SRC/{FUSE_NR => numrec}/nr.f90 | 0 build/FUSE_SRC/{FUSE_NR => numrec}/nrtype.f90 | 0 build/FUSE_SRC/{FUSE_NR => numrec}/nrutil.f90 | 0 build/FUSE_SRC/{FUSE_NR => numrec}/pythag.f90 | 0 build/FUSE_SRC/{FUSE_NR => numrec}/svbksb.f90 | 0 build/FUSE_SRC/{FUSE_NR => numrec}/svdcmp.f90 | 0 .../evap_lower.f90 | 0 .../evap_upper.f90 | 0 .../fix_states.f90 | 0 .../meanfluxes.f90 | 0 .../mod_derivs.f90 | 0 .../mstate_eqn.f90 | 0 .../q_baseflow.f90 | 0 .../q_misscell.f90 | 0 .../q_overland.f90 | 0 .../qinterflow.f90 | 0 .../qpercolate.f90 | 0 .../qrainerror.f90 | 0 .../qsatexcess.f90 | 0 .../update_swe.f90 | 0 .../updatstate.f90 | 0 .../wgt_fluxes.f90 | 0 .../{FUSE_ENGINE => runtime}/clrsky_rad.f90 | 0 .../{FUSE_ENGINE => runtime}/comp_stats.f90 | 0 .../{FUSE_ENGINE => runtime}/conv_funcs.f90 | 0 .../{FUSE_ENGINE => runtime}/fuse_solve.f90 | 0 .../{FUSE_ENGINE => runtime}/getPETgrid.f90 | 0 .../{FUSE_ENGINE => runtime}/get_mbands.f90 | 0 .../get_time_indices.f90 | 0 .../{FUSE_ENGINE => runtime}/initfluxes.f90 | 0 .../{FUSE_ENGINE => runtime}/mean_stats.f90 | 0 .../{FUSE_ENGINE => runtime}/ode_int.f90 | 0 .../{FUSE_ENGINE => runtime}/set_all.f90 | 0 build/FUSE_SRC/{FUSE_SCE => sce}/sce.f | 0 build/FUSE_SRC/{FUSE_SCE => sce}/sce_16plus.f | 0 build/FUSE_SRC/{FUSE_SCE => sce}/sobol.f90 | 0 .../disaggflux.f90 | 0 .../fdjac_ode.f90 | 0 .../flux_deriv.f90 | 0 .../{FUSE_ENGINE => solver_orig}/fmin.f90 | 0 .../fuse_deriv.f90 | 0 .../fuse_sieul.f90 | 0 .../interfaceb.f90 | 0 .../limit_xtry.f90 | 0 .../{FUSE_ENGINE => solver_orig}/lnsrch.f90 | 0 .../newtoniter.f90 | 0 .../viol_state.f90 | 0 .../{FUSE_ENGINE => util}/getpar_str.f90 | 0 .../{FUSE_ENGINE => util}/meta_stats.f90 | 0 .../{FUSE_ENGINE => util}/metaoutput.f90 | 0 .../{FUSE_ENGINE => util}/metaparams.f90 | 0 .../{FUSE_ENGINE => util}/par_insert.f90 | 0 .../{FUSE_ENGINE => util}/parextract.f90 | 0 .../{FUSE_ENGINE => util}/putpar_str.f90 | 0 .../{FUSE_ENGINE => util}/selectmodl.f90 | 0 .../{FUSE_ENGINE => util}/str_2_xtry.f90 | 0 .../{FUSE_ENGINE => util}/sumextract.f90 | 0 .../{FUSE_ENGINE => util}/varextract.f90 | 0 .../{FUSE_ENGINE => util}/xtry_2_str.f90 | 0 build/Makefile | 41 ++++++++++-------- build/generated/fuseversion.inc | 4 +- 205 files changed, 24 insertions(+), 547 deletions(-) delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/adjust_stt__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/assign_flx__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/assign_par__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/assign_stt__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/bucketsize__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/caldatss__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/comp_stats__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/evap_lower__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/evap_upper__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/extractor__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/fix_states__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/flux_deriv__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/fuse_solve__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/gammln_s__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/gammln_v__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/gammp_s__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/gammp_v__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/gcf_s__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/gcf_v__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/getforcing__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/getnumerix__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/getparmeta__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/gser_s__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/gser_v__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/init_state__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/init_stats__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/initfluxes__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/juldayss__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/lnsrch__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/logismooth__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/lubksb__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/ludcmp__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/mean_stats__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/mean_tipow__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/meanfluxes__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/mod_derivs__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/mstate_eqn__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/ode_int__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/par_derive__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/pythag_sp__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/q_baseflow__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/q_misscell__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/q_overland__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/qbsaturatn__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/qinterflow__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/qpercolate__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/qrainerror__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/qsatexcess__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/qtimedelay__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/svbksb_sp__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/svdcmp_sp__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/uniquemodl__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/updatstate__genmod.f90 delete mode 100644 build/FUSE_SRC/FUSE_NUMERIX/wgt_fluxes__genmod.f90 rename build/FUSE_SRC/{ => deprecated}/FUSE_DMSL/URS_driver.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_DMSL/URS_driver_run.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_DMSL/adapt_test__driver.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_DMSL/dmsl_wrapper.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_DMSL/nfunc_test__driver.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_DMSL/niter_test__driver.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_DMSL/optimiser_miniDmsl_qnewton_kit.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_DMSL/pargrid_driver-copy.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_DMSL/pargrid_driver-slice.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_DMSL/pargrid_driver.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_DMSL/parslice_optim.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_DMSL/program read_para_file.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_DMSL/qnewton_mcmc__driver.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_DMSL/read_para_file.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_DMSL/sce_merge.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_DMSL/sce_merge_snow.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_DMSL/sobol.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_DMSL/sobol_driver.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_DMSL/test_fidelity.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_ENGINE/batea_file.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_ENGINE/fdjac.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_ENGINE/frac_error.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_ENGINE/funcv.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_ENGINE/get_limits.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_ENGINE/getf_ascii.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_ENGINE/getforcing.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_MAIN/batea_test.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_MAIN/driver_ascii.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_MAIN/driver_netcdf.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_MAIN/fmodel_run_ascii.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_MAIN/fmodel_run_netcdf.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_MAIN/sobol.f90 (100%) rename build/FUSE_SRC/{FUSE_NETCDF => deprecated/FUSE_NETCDF__DUMMY}/caldatss.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_NETCDF__DUMMY/def_output.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_NETCDF__DUMMY/def_params.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_NETCDF__DUMMY/def_sstats.f90 (100%) rename build/FUSE_SRC/{FUSE_NETCDF => deprecated/FUSE_NETCDF__DUMMY}/extractor.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_NETCDF__DUMMY/get_fparam.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_NETCDF__DUMMY/get_objfnc.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_NETCDF__DUMMY/get_smodel.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_NETCDF__DUMMY/getmahudat.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_NETCDF__DUMMY/handle_err.f90 (100%) rename build/FUSE_SRC/{FUSE_NETCDF => deprecated/FUSE_NETCDF__DUMMY}/juldayss.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_NETCDF__DUMMY/put_output.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_NETCDF__DUMMY/put_params.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_NETCDF__DUMMY/put_sstats.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_NUMERIX/nmodel_run.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_NUMERIX/numerix_driver.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_NUMERIX/sobol.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_PARSENS/URS_driver.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_PARSENS/qnewt_mcmc__driver.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_PARSENS/sobol.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_TESTFUNC/driver_testfunc.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_TESTFUNC/impl_error.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_TESTFUNC/interfaceb.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_TESTFUNC/model_numerix.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_TESTFUNC/ode_int.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_TESTFUNC/rtnewt_sub.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_TESTFUNC/substepper.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_TESTFUNC/test_deriv.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_TESTFUNC/test_modvar.f90 (100%) rename build/FUSE_SRC/{ => deprecated}/FUSE_TESTFUNC/test_solve.f90 (100%) rename build/FUSE_SRC/{FUSE_HOOK => hookup}/fuse_fileManager.f90 (100%) rename build/FUSE_SRC/{FUSE_HOOK => hookup}/kinds_dmsl_kit_FUSE.f90 (100%) rename build/FUSE_SRC/{FUSE_HOOK => hookup}/utilities_dmsl_kit_FUSE.f90 (100%) rename build/FUSE_SRC/{FUSE_NETCDF__DUMMY => netcdf}/caldatss.f90 (100%) rename build/FUSE_SRC/{FUSE_NETCDF => netcdf}/def_output.f90 (100%) rename build/FUSE_SRC/{FUSE_NETCDF => netcdf}/def_params.f90 (100%) rename build/FUSE_SRC/{FUSE_NETCDF => netcdf}/def_sstats.f90 (100%) rename build/FUSE_SRC/{FUSE_NETCDF__DUMMY => netcdf}/extractor.f90 (100%) rename build/FUSE_SRC/{FUSE_NETCDF => netcdf}/get_fparam.f90 (100%) rename build/FUSE_SRC/{FUSE_NETCDF => netcdf}/get_gforce.f90 (100%) rename build/FUSE_SRC/{FUSE_NETCDF => netcdf}/get_objfnc.f90 (100%) rename build/FUSE_SRC/{FUSE_NETCDF => netcdf}/get_smodel.f90 (100%) rename build/FUSE_SRC/{FUSE_NETCDF => netcdf}/get_smodel__notUpdated.f90 (100%) rename build/FUSE_SRC/{FUSE_NETCDF => netcdf}/getmahudat.f90 (100%) rename build/FUSE_SRC/{FUSE_NETCDF => netcdf}/handle_err.f90 (100%) rename build/FUSE_SRC/{FUSE_NETCDF__DUMMY => netcdf}/juldayss.f90 (100%) rename build/FUSE_SRC/{FUSE_NETCDF => netcdf}/put_output.f90 (100%) rename build/FUSE_SRC/{FUSE_NETCDF => netcdf}/put_params.f90 (100%) rename build/FUSE_SRC/{FUSE_NETCDF => netcdf}/put_sstats.f90 (100%) rename build/FUSE_SRC/{FUSE_NETCDF => netcdf}/slob (100%) rename build/FUSE_SRC/{FUSE_NETCDF => netcdf}/test_netcdf.f90 (100%) rename build/FUSE_SRC/{FUSE_TIME => netcdf}/time_io.f90 (100%) rename build/FUSE_SRC/{FUSE_NR => numrec}/gammln.f90 (100%) rename build/FUSE_SRC/{FUSE_NR => numrec}/gammp.f90 (100%) rename build/FUSE_SRC/{FUSE_NR => numrec}/gcf.f90 (100%) rename build/FUSE_SRC/{FUSE_NR => numrec}/gser.f90 (100%) rename build/FUSE_SRC/{FUSE_NR => numrec}/lubksb.f90 (100%) rename build/FUSE_SRC/{FUSE_NR => numrec}/ludcmp.f90 (100%) rename build/FUSE_SRC/{FUSE_NR => numrec}/nr.f90 (100%) rename build/FUSE_SRC/{FUSE_NR => numrec}/nrtype.f90 (100%) rename build/FUSE_SRC/{FUSE_NR => numrec}/nrutil.f90 (100%) rename build/FUSE_SRC/{FUSE_NR => numrec}/pythag.f90 (100%) rename build/FUSE_SRC/{FUSE_NR => numrec}/svbksb.f90 (100%) rename build/FUSE_SRC/{FUSE_NR => numrec}/svdcmp.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => physics_orig}/evap_lower.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => physics_orig}/evap_upper.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => physics_orig}/fix_states.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => physics_orig}/meanfluxes.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => physics_orig}/mod_derivs.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => physics_orig}/mstate_eqn.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => physics_orig}/q_baseflow.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => physics_orig}/q_misscell.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => physics_orig}/q_overland.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => physics_orig}/qinterflow.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => physics_orig}/qpercolate.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => physics_orig}/qrainerror.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => physics_orig}/qsatexcess.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => physics_orig}/update_swe.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => physics_orig}/updatstate.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => physics_orig}/wgt_fluxes.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => runtime}/clrsky_rad.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => runtime}/comp_stats.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => runtime}/conv_funcs.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => runtime}/fuse_solve.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => runtime}/getPETgrid.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => runtime}/get_mbands.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => runtime}/get_time_indices.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => runtime}/initfluxes.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => runtime}/mean_stats.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => runtime}/ode_int.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => runtime}/set_all.f90 (100%) rename build/FUSE_SRC/{FUSE_SCE => sce}/sce.f (100%) rename build/FUSE_SRC/{FUSE_SCE => sce}/sce_16plus.f (100%) rename build/FUSE_SRC/{FUSE_SCE => sce}/sobol.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => solver_orig}/disaggflux.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => solver_orig}/fdjac_ode.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => solver_orig}/flux_deriv.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => solver_orig}/fmin.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => solver_orig}/fuse_deriv.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => solver_orig}/fuse_sieul.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => solver_orig}/interfaceb.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => solver_orig}/limit_xtry.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => solver_orig}/lnsrch.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => solver_orig}/newtoniter.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => solver_orig}/viol_state.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => util}/getpar_str.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => util}/meta_stats.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => util}/metaoutput.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => util}/metaparams.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => util}/par_insert.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => util}/parextract.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => util}/putpar_str.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => util}/selectmodl.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => util}/str_2_xtry.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => util}/sumextract.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => util}/varextract.f90 (100%) rename build/FUSE_SRC/{FUSE_ENGINE => util}/xtry_2_str.f90 (100%) diff --git a/build/FUSE_SRC/FUSE_NUMERIX/adjust_stt__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/adjust_stt__genmod.f90 deleted file mode 100644 index 125c95a..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/adjust_stt__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:21 2015 - MODULE ADJUST_STT__genmod - INTERFACE - SUBROUTINE ADJUST_STT - END SUBROUTINE ADJUST_STT - END INTERFACE - END MODULE ADJUST_STT__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/assign_flx__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/assign_flx__genmod.f90 deleted file mode 100644 index ba547e6..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/assign_flx__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:21 2015 - MODULE ASSIGN_FLX__genmod - INTERFACE - SUBROUTINE ASSIGN_FLX - END SUBROUTINE ASSIGN_FLX - END INTERFACE - END MODULE ASSIGN_FLX__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/assign_par__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/assign_par__genmod.f90 deleted file mode 100644 index bab8aba..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/assign_par__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:21 2015 - MODULE ASSIGN_PAR__genmod - INTERFACE - SUBROUTINE ASSIGN_PAR - END SUBROUTINE ASSIGN_PAR - END INTERFACE - END MODULE ASSIGN_PAR__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/assign_stt__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/assign_stt__genmod.f90 deleted file mode 100644 index e171743..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/assign_stt__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:21 2015 - MODULE ASSIGN_STT__genmod - INTERFACE - SUBROUTINE ASSIGN_STT - END SUBROUTINE ASSIGN_STT - END INTERFACE - END MODULE ASSIGN_STT__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/bucketsize__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/bucketsize__genmod.f90 deleted file mode 100644 index 4227a3b..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/bucketsize__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:21 2015 - MODULE BUCKETSIZE__genmod - INTERFACE - SUBROUTINE BUCKETSIZE - END SUBROUTINE BUCKETSIZE - END INTERFACE - END MODULE BUCKETSIZE__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/caldatss__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/caldatss__genmod.f90 deleted file mode 100644 index d70de52..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/caldatss__genmod.f90 +++ /dev/null @@ -1,14 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:22 2015 - MODULE CALDATSS__genmod - INTERFACE - SUBROUTINE CALDATSS(JULIANSS,IYYY,MM,ID,IH,IM,SS) - REAL(KIND=8) :: JULIANSS - INTEGER(KIND=4) :: IYYY - INTEGER(KIND=4) :: MM - INTEGER(KIND=4) :: ID - INTEGER(KIND=4) :: IH - INTEGER(KIND=4) :: IM - REAL(KIND=8) :: SS - END SUBROUTINE CALDATSS - END INTERFACE - END MODULE CALDATSS__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/comp_stats__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/comp_stats__genmod.f90 deleted file mode 100644 index ba87dc7..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/comp_stats__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:22 2015 - MODULE COMP_STATS__genmod - INTERFACE - SUBROUTINE COMP_STATS - END SUBROUTINE COMP_STATS - END INTERFACE - END MODULE COMP_STATS__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/evap_lower__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/evap_lower__genmod.f90 deleted file mode 100644 index b2ae87a..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/evap_lower__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE EVAP_LOWER__genmod - INTERFACE - SUBROUTINE EVAP_LOWER - END SUBROUTINE EVAP_LOWER - END INTERFACE - END MODULE EVAP_LOWER__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/evap_upper__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/evap_upper__genmod.f90 deleted file mode 100644 index 0b68a39..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/evap_upper__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE EVAP_UPPER__genmod - INTERFACE - SUBROUTINE EVAP_UPPER - END SUBROUTINE EVAP_UPPER - END INTERFACE - END MODULE EVAP_UPPER__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/extractor__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/extractor__genmod.f90 deleted file mode 100644 index a285b5c..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/extractor__genmod.f90 +++ /dev/null @@ -1,12 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:22 2015 - MODULE EXTRACTOR__genmod - INTERFACE - SUBROUTINE EXTRACTOR(REFDATE,YY,IM,DD,HH) - CHARACTER(LEN=50) :: REFDATE - INTEGER(KIND=4) :: YY - INTEGER(KIND=4) :: IM - INTEGER(KIND=4) :: DD - INTEGER(KIND=4) :: HH - END SUBROUTINE EXTRACTOR - END INTERFACE - END MODULE EXTRACTOR__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/fix_states__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/fix_states__genmod.f90 deleted file mode 100644 index 7edad64..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/fix_states__genmod.f90 +++ /dev/null @@ -1,9 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE FIX_STATES__genmod - INTERFACE - SUBROUTINE FIX_STATES(DT,ERROR_FLAG) - REAL(KIND=8), INTENT(IN) :: DT - LOGICAL(KIND=4), INTENT(OUT) :: ERROR_FLAG - END SUBROUTINE FIX_STATES - END INTERFACE - END MODULE FIX_STATES__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/flux_deriv__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/flux_deriv__genmod.f90 deleted file mode 100644 index 6d76693..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/flux_deriv__genmod.f90 +++ /dev/null @@ -1,9 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:21 2015 - MODULE FLUX_DERIV__genmod - INTERFACE - SUBROUTINE FLUX_DERIV(J,DS) - INTEGER(KIND=4), INTENT(IN) :: J - REAL(KIND=8), INTENT(IN) :: DS - END SUBROUTINE FLUX_DERIV - END INTERFACE - END MODULE FLUX_DERIV__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/fuse_solve__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/fuse_solve__genmod.f90 deleted file mode 100644 index 1e426a4..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/fuse_solve__genmod.f90 +++ /dev/null @@ -1,27 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:22 2015 - MODULE FUSE_SOLVE__genmod - INTERFACE - SUBROUTINE FUSE_SOLVE(CALCDSDT,IE_SOLVE,SI_SOLVE,B_IMPOSE, & - &AVG_FLUX,ADD_FLUX,NEWSTATE,DT,S0,S1,DSDT,NEWSTEP,CONVCHECK,NITER, & - &SOLUTION,HBOUND,IERR,MESSAGE) - LOGICAL(KIND=4) ,OPTIONAL, INTENT(IN) :: CALCDSDT - LOGICAL(KIND=4) ,OPTIONAL, INTENT(IN) :: IE_SOLVE - LOGICAL(KIND=4) ,OPTIONAL, INTENT(IN) :: SI_SOLVE - LOGICAL(KIND=4) ,OPTIONAL, INTENT(IN) :: B_IMPOSE - LOGICAL(KIND=4) ,OPTIONAL, INTENT(IN) :: AVG_FLUX - LOGICAL(KIND=4) ,OPTIONAL, INTENT(IN) :: ADD_FLUX - LOGICAL(KIND=4) ,OPTIONAL, INTENT(IN) :: NEWSTATE - REAL(KIND=8) ,OPTIONAL, INTENT(IN) :: DT - REAL(KIND=8) ,OPTIONAL, INTENT(IN) :: S0(:) - REAL(KIND=8) ,OPTIONAL, INTENT(OUT) :: S1(:) - REAL(KIND=8) ,OPTIONAL, INTENT(INOUT) :: DSDT(:) - LOGICAL(KIND=4) ,OPTIONAL, INTENT(IN) :: NEWSTEP - LOGICAL(KIND=4) ,OPTIONAL, INTENT(OUT) :: CONVCHECK - INTEGER(KIND=4) ,OPTIONAL, INTENT(OUT) :: NITER - INTEGER(KIND=4) ,OPTIONAL, INTENT(IN) :: SOLUTION - LOGICAL(KIND=4) ,OPTIONAL, INTENT(OUT) :: HBOUND - INTEGER(KIND=4), INTENT(OUT) :: IERR - CHARACTER(*), INTENT(OUT) :: MESSAGE - END SUBROUTINE FUSE_SOLVE - END INTERFACE - END MODULE FUSE_SOLVE__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/gammln_s__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/gammln_s__genmod.f90 deleted file mode 100644 index 4072b74..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/gammln_s__genmod.f90 +++ /dev/null @@ -1,9 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE GAMMLN_S__genmod - INTERFACE - FUNCTION GAMMLN_S(XX) - REAL(KIND=8), INTENT(IN) :: XX - REAL(KIND=8) :: GAMMLN_S - END FUNCTION GAMMLN_S - END INTERFACE - END MODULE GAMMLN_S__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/gammln_v__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/gammln_v__genmod.f90 deleted file mode 100644 index f1014ca..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/gammln_v__genmod.f90 +++ /dev/null @@ -1,9 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE GAMMLN_V__genmod - INTERFACE - FUNCTION GAMMLN_V(XX) - REAL(KIND=8), INTENT(IN) :: XX(:) - REAL(KIND=8) :: GAMMLN_V(SIZE(XX)) - END FUNCTION GAMMLN_V - END INTERFACE - END MODULE GAMMLN_V__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/gammp_s__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/gammp_s__genmod.f90 deleted file mode 100644 index 88a50f4..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/gammp_s__genmod.f90 +++ /dev/null @@ -1,10 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE GAMMP_S__genmod - INTERFACE - FUNCTION GAMMP_S(A,X) - REAL(KIND=8), INTENT(IN) :: A - REAL(KIND=8), INTENT(IN) :: X - REAL(KIND=8) :: GAMMP_S - END FUNCTION GAMMP_S - END INTERFACE - END MODULE GAMMP_S__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/gammp_v__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/gammp_v__genmod.f90 deleted file mode 100644 index ba77d51..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/gammp_v__genmod.f90 +++ /dev/null @@ -1,10 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE GAMMP_V__genmod - INTERFACE - FUNCTION GAMMP_V(A,X) - REAL(KIND=8), INTENT(IN) :: A(:) - REAL(KIND=8), INTENT(IN) :: X(:) - REAL(KIND=8) :: GAMMP_V(SIZE(X)) - END FUNCTION GAMMP_V - END INTERFACE - END MODULE GAMMP_V__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/gcf_s__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/gcf_s__genmod.f90 deleted file mode 100644 index e8f7a72..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/gcf_s__genmod.f90 +++ /dev/null @@ -1,11 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE GCF_S__genmod - INTERFACE - FUNCTION GCF_S(A,X,GLN) - REAL(KIND=8), INTENT(IN) :: A - REAL(KIND=8), INTENT(IN) :: X - REAL(KIND=8) ,OPTIONAL, INTENT(OUT) :: GLN - REAL(KIND=8) :: GCF_S - END FUNCTION GCF_S - END INTERFACE - END MODULE GCF_S__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/gcf_v__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/gcf_v__genmod.f90 deleted file mode 100644 index 63302b0..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/gcf_v__genmod.f90 +++ /dev/null @@ -1,11 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE GCF_V__genmod - INTERFACE - FUNCTION GCF_V(A,X,GLN) - REAL(KIND=8), INTENT(IN) :: A(:) - REAL(KIND=8), INTENT(IN) :: X(:) - REAL(KIND=8) ,OPTIONAL, INTENT(OUT) :: GLN(:) - REAL(KIND=8) :: GCF_V(SIZE(A)) - END FUNCTION GCF_V - END INTERFACE - END MODULE GCF_V__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/getforcing__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/getforcing__genmod.f90 deleted file mode 100644 index c3bd980..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/getforcing__genmod.f90 +++ /dev/null @@ -1,9 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:21 2015 - MODULE GETFORCING__genmod - INTERFACE - SUBROUTINE GETFORCING(INFERN_START,NTIM) - INTEGER(KIND=4), INTENT(OUT) :: INFERN_START - INTEGER(KIND=4), INTENT(OUT) :: NTIM - END SUBROUTINE GETFORCING - END INTERFACE - END MODULE GETFORCING__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/getnumerix__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/getnumerix__genmod.f90 deleted file mode 100644 index 43c47f3..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/getnumerix__genmod.f90 +++ /dev/null @@ -1,9 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:21 2015 - MODULE GETNUMERIX__genmod - INTERFACE - SUBROUTINE GETNUMERIX(ERR,MESSAGE) - INTEGER(KIND=4), INTENT(OUT) :: ERR - CHARACTER(*), INTENT(OUT) :: MESSAGE - END SUBROUTINE GETNUMERIX - END INTERFACE - END MODULE GETNUMERIX__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/getparmeta__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/getparmeta__genmod.f90 deleted file mode 100644 index 9584d26..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/getparmeta__genmod.f90 +++ /dev/null @@ -1,9 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:21 2015 - MODULE GETPARMETA__genmod - INTERFACE - SUBROUTINE GETPARMETA(ERR,MESSAGE) - INTEGER(KIND=4), INTENT(OUT) :: ERR - CHARACTER(*), INTENT(OUT) :: MESSAGE - END SUBROUTINE GETPARMETA - END INTERFACE - END MODULE GETPARMETA__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/gser_s__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/gser_s__genmod.f90 deleted file mode 100644 index 03c4a73..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/gser_s__genmod.f90 +++ /dev/null @@ -1,11 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE GSER_S__genmod - INTERFACE - FUNCTION GSER_S(A,X,GLN) - REAL(KIND=8), INTENT(IN) :: A - REAL(KIND=8), INTENT(IN) :: X - REAL(KIND=8) ,OPTIONAL, INTENT(OUT) :: GLN - REAL(KIND=8) :: GSER_S - END FUNCTION GSER_S - END INTERFACE - END MODULE GSER_S__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/gser_v__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/gser_v__genmod.f90 deleted file mode 100644 index b10ccff..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/gser_v__genmod.f90 +++ /dev/null @@ -1,11 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE GSER_V__genmod - INTERFACE - FUNCTION GSER_V(A,X,GLN) - REAL(KIND=8), INTENT(IN) :: A(:) - REAL(KIND=8), INTENT(IN) :: X(:) - REAL(KIND=8) ,OPTIONAL, INTENT(OUT) :: GLN(:) - REAL(KIND=8) :: GSER_V(SIZE(A)) - END FUNCTION GSER_V - END INTERFACE - END MODULE GSER_V__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/init_state__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/init_state__genmod.f90 deleted file mode 100644 index 70cd975..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/init_state__genmod.f90 +++ /dev/null @@ -1,8 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:21 2015 - MODULE INIT_STATE__genmod - INTERFACE - SUBROUTINE INIT_STATE(FRAC) - REAL(KIND=8), INTENT(IN) :: FRAC - END SUBROUTINE INIT_STATE - END INTERFACE - END MODULE INIT_STATE__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/init_stats__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/init_stats__genmod.f90 deleted file mode 100644 index 8db3e92..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/init_stats__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:21 2015 - MODULE INIT_STATS__genmod - INTERFACE - SUBROUTINE INIT_STATS - END SUBROUTINE INIT_STATS - END INTERFACE - END MODULE INIT_STATS__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/initfluxes__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/initfluxes__genmod.f90 deleted file mode 100644 index 14718e3..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/initfluxes__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:22 2015 - MODULE INITFLUXES__genmod - INTERFACE - SUBROUTINE INITFLUXES - END SUBROUTINE INITFLUXES - END INTERFACE - END MODULE INITFLUXES__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/juldayss__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/juldayss__genmod.f90 deleted file mode 100644 index 11c2cf1..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/juldayss__genmod.f90 +++ /dev/null @@ -1,12 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:22 2015 - MODULE JULDAYSS__genmod - INTERFACE - FUNCTION JULDAYSS(YYIN,MMIN,DDIN,HHIN) - INTEGER(KIND=4) :: YYIN - INTEGER(KIND=4) :: MMIN - INTEGER(KIND=4) :: DDIN - INTEGER(KIND=4) :: HHIN - REAL(KIND=8) :: JULDAYSS - END FUNCTION JULDAYSS - END INTERFACE - END MODULE JULDAYSS__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/lnsrch__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/lnsrch__genmod.f90 deleted file mode 100644 index cb2a314..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/lnsrch__genmod.f90 +++ /dev/null @@ -1,21 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:21 2015 - MODULE LNSRCH__genmod - INTERFACE - SUBROUTINE LNSRCH(XOLD,FOLD,G,P,X,F,STPMAX,CHECK,FUNC) - REAL(KIND=8), INTENT(IN) :: XOLD(:) - REAL(KIND=8), INTENT(IN) :: FOLD - REAL(KIND=8), INTENT(IN) :: G(:) - REAL(KIND=8), INTENT(INOUT) :: P(:) - REAL(KIND=8), INTENT(OUT) :: X(:) - REAL(KIND=8), INTENT(OUT) :: F - REAL(KIND=8), INTENT(IN) :: STPMAX - LOGICAL(KIND=4), INTENT(OUT) :: CHECK - INTERFACE - FUNCTION FUNC(X) - REAL(KIND=8), INTENT(IN) :: X(:) - REAL(KIND=8) :: FUNC - END FUNCTION FUNC - END INTERFACE - END SUBROUTINE LNSRCH - END INTERFACE - END MODULE LNSRCH__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/logismooth__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/logismooth__genmod.f90 deleted file mode 100644 index dbf3fd3..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/logismooth__genmod.f90 +++ /dev/null @@ -1,11 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE LOGISMOOTH__genmod - INTERFACE - PURE FUNCTION LOGISMOOTH(STATE,STATE_MAX,PSMOOTH) - REAL(KIND=8), INTENT(IN) :: STATE - REAL(KIND=8), INTENT(IN) :: STATE_MAX - REAL(KIND=8), INTENT(IN) :: PSMOOTH - REAL(KIND=8) :: LOGISMOOTH - END FUNCTION LOGISMOOTH - END INTERFACE - END MODULE LOGISMOOTH__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/lubksb__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/lubksb__genmod.f90 deleted file mode 100644 index f0a475a..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/lubksb__genmod.f90 +++ /dev/null @@ -1,10 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE LUBKSB__genmod - INTERFACE - SUBROUTINE LUBKSB(A,INDX,B) - REAL(KIND=8), INTENT(IN) :: A(:,:) - INTEGER(KIND=4), INTENT(IN) :: INDX(:) - REAL(KIND=8), INTENT(INOUT) :: B(:) - END SUBROUTINE LUBKSB - END INTERFACE - END MODULE LUBKSB__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/ludcmp__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/ludcmp__genmod.f90 deleted file mode 100644 index 82d2ad5..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/ludcmp__genmod.f90 +++ /dev/null @@ -1,10 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:19 2015 - MODULE LUDCMP__genmod - INTERFACE - SUBROUTINE LUDCMP(A,INDX,D) - REAL(KIND=8), INTENT(INOUT) :: A(:,:) - INTEGER(KIND=4), INTENT(OUT) :: INDX(:) - REAL(KIND=8), INTENT(OUT) :: D - END SUBROUTINE LUDCMP - END INTERFACE - END MODULE LUDCMP__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/mean_stats__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/mean_stats__genmod.f90 deleted file mode 100644 index 30e3857..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/mean_stats__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:22 2015 - MODULE MEAN_STATS__genmod - INTERFACE - SUBROUTINE MEAN_STATS - END SUBROUTINE MEAN_STATS - END INTERFACE - END MODULE MEAN_STATS__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/mean_tipow__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/mean_tipow__genmod.f90 deleted file mode 100644 index c598562..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/mean_tipow__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:21 2015 - MODULE MEAN_TIPOW__genmod - INTERFACE - SUBROUTINE MEAN_TIPOW - END SUBROUTINE MEAN_TIPOW - END INTERFACE - END MODULE MEAN_TIPOW__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/meanfluxes__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/meanfluxes__genmod.f90 deleted file mode 100644 index 7b58489..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/meanfluxes__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE MEANFLUXES__genmod - INTERFACE - SUBROUTINE MEANFLUXES - END SUBROUTINE MEANFLUXES - END INTERFACE - END MODULE MEANFLUXES__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/mod_derivs__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/mod_derivs__genmod.f90 deleted file mode 100644 index b1dea8c..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/mod_derivs__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE MOD_DERIVS__genmod - INTERFACE - SUBROUTINE MOD_DERIVS - END SUBROUTINE MOD_DERIVS - END INTERFACE - END MODULE MOD_DERIVS__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/mstate_eqn__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/mstate_eqn__genmod.f90 deleted file mode 100644 index 8540776..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/mstate_eqn__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE MSTATE_EQN__genmod - INTERFACE - SUBROUTINE MSTATE_EQN - END SUBROUTINE MSTATE_EQN - END INTERFACE - END MODULE MSTATE_EQN__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/ode_int__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/ode_int__genmod.f90 deleted file mode 100644 index bff1c67..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/ode_int__genmod.f90 +++ /dev/null @@ -1,38 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:22 2015 - MODULE ODE_INT__genmod - INTERFACE - SUBROUTINE ODE_INT(MODL_SOLVE,STATE_START,STATE_END,DT_SUB, & - &DT_FULL,IERR,MESSAGE) - INTERFACE - SUBROUTINE MODL_SOLVE(CALCDSDT,IE_SOLVE,SI_SOLVE, & - &B_IMPOSE,AVG_FLUX,ADD_FLUX,NEWSTATE,DT,S0,S1,DSDT,NEWSTEP, & - &CONVCHECK,NITER,SOLUTION,HBOUND,IERR,MESSAGE) - LOGICAL(KIND=4) ,OPTIONAL, INTENT(IN) :: CALCDSDT - LOGICAL(KIND=4) ,OPTIONAL, INTENT(IN) :: IE_SOLVE - LOGICAL(KIND=4) ,OPTIONAL, INTENT(IN) :: SI_SOLVE - LOGICAL(KIND=4) ,OPTIONAL, INTENT(IN) :: B_IMPOSE - LOGICAL(KIND=4) ,OPTIONAL, INTENT(IN) :: AVG_FLUX - LOGICAL(KIND=4) ,OPTIONAL, INTENT(IN) :: ADD_FLUX - LOGICAL(KIND=4) ,OPTIONAL, INTENT(IN) :: NEWSTATE - REAL(KIND=8) ,OPTIONAL, INTENT(IN) :: DT - REAL(KIND=8) ,OPTIONAL, INTENT(IN) :: S0(:) - REAL(KIND=8) ,OPTIONAL, INTENT(OUT) :: S1(:) - REAL(KIND=8) ,OPTIONAL, INTENT(INOUT) :: DSDT(:) - LOGICAL(KIND=4) ,OPTIONAL, INTENT(IN) :: NEWSTEP - LOGICAL(KIND=4) ,OPTIONAL, INTENT(IN) :: CONVCHECK - INTEGER(KIND=4) ,OPTIONAL, INTENT(OUT) :: NITER - INTEGER(KIND=4) ,OPTIONAL, INTENT(IN) :: SOLUTION - LOGICAL(KIND=4) ,OPTIONAL, INTENT(IN) :: HBOUND - INTEGER(KIND=4), INTENT(OUT) :: IERR - CHARACTER(*), INTENT(OUT) :: MESSAGE - END SUBROUTINE MODL_SOLVE - END INTERFACE - REAL(KIND=8), INTENT(IN) :: STATE_START(:) - REAL(KIND=8), INTENT(OUT) :: STATE_END(:) - REAL(KIND=8), INTENT(INOUT) :: DT_SUB - REAL(KIND=8), INTENT(IN) :: DT_FULL - INTEGER(KIND=4), INTENT(OUT) :: IERR - CHARACTER(*), INTENT(OUT) :: MESSAGE - END SUBROUTINE ODE_INT - END INTERFACE - END MODULE ODE_INT__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/par_derive__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/par_derive__genmod.f90 deleted file mode 100644 index 2b31475..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/par_derive__genmod.f90 +++ /dev/null @@ -1,9 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:21 2015 - MODULE PAR_DERIVE__genmod - INTERFACE - SUBROUTINE PAR_DERIVE(ERR,MESSAGE) - INTEGER(KIND=4), INTENT(OUT) :: ERR - CHARACTER(*), INTENT(OUT) :: MESSAGE - END SUBROUTINE PAR_DERIVE - END INTERFACE - END MODULE PAR_DERIVE__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/pythag_sp__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/pythag_sp__genmod.f90 deleted file mode 100644 index 123a882..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/pythag_sp__genmod.f90 +++ /dev/null @@ -1,10 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE PYTHAG_SP__genmod - INTERFACE - FUNCTION PYTHAG_SP(A,B) - REAL(KIND=8), INTENT(IN) :: A - REAL(KIND=8), INTENT(IN) :: B - REAL(KIND=8) :: PYTHAG_SP - END FUNCTION PYTHAG_SP - END INTERFACE - END MODULE PYTHAG_SP__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/q_baseflow__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/q_baseflow__genmod.f90 deleted file mode 100644 index 8dc0d81..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/q_baseflow__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE Q_BASEFLOW__genmod - INTERFACE - SUBROUTINE Q_BASEFLOW - END SUBROUTINE Q_BASEFLOW - END INTERFACE - END MODULE Q_BASEFLOW__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/q_misscell__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/q_misscell__genmod.f90 deleted file mode 100644 index 0ea9033..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/q_misscell__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE Q_MISSCELL__genmod - INTERFACE - SUBROUTINE Q_MISSCELL - END SUBROUTINE Q_MISSCELL - END INTERFACE - END MODULE Q_MISSCELL__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/q_overland__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/q_overland__genmod.f90 deleted file mode 100644 index 3e5b92e..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/q_overland__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE Q_OVERLAND__genmod - INTERFACE - SUBROUTINE Q_OVERLAND - END SUBROUTINE Q_OVERLAND - END INTERFACE - END MODULE Q_OVERLAND__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/qbsaturatn__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/qbsaturatn__genmod.f90 deleted file mode 100644 index 902c10c..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/qbsaturatn__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:21 2015 - MODULE QBSATURATN__genmod - INTERFACE - SUBROUTINE QBSATURATN - END SUBROUTINE QBSATURATN - END INTERFACE - END MODULE QBSATURATN__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/qinterflow__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/qinterflow__genmod.f90 deleted file mode 100644 index 2a448c5..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/qinterflow__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE QINTERFLOW__genmod - INTERFACE - SUBROUTINE QINTERFLOW - END SUBROUTINE QINTERFLOW - END INTERFACE - END MODULE QINTERFLOW__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/qpercolate__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/qpercolate__genmod.f90 deleted file mode 100644 index 1eeb4e2..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/qpercolate__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE QPERCOLATE__genmod - INTERFACE - SUBROUTINE QPERCOLATE - END SUBROUTINE QPERCOLATE - END INTERFACE - END MODULE QPERCOLATE__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/qrainerror__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/qrainerror__genmod.f90 deleted file mode 100644 index 99d82b1..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/qrainerror__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE QRAINERROR__genmod - INTERFACE - SUBROUTINE QRAINERROR - END SUBROUTINE QRAINERROR - END INTERFACE - END MODULE QRAINERROR__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/qsatexcess__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/qsatexcess__genmod.f90 deleted file mode 100644 index 4491d1b..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/qsatexcess__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE QSATEXCESS__genmod - INTERFACE - SUBROUTINE QSATEXCESS - END SUBROUTINE QSATEXCESS - END INTERFACE - END MODULE QSATEXCESS__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/qtimedelay__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/qtimedelay__genmod.f90 deleted file mode 100644 index 6606c2d..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/qtimedelay__genmod.f90 +++ /dev/null @@ -1,9 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:21 2015 - MODULE QTIMEDELAY__genmod - INTERFACE - SUBROUTINE QTIMEDELAY(ERR,MESSAGE) - INTEGER(KIND=4), INTENT(OUT) :: ERR - CHARACTER(*), INTENT(OUT) :: MESSAGE - END SUBROUTINE QTIMEDELAY - END INTERFACE - END MODULE QTIMEDELAY__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/svbksb_sp__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/svbksb_sp__genmod.f90 deleted file mode 100644 index 3215d5b..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/svbksb_sp__genmod.f90 +++ /dev/null @@ -1,12 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE SVBKSB_SP__genmod - INTERFACE - SUBROUTINE SVBKSB_SP(U,W,V,B,X) - REAL(KIND=8), INTENT(IN) :: U(:,:) - REAL(KIND=8), INTENT(IN) :: W(:) - REAL(KIND=8), INTENT(IN) :: V(:,:) - REAL(KIND=8), INTENT(IN) :: B(:) - REAL(KIND=8), INTENT(OUT) :: X(:) - END SUBROUTINE SVBKSB_SP - END INTERFACE - END MODULE SVBKSB_SP__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/svdcmp_sp__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/svdcmp_sp__genmod.f90 deleted file mode 100644 index 3ee3aa4..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/svdcmp_sp__genmod.f90 +++ /dev/null @@ -1,10 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE SVDCMP_SP__genmod - INTERFACE - SUBROUTINE SVDCMP_SP(A,W,V) - REAL(KIND=8), INTENT(INOUT) :: A(:,:) - REAL(KIND=8), INTENT(OUT) :: W(:) - REAL(KIND=8), INTENT(OUT) :: V(:,:) - END SUBROUTINE SVDCMP_SP - END INTERFACE - END MODULE SVDCMP_SP__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/uniquemodl__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/uniquemodl__genmod.f90 deleted file mode 100644 index 0813070..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/uniquemodl__genmod.f90 +++ /dev/null @@ -1,10 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:21 2015 - MODULE UNIQUEMODL__genmod - INTERFACE - SUBROUTINE UNIQUEMODL(NMOD,ERR,MESSAGE) - INTEGER(KIND=4) :: NMOD - INTEGER(KIND=4), INTENT(OUT) :: ERR - CHARACTER(*), INTENT(OUT) :: MESSAGE - END SUBROUTINE UNIQUEMODL - END INTERFACE - END MODULE UNIQUEMODL__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/updatstate__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/updatstate__genmod.f90 deleted file mode 100644 index 9848473..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/updatstate__genmod.f90 +++ /dev/null @@ -1,8 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE UPDATSTATE__genmod - INTERFACE - SUBROUTINE UPDATSTATE(DT) - REAL(KIND=8), INTENT(IN) :: DT - END SUBROUTINE UPDATSTATE - END INTERFACE - END MODULE UPDATSTATE__genmod diff --git a/build/FUSE_SRC/FUSE_NUMERIX/wgt_fluxes__genmod.f90 b/build/FUSE_SRC/FUSE_NUMERIX/wgt_fluxes__genmod.f90 deleted file mode 100644 index b89ee54..0000000 --- a/build/FUSE_SRC/FUSE_NUMERIX/wgt_fluxes__genmod.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !COMPILER-GENERATED INTERFACE MODULE: Fri Oct 16 17:25:20 2015 - MODULE WGT_FLUXES__genmod - INTERFACE - SUBROUTINE WGT_FLUXES - END SUBROUTINE WGT_FLUXES - END INTERFACE - END MODULE WGT_FLUXES__genmod diff --git a/build/FUSE_SRC/FUSE_DMSL/URS_driver.f90 b/build/FUSE_SRC/deprecated/FUSE_DMSL/URS_driver.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DMSL/URS_driver.f90 rename to build/FUSE_SRC/deprecated/FUSE_DMSL/URS_driver.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/URS_driver_run.f90 b/build/FUSE_SRC/deprecated/FUSE_DMSL/URS_driver_run.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DMSL/URS_driver_run.f90 rename to build/FUSE_SRC/deprecated/FUSE_DMSL/URS_driver_run.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/adapt_test__driver.f90 b/build/FUSE_SRC/deprecated/FUSE_DMSL/adapt_test__driver.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DMSL/adapt_test__driver.f90 rename to build/FUSE_SRC/deprecated/FUSE_DMSL/adapt_test__driver.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/dmsl_wrapper.f90 b/build/FUSE_SRC/deprecated/FUSE_DMSL/dmsl_wrapper.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DMSL/dmsl_wrapper.f90 rename to build/FUSE_SRC/deprecated/FUSE_DMSL/dmsl_wrapper.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/nfunc_test__driver.f90 b/build/FUSE_SRC/deprecated/FUSE_DMSL/nfunc_test__driver.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DMSL/nfunc_test__driver.f90 rename to build/FUSE_SRC/deprecated/FUSE_DMSL/nfunc_test__driver.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/niter_test__driver.f90 b/build/FUSE_SRC/deprecated/FUSE_DMSL/niter_test__driver.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DMSL/niter_test__driver.f90 rename to build/FUSE_SRC/deprecated/FUSE_DMSL/niter_test__driver.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/optimiser_miniDmsl_qnewton_kit.f90 b/build/FUSE_SRC/deprecated/FUSE_DMSL/optimiser_miniDmsl_qnewton_kit.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DMSL/optimiser_miniDmsl_qnewton_kit.f90 rename to build/FUSE_SRC/deprecated/FUSE_DMSL/optimiser_miniDmsl_qnewton_kit.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/pargrid_driver-copy.f90 b/build/FUSE_SRC/deprecated/FUSE_DMSL/pargrid_driver-copy.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DMSL/pargrid_driver-copy.f90 rename to build/FUSE_SRC/deprecated/FUSE_DMSL/pargrid_driver-copy.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/pargrid_driver-slice.f90 b/build/FUSE_SRC/deprecated/FUSE_DMSL/pargrid_driver-slice.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DMSL/pargrid_driver-slice.f90 rename to build/FUSE_SRC/deprecated/FUSE_DMSL/pargrid_driver-slice.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/pargrid_driver.f90 b/build/FUSE_SRC/deprecated/FUSE_DMSL/pargrid_driver.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DMSL/pargrid_driver.f90 rename to build/FUSE_SRC/deprecated/FUSE_DMSL/pargrid_driver.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/parslice_optim.f90 b/build/FUSE_SRC/deprecated/FUSE_DMSL/parslice_optim.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DMSL/parslice_optim.f90 rename to build/FUSE_SRC/deprecated/FUSE_DMSL/parslice_optim.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/program read_para_file.f90 b/build/FUSE_SRC/deprecated/FUSE_DMSL/program read_para_file.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DMSL/program read_para_file.f90 rename to build/FUSE_SRC/deprecated/FUSE_DMSL/program read_para_file.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/qnewton_mcmc__driver.f90 b/build/FUSE_SRC/deprecated/FUSE_DMSL/qnewton_mcmc__driver.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DMSL/qnewton_mcmc__driver.f90 rename to build/FUSE_SRC/deprecated/FUSE_DMSL/qnewton_mcmc__driver.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/read_para_file.f90 b/build/FUSE_SRC/deprecated/FUSE_DMSL/read_para_file.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DMSL/read_para_file.f90 rename to build/FUSE_SRC/deprecated/FUSE_DMSL/read_para_file.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/sce_merge.f90 b/build/FUSE_SRC/deprecated/FUSE_DMSL/sce_merge.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DMSL/sce_merge.f90 rename to build/FUSE_SRC/deprecated/FUSE_DMSL/sce_merge.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/sce_merge_snow.f90 b/build/FUSE_SRC/deprecated/FUSE_DMSL/sce_merge_snow.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DMSL/sce_merge_snow.f90 rename to build/FUSE_SRC/deprecated/FUSE_DMSL/sce_merge_snow.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/sobol.f90 b/build/FUSE_SRC/deprecated/FUSE_DMSL/sobol.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DMSL/sobol.f90 rename to build/FUSE_SRC/deprecated/FUSE_DMSL/sobol.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/sobol_driver.f90 b/build/FUSE_SRC/deprecated/FUSE_DMSL/sobol_driver.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DMSL/sobol_driver.f90 rename to build/FUSE_SRC/deprecated/FUSE_DMSL/sobol_driver.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/test_fidelity.f90 b/build/FUSE_SRC/deprecated/FUSE_DMSL/test_fidelity.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DMSL/test_fidelity.f90 rename to build/FUSE_SRC/deprecated/FUSE_DMSL/test_fidelity.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/batea_file.f90 b/build/FUSE_SRC/deprecated/FUSE_ENGINE/batea_file.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/batea_file.f90 rename to build/FUSE_SRC/deprecated/FUSE_ENGINE/batea_file.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/fdjac.f90 b/build/FUSE_SRC/deprecated/FUSE_ENGINE/fdjac.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/fdjac.f90 rename to build/FUSE_SRC/deprecated/FUSE_ENGINE/fdjac.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/frac_error.f90 b/build/FUSE_SRC/deprecated/FUSE_ENGINE/frac_error.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/frac_error.f90 rename to build/FUSE_SRC/deprecated/FUSE_ENGINE/frac_error.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/funcv.f90 b/build/FUSE_SRC/deprecated/FUSE_ENGINE/funcv.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/funcv.f90 rename to build/FUSE_SRC/deprecated/FUSE_ENGINE/funcv.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/get_limits.f90 b/build/FUSE_SRC/deprecated/FUSE_ENGINE/get_limits.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/get_limits.f90 rename to build/FUSE_SRC/deprecated/FUSE_ENGINE/get_limits.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/getf_ascii.f90 b/build/FUSE_SRC/deprecated/FUSE_ENGINE/getf_ascii.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/getf_ascii.f90 rename to build/FUSE_SRC/deprecated/FUSE_ENGINE/getf_ascii.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/getforcing.f90 b/build/FUSE_SRC/deprecated/FUSE_ENGINE/getforcing.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/getforcing.f90 rename to build/FUSE_SRC/deprecated/FUSE_ENGINE/getforcing.f90 diff --git a/build/FUSE_SRC/FUSE_MAIN/batea_test.f90 b/build/FUSE_SRC/deprecated/FUSE_MAIN/batea_test.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_MAIN/batea_test.f90 rename to build/FUSE_SRC/deprecated/FUSE_MAIN/batea_test.f90 diff --git a/build/FUSE_SRC/FUSE_MAIN/driver_ascii.f90 b/build/FUSE_SRC/deprecated/FUSE_MAIN/driver_ascii.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_MAIN/driver_ascii.f90 rename to build/FUSE_SRC/deprecated/FUSE_MAIN/driver_ascii.f90 diff --git a/build/FUSE_SRC/FUSE_MAIN/driver_netcdf.f90 b/build/FUSE_SRC/deprecated/FUSE_MAIN/driver_netcdf.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_MAIN/driver_netcdf.f90 rename to build/FUSE_SRC/deprecated/FUSE_MAIN/driver_netcdf.f90 diff --git a/build/FUSE_SRC/FUSE_MAIN/fmodel_run_ascii.f90 b/build/FUSE_SRC/deprecated/FUSE_MAIN/fmodel_run_ascii.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_MAIN/fmodel_run_ascii.f90 rename to build/FUSE_SRC/deprecated/FUSE_MAIN/fmodel_run_ascii.f90 diff --git a/build/FUSE_SRC/FUSE_MAIN/fmodel_run_netcdf.f90 b/build/FUSE_SRC/deprecated/FUSE_MAIN/fmodel_run_netcdf.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_MAIN/fmodel_run_netcdf.f90 rename to build/FUSE_SRC/deprecated/FUSE_MAIN/fmodel_run_netcdf.f90 diff --git a/build/FUSE_SRC/FUSE_MAIN/sobol.f90 b/build/FUSE_SRC/deprecated/FUSE_MAIN/sobol.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_MAIN/sobol.f90 rename to build/FUSE_SRC/deprecated/FUSE_MAIN/sobol.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF/caldatss.f90 b/build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/caldatss.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF/caldatss.f90 rename to build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/caldatss.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/def_output.f90 b/build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/def_output.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF__DUMMY/def_output.f90 rename to build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/def_output.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/def_params.f90 b/build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/def_params.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF__DUMMY/def_params.f90 rename to build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/def_params.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/def_sstats.f90 b/build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/def_sstats.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF__DUMMY/def_sstats.f90 rename to build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/def_sstats.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF/extractor.f90 b/build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/extractor.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF/extractor.f90 rename to build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/extractor.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/get_fparam.f90 b/build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/get_fparam.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF__DUMMY/get_fparam.f90 rename to build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/get_fparam.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/get_objfnc.f90 b/build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/get_objfnc.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF__DUMMY/get_objfnc.f90 rename to build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/get_objfnc.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/get_smodel.f90 b/build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/get_smodel.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF__DUMMY/get_smodel.f90 rename to build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/get_smodel.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/getmahudat.f90 b/build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/getmahudat.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF__DUMMY/getmahudat.f90 rename to build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/getmahudat.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/handle_err.f90 b/build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/handle_err.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF__DUMMY/handle_err.f90 rename to build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/handle_err.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF/juldayss.f90 b/build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/juldayss.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF/juldayss.f90 rename to build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/juldayss.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/put_output.f90 b/build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/put_output.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF__DUMMY/put_output.f90 rename to build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/put_output.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/put_params.f90 b/build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/put_params.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF__DUMMY/put_params.f90 rename to build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/put_params.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/put_sstats.f90 b/build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/put_sstats.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF__DUMMY/put_sstats.f90 rename to build/FUSE_SRC/deprecated/FUSE_NETCDF__DUMMY/put_sstats.f90 diff --git a/build/FUSE_SRC/FUSE_NUMERIX/nmodel_run.f90 b/build/FUSE_SRC/deprecated/FUSE_NUMERIX/nmodel_run.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NUMERIX/nmodel_run.f90 rename to build/FUSE_SRC/deprecated/FUSE_NUMERIX/nmodel_run.f90 diff --git a/build/FUSE_SRC/FUSE_NUMERIX/numerix_driver.f90 b/build/FUSE_SRC/deprecated/FUSE_NUMERIX/numerix_driver.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NUMERIX/numerix_driver.f90 rename to build/FUSE_SRC/deprecated/FUSE_NUMERIX/numerix_driver.f90 diff --git a/build/FUSE_SRC/FUSE_NUMERIX/sobol.f90 b/build/FUSE_SRC/deprecated/FUSE_NUMERIX/sobol.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NUMERIX/sobol.f90 rename to build/FUSE_SRC/deprecated/FUSE_NUMERIX/sobol.f90 diff --git a/build/FUSE_SRC/FUSE_PARSENS/URS_driver.f90 b/build/FUSE_SRC/deprecated/FUSE_PARSENS/URS_driver.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_PARSENS/URS_driver.f90 rename to build/FUSE_SRC/deprecated/FUSE_PARSENS/URS_driver.f90 diff --git a/build/FUSE_SRC/FUSE_PARSENS/qnewt_mcmc__driver.f90 b/build/FUSE_SRC/deprecated/FUSE_PARSENS/qnewt_mcmc__driver.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_PARSENS/qnewt_mcmc__driver.f90 rename to build/FUSE_SRC/deprecated/FUSE_PARSENS/qnewt_mcmc__driver.f90 diff --git a/build/FUSE_SRC/FUSE_PARSENS/sobol.f90 b/build/FUSE_SRC/deprecated/FUSE_PARSENS/sobol.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_PARSENS/sobol.f90 rename to build/FUSE_SRC/deprecated/FUSE_PARSENS/sobol.f90 diff --git a/build/FUSE_SRC/FUSE_TESTFUNC/driver_testfunc.f90 b/build/FUSE_SRC/deprecated/FUSE_TESTFUNC/driver_testfunc.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_TESTFUNC/driver_testfunc.f90 rename to build/FUSE_SRC/deprecated/FUSE_TESTFUNC/driver_testfunc.f90 diff --git a/build/FUSE_SRC/FUSE_TESTFUNC/impl_error.f90 b/build/FUSE_SRC/deprecated/FUSE_TESTFUNC/impl_error.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_TESTFUNC/impl_error.f90 rename to build/FUSE_SRC/deprecated/FUSE_TESTFUNC/impl_error.f90 diff --git a/build/FUSE_SRC/FUSE_TESTFUNC/interfaceb.f90 b/build/FUSE_SRC/deprecated/FUSE_TESTFUNC/interfaceb.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_TESTFUNC/interfaceb.f90 rename to build/FUSE_SRC/deprecated/FUSE_TESTFUNC/interfaceb.f90 diff --git a/build/FUSE_SRC/FUSE_TESTFUNC/model_numerix.f90 b/build/FUSE_SRC/deprecated/FUSE_TESTFUNC/model_numerix.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_TESTFUNC/model_numerix.f90 rename to build/FUSE_SRC/deprecated/FUSE_TESTFUNC/model_numerix.f90 diff --git a/build/FUSE_SRC/FUSE_TESTFUNC/ode_int.f90 b/build/FUSE_SRC/deprecated/FUSE_TESTFUNC/ode_int.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_TESTFUNC/ode_int.f90 rename to build/FUSE_SRC/deprecated/FUSE_TESTFUNC/ode_int.f90 diff --git a/build/FUSE_SRC/FUSE_TESTFUNC/rtnewt_sub.f90 b/build/FUSE_SRC/deprecated/FUSE_TESTFUNC/rtnewt_sub.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_TESTFUNC/rtnewt_sub.f90 rename to build/FUSE_SRC/deprecated/FUSE_TESTFUNC/rtnewt_sub.f90 diff --git a/build/FUSE_SRC/FUSE_TESTFUNC/substepper.f90 b/build/FUSE_SRC/deprecated/FUSE_TESTFUNC/substepper.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_TESTFUNC/substepper.f90 rename to build/FUSE_SRC/deprecated/FUSE_TESTFUNC/substepper.f90 diff --git a/build/FUSE_SRC/FUSE_TESTFUNC/test_deriv.f90 b/build/FUSE_SRC/deprecated/FUSE_TESTFUNC/test_deriv.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_TESTFUNC/test_deriv.f90 rename to build/FUSE_SRC/deprecated/FUSE_TESTFUNC/test_deriv.f90 diff --git a/build/FUSE_SRC/FUSE_TESTFUNC/test_modvar.f90 b/build/FUSE_SRC/deprecated/FUSE_TESTFUNC/test_modvar.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_TESTFUNC/test_modvar.f90 rename to build/FUSE_SRC/deprecated/FUSE_TESTFUNC/test_modvar.f90 diff --git a/build/FUSE_SRC/FUSE_TESTFUNC/test_solve.f90 b/build/FUSE_SRC/deprecated/FUSE_TESTFUNC/test_solve.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_TESTFUNC/test_solve.f90 rename to build/FUSE_SRC/deprecated/FUSE_TESTFUNC/test_solve.f90 diff --git a/build/FUSE_SRC/FUSE_HOOK/fuse_fileManager.f90 b/build/FUSE_SRC/hookup/fuse_fileManager.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_HOOK/fuse_fileManager.f90 rename to build/FUSE_SRC/hookup/fuse_fileManager.f90 diff --git a/build/FUSE_SRC/FUSE_HOOK/kinds_dmsl_kit_FUSE.f90 b/build/FUSE_SRC/hookup/kinds_dmsl_kit_FUSE.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_HOOK/kinds_dmsl_kit_FUSE.f90 rename to build/FUSE_SRC/hookup/kinds_dmsl_kit_FUSE.f90 diff --git a/build/FUSE_SRC/FUSE_HOOK/utilities_dmsl_kit_FUSE.f90 b/build/FUSE_SRC/hookup/utilities_dmsl_kit_FUSE.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_HOOK/utilities_dmsl_kit_FUSE.f90 rename to build/FUSE_SRC/hookup/utilities_dmsl_kit_FUSE.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/caldatss.f90 b/build/FUSE_SRC/netcdf/caldatss.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF__DUMMY/caldatss.f90 rename to build/FUSE_SRC/netcdf/caldatss.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF/def_output.f90 b/build/FUSE_SRC/netcdf/def_output.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF/def_output.f90 rename to build/FUSE_SRC/netcdf/def_output.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF/def_params.f90 b/build/FUSE_SRC/netcdf/def_params.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF/def_params.f90 rename to build/FUSE_SRC/netcdf/def_params.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF/def_sstats.f90 b/build/FUSE_SRC/netcdf/def_sstats.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF/def_sstats.f90 rename to build/FUSE_SRC/netcdf/def_sstats.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/extractor.f90 b/build/FUSE_SRC/netcdf/extractor.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF__DUMMY/extractor.f90 rename to build/FUSE_SRC/netcdf/extractor.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF/get_fparam.f90 b/build/FUSE_SRC/netcdf/get_fparam.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF/get_fparam.f90 rename to build/FUSE_SRC/netcdf/get_fparam.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF/get_gforce.f90 b/build/FUSE_SRC/netcdf/get_gforce.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF/get_gforce.f90 rename to build/FUSE_SRC/netcdf/get_gforce.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF/get_objfnc.f90 b/build/FUSE_SRC/netcdf/get_objfnc.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF/get_objfnc.f90 rename to build/FUSE_SRC/netcdf/get_objfnc.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF/get_smodel.f90 b/build/FUSE_SRC/netcdf/get_smodel.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF/get_smodel.f90 rename to build/FUSE_SRC/netcdf/get_smodel.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF/get_smodel__notUpdated.f90 b/build/FUSE_SRC/netcdf/get_smodel__notUpdated.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF/get_smodel__notUpdated.f90 rename to build/FUSE_SRC/netcdf/get_smodel__notUpdated.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF/getmahudat.f90 b/build/FUSE_SRC/netcdf/getmahudat.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF/getmahudat.f90 rename to build/FUSE_SRC/netcdf/getmahudat.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF/handle_err.f90 b/build/FUSE_SRC/netcdf/handle_err.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF/handle_err.f90 rename to build/FUSE_SRC/netcdf/handle_err.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF__DUMMY/juldayss.f90 b/build/FUSE_SRC/netcdf/juldayss.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF__DUMMY/juldayss.f90 rename to build/FUSE_SRC/netcdf/juldayss.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF/put_output.f90 b/build/FUSE_SRC/netcdf/put_output.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF/put_output.f90 rename to build/FUSE_SRC/netcdf/put_output.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF/put_params.f90 b/build/FUSE_SRC/netcdf/put_params.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF/put_params.f90 rename to build/FUSE_SRC/netcdf/put_params.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF/put_sstats.f90 b/build/FUSE_SRC/netcdf/put_sstats.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF/put_sstats.f90 rename to build/FUSE_SRC/netcdf/put_sstats.f90 diff --git a/build/FUSE_SRC/FUSE_NETCDF/slob b/build/FUSE_SRC/netcdf/slob similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF/slob rename to build/FUSE_SRC/netcdf/slob diff --git a/build/FUSE_SRC/FUSE_NETCDF/test_netcdf.f90 b/build/FUSE_SRC/netcdf/test_netcdf.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NETCDF/test_netcdf.f90 rename to build/FUSE_SRC/netcdf/test_netcdf.f90 diff --git a/build/FUSE_SRC/FUSE_TIME/time_io.f90 b/build/FUSE_SRC/netcdf/time_io.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_TIME/time_io.f90 rename to build/FUSE_SRC/netcdf/time_io.f90 diff --git a/build/FUSE_SRC/FUSE_NR/gammln.f90 b/build/FUSE_SRC/numrec/gammln.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NR/gammln.f90 rename to build/FUSE_SRC/numrec/gammln.f90 diff --git a/build/FUSE_SRC/FUSE_NR/gammp.f90 b/build/FUSE_SRC/numrec/gammp.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NR/gammp.f90 rename to build/FUSE_SRC/numrec/gammp.f90 diff --git a/build/FUSE_SRC/FUSE_NR/gcf.f90 b/build/FUSE_SRC/numrec/gcf.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NR/gcf.f90 rename to build/FUSE_SRC/numrec/gcf.f90 diff --git a/build/FUSE_SRC/FUSE_NR/gser.f90 b/build/FUSE_SRC/numrec/gser.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NR/gser.f90 rename to build/FUSE_SRC/numrec/gser.f90 diff --git a/build/FUSE_SRC/FUSE_NR/lubksb.f90 b/build/FUSE_SRC/numrec/lubksb.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NR/lubksb.f90 rename to build/FUSE_SRC/numrec/lubksb.f90 diff --git a/build/FUSE_SRC/FUSE_NR/ludcmp.f90 b/build/FUSE_SRC/numrec/ludcmp.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NR/ludcmp.f90 rename to build/FUSE_SRC/numrec/ludcmp.f90 diff --git a/build/FUSE_SRC/FUSE_NR/nr.f90 b/build/FUSE_SRC/numrec/nr.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NR/nr.f90 rename to build/FUSE_SRC/numrec/nr.f90 diff --git a/build/FUSE_SRC/FUSE_NR/nrtype.f90 b/build/FUSE_SRC/numrec/nrtype.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NR/nrtype.f90 rename to build/FUSE_SRC/numrec/nrtype.f90 diff --git a/build/FUSE_SRC/FUSE_NR/nrutil.f90 b/build/FUSE_SRC/numrec/nrutil.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NR/nrutil.f90 rename to build/FUSE_SRC/numrec/nrutil.f90 diff --git a/build/FUSE_SRC/FUSE_NR/pythag.f90 b/build/FUSE_SRC/numrec/pythag.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NR/pythag.f90 rename to build/FUSE_SRC/numrec/pythag.f90 diff --git a/build/FUSE_SRC/FUSE_NR/svbksb.f90 b/build/FUSE_SRC/numrec/svbksb.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NR/svbksb.f90 rename to build/FUSE_SRC/numrec/svbksb.f90 diff --git a/build/FUSE_SRC/FUSE_NR/svdcmp.f90 b/build/FUSE_SRC/numrec/svdcmp.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NR/svdcmp.f90 rename to build/FUSE_SRC/numrec/svdcmp.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/evap_lower.f90 b/build/FUSE_SRC/physics_orig/evap_lower.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/evap_lower.f90 rename to build/FUSE_SRC/physics_orig/evap_lower.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/evap_upper.f90 b/build/FUSE_SRC/physics_orig/evap_upper.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/evap_upper.f90 rename to build/FUSE_SRC/physics_orig/evap_upper.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/fix_states.f90 b/build/FUSE_SRC/physics_orig/fix_states.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/fix_states.f90 rename to build/FUSE_SRC/physics_orig/fix_states.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/meanfluxes.f90 b/build/FUSE_SRC/physics_orig/meanfluxes.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/meanfluxes.f90 rename to build/FUSE_SRC/physics_orig/meanfluxes.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/mod_derivs.f90 b/build/FUSE_SRC/physics_orig/mod_derivs.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/mod_derivs.f90 rename to build/FUSE_SRC/physics_orig/mod_derivs.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/mstate_eqn.f90 b/build/FUSE_SRC/physics_orig/mstate_eqn.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/mstate_eqn.f90 rename to build/FUSE_SRC/physics_orig/mstate_eqn.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/q_baseflow.f90 b/build/FUSE_SRC/physics_orig/q_baseflow.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/q_baseflow.f90 rename to build/FUSE_SRC/physics_orig/q_baseflow.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/q_misscell.f90 b/build/FUSE_SRC/physics_orig/q_misscell.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/q_misscell.f90 rename to build/FUSE_SRC/physics_orig/q_misscell.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/q_overland.f90 b/build/FUSE_SRC/physics_orig/q_overland.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/q_overland.f90 rename to build/FUSE_SRC/physics_orig/q_overland.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/qinterflow.f90 b/build/FUSE_SRC/physics_orig/qinterflow.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/qinterflow.f90 rename to build/FUSE_SRC/physics_orig/qinterflow.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/qpercolate.f90 b/build/FUSE_SRC/physics_orig/qpercolate.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/qpercolate.f90 rename to build/FUSE_SRC/physics_orig/qpercolate.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/qrainerror.f90 b/build/FUSE_SRC/physics_orig/qrainerror.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/qrainerror.f90 rename to build/FUSE_SRC/physics_orig/qrainerror.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/qsatexcess.f90 b/build/FUSE_SRC/physics_orig/qsatexcess.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/qsatexcess.f90 rename to build/FUSE_SRC/physics_orig/qsatexcess.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/update_swe.f90 b/build/FUSE_SRC/physics_orig/update_swe.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/update_swe.f90 rename to build/FUSE_SRC/physics_orig/update_swe.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/updatstate.f90 b/build/FUSE_SRC/physics_orig/updatstate.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/updatstate.f90 rename to build/FUSE_SRC/physics_orig/updatstate.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/wgt_fluxes.f90 b/build/FUSE_SRC/physics_orig/wgt_fluxes.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/wgt_fluxes.f90 rename to build/FUSE_SRC/physics_orig/wgt_fluxes.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/clrsky_rad.f90 b/build/FUSE_SRC/runtime/clrsky_rad.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/clrsky_rad.f90 rename to build/FUSE_SRC/runtime/clrsky_rad.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/comp_stats.f90 b/build/FUSE_SRC/runtime/comp_stats.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/comp_stats.f90 rename to build/FUSE_SRC/runtime/comp_stats.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/conv_funcs.f90 b/build/FUSE_SRC/runtime/conv_funcs.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/conv_funcs.f90 rename to build/FUSE_SRC/runtime/conv_funcs.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/fuse_solve.f90 b/build/FUSE_SRC/runtime/fuse_solve.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/fuse_solve.f90 rename to build/FUSE_SRC/runtime/fuse_solve.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/getPETgrid.f90 b/build/FUSE_SRC/runtime/getPETgrid.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/getPETgrid.f90 rename to build/FUSE_SRC/runtime/getPETgrid.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/get_mbands.f90 b/build/FUSE_SRC/runtime/get_mbands.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/get_mbands.f90 rename to build/FUSE_SRC/runtime/get_mbands.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/get_time_indices.f90 b/build/FUSE_SRC/runtime/get_time_indices.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/get_time_indices.f90 rename to build/FUSE_SRC/runtime/get_time_indices.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/initfluxes.f90 b/build/FUSE_SRC/runtime/initfluxes.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/initfluxes.f90 rename to build/FUSE_SRC/runtime/initfluxes.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/mean_stats.f90 b/build/FUSE_SRC/runtime/mean_stats.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/mean_stats.f90 rename to build/FUSE_SRC/runtime/mean_stats.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/ode_int.f90 b/build/FUSE_SRC/runtime/ode_int.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/ode_int.f90 rename to build/FUSE_SRC/runtime/ode_int.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/set_all.f90 b/build/FUSE_SRC/runtime/set_all.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/set_all.f90 rename to build/FUSE_SRC/runtime/set_all.f90 diff --git a/build/FUSE_SRC/FUSE_SCE/sce.f b/build/FUSE_SRC/sce/sce.f similarity index 100% rename from build/FUSE_SRC/FUSE_SCE/sce.f rename to build/FUSE_SRC/sce/sce.f diff --git a/build/FUSE_SRC/FUSE_SCE/sce_16plus.f b/build/FUSE_SRC/sce/sce_16plus.f similarity index 100% rename from build/FUSE_SRC/FUSE_SCE/sce_16plus.f rename to build/FUSE_SRC/sce/sce_16plus.f diff --git a/build/FUSE_SRC/FUSE_SCE/sobol.f90 b/build/FUSE_SRC/sce/sobol.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_SCE/sobol.f90 rename to build/FUSE_SRC/sce/sobol.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/disaggflux.f90 b/build/FUSE_SRC/solver_orig/disaggflux.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/disaggflux.f90 rename to build/FUSE_SRC/solver_orig/disaggflux.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/fdjac_ode.f90 b/build/FUSE_SRC/solver_orig/fdjac_ode.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/fdjac_ode.f90 rename to build/FUSE_SRC/solver_orig/fdjac_ode.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/flux_deriv.f90 b/build/FUSE_SRC/solver_orig/flux_deriv.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/flux_deriv.f90 rename to build/FUSE_SRC/solver_orig/flux_deriv.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/fmin.f90 b/build/FUSE_SRC/solver_orig/fmin.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/fmin.f90 rename to build/FUSE_SRC/solver_orig/fmin.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/fuse_deriv.f90 b/build/FUSE_SRC/solver_orig/fuse_deriv.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/fuse_deriv.f90 rename to build/FUSE_SRC/solver_orig/fuse_deriv.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/fuse_sieul.f90 b/build/FUSE_SRC/solver_orig/fuse_sieul.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/fuse_sieul.f90 rename to build/FUSE_SRC/solver_orig/fuse_sieul.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/interfaceb.f90 b/build/FUSE_SRC/solver_orig/interfaceb.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/interfaceb.f90 rename to build/FUSE_SRC/solver_orig/interfaceb.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/limit_xtry.f90 b/build/FUSE_SRC/solver_orig/limit_xtry.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/limit_xtry.f90 rename to build/FUSE_SRC/solver_orig/limit_xtry.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/lnsrch.f90 b/build/FUSE_SRC/solver_orig/lnsrch.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/lnsrch.f90 rename to build/FUSE_SRC/solver_orig/lnsrch.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/newtoniter.f90 b/build/FUSE_SRC/solver_orig/newtoniter.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/newtoniter.f90 rename to build/FUSE_SRC/solver_orig/newtoniter.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/viol_state.f90 b/build/FUSE_SRC/solver_orig/viol_state.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/viol_state.f90 rename to build/FUSE_SRC/solver_orig/viol_state.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/getpar_str.f90 b/build/FUSE_SRC/util/getpar_str.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/getpar_str.f90 rename to build/FUSE_SRC/util/getpar_str.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/meta_stats.f90 b/build/FUSE_SRC/util/meta_stats.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/meta_stats.f90 rename to build/FUSE_SRC/util/meta_stats.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/metaoutput.f90 b/build/FUSE_SRC/util/metaoutput.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/metaoutput.f90 rename to build/FUSE_SRC/util/metaoutput.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/metaparams.f90 b/build/FUSE_SRC/util/metaparams.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/metaparams.f90 rename to build/FUSE_SRC/util/metaparams.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/par_insert.f90 b/build/FUSE_SRC/util/par_insert.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/par_insert.f90 rename to build/FUSE_SRC/util/par_insert.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/parextract.f90 b/build/FUSE_SRC/util/parextract.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/parextract.f90 rename to build/FUSE_SRC/util/parextract.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/putpar_str.f90 b/build/FUSE_SRC/util/putpar_str.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/putpar_str.f90 rename to build/FUSE_SRC/util/putpar_str.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/selectmodl.f90 b/build/FUSE_SRC/util/selectmodl.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/selectmodl.f90 rename to build/FUSE_SRC/util/selectmodl.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/str_2_xtry.f90 b/build/FUSE_SRC/util/str_2_xtry.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/str_2_xtry.f90 rename to build/FUSE_SRC/util/str_2_xtry.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/sumextract.f90 b/build/FUSE_SRC/util/sumextract.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/sumextract.f90 rename to build/FUSE_SRC/util/sumextract.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/varextract.f90 b/build/FUSE_SRC/util/varextract.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/varextract.f90 rename to build/FUSE_SRC/util/varextract.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/xtry_2_str.f90 b/build/FUSE_SRC/util/xtry_2_str.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/xtry_2_str.f90 rename to build/FUSE_SRC/util/xtry_2_str.f90 diff --git a/build/Makefile b/build/Makefile index e1a337d..8e2e36f 100644 --- a/build/Makefile +++ b/build/Makefile @@ -78,16 +78,19 @@ $(VERSIONFILE): | $(GENINC) #======================================================================== # Define directories -NUMREC_DIR = $(F_KORE_DIR)FUSE_NR -HOOKUP_DIR = $(F_KORE_DIR)FUSE_HOOK +NUMREC_DIR = $(F_KORE_DIR)numrec +HOOKUP_DIR = $(F_KORE_DIR)hookup DRIVER_DIR = $(F_KORE_DIR)driver -NETCDF_DIR = $(F_KORE_DIR)FUSE_NETCDF +NETCDF_DIR = $(F_KORE_DIR)netcdf DSHARE_DIR = $(F_KORE_DIR)dshare PRELIM_DIR = $(F_KORE_DIR)prelim +RUNTIME_DIR = $(F_KORE_DIR)runtime PHYSICS_DIR = $(F_KORE_DIR)physics -ENGINE_DIR = $(F_KORE_DIR)FUSE_ENGINE -SCE_DIR = $(F_KORE_DIR)FUSE_SCE -TIME_DIR = $(F_KORE_DIR)FUSE_TIME +OLDPHYS_DIR = $(F_KORE_DIR)physics_orig +SOLVER_DIR = $(F_KORE_DIR)solver_orig +UTILMS_DIR = $(F_KORE_DIR)util +SCE_DIR = $(F_KORE_DIR)sce +TIME_DIR = $(F_KORE_DIR)netcdf # Define the executables DRIVER_EX = fuse.exe @@ -100,12 +103,12 @@ FUSE_DRIVER = \ fuse_driver.f90 DRIVER = $(patsubst %, $(DRIVER_DIR)/%, $(FUSE_DRIVER)) -# Utility modules -FUSE_UTILMS= \ +# Manager modules +FUSE_HOOKUP= \ kinds_dmsl_kit_FUSE.f90 \ utilities_dmsl_kit_FUSE.f90 \ fuse_fileManager.f90 -UTILMS = $(patsubst %, $(HOOKUP_DIR)/%, $(FUSE_UTILMS)) +HOOKUP = $(patsubst %, $(HOOKUP_DIR)/%, $(FUSE_HOOKUP)) # Numerical Recipes utilities FUSE_NRUTIL= \ @@ -135,8 +138,8 @@ FUSE_TIMEMS= \ time_io.f90 TIMUTILS = $(patsubst %, $(TIME_DIR)/%, $(FUSE_TIMEMS)) -# Information modules -FUSE_INFOMS= \ +# Utility modules +FUSE_UTILMS= \ metaoutput.f90 \ metaparams.f90 \ meta_stats.f90 \ @@ -149,7 +152,7 @@ FUSE_INFOMS= \ sumextract.f90 \ str_2_xtry.f90 \ xtry_2_str.f90 -INFOMS = $(patsubst %, $(ENGINE_DIR)/%, $(FUSE_INFOMS)) +UTILMS = $(patsubst %, $(UTILMS_DIR)/%, $(FUSE_UTILMS)) # Numerical Recipes FUSE_NR_SUB= \ @@ -157,7 +160,7 @@ FUSE_NR_SUB= \ gammln.f90 gammp.f90 gcf.f90 gser.f90 NR_SUB = $(patsubst %, $(NUMREC_DIR)/%, $(FUSE_NR_SUB)) -# FUSE physics +# FUSE physics (differentiable model) FUSE_PHYSICS= \ smoothers.f90 \ get_parent.f90 \ @@ -194,7 +197,7 @@ FUSE_MODGUT=\ wgt_fluxes.f90 \ updatstate.f90 \ q_overland.f90 -MODGUT = $(patsubst %, $(ENGINE_DIR)/%, $(FUSE_MODGUT)) +MODGUT = $(patsubst %, $(OLDPHYS_DIR)/%, $(FUSE_MODGUT)) # Solver FUSE_SOLVER= \ @@ -205,7 +208,7 @@ FUSE_SOLVER= \ fmin.f90 fdjac_ode.f90 flux_deriv.f90 disaggflux.f90 \ fuse_sieul.f90 \ newtoniter.f90 lnsrch.f90 -SOLVER = $(patsubst %, $(ENGINE_DIR)/%, $(FUSE_SOLVER)) +SOLVER = $(patsubst %, $(SOLVER_DIR)/%, $(FUSE_SOLVER)) # Define routines for FUSE preliminaries FUSE_PRELIM= \ @@ -228,7 +231,7 @@ FUSE_PRELIM= \ init_state.f90 PRELIM = $(patsubst %, $(PRELIM_DIR)/%, $(FUSE_PRELIM)) -FUSE_MODRUN= \ +FUSE_RUNTIME= \ conv_funcs.f90 \ clrsky_rad.f90 \ getPETgrid.f90 \ @@ -240,7 +243,7 @@ FUSE_MODRUN= \ fuse_solve.f90 \ comp_stats.f90 \ mean_stats.f90 -MODRUN = $(patsubst %, $(ENGINE_DIR)/%, $(FUSE_MODRUN)) +RUNTIME = $(patsubst %, $(RUNTIME_DIR)/%, $(FUSE_RUNTIME)) # Define NetCDF routines FUSE_NETCDF = \ @@ -261,8 +264,8 @@ SCE = \ sce_16plus.o # ... and stitch it all together... -FUSE_ALL = $(UTILMS) $(NRUTIL) $(DATAMS) $(TIMUTILS) $(INFOMS) \ - $(NR_SUB) $(PHYSICS) $(MODGUT) $(SOLVER) $(PRELIM) $(MODRUN) \ +FUSE_ALL = $(HOOKUP) $(NRUTIL) $(DATAMS) $(TIMUTILS) $(UTILMS) \ + $(NR_SUB) $(PHYSICS) $(MODGUT) $(SOLVER) $(PRELIM) $(RUNTIME) \ $(NETCDF) $(SCE) #======================================================================== diff --git a/build/generated/fuseversion.inc b/build/generated/fuseversion.inc index bd93cac..0765f8c 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 = '2025-12-23T12:46:39Z' +character(len=FUSE_BUILDTIME_LEN), parameter :: FUSE_BUILDTIME = '2025-12-23T15:25:46Z' character(len=FUSE_GITBRANCH_LEN), parameter :: FUSE_GITBRANCH = 'feature/refactor' -character(len=FUSE_GITHASH_LEN), parameter :: FUSE_GITHASH = 'e5093609dde9f039e889dcdbf4a5f9f1f322b135' +character(len=FUSE_GITHASH_LEN), parameter :: FUSE_GITHASH = '931a21f36dd28801e3272fb784d3394f6dee61a2' From 6314894d82e2ee328eda6621e37e098b58c5be46 Mon Sep 17 00:00:00 2001 From: Martyn Clark Date: Thu, 1 Jan 2026 10:16:58 +1300 Subject: [PATCH 16/16] refactor of fuse driver --- .../{runtime => deprecated}/get_mbands.f90 | 0 build/FUSE_SRC/driver/fuse_driver.f90 | 100 ++++- build/FUSE_SRC/driver/fuse_rmse.f90 | 81 ++-- build/FUSE_SRC/driver/get_fuse_prelim.f90 | 6 +- build/FUSE_SRC/driver/setup_domain.f90 | 140 ++++++ .../driver/setup_model_definition.f90 | 138 ++++++ build/FUSE_SRC/dshare/data_types.f90 | 265 +++++++++++- build/FUSE_SRC/dshare/multi_flux.f90 | 10 +- build/FUSE_SRC/dshare/multibands.f90 | 14 +- build/FUSE_SRC/dshare/multiforce.f90 | 164 +++---- build/FUSE_SRC/dshare/multiparam.f90 | 24 +- build/FUSE_SRC/dshare/multiroute.f90 | 14 +- build/FUSE_SRC/dshare/multistate.f90 | 4 +- build/FUSE_SRC/hookup/fuse_fileManager.f90 | 200 --------- build/FUSE_SRC/netcdf/def_output.f90 | 33 +- build/FUSE_SRC/netcdf/def_sstats.f90 | 151 ++++--- build/FUSE_SRC/netcdf/domain_decomp.f90 | 134 ++++++ build/FUSE_SRC/netcdf/get_mbands.f90 | 64 +++ build/FUSE_SRC/netcdf/put_output.f90 | 45 +- build/FUSE_SRC/netcdf/put_params.f90 | 4 +- build/FUSE_SRC/netcdf/read_coords.f90 | 101 +++++ build/FUSE_SRC/physics/get_parent.f90 | 11 +- build/FUSE_SRC/physics/update_swe_diff.f90 | 26 +- build/FUSE_SRC/physics_orig/update_swe.f90 | 34 +- build/FUSE_SRC/prelim/assign_flx.f90 | 176 ++++---- build/FUSE_SRC/prelim/assign_par.f90 | 409 +++++++++--------- build/FUSE_SRC/prelim/assign_stt.f90 | 130 +++--- build/FUSE_SRC/prelim/force_info.f90 | 1 + build/FUSE_SRC/prelim/getparmeta.f90 | 173 ++++---- build/FUSE_SRC/prelim/init_state.f90 | 2 +- build/FUSE_SRC/prelim/par_derive.f90 | 79 ++-- build/FUSE_SRC/prelim/parse_command_args.f90 | 118 ++++- build/FUSE_SRC/prelim/uniquemodl.f90 | 288 ++++++------ build/FUSE_SRC/runtime/get_time_windows.f90 | 340 +++++++++++++++ build/FUSE_SRC/runtime/initfluxes.f90 | 4 +- build/FUSE_SRC/runtime/set_all.f90 | 14 +- build/FUSE_SRC/util/alloc_domain.f90 | 98 +++++ build/FUSE_SRC/util/alloc_scratch.f90 | 161 +++++++ build/FUSE_SRC/util/fuse_fileManager.f90 | 382 ++++++++++++++++ build/FUSE_SRC/util/getpar_str.f90 | 139 +++--- build/FUSE_SRC/util/metaoutput.f90 | 152 +++---- build/Makefile | 19 +- build/generated/fuseversion.inc | 6 +- 43 files changed, 3154 insertions(+), 1300 deletions(-) rename build/FUSE_SRC/{runtime => deprecated}/get_mbands.f90 (100%) create mode 100644 build/FUSE_SRC/driver/setup_domain.f90 create mode 100644 build/FUSE_SRC/driver/setup_model_definition.f90 delete mode 100644 build/FUSE_SRC/hookup/fuse_fileManager.f90 create mode 100644 build/FUSE_SRC/netcdf/domain_decomp.f90 create mode 100644 build/FUSE_SRC/netcdf/get_mbands.f90 create mode 100644 build/FUSE_SRC/netcdf/read_coords.f90 create mode 100644 build/FUSE_SRC/runtime/get_time_windows.f90 create mode 100644 build/FUSE_SRC/util/alloc_domain.f90 create mode 100644 build/FUSE_SRC/util/alloc_scratch.f90 create mode 100644 build/FUSE_SRC/util/fuse_fileManager.f90 diff --git a/build/FUSE_SRC/runtime/get_mbands.f90 b/build/FUSE_SRC/deprecated/get_mbands.f90 similarity index 100% rename from build/FUSE_SRC/runtime/get_mbands.f90 rename to build/FUSE_SRC/deprecated/get_mbands.f90 diff --git a/build/FUSE_SRC/driver/fuse_driver.f90 b/build/FUSE_SRC/driver/fuse_driver.f90 index dc7ae6f..d942bd1 100644 --- a/build/FUSE_SRC/driver/fuse_driver.f90 +++ b/build/FUSE_SRC/driver/fuse_driver.f90 @@ -13,10 +13,12 @@ PROGRAM DISTRIBUTED_DRIVER ! --------------------------------------------------------------------------------------- ! data types USE nrtype ! variable types, etc. -USE data_types, only: cli_options ! command line interface options +USE data_types, only: cli_options ! domain (includes "everything") +USE data_types, only: domain_type ! command line interface options USE multistats, only: PCOUNT ! counter ! data +USE globaldata, only: isPrint USE globaldata, only: ncid_out USE multiparam, only: NUMPAR USE multiforce, only: NUMPSET @@ -25,16 +27,23 @@ PROGRAM DISTRIBUTED_DRIVER USE multiState, only: gState, gState_3d USE multiRoute, only: aRoute, AROUTE_3d -! modules -USE netcdf ! NetCDF library -USE get_fuse_prelim_MODULE, only: get_fuse_prelim ! FUSE model setup -USE parse_command_args_MODULE, only: parse_command_args ! parse command line arguments +! model setup: external subroutines/functions +USE netcdf ! NetCDF library +USE parse_command_args_MODULE, only: parse_command_args ! parse command line arguments +USE setup_domain_module, only: setup_domain ! initialize the model domain +USE setup_model_definition_module, only: setup_model_definition ! setup the FUSE model configuration + +! model run: external subroutines/functions USE get_fparam_module, only: GET_PRE_PARAM, GET_SCE_PARAM ! read parameters from netcdf file USE sce_driver_MODULE, only: sce_driver ! SCE optimization ! model simulation modules USE fuse_rmse_module ! run model and compute the root mean squared error +#ifdef __MPI__ + use mpi +#endif + IMPLICIT NONE ! error control @@ -56,24 +65,60 @@ PROGRAM DISTRIBUTED_DRIVER LOGICAL(LGT) :: OUTPUT_FLAG ! .TRUE. = write time series output INTEGER(I4B) :: ONEMOD=1 ! just specify one model -! ----- set initial counters ------------------------------------------------------------ +! global domaia type +type(domain_type) :: domain ! includes "everything" -! Define output and parameter files -ONEMOD=1 ! one file per model (i.e., model dimension = 1) -PCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) +! --------------------------------------------------------------------------------------- +! ----- model preliminaries (initialize) ------------------------------------------------ +! --------------------------------------------------------------------------------------- + +! ----- initialize MPI ------------------------------------------------------------------ + +#ifdef __MPI__ + domain%info%mpi%enabled = .true. + call MPI_Init(err); call MPI_check(err, "MPI_Init") + call MPI_Comm_rank(MPI_COMM_WORLD, domain%info%mpi%rank, err); call MPI_check(err, "MPI_Comm_rank") + call MPI_Comm_size(MPI_COMM_WORLD, domain%info%mpi%nproc, err); call MPI_check(err, "MPI_Comm_size") +#else + domain%info%mpi%enabled = .false. + domain%info%mpi%rank = 0 + domain%info%mpi%nproc = 1 +#endif + +! suppress printing for higher ranks +if(domain%info%mpi%rank > 0) isPrint=.false. ! ----- parse command line arguments ---------------------------------------------------- call parse_command_args(cli_opts,err,message) if(err/=0) stop trim(message) -! ----- get preliminary information for simulation -------------------------------------- +if(isPrint)then + print*, 'Control file = ', cli_opts%control_file + print*, 'Run mode = ', cli_opts%runmode +endif + +! ----- initialize the model domain ----------------------------------------------------- -call get_fuse_prelim(cli_opts, APAR, BL, BU, err, message) +! read forcing metadata (space/time/coords), apply MPI decomposition, and allocate domain arrays +call setup_domain(cli_opts, domain, err, message) if(err/=0) stop trim(message) -print*, 'Control file = ', cli_opts%control_file -print*, 'Run mode = ', cli_opts%runmode +! ----- initialize model configurations ------------------------------------------------- + +! choose model, load parameter metadata, derive parameters, and define NetCDF output files +call setup_model_definition(cli_opts, domain, APAR, BL, BU, err, message) +if(err/=0) stop trim(message) + +! ----- set initial counters ------------------------------------------------------------ + +! Define output and parameter files +ONEMOD=1 ! one file per model (i.e., model dimension = 1) +PCOUNT=0 ! counter for parameter sets evaluated (shared in MODULE multistats) + +! ----- allocate data structures -------------------------------------------------------- + + ! --------------------------------------------------------------------------------------- ! ----- run different FUSE modes -------------------------------------------------------- @@ -137,7 +182,34 @@ PROGRAM DISTRIBUTED_DRIVER if(err/=0)then; message=trim(message)//' nf90_close failed: '//trim(nf90_strerror(err)); return; endif PRINT *, 'Done' +STOP +! --------------------------------------------------------------------------------------- +! --------------------------------------------------------------------------------------- +! --------------------------------------------------------------------------------------- + +contains + +! ----- MPI checker --------------------------------------------------------------------- + +subroutine mpi_check(ierr, callee) +#ifdef __MPI__ + use mpi +#endif + implicit none + integer(i4b), intent(in) :: ierr + character(len=*), intent(in) :: callee +#ifdef __MPI__ + integer(i4b) :: slen, ierr2 + character(len=256) :: errstr + if (ierr /= MPI_SUCCESS) then + call MPI_Error_string(ierr, errstr, slen, ierr2) + write(*,*) "MPI error at ", trim(callee), ": ", trim(errstr(1:slen)) + call MPI_Abort(MPI_COMM_WORLD, ierr, ierr2) + end if +#else + ! serial build: do nothing +#endif +end subroutine mpi_check -STOP END PROGRAM DISTRIBUTED_DRIVER diff --git a/build/FUSE_SRC/driver/fuse_rmse.f90 b/build/FUSE_SRC/driver/fuse_rmse.f90 index 81833e4..741b8cd 100644 --- a/build/FUSE_SRC/driver/fuse_rmse.f90 +++ b/build/FUSE_SRC/driver/fuse_rmse.f90 @@ -55,6 +55,7 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG USE getPETgrid_module, ONLY: getPETgrid ! get gridded PET USE put_params_module, ONLY: put_params ! write parameters USE put_output_module, ONLY: put_goutput_3d ! write gridded output + USE PAR_DERIVE_module, ONLY: PAR_DERIVE 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 @@ -114,9 +115,9 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ALLOCATE(STATE0(NSTATE),STATE1(NSTATE),STAT=IERR) IF (IERR.NE.0) STOP ' problem allocating space for state vectors in fuse_rmse' - ! allocate flux derivative vector - allocate(fuseStruct%df_dS(nState), stat=ierr) - if(ierr/=0) STOP ' problem allocating space for the flux derivative vector' + ! allocate flux derivative vectors + allocate(fuseStruct%df_dS(nState), fuseStruct%df_dPar(NUMPAR), fuseStruct%dL_dPar(NUMPAR), stat=ierr) + if(ierr/=0) STOP ' problem allocating space for the flux derivative vectors' ! allocate elevation bands (for the snow model) allocate(fuseStruct%sbands(n_bands), stat=ierr) @@ -124,11 +125,9 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! allocate parameter derivative for each elevation band do iBands=1,n_bands - allocate(fuseStruct%sbands(iBands)%dx%dSWE_dParam(NPAR_SNOW), & - fuseStruct%sbands(iBands)%dx%dEffP_dParam(NUMPAR), stat=ierr) + allocate(fuseStruct%sbands(iBands)%var%dSWE_dParam(NPAR_SNOW), stat=ierr) if(ierr/=0) STOP ' problem allocating space for the parameter derivatives' - fuseStruct%sbands(iBands)%dx%dSWE_dparam(:) = 0._sp - fuseStruct%sbands(iBands)%dx%dEffP_dParam(:) = 0._sp + fuseStruct%sbands(iBands)%var%dSWE_dparam(:) = 0._sp end do ! increment parameter counter for model output @@ -149,9 +148,8 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! get elevation bands (if catchment) if(SMODL%iSNOWM == iopt_temp_index .and. .not.GRID_FLAG)then - Z_FORCING = Z_FORCING_grid(1,1) ! elevation of forcing data (m) - MBANDS%AF = MBANDS_INFO_3d(1,1,:)%AF ! fraction of basin area in band (-) - MBANDS%Z_MID = MBANDS_INFO_3d(1,1,:)%Z_MID ! band mid-point elevation (m) + Z_FORCING = Z_FORCING_grid(1,1) ! elevation of forcing data (m) + MBANDS(:)%info = MBANDS_INFO_3d(1,1,:) ! info structure, %AF, %Z_MID endif if(isPrint) PRINT *, 'Writing parameter values...' @@ -171,18 +169,26 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! initialize elevations bands if snow module is on if(isPrint) PRINT *, 'N_BANDS =', N_BANDS IF (SMODL%iSNOWM.EQ.iopt_temp_index) THEN + + ! initialize the per-band template once + ! (dSWE_dParam allocated & initialized earlier) + fuseStruct%sbands(:)%var%SWE = 0._sp ! band snowpack water equivalent (mm) + fuseStruct%sbands(:)%var%SNOWACCMLTN = 0._sp ! new snow accumulation in band (mm day-1) + fuseStruct%sbands(:)%var%SNOWMELT = 0._sp ! snowmelt in band (mm day-1) + fuseStruct%sbands(:)%var%DSWE_DT = 0._sp ! rate of change of band SWE (mm day-1) + + ! copy to every grid cell 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 + do iBands=1,n_bands + MBANDS_VAR_4d(iSpat1,iSpat2,iBands,1) = fuseStruct%sbands(iBands)%var + end do ! elevation bands + end do ! 1st spatial dimension + end do ! 2nd spatial dimension + if(isPrint) PRINT *, 'Snow states initiatlized over the 2D gridded domain ' - ENDIF + + ENDIF ! if snow model is on ! allocate 3d data structure for fluxes ALLOCATE(W_FLUX_3d(nspat1,nspat2,numtim_sub)) @@ -196,7 +202,8 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG 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 + ! + ! 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 @@ -277,17 +284,14 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! 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) + mbands(:)%info = MBANDS_INFO_3d(iSpat1,iSpat2,:) ! info structure + mbands(:)%var = MBANDS_VAR_4d(iSpat1,iSpat2,:,itim_sub) ! var structure ! put data into the FUSE structure if(diff_mode == differentiable)then - fuseStruct%sbands%var = MBANDS - fuseStruct%z_forcing = Z_FORCING + fuseStruct%sbands(:)%info = MBANDS(:)%info + fuseStruct%sbands(:)%var = MBANDS(:)%var + fuseStruct%z_forcing = Z_FORCING endif ! if diff_mode == differentiable ! run the snow model @@ -354,18 +358,15 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! extract data from the FUSE structure if(diff_mode == differentiable)then - MBANDS = fuseStruct%sbands%var + MBANDS = fuseStruct%sbands ! gets full structure (info and vars) Z_FORCING = fuseStruct%z_forcing endif ! if diff_mode == differentiable ! 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) + gState_3d(iSpat1,iSpat2,itim_sub+1)%SWE_TOT = SUM(MBANDS(:)%var%SWE * MBANDS(:)%info%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 + MBANDS_VAR_4d(iSpat1,iSpat2,:,itim_sub+1) = MBANDS(:)%var END IF @@ -410,11 +411,8 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! 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 + gState_3d(:,:,1) = gState_3d(:,:,itim_sub+1) + MBANDS_VAR_4d(:,:,:,1) = MBANDS_VAR_4d(:,:,:,itim_sub+1) ! reset itim_sub itim_sub=1 @@ -452,15 +450,14 @@ SUBROUTINE FUSE_RMSE(XPAR,GRID_FLAG,NCID_FORC,RMSE,OUTPUT_FLAG,IPSET,MPARAM_FLAG ! deallocate parameter derivative vectors do iBands=1,n_bands - deallocate(fuseStruct%sbands(iBands)%dx%dSWE_dParam, & - fuseStruct%sbands(iBands)%dx%dEffP_dParam, stat=ierr) + deallocate(fuseStruct%sbands(iBands)%var%dSWE_dParam, stat=ierr) if(ierr/=0) STOP ' problem deallocating space for the parameter derivatives' end do ! deallocate vectors DEALLOCATE(W_FLUX_3d); IF (IERR.NE.0) STOP ' problem deallocating W_FLUX_3d in fuse_rmse ' DEALLOCATE(STATE0,STATE1,STAT=IERR); IF (IERR.NE.0) STOP ' problem deallocating state vectors in fuse_rmse' - deallocate(fuseStruct%df_dS, stat=ierr); if(ierr/=0) STOP ' problem deallocating space for the flux derivative vector' + deallocate(fuseStruct%df_dS, fuseStruct%df_dPar, fuseStruct%dL_dPar, stat=ierr); if(ierr/=0) STOP ' problem deallocating space for the flux derivative vectors' deallocate(fuseStruct%sbands, stat=ierr); if(ierr/=0) STOP ' problem deallocating space for the elevation bands' END SUBROUTINE FUSE_RMSE diff --git a/build/FUSE_SRC/driver/get_fuse_prelim.f90 b/build/FUSE_SRC/driver/get_fuse_prelim.f90 index f274b29..492bee0 100644 --- a/build/FUSE_SRC/driver/get_fuse_prelim.f90 +++ b/build/FUSE_SRC/driver/get_fuse_prelim.f90 @@ -127,6 +127,7 @@ subroutine get_fuse_prelim(opts, APAR, BL, BU, err, message) endif ! get elevation band info, in particular N_BANDS + ! NOTE: allocates space for the elevation band structures CALL GET_MBANDS_INFO(ELEV_BANDS_NC,err,cmessage) ! read band data from NetCDF file if (err/=0)then; message=trim(message)//trim(cmessage); err=20; return; endif @@ -166,7 +167,7 @@ subroutine get_fuse_prelim(opts, APAR, BL, BU, err, message) CALL DEF_PARAMS(NUMPSET) ! define model parameters (initial CREATE) CALL DEF_SSTATS() ! define summary statistics (REDEF) - CALL DEF_OUTPUT(nSpat1,nSpat2,N_BANDS,numtim_sim) ! define model output time series (REDEF) + CALL DEF_OUTPUT(nSpat1,nSpat2,N_BANDS,NUMPAR,numtim_sim) ! define model output time series (REDEF) ! get parameter bounds and random numbers ALLOCATE(APAR(NUMPAR),BL(NUMPAR),BU(NUMPAR)) @@ -180,6 +181,9 @@ subroutine get_fuse_prelim(opts, APAR, BL, BU, err, message) ! ----- allocate space for time series, grids, and states ------------------------------- + + + ! allocate space for the basin/grid-average time series allocate(aForce(numtim_sub),aRoute(numtim_sub),stat=err) if(err/=0)then; message=trim(message)//'unable to allocate space for basin-average time series [aForce,aRoute]'; return; endif diff --git a/build/FUSE_SRC/driver/setup_domain.f90 b/build/FUSE_SRC/driver/setup_domain.f90 new file mode 100644 index 0000000..b7fc920 --- /dev/null +++ b/build/FUSE_SRC/driver/setup_domain.f90 @@ -0,0 +1,140 @@ +module setup_domain_module + + USE nrtype + USE data_types, only: cli_options + USE data_types, only: domain_type + USE globaldata, only: isPrint + + implicit none + + private + public :: setup_domain + +contains + + subroutine setup_domain(opts, domain, ierr, message) + + ! access subroutines + use netcdf, only: nf90_open, nf90_nowrite, nf90_strerror ! NetCDF functions + USE fuse_fileManager, only: fuse_SetDirsUndPhiles ! sets directories and filenames + USE fuse_fileManager, only: export_filemanager_to_domain ! populates domain%info structure + USE fuse_fileManager, only: finalize_domain_config ! compute additional filenames/variables + USE fuse_fileManager, only: export_domain_to_legacy ! populates legacy modules + + USE force_info_module, only: force_info ! get forcing info for NetCDF files + + USE get_gforce_module, only: read_ginfo ! get dimension lengths from the NetCDF file + USE get_gforce_module, only: get_varID ! list of var ids + + USE get_mbands_module, only: GET_MBANDS_INFO ! get elevation bands for snow modeling + + USE domain_decomp_module, only: read_forcing_dimensions ! get forcing dimensions for MPI domain decomposition + USE domain_decomp_module, only: get_domain_decomp_indices ! get MPI domain decomposition indices + + USE time_windows_module, only: get_time_windows ! get info on the rolling time windows + USE time_windows_module, only: export_time_to_multiforce ! populate legacy multiforce modules + + USE alloc_domain_module, only: allocate_domain_data ! allocate space for data arrays in the domain structure + USE alloc_domain_module, only: set_legacy_arrays ! copy arrays in the domain%data structure to legacy arrays + + ! shared data: TODO move into domain structure + USE multiforce, only: ncid_forc + + implicit none + + ! input + type(cli_options) , intent(in) :: opts ! command line interface options + type(domain_type) , intent(inout) :: domain ! the structure that holds "everything" + + ! output + integer(i4b) , intent(out) :: ierr ! error code + character(len=1024) , intent(out) :: message ! error message + + ! ----- internal ----------------------------------------------------------------------- + CHARACTER(LEN=1024) :: CMESSAGE ! error message + ! --------------------------------------------------------------------------------------- + associate(INPUT_PATH => domain%info%files%input_path, & + forcefile => domain%info%files%forcing_file) + ! --------------------------------------------------------------------------------------- + ierr=0; message='setup_domain/' + + ! ----- set paths and file names -------------------------------------------------------- + + ! set directories and filenames for control files + call fuse_SetDirsUndPhiles(fuseFileManagerIn=opts%control_file, err=ierr, message=cmessage) + if (ierr/=0)then; message=trim(message)//trim(cmessage); ierr=20; return; endif + + ! copy global file information to the domain structure + call export_filemanager_to_domain(opts, domain) + + ! derive filenames + parse config strings + call finalize_domain_config(opts, domain, ierr, message) + if (ierr/=0)then; message=trim(message)//trim(cmessage); ierr=20; return; endif + + ! populate legacy modules + call export_domain_to_legacy(domain) + + ! ----- read information on numerical decisions and forcing files ----------------------- + + ! defines method/parameters used for numerical solution based on numerix file + ! NOTE: This routine supports the legacy FUSE v1 numerics experiments + CALL GETNUMERIX(IERR,CMESSAGE) + if (ierr/=0)then; message=trim(message)//trim(cmessage); ierr=20; return; endif + + ! get forcing info from the txt file + ! -- forcing info is text that describes the forcing NetCDF files (TODO: needs improvement) + call force_info(ierr,cmessage) + if (ierr/=0)then; message=trim(message)//trim(cmessage); ierr=20; return; endif + if(isPrint) print *, 'Open forcing file:', trim(INPUT_PATH)//trim(forcefile) + + ! ----- read grid info and define indices for MPI domain decomposition ------------------ + + ! open NetCDF forcing file + ierr = nf90_open(trim(INPUT_PATH)//trim(forcefile), nf90_nowrite, ncid_forc) + if (ierr/=0)then; message=trim(message)//' nf90_open failed: '//trim(nf90_strerror(ierr)); return; endif + if(isPrint) PRINT *, 'NCID_FORC is', ncid_forc + + ! get NetCDF ID for each variable of the forcing file + ! NOTE: populates data structures in multiforce + call get_varID(ncid_forc, ierr, cmessage) + if (ierr/=0)then; message=trim(message)//trim(cmessage); ierr=20; return; endif + + ! populate domain structure with (x,y,t) dimension lengths + ! -- nx_global, ny_global, nt_global + call read_forcing_dimensions(ncid_forc, domain%info, ierr, cmessage) + if (ierr/=0)then; message=trim(message)//trim(cmessage); ierr=20; return; endif + + ! get indices for MPI decomposition of the spatial domain: y_start_global, ny_local + ! NOTE: These indices will be used later to read different subsets of forcing data for different ranks + call get_domain_decomp_indices(domain) + + ! ----- Compute time indices for sim/eval windows and subperiod chunk size -------------- + + call get_time_windows(ncid_forc, domain, ierr, cmessage) + if (ierr/=0)then; message=trim(message)//trim(cmessage); ierr=20; return; endif + + ! export domain%info%time -> multiforce to keep legacy code working + call export_time_to_multiforce(domain) + + ! ----- Get information on elevation bands ---------------------------------------------- + + ! get elevation band info, in particular N_BANDS, from NetCDF file + CALL GET_MBANDS_INFO(domain%info, ierr, cmessage) + if (ierr/=0)then; message=trim(message)//trim(cmessage); ierr=20; return; endif + + ! ----- Allocate space for domain data -------------------------------------------------- + + ! allocate space for the arrays in the domain%data structure + call allocate_domain_data(domain, ierr, cmessage) + if (ierr/=0)then; message=trim(message)//trim(cmessage); ierr=20; return; endif + + ! copy arrays in the domain%data structure to legacy arrays + call set_legacy_arrays(domain) + + end associate + end subroutine setup_domain + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + +end module setup_domain_module diff --git a/build/FUSE_SRC/driver/setup_model_definition.f90 b/build/FUSE_SRC/driver/setup_model_definition.f90 new file mode 100644 index 0000000..1d82db9 --- /dev/null +++ b/build/FUSE_SRC/driver/setup_model_definition.f90 @@ -0,0 +1,138 @@ +module setup_model_definition_MODULE + + USE nrtype + USE data_types, only: cli_options + USE data_types, only: domain_type + USE data_types, only: PARATT + + implicit none + + private + public :: setup_model_definition + +contains + + subroutine setup_model_definition(opts, domain, APAR, BL, BU, err, message) + + ! access subroutines + use uniquemodl_module, only: uniquemodl ! Defines unique strings for all FUSE models + use GETPARMETA_module, only: GETPARMETA ! Reads parameter metadata from the parameter constraints file + use selectmodl_module, only: selectmodl ! reads model control file + use ASSIGN_STT_module, only: ASSIGN_STT ! state definitions: data are stored in module model_defn + use ASSIGN_FLX_module, only: ASSIGN_FLX ! flux definitions: data are stored in module model_defn + use ASSIGN_PAR_module, only: ASSIGN_PAR ! parameter definitions: data are stored in module multiparam + use PAR_DERIVE_module, only: PAR_DERIVE ! Compute derived model parameters (bucket sizes, etc.) + USE DEF_SSTATS_MODULE, only: DEF_SSTATS ! define summary statistics + USE DEF_PARAMS_MODULE, only: DEF_PARAMS ! define model parameters + USE DEF_OUTPUT_MODULE, only: DEF_OUTPUT ! define model output + USE getpar_str_module, only: GETPAR_STR ! extracts parameter metadata + + ! data stored in legacy modules + USE model_defn, only: NSTATE ! number of state variables + USE multiparam, only: NUMPAR ! number of paramters for the current model + USE multiparam, only: LPARAM ! list of model parameters + USE multiparam, only: MAXN ! maximum number of function evaluations in SCE -- used for NUMPSET + USE multiforce, only: NUMPSET ! number of model parameter sets + + implicit none + + ! input + type(cli_options) , intent(in) :: opts ! command line interface options + type(domain_type) , intent(inout) :: domain ! the domain structure that stores "everything" + + ! output + real(sp) , intent(out) , allocatable :: aPar(:) ! parameter vector + real(sp) , intent(out) , allocatable :: BL(:), BU(:) ! parameter bounds + integer(i4b) , intent(out) :: err ! error code + character(len=1024) , intent(out) :: message ! error message + + ! ----- internal ----------------------------------------------------------------------- + INTEGER(I4B) :: IPAR ! parameter index + INTEGER(I4B) :: NMOD ! number of models + TYPE(PARATT) :: PARAM_META ! parameter metadata (model parameters) + CHARACTER(LEN=1024) :: CMESSAGE ! error message + ! ----- output dimensions -------------------------------------------------------------- + integer(i4b) :: nx, ny, nt, nb, nSet, nPar + ! --------------------------------------------------------------------------------------- + associate(fmodel_id => domain%info%config%fmodel_id) ! use domain as truth where possible + ! --------------------------------------------------------------------------------------- + err=0; message='setup_model_definition/' + + ! ----- define characteristics of the current model ------------------------------------- + + ! Define model attributes (valid for all models) + CALL UNIQUEMODL(NMOD) ! get nmod unique models: stored in module model_defn; NMOD is intent(out) + CALL GETPARMETA(ERR,CMESSAGE) ! read parameter metadata from constraints txt file (parameter bounds etc.) + if (err/=0)then; message=trim(message)//trim(cmessage); err=20; return; endif + + ! Identify a single model: FMODEL_ID is read from the control file and used to build string for zDecisions + CALL SELECTMODL(FMODEL_ID,ERR=ERR,MESSAGE=CMESSAGE) ! FMODEL_ID is intent(in) + if (err/=0)then; message=trim(message)//trim(cmessage); err=20; return; endif + + ! Define list of states and parameters for the current model + CALL ASSIGN_STT() ! state definitions are stored in module model_defn + CALL ASSIGN_FLX() ! flux definitions are stored in module model_defn + CALL ASSIGN_PAR() ! parameter definitions are stored in module multiparam + + ! save information in global data structures + domain%info%config%nState = NSTATE ! NSTATE is in module model_defn + domain%info%config%nParam = NUMPAR ! NSTATE is in module multiparam + domain%info%config%listParam = LPARAM(1:NUMPAR) ! (performs allocation) LPARAM is in module multiparam + + ! Compute derived model parameters (bucket sizes, etc.) + CALL PAR_DERIVE(ERR,CMESSAGE) + if (err/=0)then; message=trim(message)//trim(cmessage); err=20; return; endif + + ! ----- initialize parameters, statistics, and output ----------------------------------- + + ! get number of parameter sets + ! will be used to define the parameter set dimension of the NetCDF files + select case(opts%runmode) + + ! options that run with a single parameter set + case('def', 'idx', 'opt'); NUMPSET = 1 + + ! use NUMPSET =1.2MAXN since final number of parameter sets produced by SCE is unknown + case('sce'); NUMPSET = int(1.2_sp * real(MAXN, sp)) + + ! check + err=20; message=trim(message)//'opts%runmode is unknown: '//trim(opts%runmode) + + end select + + ! save the number of parameter sets in the global domain structure + domain%info%config%nSets = NUMPSET + + ! define NetCDF files + + ! assign dimensions (use domain data for provenance/clarity) + + nx = domain%info%space%nx_local ! NOTE: local to rank (MPI parallelization) + ny = domain%info%space%ny_local + nt = domain%info%time%nt_window + nb = domain%info%snow%n_bands + + nSet = domain%info%config%nSets + nPar = domain%info%config%nParam + + + CALL DEF_PARAMS(nSet) ! define model parameters + CALL DEF_OUTPUT(nx,ny,nb,nPar,nt) ! define model output time series (nPar used for parameter derivatives) + + CALL DEF_SSTATS() ! define summary statistics (REDEF) + + ! get parameter bounds and random numbers + ALLOCATE(APAR(NUMPAR),BL(NUMPAR),BU(NUMPAR)) + + DO IPAR=1,NUMPAR + CALL GETPAR_STR(LPARAM(IPAR)%PARNAME,PARAM_META) + BL(IPAR) = PARAM_META%PARLOW ! lower boundary + BU(IPAR) = PARAM_META%PARUPP ! upper boundary + APAR(IPAR) = PARAM_META%PARDEF ! using default parameter values + END DO + + end associate + + end subroutine setup_model_definition + +end module setup_model_definition_MODULE diff --git a/build/FUSE_SRC/dshare/data_types.f90 b/build/FUSE_SRC/dshare/data_types.f90 index aa42ffb..c5d7734 100644 --- a/build/FUSE_SRC/dshare/data_types.f90 +++ b/build/FUSE_SRC/dshare/data_types.f90 @@ -14,9 +14,10 @@ module data_types character(len=:), allocatable :: sets_file ! for idx,opt integer(i4b) :: indx = -1 ! for idx character(len=:), allocatable :: restart_freq ! y/m/d/e/never - character(len=:), allocatable :: progress_freq ! m/d/h/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 ! -------------------------------------------------------------------------------------- @@ -289,18 +290,6 @@ module data_types ! elevation bands ! -------------------------------------------------------------------------------------- - 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 (-) @@ -311,17 +300,13 @@ module data_types 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) + real(sp), allocatable :: dSWE_dParam(:) ! parameter derivative vector ENDTYPE BANDS_VAR - type bands_dx ! derivatives - real(sp), allocatable :: dSWE_dParam(:) ! parameter derivative vector - real(sp), allocatable :: dEffP_dParam(:) ! parameter derivative vector - endtype bands_dx - - type ebands - type(bands) :: var ! time-dependent variables - type(bands_dx) :: dx ! derivatives - endtype + TYPE BANDS + type(bands_info) :: info ! information variables (elevation, area fraction) + type(bands_var) :: var ! model variables (SWE, snowfall, snowmelt, ...) + ENDTYPE BANDS ! -------------------------------------------------------------------------------------- ! model statistics structure @@ -360,12 +345,14 @@ module data_types type parent type(tdata) :: time ! time data type(fdata) :: force ! model forcing data - type(ebands), allocatable :: sbands(:) ! info/variables for elevation bands (snow model) + type(bands) , allocatable :: sbands(:) ! info/variables for elevation bands (snow model) 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(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 type(runoff) :: route ! hillslope routing type(par_id) :: param_name ! parameter names type(parinfo) :: param_meta ! metadata on model parameters @@ -375,4 +362,236 @@ module data_types real(sp) :: z_forcing ! elevation of forcing data (m) end type parent + ! -------------------------------------------------------------------------------------- + ! Domain metadata and gridded/time-windowed data + ! -------------------------------------------------------------------------------------- + + type :: mpi_info + logical(lgt) :: enabled = .false. + integer(i4b) :: rank = 0 + integer(i4b) :: nproc = 1 + end type mpi_info + + ! ------------------------------------------------------------------------------------- + + 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 :: domain_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 domain_info + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + 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 + + ! ------------------------------------------------------------------------------------- + + type :: fuse_work + + ! state vectors used for ODE integration + real(sp), allocatable :: state0(:) ! (nState) + real(sp), allocatable :: state1(:) ! (nState) + + ! optional scratch for Jacobian tests / ODE checks (if you still use them) + real(sp), allocatable :: dSdt(:) ! (nState) + real(sp), allocatable :: J(:,:) ! (nState,nState) + + ! differentiable parent structure (single-cell scratch) + type(parent) :: fuseStruct + + ! flags so we know if it's initialized + logical(lgt) :: is_initialized = .false. + + end type fuse_work + + ! ------------------------------------------------------------------------------------- + + type :: domain_type + type(domain_info) :: info + type(domain_data) :: data + type(fuse_work) :: work + end type domain_type + end module data_types diff --git a/build/FUSE_SRC/dshare/multi_flux.f90 b/build/FUSE_SRC/dshare/multi_flux.f90 index b00bb06..30015a3 100644 --- a/build/FUSE_SRC/dshare/multi_flux.f90 +++ b/build/FUSE_SRC/dshare/multi_flux.f90 @@ -1,10 +1,10 @@ MODULE multi_flux USE nrtype use data_types, only: 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) :: 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) :: 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 + TYPE(FLUXES), dimension(:) , pointer :: FDFLUX => null() ! finite difference fluxes END MODULE multi_flux diff --git a/build/FUSE_SRC/dshare/multibands.f90 b/build/FUSE_SRC/dshare/multibands.f90 index 8b962a6..146a21b 100644 --- a/build/FUSE_SRC/dshare/multibands.f90 +++ b/build/FUSE_SRC/dshare/multibands.f90 @@ -4,12 +4,12 @@ MODULE multibands USE nrtype USE data_types, only: BANDS, BANDS_INFO, 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 + 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 + LOGICAL(LGT) , DIMENSION(:,:) , allocatable :: elev_mask ! mask domain - TRUE means the cell must be masked, i.e. not run + REAL(SP) , DIMENSION(:,:) , allocatable :: Z_FORCING_grid ! elevation of forcing data (m) for the 2D domain + INTEGER(I4B) :: N_BANDS=0 ! number of bands, initialize to zero + REAL(SP) :: Z_FORCING ! elevation of forcing data (m) ! -------------------------------------------------------------------------------------- END MODULE multibands diff --git a/build/FUSE_SRC/dshare/multiforce.f90 b/build/FUSE_SRC/dshare/multiforce.f90 index 468f649..a510813 100644 --- a/build/FUSE_SRC/dshare/multiforce.f90 +++ b/build/FUSE_SRC/dshare/multiforce.f90 @@ -12,117 +12,117 @@ MODULE multiforce SAVE ! -------------------------------------------------------------------------------------- ! general - INTEGER(I4B),PARAMETER :: STRLEN=256 ! length of the character string + INTEGER(I4B),PARAMETER :: STRLEN=256 ! length of the character string ! time data structures - TYPE(tData) :: timDat ! model time structure + TYPE(tData) :: timDat ! model time structure ! response data structures - TYPE(vData) :: valDat ! validation structure - TYPE(vData), DIMENSION(:,:,:), POINTER :: aValid ! all model validation data + TYPE(vData) :: valDat ! validation structure + TYPE(vData), DIMENSION(:,:,:), allocatable :: 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 + TYPE(FDATA) :: MFORCE ! model forcing data for a single time step + TYPE(FDATA), DIMENSION(:), allocatable :: CFORCE ! COPY of model forcing data + TYPE(FDATA), DIMENSION(:), allocatable :: AFORCE ! all model forcing data + TYPE(fData), DIMENSION(:,:), allocatable :: gForce ! model forcing data for a 2-d grid + TYPE(aData), DIMENSION(:,:), allocatable :: ancilF ! ancillary forcing data for the 2-d grid + TYPE(fData), DIMENSION(:,:,:), allocatable :: gForce_3d ! model forcing data for a 3-d grid (time as 3rd dimension) + TYPE(aData), DIMENSION(:,:,:), allocatable :: 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 + 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) :: 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_rmse - INTEGER(i4b) :: sim_end=-1 ! index for the end of the simulation in fuse_rmse - 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) :: sim_beg=-1 ! index for the start of the simulation in fuse_rmse + INTEGER(i4b) :: sim_end=-1 ! index for the end of the simulation in fuse_rmse + 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) + 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) :: 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 + 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),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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 ! -------------------------------------------------------------------------------------- END MODULE multiforce diff --git a/build/FUSE_SRC/dshare/multiparam.f90 b/build/FUSE_SRC/dshare/multiparam.f90 index 0bffa67..e6b1173 100644 --- a/build/FUSE_SRC/dshare/multiparam.f90 +++ b/build/FUSE_SRC/dshare/multiparam.f90 @@ -3,22 +3,22 @@ ! -------- ! Martyn Clark ! Modified by Brian Henn to include snow model, 6/2013 -! Modified by Martyn Clark to separate derived types from shard data, 12/2025 +! Modified by Martyn Clark to separate derived types from shared data, 12/2025 ! --------------------------------------------------------------------------------------- MODULE multiparam USE nrtype USE data_types,ONLY:par_id,parinfo,paradj,pardvd ! -------------------------------------------------------------------------------------- - 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 - integer(i4b) :: MAXN ! maximum number of trials before optimization is terminated - integer(i4b) :: KSTOP ! number of shuffling loops the value must change by PCENTO - REAL(MSP) :: PCENTO ! the percentage + INTEGER(I4B), PARAMETER :: MAXPAR=50 ! maximum number of parameters for a single model + TYPE(PARADJ), DIMENSION(:), allocatable :: APARAM ! 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 + integer(i4b) :: MAXN ! maximum number of trials before optimization is terminated + integer(i4b) :: KSTOP ! number of shuffling loops the value must change by PCENTO + REAL(MSP) :: PCENTO ! the percentage ! -------------------------------------------------------------------------------------- END MODULE multiparam diff --git a/build/FUSE_SRC/dshare/multiroute.f90 b/build/FUSE_SRC/dshare/multiroute.f90 index f9d046b..307f040 100644 --- a/build/FUSE_SRC/dshare/multiroute.f90 +++ b/build/FUSE_SRC/dshare/multiroute.f90 @@ -1,13 +1,9 @@ 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 + Use data_types,only:runoff + REAL(SP) , DIMENSION(NTDH_MAX) :: FUTURE ! runoff placed in future time steps + TYPE(RUNOFF) , DIMENSION(:) , allocatable :: 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 index f7724f0..0ffb2af 100644 --- a/build/FUSE_SRC/dshare/multistate.f90 +++ b/build/FUSE_SRC/dshare/multistate.f90 @@ -3,8 +3,8 @@ MODULE multistate use data_types, only: statev, m_time ! <— import canonical types ! 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) , dimension(:,:) , allocatable :: gState ! (grid of model states) + type(statev) , dimension(:,:,:) , allocatable :: 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) diff --git a/build/FUSE_SRC/hookup/fuse_fileManager.f90 b/build/FUSE_SRC/hookup/fuse_fileManager.f90 deleted file mode 100644 index 4677d76..0000000 --- a/build/FUSE_SRC/hookup/fuse_fileManager.f90 +++ /dev/null @@ -1,200 +0,0 @@ -!****************************************************************** -! (C) Copyright 2009-2010 --- Dmitri Kavetski and Martyn Clark --- All rights reserved -!****************************************************************** -! Edited by Brian Henn to include snow model, 7/2013 -! Edited by Nans Addor to set simulation and evaluation periods, 11/2017 -MODULE fuse_filemanager -use kinds_dmsl_kit_FUSE,only:mik,mlk - -implicit none -public -! FUSE-wide pathlength -integer(mik),parameter::fusePathLen=256 -! defines the path for data files -CHARACTER(LEN=fusePathLen) :: SETNGS_PATH -CHARACTER(LEN=fusePathLen) :: INPUT_PATH -CHARACTER(LEN=fusePathLen) :: OUTPUT_PATH -! content of input directory -CHARACTER(LEN=fusePathLen) :: suffix_forcing ! suffix for forcing file -CHARACTER(LEN=fusePathLen) :: suffix_elev_bands ! suffix for elevation band file -! content of settings directory -CHARACTER(LEN=fusePathLen) :: M_DECISIONS ! definition of model decisions -CHARACTER(LEN=fusePathLen) :: CONSTRAINTS ! definition of parameter constraints -CHARACTER(LEN=fusePathLen) :: MOD_NUMERIX ! definition of numerical solution technique -CHARACTER(LEN=fusePathLen) :: FORCINGINFO ! info on forcing data files -CHARACTER(LEN=fusePathLen) :: MBANDS_INFO ! info on basin band data files ! not needed anymore -CHARACTER(LEN=fusePathLen) :: MBANDS_NC ! netcdf file defining the elevation bands -CHARACTER(LEN=fusePathLen) :: BATEA_PARAM ! definition of BATEA parameters ! remove this -! content of output directory -CHARACTER(LEN=64) :: FMODEL_ID ! string defining FUSE model -CHARACTER(LEN=64) :: Q_ONLY_STR ! TRUE = restrict attention to simulated runoff -LOGICAL :: Q_ONLY ! .TRUE. = restrict attention to simulated runoff -! define simulation and evaluation periods -CHARACTER(len=20) :: date_start_sim ! date start simulation -CHARACTER(len=20) :: date_end_sim ! date end simulation -CHARACTER(len=20) :: date_start_eval ! date start evaluation period -CHARACTER(len=20) :: date_end_eval ! date end evaluation period -CHARACTER(len=20) :: numtim_sub_str ! number of time steps of subperiod (will be kept in memory) -! SCE parameters -CHARACTER(len=20) :: KSTOP_str ! number of shuffling loops the value must change by PCENTO -CHARACTER(len=20) :: MAXN_str ! maximum number of trials before optimization is terminated -CHARACTER(len=20) :: PCENTO_str ! the percentage - -!---------------------------------------------------- -contains -!---------------------------------------------------- -subroutine fuse_SetDirsUndPhiles(fuseMusterDirektorIn,fuseFileManagerIn,err,message) -! Purpose: Sets direcotries and philenames for FUSE. -! --- -! Programmer: Dmitri Kavetski -! History: -! Darby St, 18/10/2009 AD - leid out basik frammenverk -! Sonnental, 17/06/2012 AD - more general path handling -! --- -! Usage -! fuseMusterDirektorIn = master direktor file (path to filemanager) -! fuseFileManagerIn = global names/path file -! --- -! Comments: -! 1. If present will try to use fuseMasterIn, otherwise default file. -! if default not present in EXE path then uses default options -! --- -use utilities_dmsl_kit_FUSE,only:getSpareUnit -implicit none -! dummies -character(*),intent(in),optional::fuseMusterDirektorIn,fuseFileManagerIn -integer(mik),intent(out)::err -character(*),intent(out)::message -! registered settings -character(*),parameter::procnam="fuseSetDirsUndPhiles" -character(*),parameter::pathDelim="/\",defpathSymb="*",blank=" " -character(*),parameter::fuseMusterDirektorHeader="FUSE_MUSTERDIREKTOR_V1.0" -character(*),parameter::fuseFileManagerHeader="FUSE_FILEMANAGER_V1.5" -! locals -logical(mlk)::haveFMG,haveMUS -character(LEN=fusePathLen)::fuseMusterDirektor,fuseFileManager,defpath -character(LEN=100)::temp -integer(mik)::unt,i -! Start procedure here -err=0; message=procnam//"/ok"; defpath=blank -haveMUS=present(fuseMusterDirektorIn); haveFMG=present(fuseFileManagerIn) -if(haveMUS)haveMUS=len_trim(fuseMusterDirektorIn)>0 -if(haveFMG)haveFMG=len_trim(fuseFileManagerIn)>0 ! check for zero-string -if(haveMUS.and.haveFMG)then - message="f-"//procnam//"/mustSpecifyEither(notBoth)& - &[fuseMusterDirektor.or.fuseFileManager]" - err=10; return -elseif(haveFMG)then - fuseFileManager=fuseFileManagerIn - i=scan(fuseFileManager,pathDelim,back=.true.) - if(i>0)defpath=fuseFileManager(:i-1)//pathDelim(1:1) - print *, 'fuseFileManager:', TRIM(fuseFileManager) - -elseif(haveMUS)then - fuseMusterDirektor=fuseMusterDirektorIn - i=scan(fuseMusterDirektor,pathDelim,back=.true.) - if(i>0)defpath=fuseMusterDirektor(:i-1)//pathDelim(1:1) - print *, 'fuseMusterDirektor:', TRIM(fuseMusterDirektor) - -else - message="f-"//procnam//"/mustSpecifyEither& - &[fuseMusterDirektor.or.fuseFileManager]" - err=20; return -endif -call getSpareUnit(unt,err,message) ! make sure 'unt' is actually available -if(err/=0)then - message="f-"//procnam//"/weird/&"//message - err=100; return -endif -if(.not.haveFMG)then ! grab it from the muster-direktor - -! 2. Open muster-direktor and read it - open(unt,file=fuseMusterDirektor,status="old",action="read",iostat=err) - if(err/=0)then - message="f-"//procnam//"/musterDirektorFileOpenError['"//trim(fuseMusterDirektor)//"']" - err=10; return - endif - read(unt,*)temp - if(temp/=fuseMusterDirektorHeader)then - message="f-"//procnam//"/unknownHeader&[file='"//trim(fuseMusterDirektor)//"']&& - &[header='"//trim(temp)//"']" - err=20; return - endif - read(unt,*)fuseFileManager - close(unt) -endif -! open file manager file -open(unt,file=fuseFileManager,status="old",action="read",iostat=err) -if(err/=0)then - message="f-"//procnam//"/fileManagerOpenError['"//trim(fuseFileManager)//"']" - err=10; return -endif -read(unt,*)temp -if(temp/=fuseFileManagerHeader)then - message="f-"//procnam//"/unknownHeader&[file='"//trim(fuseFileManager)//"']&& - &[header="//trim(temp)//"]" - - message='This version of FUSE requires the file manager to follow the following format: '//trim(fuseFileManagerHeader)//' not '//trim(temp) - - err=20; return -endif -read(unt,'(a)')temp -read(unt,*)SETNGS_PATH -read(unt,*)INPUT_PATH -read(unt,*)OUTPUT_PATH -read(unt,'(a)')temp -read(unt,*)suffix_forcing -read(unt,*)suffix_elev_bands -read(unt,'(a)')temp -read(unt,*)FORCINGINFO -read(unt,*)CONSTRAINTS -read(unt,*)MOD_NUMERIX -read(unt,*)M_DECISIONS -read(unt,'(a)')temp -read(unt,*)FMODEL_ID -read(unt,*)Q_ONLY_STR -read(unt,'(a)')temp -read(unt,*)date_start_sim -read(unt,*)date_end_sim -read(unt,*)date_start_eval -read(unt,*)date_end_eval -read(unt,*)numtim_sub_str -read(unt,'(a)')temp -read(unt,*)MAXN_STR -read(unt,*)KSTOP_STR -read(unt,*)PCENTO_STR -close(unt) - -! Convert Q_ONLY to logical -if(Q_ONLY_STR=='TRUE')then - Q_ONLY = .TRUE. -elseif(Q_ONLY_STR=='FALSE')then - Q_ONLY = .FALSE. -else - message="Q_ONLY must be either TRUE or FALSE" - err=20; return -endif - -PRINT*, 'Q_ONLY', Q_ONLY - -! process paths a bit -if(SETNGS_PATH(1:1)==defpathSymb)SETNGS_PATH=trim(defpath)//SETNGS_PATH(2:) -if( INPUT_PATH(1:1)==defpathSymb) INPUT_PATH=trim(defpath)//INPUT_PATH (2:) -if(OUTPUT_PATH(1:1)==defpathSymb)OUTPUT_PATH=trim(defpath)//OUTPUT_PATH(2:) - -PRINT *, 'Paths defined in file manager:' -PRINT *, 'SETNGS_PATH:', TRIM(SETNGS_PATH) -PRINT *, 'INPUT_PATH:', TRIM(INPUT_PATH) -PRINT *, 'OUTPUT_PATH:', TRIM(OUTPUT_PATH) - -PRINT *, 'Dates defined in file manager:' -PRINT *, 'date_start_sim:', TRIM(date_start_sim) -PRINT *, 'date_end_sim:', TRIM(date_end_sim) -PRINT *, 'date_start_eval:', TRIM(date_start_eval) -PRINT *, 'date_end_eval:', TRIM(date_end_eval) -PRINT *, 'numtim_sub_str:', TRIM(numtim_sub_str) - -! End procedure here -endsubroutine fuse_SetDirsUndPhiles -!---------------------------------------------------- -END MODULE fuse_filemanager diff --git a/build/FUSE_SRC/netcdf/def_output.f90 b/build/FUSE_SRC/netcdf/def_output.f90 index df726a2..cbf6d52 100644 --- a/build/FUSE_SRC/netcdf/def_output.f90 +++ b/build/FUSE_SRC/netcdf/def_output.f90 @@ -9,7 +9,7 @@ MODULE DEF_OUTPUT_MODULE contains - SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,n_bands,NTIM) + SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,n_bands,NUMPAR,NTIM) ! --------------------------------------------------------------------------------------- ! Creator: @@ -29,7 +29,7 @@ SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,n_bands,NTIM) USE globaldata, only: FUSE_VERSION, FUSE_BUILDTIME, FUSE_GITBRANCH, FUSE_GITHASH USE metaoutput, only: NOUTVAR ! number of output variables USE metaoutput, only: VNAME, LNAME, VUNIT ! metadata for all model variables - USE metaoutput, only: isBand ! logical flag to define vars with elevation dimension + USE metaoutput, only: isBand, isFlux ! logical flag to define vars with band/flux dimension USE model_defn, only: FNAME_NETCDF_RUNS ! model definition (includes filename) USE fuse_fileManager, only: Q_ONLY ! only write streamflow to output file? USE multiforce, only: GRID_FLAG ! .true. if distributed @@ -45,9 +45,11 @@ SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,n_bands,NTIM) INTEGER(I4B), INTENT(IN) :: NTIM ! number of time steps INTEGER(I4B), INTENT(IN) :: nSpat1,nSpat2 ! length of spatial dimensions INTEGER(I4B), INTENT(IN) :: n_bands ! number of elevation bands + INTEGER(I4B), INTENT(IN) :: NUMPAR ! number of model parameters ! internal integer(i4b), dimension(n_bands) :: band_i ! coordinate variable + integer(i4b), dimension(NUMPAR) :: param_i ! coordinate variable REAL(MSP),DIMENSION(nspat1) :: longitude_msp ! coordinate variable (SINGLE PRECISION) REAL(MSP),DIMENSION(nspat2) :: latitude_msp ! coordinate variable (SINGLE PRECISION) REAL(SP),parameter :: NA_VALUE_OUT= -9999. ! NA_VALUE for output file @@ -58,10 +60,13 @@ SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,n_bands,NTIM) INTEGER(I4B) :: NTIM_DIM ! time INTEGER(I4B) :: lon_dim ! 1st spatial dimension INTEGER(I4B) :: lat_dim ! 2nd spatial dimension + INTEGER(I4B) :: par_dim ! parameter dimension INTEGER(I4B) :: band_dim ! band dimension - INTEGER(I4B), DIMENSION(3) :: TVAR ! dimension list: exclude band + INTEGER(I4B), DIMENSION(3) :: TVAR ! dimension list: exclude band, param INTEGER(I4B), DIMENSION(4) :: EVAR ! dimension list: include band + INTEGER(I4B), DIMENSION(4) :: PVAR ! dimension list: include param integer(i4b) :: ib ! loop through bands + integer(i4b) :: ip ! loop through parameters INTEGER(I4B) :: IVAR ! loop through variables INTEGER(I4B) :: IVAR_ID ! variable ID @@ -78,13 +83,15 @@ SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,n_bands,NTIM) IERR = NF_CREATE(TRIM(FNAME_NETCDF_RUNS),NF_CLOBBER,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, 'time', NF_UNLIMITED, NTIM_DIM); CALL HANDLE_ERR(IERR) !record dimension (unlimited length) IERR = NF_DEF_DIM(ncid_out, 'band', n_bands, band_dim); CALL HANDLE_ERR(IERR) + IERR = NF_DEF_DIM(ncid_out, 'param', NUMPAR, par_dim); CALL HANDLE_ERR(IERR) 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) ! define dimension vector TVAR = (/lon_dim, lat_dim, NTIM_DIM/) + PVAR = (/lon_dim, lat_dim, par_dim, NTIM_DIM/) EVAR = (/lon_dim, lat_dim, band_dim, NTIM_DIM/) ! define time-varying output variables @@ -113,6 +120,12 @@ SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,n_bands,NTIM) 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_PUT_ATT_REAL(ncid_out,IVAR_ID,'_FillValue',NF_FLOAT,1,NA_VALUE_OUT_MSP); CALL HANDLE_ERR(IERR) + + ! define the parameter sensitivity for each flux: extra variable + if(isFlux(iVar))then + IERR = NF_DEF_VAR(ncid_out,TRIM(VNAME(IVAR)//'__dFlux_dParam'),NF_REAL,4,PVAR,IVAR_ID); CALL HANDLE_ERR(IERR) + IERR = NF_PUT_ATT_REAL(ncid_out,IVAR_ID,'_FillValue',NF_FLOAT,1,NA_VALUE_OUT_MSP); CALL HANDLE_ERR(IERR) + endif END DO ! ivar @@ -131,6 +144,10 @@ SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,n_bands,NTIM) 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) + ! define the parameter set variable + ierr = nf_def_var(ncid_out,'param',nf_int,1,(/band_dim/),ivar_id); call handle_err(ierr) + ierr = nf_put_att_text(ncid_out,ivar_id,'units',1,'-'); call handle_err(ierr) + ! define the band variable ierr = nf_def_var(ncid_out,'band',nf_int,1,(/band_dim/),ivar_id); call handle_err(ierr) ierr = nf_put_att_text(ncid_out,ivar_id,'units',1,'-'); call handle_err(ierr) @@ -157,11 +174,17 @@ SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,n_bands,NTIM) ierr = NF_INQ_VARID(ncid_out, 'band', ivar_id); call HANDLE_ERR(ierr) ierr = NF_PUT_VARA_INT(ncid_out, ivar_id, (/1/), (/n_bands/), band_i); call HANDLE_ERR(ierr) - PRINT *, 'NetCDF file for model runs defined with dimensions', n_bands, nSpat1 , nSpat2, NTIM + param_i = [(ip, ip=1,NUMPAR)] ! 1..NUMPAR + ierr = NF_INQ_VARID(ncid_out, 'param', ivar_id); call HANDLE_ERR(ierr) + ierr = NF_PUT_VARA_INT(ncid_out, ivar_id, (/1/), (/NUMPAR/), param_i); call HANDLE_ERR(ierr) + + PRINT *, 'NetCDF file for model runs defined with dimensions', n_bands, nSpat1 , nSpat2, NUMPAR, NTIM ! close output file IERR = NF_CLOSE(ncid_out) + stop "DEF_OUTPUT" + ! --------------------------------------------------------------------------------------- END SUBROUTINE DEF_OUTPUT diff --git a/build/FUSE_SRC/netcdf/def_sstats.f90 b/build/FUSE_SRC/netcdf/def_sstats.f90 index f75b1e2..3dd5213 100644 --- a/build/FUSE_SRC/netcdf/def_sstats.f90 +++ b/build/FUSE_SRC/netcdf/def_sstats.f90 @@ -1,74 +1,83 @@ -SUBROUTINE DEF_SSTATS() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Define NetCDF output files -- summary statistics -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition (includes filename) -USE meta_stats ! metadata for summary statistics -USE model_numerix ! model numerix decisions -USE globaldata, only: ncid_out ! NetCDF output file ID -IMPLICIT NONE -! internal -INTEGER(I4B) :: IERR ! error code; NetCDF ID -INTEGER(I4B) :: NPAR_DIM ! number of parameter sets -INTEGER(I4B) :: NMOD_DIM ! number of models -!INTEGER(I4B) :: NORD_DIM ! number of ordinates in prob distn -INTEGER(I4B), DIMENSION(1) :: FVAR ! dimensions for summary statistics -INTEGER(I4B), DIMENSION(2) :: PVAR ! dimensions for probability distributions -INTEGER(I4B) :: IVAR ! loop through variables -INTEGER(I4B) :: IVAR_ID ! variable ID -!INTEGER(I4B) :: IORD_ID ! ordinates ID -!real(MSP), dimension(size(ORD_NSUBS)) :: rORD ! ordinates of the prob dist (real numbers) -include 'netcdf.inc' ! use netCDF libraries -! --------------------------------------------------------------------------------------- -CALL SUMDESCRIBE() ! get list of summary statistics -! --------------------------------------------------------------------------------------- -! open file and put in define mode -IERR = NF_OPEN(TRIM(FNAME_NETCDF_PARA),NF_WRITE,ncid_out); CALL HANDLE_ERR(IERR) -IERR = NF_REDEF(ncid_out); CALL HANDLE_ERR(IERR) - ! retrieve ID for the model and parameter dimensions - IERR = NF_INQ_DIMID(ncid_out,'par',NPAR_DIM); CALL HANDLE_ERR(IERR) - !IERR = NF_INQ_DIMID(ncid_out,'mod',NMOD_DIM); CALL HANDLE_ERR(IERR) +module DEF_SSTATS_module + implicit none + private + public :: DEF_SSTATS - ! define ord dimension - !IERR = NF_DEF_DIM(ncid_out,'ord',SIZE(ORD_NSUBS),NORD_DIM); CALL HANDLE_ERR(IERR) +contains - ! define variables - FVAR = (/NPAR_DIM/) ! dimensions for fixed output (parameters) - DO IVAR=1,NSUMVAR - IERR = NF_DEF_VAR(ncid_out,TRIM(XNAME(IVAR)),NF_REAL,1,FVAR,IVAR_ID); CALL HANDLE_ERR(IERR) - IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'long_name',LEN_TRIM(XDESC(IVAR)),TRIM(XDESC(IVAR))) + SUBROUTINE DEF_SSTATS() + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Define NetCDF output files -- summary statistics + ! --------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE model_defn ! model definition (includes filename) + USE meta_stats ! metadata for summary statistics + USE model_numerix ! model numerix decisions + USE globaldata, only: ncid_out ! NetCDF output file ID + IMPLICIT NONE + ! internal + INTEGER(I4B) :: IERR ! error code; NetCDF ID + INTEGER(I4B) :: NPAR_DIM ! number of parameter sets + INTEGER(I4B) :: NMOD_DIM ! number of models + !INTEGER(I4B) :: NORD_DIM ! number of ordinates in prob distn + INTEGER(I4B), DIMENSION(1) :: FVAR ! dimensions for summary statistics + INTEGER(I4B), DIMENSION(2) :: PVAR ! dimensions for probability distributions + INTEGER(I4B) :: IVAR ! loop through variables + INTEGER(I4B) :: IVAR_ID ! variable ID + !INTEGER(I4B) :: IORD_ID ! ordinates ID + !real(MSP), dimension(size(ORD_NSUBS)) :: rORD ! ordinates of the prob dist (real numbers) + include 'netcdf.inc' ! use netCDF libraries + ! --------------------------------------------------------------------------------------- + CALL SUMDESCRIBE() ! get list of summary statistics + ! --------------------------------------------------------------------------------------- + ! open file and put in define mode + IERR = NF_OPEN(TRIM(FNAME_NETCDF_PARA),NF_WRITE,ncid_out); CALL HANDLE_ERR(IERR) + IERR = NF_REDEF(ncid_out); CALL HANDLE_ERR(IERR) + ! retrieve ID for the model and parameter dimensions + IERR = NF_INQ_DIMID(ncid_out,'par',NPAR_DIM); CALL HANDLE_ERR(IERR) + !IERR = NF_INQ_DIMID(ncid_out,'mod',NMOD_DIM); CALL HANDLE_ERR(IERR) + + ! define ord dimension + !IERR = NF_DEF_DIM(ncid_out,'ord',SIZE(ORD_NSUBS),NORD_DIM); CALL HANDLE_ERR(IERR) + + ! define variables + FVAR = (/NPAR_DIM/) ! dimensions for fixed output (parameters) + DO IVAR=1,NSUMVAR + IERR = NF_DEF_VAR(ncid_out,TRIM(XNAME(IVAR)),NF_REAL,1,FVAR,IVAR_ID); CALL HANDLE_ERR(IERR) + IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'long_name',LEN_TRIM(XDESC(IVAR)),TRIM(XDESC(IVAR))) + + CALL HANDLE_ERR(IERR) + IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'units',LEN_TRIM(XUNIT(IVAR)),TRIM(XUNIT(IVAR))) + CALL HANDLE_ERR(IERR) + END DO ! ivar + + ! define ordinates of probability distributions + ! IERR = NF_DEF_VAR(ncid_out,'ordinates',NF_REAL,1,NORD_DIM,IORD_ID); CALL HANDLE_ERR(IERR) + ! IERR = NF_PUT_ATT_TEXT(ncid_out,IORD_ID,'long_name',37,'ordinates of probability distribution') + ! CALL HANDLE_ERR(IERR) + + ! IERR = NF_PUT_ATT_TEXT(ncid_out,IORD_ID,'units',1,'-'); CALL HANDLE_ERR(IERR) + + ! define probability distributions + ! PVAR = (/NPAR_DIM,NORD_DIM/) ! dimensions for probability distributions + ! IERR = NF_DEF_VAR(ncid_out,'probability',NF_REAL,2,PVAR,IVAR_ID); CALL HANDLE_ERR(IERR) + ! IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'long_name',44,'cumulative probability of number of substeps'); CALL HANDLE_ERR(IERR) + ! IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'units',1,'-'); CALL HANDLE_ERR(IERR) + + ! end definitions and close file + IERR = NF_ENDDEF(ncid_out) + ! write the ordinates of the probability distribution + !rORD = real(ORD_NSUBS,kind(MSP)) + ! IERR = NF_PUT_VAR_REAL(ncid_out,IORD_ID,rORD); CALL HANDLE_ERR(IERR) ! write data + IERR = NF_CLOSE(ncid_out) + + ! --------------------------------------------------------------------------------------- + END SUBROUTINE DEF_SSTATS - CALL HANDLE_ERR(IERR) - IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'units',LEN_TRIM(XUNIT(IVAR)),TRIM(XUNIT(IVAR))) - CALL HANDLE_ERR(IERR) - END DO ! ivar - - ! define ordinates of probability distributions - ! IERR = NF_DEF_VAR(ncid_out,'ordinates',NF_REAL,1,NORD_DIM,IORD_ID); CALL HANDLE_ERR(IERR) - ! IERR = NF_PUT_ATT_TEXT(ncid_out,IORD_ID,'long_name',37,'ordinates of probability distribution') - ! CALL HANDLE_ERR(IERR) - - ! IERR = NF_PUT_ATT_TEXT(ncid_out,IORD_ID,'units',1,'-'); CALL HANDLE_ERR(IERR) - - ! define probability distributions - ! PVAR = (/NPAR_DIM,NORD_DIM/) ! dimensions for probability distributions - ! IERR = NF_DEF_VAR(ncid_out,'probability',NF_REAL,2,PVAR,IVAR_ID); CALL HANDLE_ERR(IERR) - ! IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'long_name',44,'cumulative probability of number of substeps'); CALL HANDLE_ERR(IERR) - ! IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'units',1,'-'); CALL HANDLE_ERR(IERR) - -! end definitions and close file -IERR = NF_ENDDEF(ncid_out) -! write the ordinates of the probability distribution -!rORD = real(ORD_NSUBS,kind(MSP)) -! IERR = NF_PUT_VAR_REAL(ncid_out,IORD_ID,rORD); CALL HANDLE_ERR(IERR) ! write data -IERR = NF_CLOSE(ncid_out) - -! --------------------------------------------------------------------------------------- -END SUBROUTINE DEF_SSTATS +end module DEF_SSTATS_module diff --git a/build/FUSE_SRC/netcdf/domain_decomp.f90 b/build/FUSE_SRC/netcdf/domain_decomp.f90 new file mode 100644 index 0000000..0895480 --- /dev/null +++ b/build/FUSE_SRC/netcdf/domain_decomp.f90 @@ -0,0 +1,134 @@ +module domain_decomp_module + + use nrtype + use data_types, only: domain_info + + implicit none + + private + public :: read_forcing_dimensions + public :: get_domain_decomp_indices + +contains + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- read forcing dimensions (used for domain decomposition) ----------------------- + + subroutine read_forcing_dimensions(ncid, info, ierr, message) + use netcdf + USE multiforce,only:vname_aprecip ! name of precip variable + implicit none + integer(i4b), intent(in) :: ncid + type(domain_info), intent(inout) :: info + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + integer(i4b) :: ivarid + integer(i4b), parameter :: ndims=3 + integer(i4b) :: dimids(ndims), dimLen + associate(nx_global => info%space%nx_global, & + ny_global => info%space%ny_global, & + nt_global => info%time%nt_global ) + + ierr=0; message="read_forcing_dimensions/" + + ! pick one required variable to identify shape (in this case precip) + ierr = nf90_inq_varid(ncid, trim(vname_aprecip), ivarid) + + ! get dimension IDs (x,y,t) + ierr = nf90_inquire_variable(ncid, ivarid, dimids=dimids) + if(ierr/=0)then; message=trim(message)//trim(nf90_strerror(ierr)); return; endif + + ! get dimsension lengths (nx,ny,nt) + ierr = nf90_inquire_dimension(ncid, dimids(1), len=nx_global); if(ierr/=0) return + ierr = nf90_inquire_dimension(ncid, dimids(2), len=ny_global); if(ierr/=0) return + ierr = nf90_inquire_dimension(ncid, dimids(3), len=nt_global); if(ierr/=0) return + + end associate + end subroutine read_forcing_dimensions + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- get indices to decompose the spatial domain ----------------------------------- + ! 1) Determine global run mode (grid vs catchment) + ! 2) Apply MPI decomposition (y dimension) and store local dims + offsets + + subroutine get_domain_decomp_indices(domain) + use data_types, only: domain_type + implicit none + type(domain_type), intent(inout) :: domain + + associate(& + grid_flag => domain%info%space%grid_flag, & + nx_global => domain%info%space%nx_global, & + ny_global => domain%info%space%ny_global, & + nx_local => domain%info%space%nx_local, & + ny_local => domain%info%space%ny_local, & + y_start_global => domain%info%space%y_start_global, & + y_end_global => domain%info%space%y_end_global, & + mpi_enabled => domain%info%mpi%enabled, & + nproc => domain%info%mpi%nproc, & + rank => domain%info%mpi%rank ) + + ! Set flag to toggle between grid and lumped catchment modes + grid_flag = (nx_global>1 .or. ny_global>1) + + ! Copy globals + nx_local = nx_global + ny_local = ny_global + y_start_global = 1 + + ! Get indices for split dimensions + if(grid_flag .and. mpi_enabled .and. nproc>1) then + call split_1d(ny_global, rank, nproc, & ! input + y_start_global, ny_local) ! output + endif + y_end_global = y_start_global + ny_local - 1 + + end associate + end subroutine get_domain_decomp_indices + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- split the dimensions for each MPI rank ---------------------------------------- + ! Purpose: Split domain to allow for MPI. + ! Given rank, nproc, and n_global, provide start and n_local indices + ! Creator: Ethan Gutmann, 2020 + ! Modified by Martyn Clark to simplify code and input/output, 12/2025 + + subroutine split_1d(n_global, rank, nproc, start, n_local, verbose) + use nrtype + implicit none + integer(i4b), intent(in) :: n_global, rank, nproc + logical(lgt), intent(in), optional :: verbose + integer(i4b), intent(out) :: start, n_local + + integer(i4b) :: base, extra + logical(lgt) :: talk + + talk = .false.; if(present(verbose)) talk = verbose + + ! --- sanity checks --- + if(nproc <= 0) stop "split_1d: nproc must be > 0" + if(rank < 0 .or. rank >= nproc) stop "split_1d: rank out of range" + if(n_global < 1) stop "split_1d: n_global must be >= 1" + + base = n_global / nproc ! floor(n_global / nproc) rows per rank + extra = mod(n_global, nproc) ! remainder; first 'extra' ranks get +1 row + + n_local = base + merge(1, 0, rank < extra) ! add 1 row for ranks 0..extra-1 + start = rank*base + min(rank, extra) + 1 ! shift start by #extra rows assigned before this rank + + if(talk) then + write(*,'(a,i0,a,i0)') "split_1d: nproc=", nproc, " rank =", rank + write(*,'(a,i0,a,i0)') "split_1d: base =", base, " extra =", extra + write(*,'(a,i0,a,i0)') "split_1d: start=", start, " nLocal=", n_local + write(*,'(a,i0,a,i0)') "split_1d: global rows=", start, ":", start+n_local-1 + endif + end subroutine split_1d + +end module domain_decomp_module diff --git a/build/FUSE_SRC/netcdf/get_mbands.f90 b/build/FUSE_SRC/netcdf/get_mbands.f90 new file mode 100644 index 0000000..0e9fd2a --- /dev/null +++ b/build/FUSE_SRC/netcdf/get_mbands.f90 @@ -0,0 +1,64 @@ +module get_mbands_module + + USE nrtype + + implicit none + + private + public :: GET_MBANDS_INFO + +contains + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- get the number of elevation bands (used for allocate statements later) -------- + + subroutine GET_MBANDS_INFO(info, ierr, message) + + use data_types, only: domain_info + use netcdf, only: nf90_open, nf90_nowrite, nf90_close, nf90_inq_dimid, & + nf90_inquire_dimension, nf90_strerror + + implicit none + + type(domain_info), intent(inout) :: info + integer(i4b) , intent(out) :: ierr + character(*) , intent(out) :: message + + integer(i4b) :: ncid_eb, dimid_eb, dimLen + character(len=1024) :: cfile + + ierr=0; message="GET_MBANDS_INFO/" + + cfile = trim(info%files%input_path)//trim(info%files%elevbands_file) + + ierr = nf90_open(cfile, nf90_nowrite, ncid_eb) + if(ierr/=0) then + message=trim(message)//"nf90_open failed: "//trim(nf90_strerror(ierr)) + return + endif + + ierr = nf90_inq_dimid(ncid_eb, "elevation_band", dimid_eb) + if(ierr/=0) then + message=trim(message)//"nf90_inq_dimid failed: "//trim(nf90_strerror(ierr)) + return + endif + + ierr = nf90_inquire_dimension(ncid_eb, dimid_eb, len=dimLen) + if(ierr/=0) then + message=trim(message)//"nf90_inquire_dimension failed: "//trim(nf90_strerror(ierr)) + return + endif + + ierr = nf90_close(ncid_eb) + if(ierr/=0) then + message=trim(message)//"nf90_close failed: "//trim(nf90_strerror(ierr)) + return + endif + + info%snow%n_bands = dimLen + + end subroutine GET_MBANDS_INFO + +end module get_mbands_module diff --git a/build/FUSE_SRC/netcdf/put_output.f90 b/build/FUSE_SRC/netcdf/put_output.f90 index 7b995db..aaedb82 100644 --- a/build/FUSE_SRC/netcdf/put_output.f90 +++ b/build/FUSE_SRC/netcdf/put_output.f90 @@ -14,7 +14,7 @@ SUBROUTINE PUT_GOUTPUT_3D(istart_sim,istart_in,numtim) ! Creator: ! -------- ! Nans Addor, based on Martyn Clark's 2007 PUT_OUTPUT - ! Modified by Marytn Clark to use the elevation band dimension, 12/2025 + ! Modified by Marytn Clark to use the elevation band dimension and add parameter derivatives, 12/2025 ! --------------------------------------------------------------------------------------- ! Purpose: ! -------- @@ -29,6 +29,7 @@ SUBROUTINE PUT_GOUTPUT_3D(istart_sim,istart_in,numtim) USE metaoutput, only: NOUTVAR ! number of output variables USE metaoutput, only: VNAME, LNAME, VUNIT ! metadata for all model variables USE metaoutput, only: isBand ! logical flag to define vars with elevation dimension + USE multiparam, only: NUMPAR ! variables for parameters USE multibands, only: MBANDS_VAR_4d, N_BANDS ! variables for elevation bands USE multiforce, only: timDat,time_steps ! time data USE multiforce, only: nspat1,nspat2,startSpat2 ! spatial dimensions @@ -47,17 +48,21 @@ SUBROUTINE PUT_GOUTPUT_3D(istart_sim,istart_in,numtim) ! internal LOGICAL(LGT) :: WRITE_VAR ! used to denote if the variable is written INTEGER(I4B) :: IERR ! error code - integer(i4b), dimension(3) :: start3 ! start indices: exclude elevation bands - integer(i4b), dimension(3) :: count3 ! count indices: exclude elevation bands - integer(i4b), dimension(4) :: start4 ! start indices: include elevation bands - integer(i4b), dimension(4) :: count4 ! count indices: include elevation bands + integer(i4b), dimension(3) :: start3 ! start indices: exclude elevation bands and parameters + integer(i4b), dimension(3) :: count3 ! count indices: exclude elevation bands and parameters + integer(i4b), dimension(4) :: start4_band ! start indices: include elevation bands + integer(i4b), dimension(4) :: count4_band ! count indices: include elevation bands + integer(i4b), dimension(4) :: start4_param ! start indices: include parameters + integer(i4b), dimension(4) :: count4_param ! count indices: include parameters 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 3-d variable (SINGLE PRECISION) REAL(MSP), DIMENSION(nspat1,nspat2,numtim) :: AVAR_3d ! desired 3-d variable (SINGLE PRECISION) - REAL(SP), DIMENSION(nspat1,nspat2,n_bands,numtim) :: XVAR_4d ! desired 4-d variable (SINGLE PRECISION) - REAL(MSP), DIMENSION(nspat1,nspat2,n_bands,numtim) :: AVAR_4d ! desired 4-d variable (SINGLE PRECISION) + REAL(SP), DIMENSION(nspat1,nspat2,n_bands,numtim) :: XVAR_4d_band ! desired 4-d variable (SINGLE PRECISION) + REAL(MSP), DIMENSION(nspat1,nspat2,n_bands,numtim) :: AVAR_4d_band ! desired 4-d variable (SINGLE PRECISION) + REAL(SP), DIMENSION(nspat1,nspat2,NUMPAR,numtim) :: XVAR_4d_param ! desired 4-d variable (SINGLE PRECISION) + REAL(MSP), DIMENSION(nspat1,nspat2,NUMPAR,numtim) :: AVAR_4d_param ! desired 4-d variable (SINGLE PRECISION) REAL(MSP), DIMENSION(numtim) :: tDat ! time data REAL(SP), DIMENSION(numtim) :: time_steps_sub ! time data INTEGER(I4B) :: IVAR_ID ! variable ID @@ -70,9 +75,13 @@ SUBROUTINE PUT_GOUTPUT_3D(istart_sim,istart_in,numtim) start3 = (/1,1,istart_sim/) count3 = (/nspat1,nspat2,numtim/) - ! define dimension list (exclude elevation bands) - start4 = (/1,1,1,istart_sim/) - count4 = (/nspat1,nspat2,n_bands,numtim/) + ! define dimension list (include elevation bands) + start4_band = (/1,1,1,istart_sim/) + count4_band = (/nspat1,nspat2,n_bands,numtim/) + + ! define dimension list (include parameter derivatives) + start4_param = (/1,1,1,istart_sim/) + count4_param = (/nspat1,nspat2,n_bands,numtim/) ! open file IERR = NF_OPEN(TRIM(FNAME_NETCDF_RUNS),NF_WRITE,ncid_out) @@ -106,19 +115,23 @@ SUBROUTINE PUT_GOUTPUT_3D(istart_sim,istart_in,numtim) ! extract variable from 4-D elevation band matrix select case (trim(VNAME(IVAR))) - case ('swe_z' ); XVAR_4d = MBANDS_VAR_4d(:,:,:,1:numtim)%SWE - case ('snwacml_z'); XVAR_4d = MBANDS_VAR_4d(:,:,:,1:numtim)%SNOWACCMLTN - case ('snwmelt_z'); XVAR_4d = MBANDS_VAR_4d(:,:,:,1:numtim)%SNOWMELT + 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 "put_output.f90: cannot identify elevation band variable: "//trim(VNAME(IVAR)) end select - aVar_4d = xVar_4d ! use MSP to write single precision - ! write 4-d matrix - IERR = NF_PUT_VARA_REAL(ncid_out, IVAR_ID, START4, COUNT4, AVAR_4d) + ! write 4-d matrix for elevation bands + IERR = NF_PUT_VARA_REAL(ncid_out, IVAR_ID, START4_band, COUNT4_band, AVAR_4d_band) call HANDLE_ERR(IERR) endif ! (switch between 3-d and 4-d variables) + ! ! write the parameter sensitivity for each flux: extra variable + ! if(isFlux(iVar))then + ! AVAR_4d_param = fuseStruct%df_dPar(:) + ! endif + END DO ! (ivar) ! write the time diff --git a/build/FUSE_SRC/netcdf/put_params.f90 b/build/FUSE_SRC/netcdf/put_params.f90 index 6173832..2c4401c 100644 --- a/build/FUSE_SRC/netcdf/put_params.f90 +++ b/build/FUSE_SRC/netcdf/put_params.f90 @@ -71,8 +71,8 @@ SUBROUTINE PUT_PARAMS(IPAR) ! extract vector select case (trim(PNAME(IVAR))) - case ('AF') ; xVec(1:n_bands) = [ (MBANDS(ib)%AF, ib=1,n_bands) ] - case ('Z_MID'); xVec(1:n_bands) = [ (MBANDS(ib)%Z_MID, ib=1,n_bands) ] + 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 diff --git a/build/FUSE_SRC/netcdf/read_coords.f90 b/build/FUSE_SRC/netcdf/read_coords.f90 new file mode 100644 index 0000000..64a323c --- /dev/null +++ b/build/FUSE_SRC/netcdf/read_coords.f90 @@ -0,0 +1,101 @@ +module read_coords_module + + use nrtype + use netcdf + + implicit none + + private + public :: read_latlon_1d + +contains + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- read 1-D coordinate vectors (lat(y), lon(x)) for a rectilinear 2-D grid ------- + + subroutine read_latlon_1d(ncid, domain, ierr, message) + use data_types, only: domain_type + implicit none + + integer(i4b), intent(in) :: ncid + type(domain_type), intent(inout) :: domain + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + integer(i4b) :: lat_id, lon_id + integer(i4b) :: y0, ny, nx + character(len=32) :: lat_name, lon_name + + ierr = 0 + message = "read_latlon_1d/" + + associate( & + y0 => domain%info%space%y_start_global, & ! 1-based index into global forcing file + ny => domain%info%space%ny_local, & ! number of local y rows + nx => domain%info%space%nx_local, & ! should equal nx_global (split only along y) + lat_1d => domain%data%coords%lat_1d, & + lon_1d => domain%data%coords%lon_1d ) + + ! ----- allocate storage if needed ------------------------------------------------ + + if(.not. allocated(domain%data%coords%lat_1d)) print*, 'hello' + + if(.not. allocated(lat_1d)) then + allocate(lat_1d(ny), stat=ierr) + if(ierr/=0)then; message=trim(message)//'allocate(lat_1d) failed'; return; endif + endif + + if(.not. allocated(lon_1d)) then + allocate(lon_1d(nx), stat=ierr) + if(ierr/=0)then; message=trim(message)//'allocate(lon_1d) failed'; return; endif + endif + + ! ----- find latitude and longitude variables ------------------------------------- + + lat_name = "latitude" + ierr = nf90_inq_varid(ncid, trim(lat_name), lat_id) + if(ierr /= nf90_noerr) then + lat_name = "lat" + ierr = nf90_inq_varid(ncid, trim(lat_name), lat_id) + if(ierr /= nf90_noerr) then + message = trim(message)//"cannot find latitude variable (latitude or lat)" + return + endif + endif + + lon_name = "longitude" + ierr = nf90_inq_varid(ncid, trim(lon_name), lon_id) + if(ierr /= nf90_noerr) then + lon_name = "lon" + ierr = nf90_inq_varid(ncid, trim(lon_name), lon_id) + if(ierr /= nf90_noerr) then + message = trim(message)//"cannot find longitude variable (longitude or lon)" + return + endif + endif + + ! ----- read latitude slice (local y slab) ---------------------------------------- + + ierr = nf90_get_var(ncid, lat_id, lat_1d, start=(/y0/), count=(/ny/)) + if(ierr /= nf90_noerr) then + message = trim(message)//"nf90_get_var("//trim(lat_name)//") failed: " // & + trim(nf90_strerror(ierr)) + return + endif + + ! ----- read all longitudes (same on every rank) ---------------------------------- + + ierr = nf90_get_var(ncid, lon_id, lon_1d, start=(/1/), count=(/nx/)) + if(ierr /= nf90_noerr) then + message = trim(message)//"nf90_get_var("//trim(lon_name)//") failed: " // & + trim(nf90_strerror(ierr)) + return + endif + + end associate + + end subroutine read_latlon_1d + +end module read_coords_module diff --git a/build/FUSE_SRC/physics/get_parent.f90 b/build/FUSE_SRC/physics/get_parent.f90 index ddc0b27..be20636 100644 --- a/build/FUSE_SRC/physics/get_parent.f90 +++ b/build/FUSE_SRC/physics/get_parent.f90 @@ -1,7 +1,8 @@ module get_parent_module use nrtype use data_types, only: parent - USE model_defn, ONLY:NSTATE + USE model_defn, ONLY: NSTATE + USE multiparam, ONLY: NUMPAR implicit none contains @@ -15,6 +16,7 @@ subroutine get_parent(fuseStruct) implicit none type(parent), intent(inout) :: fuseStruct integer(i4b) :: iState + integer(i4b) :: iParam ! populate parent fuse structures fuseStruct%time = timdat @@ -26,11 +28,16 @@ subroutine get_parent(fuseStruct) fuseStruct%param_adjust = mParam fuseStruct%param_derive = dParam - ! initialize derivatives + ! initialize flux derivatives do iState=1,nState fuseStruct%df_dS(iState) = m_flux ! initialized at zero end do + ! initialize parameter derivatives + do iParam=1,NUMPAR + fuseStruct%df_dPar(iParam) = m_flux ! initialized at zero + end do + end subroutine get_parent diff --git a/build/FUSE_SRC/physics/update_swe_diff.f90 b/build/FUSE_SRC/physics/update_swe_diff.f90 index 55857d7..3f5d18e 100644 --- a/build/FUSE_SRC/physics/update_swe_diff.f90 +++ b/build/FUSE_SRC/physics/update_swe_diff.f90 @@ -2,6 +2,7 @@ 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 @@ -109,8 +110,7 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) MFORCE => fuseStruct%force , & ! forcing data Z_FORC => fuseStruct%z_forcing , & ! elevation of the forcing data M_FLUX => fuseStruct%flux , & ! fluxes - MBANDS => fuseStruct%sbands , & ! elevation band variables: MBANDS(i)%var%x - DERIVS => fuseStruct%sbands , & ! parameter derivatives: DERIVS(i)%dx%x + MBANDS => fuseStruct%sbands , & ! elevation band variables: MBANDS(i)%var, MBANDS(i)info MPARAM => fuseStruct%param_adjust , & ! adjustable model parameters DPARAM => fuseStruct%param_derive & ! derived model parameters ) ! (associate) @@ -188,7 +188,7 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) M_FLUX%EFF_PPT = 0._sp ! check band rea fractions sum to 1 - if (abs(sum(MBANDS(:)%var%AF) - 1._sp) > 1.e-6_sp) stop "Band area fractions do not 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 @@ -204,12 +204,12 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) endif ! copy the stored sensitivity of SWE from the previous timestep to propagate it forward - if (comp_dparam) dSWE(:) = DERIVS(ISNW)%dx%dSWE_dparam(:) + 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)%var%Z_MID - Z_FORC + 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. @@ -300,7 +300,7 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) dpotMelt(:) = dMF(:)*posTemp + MF*dposTemp(:) ! melt cap - dsnowmelt(:) = merge(dpotMelt(:), dSWE(:)/DT, potMelt < meltcap) + dsnowmelt(:) = merge(dpotMelt(:), dSWE(:)/DT, potMelt <= meltcap) endif ! computing derivatives @@ -312,21 +312,25 @@ SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) 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(:)) ) - DERIVS(ISNW)%dx%dSWE_dparam(:) = dSWE_new(:) + MBANDS(ISNW)%var%dSWE_dparam(:) = dSWE_new(:) endif ! ----- calculate effective precip (rain + melt) --------------------------------------- - M_FLUX%EFF_PPT = M_FLUX%EFF_PPT + MBANDS(ISNW)%var%AF * (rain + snowmelt) + M_FLUX%EFF_PPT = M_FLUX%EFF_PPT + MBANDS(ISNW)%info%AF * (rain + snowmelt) if(comp_dparam)then - DERIVS(ISNW)%dx%dEffP_dParam(1:NP) = DERIVS(ISNW)%dx%dEffP_dParam(1:NP) + & - MBANDS(ISNW)%var%AF * (drain(:) + dsnowmelt(:)) + fuseStruct%df_dPar(1:NP)%EFF_PPT = fuseStruct%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%dL_dPar(:) = NA_VALUE_SP + fuseStruct%dL_dPar(1:NP) = fuseStruct%df_dPar(1:NP)%EFF_PPT END SUBROUTINE UPDATE_SWE_DIFF diff --git a/build/FUSE_SRC/physics_orig/update_swe.f90 b/build/FUSE_SRC/physics_orig/update_swe.f90 index 646f73f..c38e12b 100644 --- a/build/FUSE_SRC/physics_orig/update_swe.f90 +++ b/build/FUSE_SRC/physics_orig/update_swe.f90 @@ -60,59 +60,59 @@ SUBROUTINE UPDATE_SWE(DT) DO ISNW=1,N_BANDS ! calculate forcing data for each band - DZ = MBANDS(ISNW)%Z_MID - Z_FORCING + DZ = MBANDS(ISNW)%info%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 ((MBANDS(ISNW)%var%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 + MBANDS(ISNW)%var%SNOWMELT = MF*(TEMP_Z - MPARAM%MBASE) ! MBANDS%var%SNOWMELT has units of mm day-1 ELSE - MBANDS(ISNW)%SNOWMELT = 0.0_sp + MBANDS(ISNW)%var%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) + MBANDS(ISNW)%var%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 + MBANDS(ISNW)%var%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 + MBANDS(ISNW)%var%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 + MBANDS(ISNW)%var%DSWE_DT = MBANDS(ISNW)%var%SNOWACCMLTN - MBANDS(ISNW)%var%SNOWMELT + IF ((MBANDS(ISNW)%var%SWE + MBANDS(ISNW)%var%DSWE_DT*DT).GE.0._sp) THEN + MBANDS(ISNW)%var%SWE = MBANDS(ISNW)%var%SWE + MBANDS(ISNW)%var%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 + MBANDS(ISNW)%var%SNOWMELT = MBANDS(ISNW)%var%SWE/DT + MBANDS(ISNW)%var%SNOWACCMLTN + MBANDS(ISNW)%var%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 + MBANDS(ISNW)%info%AF * & + (MAX(0.0_sp, PRECIP_Z + MPARAM%RFERR_ADD) + MBANDS(ISNW)%var%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 + MBANDS(ISNW)%info%AF * & + (PRECIP_Z * MPARAM%RFERR_MLT + MBANDS(ISNW)%var%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 + MBANDS(ISNW)%info%AF * MBANDS(ISNW)%var%SNOWMELT ENDIF END DO END SUBROUTINE UPDATE_SWE diff --git a/build/FUSE_SRC/prelim/assign_flx.f90 b/build/FUSE_SRC/prelim/assign_flx.f90 index 7b9f5f4..5f75894 100644 --- a/build/FUSE_SRC/prelim/assign_flx.f90 +++ b/build/FUSE_SRC/prelim/assign_flx.f90 @@ -1,83 +1,93 @@ -SUBROUTINE ASSIGN_FLX() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Build an array of strings that list model fluxes used for the current model -! configuration -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! Defines list and number of states in MODULE model_defn -! --------------------------------------------------------------------------------------- -USE model_defn ! model definition -USE model_defnames -IMPLICIT NONE -INTEGER(I4B) :: I_FLUX ! just used for testing -LOGICAL(LGT) :: L_TEST ! just used for testing -! --------------------------------------------------------------------------------------- -L_TEST=.FALSE. -N_FLUX=0 -C_FLUX(:)%FNAME = ' ' -! --------------------------------------------------------------------------------------- -! (1) DEFINE STATE VARIABLES IN THE UPPER LAYER -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iARCH1) - CASE(iopt_tension2_1) - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EFF_PPT ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_1A ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_1B ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'RCHR2EXCS ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'TENS2FREE_1' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QPERC_12 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QINTF_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QSURF ' - CASE(iopt_tension1_1) - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EFF_PPT ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'TENS2FREE_1' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QPERC_12 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QINTF_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QSURF ' - CASE(iopt_onestate_1) - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EFF_PPT ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QPERC_12 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QINTF_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_1 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QSURF ' - CASE DEFAULT - print *, "MDEFN(IMOD)%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" - STOP -END SELECT -! --------------------------------------------------------------------------------------- -! (2) DEFINE STATE VARIABLES IN THE LOWER LAYER -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iARCH2) - CASE(iopt_tens2pll_2) - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_2 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'TENS2FREE_2' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QBASE_2A ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QBASE_2B ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QBASE_2 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_2A ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_2B ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_2 ' - CASE(iopt_unlimfrc_2,iopt_unlimpow_2,iopt_topmdexp_2,iopt_fixedsiz_2) - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_2 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QBASE_2 ' - N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_2 ' - CASE DEFAULT - print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" - print *, " iopt_topmdexp_2, or iopt_fixedsiz_2" - STOP -END SELECT -! --------------------------------------------------------------------------------------- -IF (L_TEST) THEN; DO I_FLUX=1,N_FLUX; WRITE(*,'(A20)') C_FLUX(I_FLUX)%FNAME; END DO; ENDIF -! --------------------------------------------------------------------------------------- -END SUBROUTINE ASSIGN_FLX +module ASSIGN_FLX_module + implicit none + private + public :: ASSIGN_FLX + +contains + + + SUBROUTINE ASSIGN_FLX() + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2009 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Build an array of strings that list model fluxes used for the current model + ! configuration + ! --------------------------------------------------------------------------------------- + ! Modules Modified: + ! ----------------- + ! Defines list and number of states in MODULE model_defn + ! --------------------------------------------------------------------------------------- + USE model_defn ! model definition + USE model_defnames + IMPLICIT NONE + INTEGER(I4B) :: I_FLUX ! just used for testing + LOGICAL(LGT) :: L_TEST ! just used for testing + ! --------------------------------------------------------------------------------------- + L_TEST=.FALSE. + N_FLUX=0 + C_FLUX(:)%FNAME = ' ' + ! --------------------------------------------------------------------------------------- + ! (1) DEFINE STATE VARIABLES IN THE UPPER LAYER + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH1) + CASE(iopt_tension2_1) + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EFF_PPT ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_1A ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_1B ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'RCHR2EXCS ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'TENS2FREE_1' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QPERC_12 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QINTF_1 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_1 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QSURF ' + CASE(iopt_tension1_1) + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EFF_PPT ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_1 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'TENS2FREE_1' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QPERC_12 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QINTF_1 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_1 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QSURF ' + CASE(iopt_onestate_1) + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EFF_PPT ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_1 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QPERC_12 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QINTF_1 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_1 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QSURF ' + CASE DEFAULT + print *, "MDEFN(IMOD)%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" + STOP + END SELECT + ! --------------------------------------------------------------------------------------- + ! (2) DEFINE STATE VARIABLES IN THE LOWER LAYER + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH2) + CASE(iopt_tens2pll_2) + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_2 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'TENS2FREE_2' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QBASE_2A ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QBASE_2B ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QBASE_2 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_2A ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_2B ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_2 ' + CASE(iopt_unlimfrc_2,iopt_unlimpow_2,iopt_topmdexp_2,iopt_fixedsiz_2) + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'EVAP_2 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'QBASE_2 ' + N_FLUX=N_FLUX+1; C_FLUX(N_FLUX)%FNAME = 'OFLOW_2 ' + CASE DEFAULT + print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" + print *, " iopt_topmdexp_2, or iopt_fixedsiz_2" + STOP + END SELECT + ! --------------------------------------------------------------------------------------- + IF (L_TEST) THEN; DO I_FLUX=1,N_FLUX; WRITE(*,'(A20)') C_FLUX(I_FLUX)%FNAME; END DO; ENDIF + ! --------------------------------------------------------------------------------------- + END SUBROUTINE ASSIGN_FLX + +end module ASSIGN_FLX_module diff --git a/build/FUSE_SRC/prelim/assign_par.f90 b/build/FUSE_SRC/prelim/assign_par.f90 index e891af3..cb5f6c1 100644 --- a/build/FUSE_SRC/prelim/assign_par.f90 +++ b/build/FUSE_SRC/prelim/assign_par.f90 @@ -1,200 +1,209 @@ -SUBROUTINE ASSIGN_PAR() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! Modified by Brian Henn to include snow model, 6/2013 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Gets a list of model parameters used for the unique model in the structure SMODL -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multi_flux -- list of model parameters is stored in MODULE multiparam -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE model_defn ! model definition structure -USE model_defnames -USE data_types, ONLY : paratt ! data type for metadata -USE multiparam, ONLY : lparam, numpar ! model parameter structures -USE getpar_str_module ! access to SUBROUTINE get_par_str -IMPLICIT NONE -INTEGER(I4B) :: MPAR ! counter for number of parameters -TYPE(PARATT) :: PARAM_LEV1 ! parameter metadata (level 1) -TYPE(PARATT) :: PARAM_LEV2 ! parameter metadata (level 2) -! --------------------------------------------------------------------------------------- -MPAR = 0 ! initialize the number of model parameters -LPARAM(:)%PARNAME = 'PAR_NOUSE' -! --------------------------------------------------------------------------------------- -! (1) PRECIPITATION ERRORS -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iRFERR) - CASE(iopt_additive_e) ! additive rainfall error - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'RFERR_ADD' ! additive rainfall error (mm day-1) - CASE(iopt_multiplc_e) ! multiplicative rainfall error - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'RFERR_MLT' ! multiplicative rainfall error (-) - ! check if RFERR_MLT has any prior/hyper-parameters, and, if so, save them - CALL GETPAR_STR('RFERR_MLT',PARAM_LEV1) - IF (PARAM_LEV1%NPRIOR.GT.0) THEN - ! process 1st child - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV1%CHILD1(1:9) ! save 1st child - CALL GETPAR_STR(PARAM_LEV1%CHILD1,PARAM_LEV2) ! get metadata for 1st child - IF (PARAM_LEV2%NPRIOR.GT.0) THEN ! check if 1st child has prior/hyper-param - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV2%CHILD1(1:9) ! save 1st grandchild (from 1st child) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV2%CHILD2(1:9) ! save 2nd grandchild (from 1st child) - ENDIF - ! process 2nd child - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV1%CHILD2(1:9) ! save 2nd child - CALL GETPAR_STR(PARAM_LEV1%CHILD2,PARAM_LEV2) ! get metadata for 1st child - IF (PARAM_LEV2%NPRIOR.GT.0) THEN ! check if 1st child has prior/hyper-param - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV2%CHILD1(1:9) ! save 1st grandchild (from 2nd child) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV2%CHILD2(1:9) ! save 2nd grandchild (from 2nd child) - ENDIF - ENDIF - CASE DEFAULT - print *, "SMODL%RFERR must be 'additive_e' or 'multiplc_e'" - STOP -END SELECT ! (different upper-layer architecture) -! --------------------------------------------------------------------------------------- -! (2) SNOW MODEL -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iSNOWM) - CASE(iopt_temp_index) ! temperature index snow model - MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'MBASE ' ! snow base melting temperature - MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'MFMAX ' ! snow maximum melt factor - MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'MFMIN ' ! snow minimum melt factor - MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'PXTEMP ' ! rain snow partition temperature - MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'OPG ' ! precipitation gradient - MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'LAPSE ' ! temperature gradient - CASE(iopt_no_snowmod) ! if no snow model, no additional parameters - CASE DEFAULT - print *, "SMODL%SNOWM must be either 'temp_index' or 'no_snowmod'" - STOP -END SELECT -! --------------------------------------------------------------------------------------- -! (3) UPPER-LAYER ARCHITECTURE -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iARCH1) - CASE(iopt_tension2_1) ! tension storage sub-divided into recharge and excess - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FRCHZNE ' ! PRMS: frac tension storage in recharge zone (-) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FRACTEN ' ! frac total storage as tension storage (-) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_1' ! maximum total storage in layer1 (mm) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FRACLOWZ ' ! fraction of soil excess to lower zone (-) - CASE(iopt_tension1_1,iopt_onestate_1) ! (need to define tension and free storage -- even if one state) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FRACTEN ' ! frac total storage as tension storage (-) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_1' ! maximum total storage in layer1 (mm) - CASE DEFAULT - print *, "SMODL%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" - STOP -END SELECT ! (different upper-layer architechure) -! --------------------------------------------------------------------------------------- -! (4) LOWER-LAYER ARCHITECTURE / BASEFLOW -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iARCH2) - CASE(iopt_tens2pll_2) ! tension reservoir plus two parallel tanks - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'PERCFRAC ' ! fraction of percolation to tension storage (-) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FPRIMQB ' ! SAC: fraction of baseflow in primary resvr (-) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_2' ! maximum total storage in layer2 (mm) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QBRATE_2A ' ! baseflow depletion rate for primary resvr (day-1) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QBRATE_2B ' ! baseflow depletion rate for secondary resvr (day-1) - CASE(iopt_unlimfrc_2) ! baseflow resvr of unlimited size (0-HUGE), frac rate - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_2' ! maximum total storage in layer2 (mm) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QB_PRMS ' ! baseflow depletion rate (day-1) - CASE(iopt_topmdexp_2,iopt_unlimpow_2) ! topmodel options - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_2' ! maximum total storage in layer2 (mm) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'BASERTE ' ! baseflow rate (mm day-1) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'LOGLAMB ' ! mean value of the log-transformed topographic index (m) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'TISHAPE ' ! shape parameter for the topo index Gamma distribution (-) - ! (add extra paramater for the power-law transmissivity profile) - IF (SMODL%iARCH2.EQ.iopt_unlimpow_2) THEN ! (power-law transmissivity profile) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QB_POWR ' ! baseflow exponent (-) - ENDIF - CASE(iopt_fixedsiz_2) ! power-law relation (no parameters needed for the topo index distribution) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_2' ! maximum total storage in layer2 (mm) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'BASERTE ' ! baseflow rate (mm day-1) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QB_POWR ' ! baseflow exponent (-) - CASE DEFAULT - print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" - print *, " 'topmdexp_2', or 'fixedsiz_2'" - STOP -END SELECT ! different lower-layer architecture / baseflow parameterizations) -! --------------------------------------------------------------------------------------- -! (5) EVAPORATION -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iESOIL) - CASE(iopt_sequential) - ! (no additional parameters for the sequential scheme) - CASE(iopt_rootweight) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'RTFRAC1 ' ! fraction of roots in the upper layer (-) - CASE DEFAULT - print *, "SMODL%iESOIL must be either iopt_sequential or iopt_rootweight'" -END SELECT ! (different evaporation schemes) -! --------------------------------------------------------------------------------------- -! (6) PERCOLATION -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iQPERC) - CASE(iopt_perc_f2sat,iopt_perc_w2sat) ! standard equation k(theta)**c - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'PERCRTE ' ! percolation rate (mm day-1) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'PERCEXP ' ! percolation exponent (-) - CASE(iopt_perc_lower) ! perc defined by moisture content in lower layer (SAC) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'SACPMLT ' ! multiplier in the SAC model for dry lower layer (-) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'SACPEXP ' ! exponent in the SAC model for dry lower layer (-) - CASE DEFAULT ! check for errors - print *, "SMODL%iQPERC must be iopt_perc_f2sat, iopt_perc_w2sat, or iopt_perc_lower" - STOP -END SELECT ! (different percolation options) -! --------------------------------------------------------------------------------------- -! (7) INTERFLOW -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iQINTF) - CASE(iopt_intflwsome) ! interflow - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'IFLWRTE ' ! interflow rate (mm day-1) - CASE(iopt_intflwnone) ! no interflow - ! (no additional parameters for the case of no interflow) - CASE DEFAULT ! check for errors - print *, "SMODL%iQINTF must be either iopt_intflwsome' or iopt_intflwnone'" - STOP -END SELECT ! (different interflow options) -! --------------------------------------------------------------------------------------- -! (8) SURFACE RUNOFF -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iQSURF) - CASE(iopt_arno_x_vic) ! ARNO/Xzang/VIC parameterization (upper zone control) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'AXV_BEXP ' ! ARNO/VIC "b" exponent - CASE(iopt_prms_varnt) ! PRMS variant (fraction of upper tension storage) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'SAREAMAX ' ! maximum saturated area - CASE(iopt_tmdl_param) ! TOPMODEL parameterization - ! need the topographic index if we don't have it for baseflow - IF (SMODL%iARCH2.EQ.iopt_tens2pll_2 .OR. SMODL%iARCH2.EQ.iopt_unlimfrc_2 .OR. & - SMODL%iARCH2.EQ.iopt_fixedsiz_2) THEN - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'LOGLAMB ' ! mean value of the log-transformed topographic index (m) - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'TISHAPE ' ! shape parameter for the topo index Gamma distribution (-) - ENDIF - ! need the topmodel power if we don't have it for baseflow - IF (SMODL%iARCH2.EQ.iopt_tens2pll_2 .OR. SMODL%iARCH2.EQ.iopt_unlimfrc_2 .OR. & - SMODL%iARCH2.EQ.iopt_topmdexp_2) THEN - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QB_POWR ' ! baseflow exponent (-), used to modify the topographic index - ENDIF - CASE DEFAULT - print *, "SMODL%iQSURF must be iopt_arno_x_vic, iopt_prms_varnt, or iopt_tmdl_param" - STOP -END SELECT ! (different surface runoff options) -! --------------------------------------------------------------------------------------- -! (9) TIME DELAY IN RUNOFF -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iQ_TDH) - CASE(iopt_rout_gamma) ! use a Gamma distribution with shape parameter = 2.5 - MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'TIMEDELAY' ! time delay in runoff - CASE(iopt_no_routing) ! no routing - ! (no additional parameters when there is no time delay in runoff) - CASE DEFAULT ! check for errors - print *, "SMODL%iQ_TDH must be either iopt_rout_gamma or iopt_no_routing" - STOP -END SELECT -! --------------------------------------------------------------------------------------- -NUMPAR = MPAR ! save the number of model parameters used in a given model SMODL -! --------------------------------------------------------------------------------------- -!DO MPAR=1,NUMPAR; WRITE(*,'(A11,1X)') LPARAM(MPAR)%PARNAME; END DO -! --------------------------------------------------------------------------------------- -END SUBROUTINE ASSIGN_PAR +module ASSIGN_PAR_module + implicit none + private + public :: ASSIGN_PAR + +contains + + SUBROUTINE ASSIGN_PAR() + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Brian Henn to include snow model, 6/2013 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Gets a list of model parameters used for the unique model in the structure SMODL + ! --------------------------------------------------------------------------------------- + ! Modules Modified: + ! ----------------- + ! MODULE multi_flux -- list of model parameters is stored in MODULE multiparam + ! --------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE model_defn ! model definition structure + USE model_defnames + USE data_types, ONLY : paratt ! data type for metadata + USE multiparam, ONLY : lparam, numpar ! model parameter structures + USE getpar_str_module ! access to SUBROUTINE get_par_str + IMPLICIT NONE + INTEGER(I4B) :: MPAR ! counter for number of parameters + TYPE(PARATT) :: PARAM_LEV1 ! parameter metadata (level 1) + TYPE(PARATT) :: PARAM_LEV2 ! parameter metadata (level 2) + ! --------------------------------------------------------------------------------------- + MPAR = 0 ! initialize the number of model parameters + LPARAM(:)%PARNAME = 'PAR_NOUSE' + ! --------------------------------------------------------------------------------------- + ! (1) PRECIPITATION ERRORS + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iRFERR) + CASE(iopt_additive_e) ! additive rainfall error + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'RFERR_ADD' ! additive rainfall error (mm day-1) + CASE(iopt_multiplc_e) ! multiplicative rainfall error + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'RFERR_MLT' ! multiplicative rainfall error (-) + ! check if RFERR_MLT has any prior/hyper-parameters, and, if so, save them + CALL GETPAR_STR('RFERR_MLT',PARAM_LEV1) + IF (PARAM_LEV1%NPRIOR.GT.0) THEN + ! process 1st child + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV1%CHILD1(1:9) ! save 1st child + CALL GETPAR_STR(PARAM_LEV1%CHILD1,PARAM_LEV2) ! get metadata for 1st child + IF (PARAM_LEV2%NPRIOR.GT.0) THEN ! check if 1st child has prior/hyper-param + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV2%CHILD1(1:9) ! save 1st grandchild (from 1st child) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV2%CHILD2(1:9) ! save 2nd grandchild (from 1st child) + ENDIF + ! process 2nd child + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV1%CHILD2(1:9) ! save 2nd child + CALL GETPAR_STR(PARAM_LEV1%CHILD2,PARAM_LEV2) ! get metadata for 1st child + IF (PARAM_LEV2%NPRIOR.GT.0) THEN ! check if 1st child has prior/hyper-param + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV2%CHILD1(1:9) ! save 1st grandchild (from 2nd child) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME=PARAM_LEV2%CHILD2(1:9) ! save 2nd grandchild (from 2nd child) + ENDIF + ENDIF + CASE DEFAULT + print *, "SMODL%RFERR must be 'additive_e' or 'multiplc_e'" + STOP + END SELECT ! (different upper-layer architecture) + ! --------------------------------------------------------------------------------------- + ! (2) SNOW MODEL + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iSNOWM) + CASE(iopt_temp_index) ! temperature index snow model + MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'MBASE ' ! snow base melting temperature + MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'MFMAX ' ! snow maximum melt factor + MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'MFMIN ' ! snow minimum melt factor + MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'PXTEMP ' ! rain snow partition temperature + MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'OPG ' ! precipitation gradient + MPAR = MPAR + 1; LPARAM(MPAR)%PARNAME = 'LAPSE ' ! temperature gradient + CASE(iopt_no_snowmod) ! if no snow model, no additional parameters + CASE DEFAULT + print *, "SMODL%SNOWM must be either 'temp_index' or 'no_snowmod'" + STOP + END SELECT + ! --------------------------------------------------------------------------------------- + ! (3) UPPER-LAYER ARCHITECTURE + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH1) + CASE(iopt_tension2_1) ! tension storage sub-divided into recharge and excess + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FRCHZNE ' ! PRMS: frac tension storage in recharge zone (-) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FRACTEN ' ! frac total storage as tension storage (-) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_1' ! maximum total storage in layer1 (mm) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FRACLOWZ ' ! fraction of soil excess to lower zone (-) + CASE(iopt_tension1_1,iopt_onestate_1) ! (need to define tension and free storage -- even if one state) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FRACTEN ' ! frac total storage as tension storage (-) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_1' ! maximum total storage in layer1 (mm) + CASE DEFAULT + print *, "SMODL%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" + STOP + END SELECT ! (different upper-layer architechure) + ! --------------------------------------------------------------------------------------- + ! (4) LOWER-LAYER ARCHITECTURE / BASEFLOW + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH2) + CASE(iopt_tens2pll_2) ! tension reservoir plus two parallel tanks + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'PERCFRAC ' ! fraction of percolation to tension storage (-) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'FPRIMQB ' ! SAC: fraction of baseflow in primary resvr (-) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_2' ! maximum total storage in layer2 (mm) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QBRATE_2A ' ! baseflow depletion rate for primary resvr (day-1) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QBRATE_2B ' ! baseflow depletion rate for secondary resvr (day-1) + CASE(iopt_unlimfrc_2) ! baseflow resvr of unlimited size (0-HUGE), frac rate + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_2' ! maximum total storage in layer2 (mm) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QB_PRMS ' ! baseflow depletion rate (day-1) + CASE(iopt_topmdexp_2,iopt_unlimpow_2) ! topmodel options + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_2' ! maximum total storage in layer2 (mm) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'BASERTE ' ! baseflow rate (mm day-1) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'LOGLAMB ' ! mean value of the log-transformed topographic index (m) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'TISHAPE ' ! shape parameter for the topo index Gamma distribution (-) + ! (add extra paramater for the power-law transmissivity profile) + IF (SMODL%iARCH2.EQ.iopt_unlimpow_2) THEN ! (power-law transmissivity profile) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QB_POWR ' ! baseflow exponent (-) + ENDIF + CASE(iopt_fixedsiz_2) ! power-law relation (no parameters needed for the topo index distribution) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'MAXWATR_2' ! maximum total storage in layer2 (mm) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'BASERTE ' ! baseflow rate (mm day-1) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QB_POWR ' ! baseflow exponent (-) + CASE DEFAULT + print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" + print *, " 'topmdexp_2', or 'fixedsiz_2'" + STOP + END SELECT ! different lower-layer architecture / baseflow parameterizations) + ! --------------------------------------------------------------------------------------- + ! (5) EVAPORATION + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iESOIL) + CASE(iopt_sequential) + ! (no additional parameters for the sequential scheme) + CASE(iopt_rootweight) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'RTFRAC1 ' ! fraction of roots in the upper layer (-) + CASE DEFAULT + print *, "SMODL%iESOIL must be either iopt_sequential or iopt_rootweight'" + END SELECT ! (different evaporation schemes) + ! --------------------------------------------------------------------------------------- + ! (6) PERCOLATION + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iQPERC) + CASE(iopt_perc_f2sat,iopt_perc_w2sat) ! standard equation k(theta)**c + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'PERCRTE ' ! percolation rate (mm day-1) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'PERCEXP ' ! percolation exponent (-) + CASE(iopt_perc_lower) ! perc defined by moisture content in lower layer (SAC) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'SACPMLT ' ! multiplier in the SAC model for dry lower layer (-) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'SACPEXP ' ! exponent in the SAC model for dry lower layer (-) + CASE DEFAULT ! check for errors + print *, "SMODL%iQPERC must be iopt_perc_f2sat, iopt_perc_w2sat, or iopt_perc_lower" + STOP + END SELECT ! (different percolation options) + ! --------------------------------------------------------------------------------------- + ! (7) INTERFLOW + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iQINTF) + CASE(iopt_intflwsome) ! interflow + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'IFLWRTE ' ! interflow rate (mm day-1) + CASE(iopt_intflwnone) ! no interflow + ! (no additional parameters for the case of no interflow) + CASE DEFAULT ! check for errors + print *, "SMODL%iQINTF must be either iopt_intflwsome' or iopt_intflwnone'" + STOP + END SELECT ! (different interflow options) + ! --------------------------------------------------------------------------------------- + ! (8) SURFACE RUNOFF + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iQSURF) + CASE(iopt_arno_x_vic) ! ARNO/Xzang/VIC parameterization (upper zone control) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'AXV_BEXP ' ! ARNO/VIC "b" exponent + CASE(iopt_prms_varnt) ! PRMS variant (fraction of upper tension storage) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'SAREAMAX ' ! maximum saturated area + CASE(iopt_tmdl_param) ! TOPMODEL parameterization + ! need the topographic index if we don't have it for baseflow + IF (SMODL%iARCH2.EQ.iopt_tens2pll_2 .OR. SMODL%iARCH2.EQ.iopt_unlimfrc_2 .OR. & + SMODL%iARCH2.EQ.iopt_fixedsiz_2) THEN + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'LOGLAMB ' ! mean value of the log-transformed topographic index (m) + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'TISHAPE ' ! shape parameter for the topo index Gamma distribution (-) + ENDIF + ! need the topmodel power if we don't have it for baseflow + IF (SMODL%iARCH2.EQ.iopt_tens2pll_2 .OR. SMODL%iARCH2.EQ.iopt_unlimfrc_2 .OR. & + SMODL%iARCH2.EQ.iopt_topmdexp_2) THEN + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'QB_POWR ' ! baseflow exponent (-), used to modify the topographic index + ENDIF + CASE DEFAULT + print *, "SMODL%iQSURF must be iopt_arno_x_vic, iopt_prms_varnt, or iopt_tmdl_param" + STOP + END SELECT ! (different surface runoff options) + ! --------------------------------------------------------------------------------------- + ! (9) TIME DELAY IN RUNOFF + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iQ_TDH) + CASE(iopt_rout_gamma) ! use a Gamma distribution with shape parameter = 2.5 + MPAR=MPAR+1; LPARAM(MPAR)%PARNAME = 'TIMEDELAY' ! time delay in runoff + CASE(iopt_no_routing) ! no routing + ! (no additional parameters when there is no time delay in runoff) + CASE DEFAULT ! check for errors + print *, "SMODL%iQ_TDH must be either iopt_rout_gamma or iopt_no_routing" + STOP + END SELECT + ! --------------------------------------------------------------------------------------- + NUMPAR = MPAR ! save the number of model parameters used in a given model SMODL + ! --------------------------------------------------------------------------------------- + !DO MPAR=1,NUMPAR; WRITE(*,'(A11,1X)') LPARAM(MPAR)%PARNAME; END DO + ! --------------------------------------------------------------------------------------- + END SUBROUTINE ASSIGN_PAR + +end module ASSIGN_PAR_module diff --git a/build/FUSE_SRC/prelim/assign_stt.f90 b/build/FUSE_SRC/prelim/assign_stt.f90 index b500f22..218a047 100644 --- a/build/FUSE_SRC/prelim/assign_stt.f90 +++ b/build/FUSE_SRC/prelim/assign_stt.f90 @@ -1,60 +1,70 @@ -SUBROUTINE ASSIGN_STT() -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Build an array of strings that list model states used for the current model -! configuration -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! Defines list and number of states in MODULE model_defn -! --------------------------------------------------------------------------------------- -USE model_defn ! model definition -USE model_defnames -IMPLICIT NONE -! --------------------------------------------------------------------------------------- -NSTATE=0 -!CSTATE(:)%SNAME(1:6) = 'NO_USE' -! --------------------------------------------------------------------------------------- -! (1) DEFINE STATE VARIABLES IN THE UPPER LAYER -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iARCH1) - CASE(iopt_tension2_1) - CSTATE(NSTATE+1)%iSNAME = iopt_TENS1A - CSTATE(NSTATE+2)%iSNAME = iopt_TENS1B - CSTATE(NSTATE+3)%iSNAME = iopt_FREE_1 - NSTATE = NSTATE+3 - CASE(iopt_tension1_1) - CSTATE(NSTATE+1)%iSNAME = iopt_TENS_1 - CSTATE(NSTATE+2)%iSNAME = iopt_FREE_1 - NSTATE = NSTATE+2 - CASE(iopt_onestate_1) - CSTATE(NSTATE+1)%iSNAME = iopt_WATR_1 - NSTATE = NSTATE+1 - CASE DEFAULT - print *, "MDEFN(IMOD)%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" - STOP -END SELECT -! --------------------------------------------------------------------------------------- -! (2) DEFINE STATE VARIABLES IN THE LOWER LAYER -! --------------------------------------------------------------------------------------- -SELECT CASE(SMODL%iARCH2) - CASE(iopt_tens2pll_2) - CSTATE(NSTATE+1)%iSNAME = iopt_TENS_2 - CSTATE(NSTATE+2)%iSNAME = iopt_FREE2A - CSTATE(NSTATE+3)%iSNAME = iopt_FREE2B - NSTATE = NSTATE+3 - CASE(iopt_unlimfrc_2,iopt_unlimpow_2,iopt_topmdexp_2,iopt_fixedsiz_2) - CSTATE(NSTATE+1)%iSNAME = iopt_WATR_2 - NSTATE = NSTATE+1 - CASE DEFAULT - print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" - print *, " iopt_topmdexp_2, or iopt_fixedsiz_2" - STOP -END SELECT -! --------------------------------------------------------------------------------------- -END SUBROUTINE ASSIGN_STT +module ASSIGN_STT_module + + implicit none + private + public :: ASSIGN_STT + +contains + + SUBROUTINE ASSIGN_STT() + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Build an array of strings that list model states used for the current model + ! configuration + ! --------------------------------------------------------------------------------------- + ! Modules Modified: + ! ----------------- + ! Defines list and number of states in MODULE model_defn + ! --------------------------------------------------------------------------------------- + USE model_defn ! model definition + USE model_defnames + IMPLICIT NONE + ! --------------------------------------------------------------------------------------- + NSTATE=0 + !CSTATE(:)%SNAME(1:6) = 'NO_USE' + ! --------------------------------------------------------------------------------------- + ! (1) DEFINE STATE VARIABLES IN THE UPPER LAYER + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH1) + CASE(iopt_tension2_1) + CSTATE(NSTATE+1)%iSNAME = iopt_TENS1A + CSTATE(NSTATE+2)%iSNAME = iopt_TENS1B + CSTATE(NSTATE+3)%iSNAME = iopt_FREE_1 + NSTATE = NSTATE+3 + CASE(iopt_tension1_1) + CSTATE(NSTATE+1)%iSNAME = iopt_TENS_1 + CSTATE(NSTATE+2)%iSNAME = iopt_FREE_1 + NSTATE = NSTATE+2 + CASE(iopt_onestate_1) + CSTATE(NSTATE+1)%iSNAME = iopt_WATR_1 + NSTATE = NSTATE+1 + CASE DEFAULT + print *, "MDEFN(IMOD)%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" + STOP + END SELECT + ! --------------------------------------------------------------------------------------- + ! (2) DEFINE STATE VARIABLES IN THE LOWER LAYER + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH2) + CASE(iopt_tens2pll_2) + CSTATE(NSTATE+1)%iSNAME = iopt_TENS_2 + CSTATE(NSTATE+2)%iSNAME = iopt_FREE2A + CSTATE(NSTATE+3)%iSNAME = iopt_FREE2B + NSTATE = NSTATE+3 + CASE(iopt_unlimfrc_2,iopt_unlimpow_2,iopt_topmdexp_2,iopt_fixedsiz_2) + CSTATE(NSTATE+1)%iSNAME = iopt_WATR_2 + NSTATE = NSTATE+1 + CASE DEFAULT + print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" + print *, " iopt_topmdexp_2, or iopt_fixedsiz_2" + STOP + END SELECT + ! --------------------------------------------------------------------------------------- + END SUBROUTINE ASSIGN_STT + +end module ASSIGN_STT_module diff --git a/build/FUSE_SRC/prelim/force_info.f90 b/build/FUSE_SRC/prelim/force_info.f90 index 7f9b6eb..e86af0e 100644 --- a/build/FUSE_SRC/prelim/force_info.f90 +++ b/build/FUSE_SRC/prelim/force_info.f90 @@ -109,6 +109,7 @@ SUBROUTINE force_info(ierr,message) if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif ! close the file unit close(iunit) + ! --------------------------------------------------------------------------------------- ! initialize the check vector lCheck(:)=.false. diff --git a/build/FUSE_SRC/prelim/getparmeta.f90 b/build/FUSE_SRC/prelim/getparmeta.f90 index 774fd7b..b416b37 100644 --- a/build/FUSE_SRC/prelim/getparmeta.f90 +++ b/build/FUSE_SRC/prelim/getparmeta.f90 @@ -1,81 +1,92 @@ -SUBROUTINE GETPARMETA(err,message) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Reads parameter metadata -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multiparam -- model parameters stored in MODULE multiparam -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE fuse_fileManager,only:SETNGS_PATH,CONSTRAINTS ! defines data directory -USE data_types, ONLY: PARATT ! parameter attribute structure -USE putpar_str_module ! provide access to SUBROUTINE putpar_str -USE par_insert_module ! provide access to SUBROUTINE par_insert -IMPLICIT NONE -! dummies -integer(i4b),intent(out)::err -character(*),intent(out)::message -! locals -INTEGER(I4B) :: IUNIT ! file unit -INTEGER(I4B) :: IERR ! error code for read statement -CHARACTER(LEN=1024) :: CFILE ! name of constraints file -LOGICAL(LGT) :: LEXIST ! .TRUE. if file exists -CHARACTER(LEN=256) :: KEY ! format code -TYPE(PARATT) :: PARAM_META ! parameter metadata -INTEGER(I4B) :: IPOS,JPOS ! indices of string -INTEGER(I4B) :: ICH ! looping variable (do loop) -! --------------------------------------------------------------------------------------- -! read in control file -err=0 -IUNIT = 21 ! file unit -CFILE = TRIM(SETNGS_PATH) // TRIM(CONSTRAINTS) ! control file info shared in MODULE ddirectory -INQUIRE(FILE=CFILE,EXIST=LEXIST) ! check that control file exists -print *,'Parameter constraints file:', TRIM(CFILE) -IF (.not.LEXIST) THEN - message="f-GETPARMETA/parameter constraints file '"//trim(CFILE)//"' does not exist " - err=100; return -ENDIF -! initialize parameter strings -DO ICH=1,LEN(PARAM_META%P_NAME); PARAM_META%P_NAME(ICH:ICH)=' '; END DO -DO ICH=1,LEN(PARAM_META%CHILD1); PARAM_META%CHILD1(ICH:ICH)=' '; END DO -DO ICH=1,LEN(PARAM_META%CHILD2); PARAM_META%CHILD2(ICH:ICH)=' '; END DO -! open up parameter metadata file -OPEN(IUNIT,FILE=CFILE,STATUS='old') -! read format key (and strip out descriptive text) -READ(IUNIT,'(a256)') KEY -IPOS = INDEX(KEY,'!'); DO JPOS=IPOS,LEN(KEY); KEY(JPOS:JPOS)=' '; END DO -!PRINT *, TRIM(KEY), len_trim(key) -DO - ! read parameter constraints - READ(IUNIT,TRIM(KEY), IOSTAT=IERR) & - PARAM_META%PARFIT, & ! 'fit' (T/F) [T=parameter is fitted, F=parameter is fixed at the default value) - PARAM_META%PARSTK, & ! flag (0=deterministic, 1=stochastic) - PARAM_META%PARDEF, & ! default parameter set - PARAM_META%PARLOW, & ! lower limit of each parameter - PARAM_META%PARUPP, & ! upper limit of each parameter - PARAM_META%FRSEED, & ! fraction param space used as offset for "reasonable" bounds - PARAM_META%PARSCL, & ! typical scale of parameter - PARAM_META%PARVTN, & ! method used for variable transformation - PARAM_META%PARDIS, & ! parametric form of prob dist used for prior/hyper - PARAM_META%PARQTN, & ! transformation applied before use of prob dist - PARAM_META%PARLAT, & ! number of latent variables (0=onePerStep, -1=from data) - PARAM_META%PARMTH, & ! imeth for all variables ???what is this??? - PARAM_META%NPRIOR, & ! number of prior/hyper-parameters - PARAM_META%P_NAME, & ! parameter name - PARAM_META%CHILD1, & ! name of 1st parameter child - PARAM_META%CHILD2 ! name of 2nd parameter child - IF (IERR.NE.0) EXIT - !WRITE(*,TRIM(KEY)) PARAM_META - ! put parameters in data structures - CALL PUTPAR_STR(PARAM_META, PARAM_META%P_NAME) - ! populate the model parameter structure with default values - CALL PAR_INSERT(PARAM_META%PARDEF,PARAM_META%P_NAME) -END DO -CLOSE(IUNIT) -END SUBROUTINE GETPARMETA +module GETPARMETA_module + + implicit none + + private + public :: GETPARMETA + +contains + + SUBROUTINE GETPARMETA(err,message) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2009 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Reads parameter metadata from the parameter constraints file + ! --------------------------------------------------------------------------------------- + ! Modules Modified: + ! ----------------- + ! MODULE multiparam -- model parameters stored in MODULE multiparam + ! --------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE fuse_fileManager,only:SETNGS_PATH,CONSTRAINTS ! defines data directory + USE data_types, ONLY: PARATT ! parameter attribute structure + USE putpar_str_module ! provide access to SUBROUTINE putpar_str + USE par_insert_module ! provide access to SUBROUTINE par_insert + IMPLICIT NONE + ! dummies + integer(i4b),intent(out)::err + character(*),intent(out)::message + ! locals + INTEGER(I4B) :: IUNIT ! file unit + INTEGER(I4B) :: IERR ! error code for read statement + CHARACTER(LEN=1024) :: CFILE ! name of constraints file + LOGICAL(LGT) :: LEXIST ! .TRUE. if file exists + CHARACTER(LEN=256) :: KEY ! format code + TYPE(PARATT) :: PARAM_META ! parameter metadata + INTEGER(I4B) :: IPOS,JPOS ! indices of string + INTEGER(I4B) :: ICH ! looping variable (do loop) + ! --------------------------------------------------------------------------------------- + ! read in control file + err=0 + IUNIT = 21 ! file unit + CFILE = TRIM(SETNGS_PATH) // TRIM(CONSTRAINTS) ! control file info shared in MODULE ddirectory + INQUIRE(FILE=CFILE,EXIST=LEXIST) ! check that control file exists + print *,'Parameter constraints file:', TRIM(CFILE) + IF (.not.LEXIST) THEN + message="f-GETPARMETA/parameter constraints file '"//trim(CFILE)//"' does not exist " + err=100; return + ENDIF + ! initialize parameter strings + DO ICH=1,LEN(PARAM_META%P_NAME); PARAM_META%P_NAME(ICH:ICH)=' '; END DO + DO ICH=1,LEN(PARAM_META%CHILD1); PARAM_META%CHILD1(ICH:ICH)=' '; END DO + DO ICH=1,LEN(PARAM_META%CHILD2); PARAM_META%CHILD2(ICH:ICH)=' '; END DO + ! open up parameter metadata file + OPEN(IUNIT,FILE=CFILE,STATUS='old') + ! read format key (and strip out descriptive text) + READ(IUNIT,'(a256)') KEY + IPOS = INDEX(KEY,'!'); DO JPOS=IPOS,LEN(KEY); KEY(JPOS:JPOS)=' '; END DO + !PRINT *, TRIM(KEY), len_trim(key) + DO + ! read parameter constraints + READ(IUNIT,TRIM(KEY), IOSTAT=IERR) & + PARAM_META%PARFIT, & ! 'fit' (T/F) [T=parameter is fitted, F=parameter is fixed at the default value) + PARAM_META%PARSTK, & ! flag (0=deterministic, 1=stochastic) + PARAM_META%PARDEF, & ! default parameter set + PARAM_META%PARLOW, & ! lower limit of each parameter + PARAM_META%PARUPP, & ! upper limit of each parameter + PARAM_META%FRSEED, & ! fraction param space used as offset for "reasonable" bounds + PARAM_META%PARSCL, & ! typical scale of parameter + PARAM_META%PARVTN, & ! method used for variable transformation + PARAM_META%PARDIS, & ! parametric form of prob dist used for prior/hyper + PARAM_META%PARQTN, & ! transformation applied before use of prob dist + PARAM_META%PARLAT, & ! number of latent variables (0=onePerStep, -1=from data) + PARAM_META%PARMTH, & ! imeth for all variables ???what is this??? + PARAM_META%NPRIOR, & ! number of prior/hyper-parameters + PARAM_META%P_NAME, & ! parameter name + PARAM_META%CHILD1, & ! name of 1st parameter child + PARAM_META%CHILD2 ! name of 2nd parameter child + IF (IERR.NE.0) EXIT + !WRITE(*,TRIM(KEY)) PARAM_META + ! put parameters in data structures + CALL PUTPAR_STR(PARAM_META, PARAM_META%P_NAME) + ! populate the model parameter structure with default values + CALL PAR_INSERT(PARAM_META%PARDEF,PARAM_META%P_NAME) + END DO + CLOSE(IUNIT) + END SUBROUTINE GETPARMETA + +end module GETPARMETA_module diff --git a/build/FUSE_SRC/prelim/init_state.f90 b/build/FUSE_SRC/prelim/init_state.f90 index ea88d82..e792e1f 100644 --- a/build/FUSE_SRC/prelim/init_state.f90 +++ b/build/FUSE_SRC/prelim/init_state.f90 @@ -35,7 +35,7 @@ SUBROUTINE INIT_STATE(FRAC) FSTATE%WATR_2 = MPARAM%MAXWATR_2 * FRAC ! snow model, assume no snow at start DO ISNW=1,N_BANDS - MBANDS(ISNW)%SWE = 0.0_sp + MBANDS(ISNW)%var%SWE = 0.0_sp END DO ! (routed runoff) FUTURE = 0._sp diff --git a/build/FUSE_SRC/prelim/par_derive.f90 b/build/FUSE_SRC/prelim/par_derive.f90 index 8a1b699..e36e869 100644 --- a/build/FUSE_SRC/prelim/par_derive.f90 +++ b/build/FUSE_SRC/prelim/par_derive.f90 @@ -1,35 +1,44 @@ -SUBROUTINE PAR_DERIVE(err,message) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Computes derived model parameters (bucket sizes, etc.) -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE multiparam -- model parameters stored in MODULE multiparam -! --------------------------------------------------------------------------------------- -USE nrtype ! define data types -USE model_defn, ONLY: SMODL ! model definition structures -USE model_defnames -USE multiparam, ONLY: MPARAM,DPARAM ! model parameter structures -IMPLICIT NONE -! dummies -integer(i4b),intent(out)::err -character(*),intent(out)::message -! --------------------------------------------------------------------------------------- -err=0 -CALL BUCKETSIZE() ! compute bucket size -CALL MEAN_TIPOW() ! mean of the power-transformed topo index -CALL QBSATURATN() ! compute baseflow at saturation (used in the SAC percolation model) -CALL QTIMEDELAY(err,message) ! compute fraction of runoff in future time steps -if(err/=0)then - err=10; message="f-PAR_DERIVE/&"//trim(message); return -endif -! --------------------------------------------------------------------------------------- -IF (SMODL%iESOIL.EQ.iopt_rootweight) DPARAM%RTFRAC2 = 1._SP - MPARAM%RTFRAC1 -! --------------------------------------------------------------------------------------- -END SUBROUTINE PAR_DERIVE +module PAR_DERIVE_module + implicit none + private + public :: PAR_DERIVE + +contains + + SUBROUTINE PAR_DERIVE(err,message) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Computes derived model parameters (bucket sizes, etc.) + ! --------------------------------------------------------------------------------------- + ! Modules Modified: + ! ----------------- + ! MODULE multiparam -- model parameters stored in MODULE multiparam + ! --------------------------------------------------------------------------------------- + USE nrtype ! define data types + USE model_defn, ONLY: SMODL ! model definition structures + USE model_defnames + USE multiparam, ONLY: MPARAM,DPARAM ! model parameter structures + IMPLICIT NONE + ! dummies + integer(i4b),intent(out)::err + character(*),intent(out)::message + ! --------------------------------------------------------------------------------------- + err=0 + CALL BUCKETSIZE() ! compute bucket size + CALL MEAN_TIPOW() ! mean of the power-transformed topo index + CALL QBSATURATN() ! compute baseflow at saturation (used in the SAC percolation model) + CALL QTIMEDELAY(err,message) ! compute fraction of runoff in future time steps + if(err/=0)then + err=10; message="f-PAR_DERIVE/&"//trim(message); return + endif + ! --------------------------------------------------------------------------------------- + IF (SMODL%iESOIL.EQ.iopt_rootweight) DPARAM%RTFRAC2 = 1._SP - MPARAM%RTFRAC1 + ! --------------------------------------------------------------------------------------- + END SUBROUTINE PAR_DERIVE + +end module PAR_DERIVE_module diff --git a/build/FUSE_SRC/prelim/parse_command_args.f90 b/build/FUSE_SRC/prelim/parse_command_args.f90 index 0566ff1..bfb2321 100644 --- a/build/FUSE_SRC/prelim/parse_command_args.f90 +++ b/build/FUSE_SRC/prelim/parse_command_args.f90 @@ -20,6 +20,8 @@ subroutine parse_command_args(opts, err, message) integer(i4b) :: i ! index of command line argument character(len=:) , allocatable :: a, v ! command line arguments character(len=:) , allocatable :: cIndex ! character index + character(len=:) , allocatable :: kv, pname, pval_str ! parameter strings + real(sp) :: pval ! parameter value integer(i4b) :: nArg ! number of command line arguments character(len=:) , allocatable :: cmessage ! initialize error control @@ -35,8 +37,8 @@ subroutine parse_command_args(opts, err, message) ! -s/--sets (required for idx,opt) ! -i/--index (required for idx) ! -r/--restart (optional) - ! -p/--progress (optional) ! -t/--tag (optional) + ! -p/--param (optional) ! -v/--version (prints version info and exits) ! -h/--help (prints help and exits) ! ----------------------------------------------------------------------------------------- @@ -78,6 +80,10 @@ subroutine parse_command_args(opts, err, message) opts%domain_id = trim(v) i = i + 2 + case ('-p', '--param') + call require_next(i, narg, a, kv, err, cmessage) + i = i + 2 + case ('-s','--sets','--param-sets') call require_next(i, narg, a, v, err, cmessage) opts%sets_file = trim(v) @@ -92,11 +98,6 @@ subroutine parse_command_args(opts, err, message) opts%restart_freq = to_lower(trim(v)) i = i + 2 - case ('-p','--progress') - call require_next(i, narg, a, v, err, cmessage) - opts%progress_freq = to_lower(trim(v)) - i = i + 2 - case default if (len_trim(a) > 0 .and. a(1:1) == '-') then err = 1 @@ -113,6 +114,27 @@ subroutine parse_command_args(opts, err, message) err=20; return endif + ! process parameters -- needs to be in the do loop since multiple parameters + if(allocated(kv))then + + ! split name/value based on the equal sign + call split_param_kv(trim(kv), pname, pval_str, err, cmessage) + if(err /= 0)then; message=trim(message)//trim(cmessage); err=20; return; endif + + ! convert characters to real values + call parse_real_sp(pval_str, pval, err, cmessage) + if (err /= 0) then + message=trim(message)//"invalid --param value for "//trim(pname)//": "//trim(cmessage) + err=20; return + end if + + ! add to structure in opts + call push_param(opts%param_name, opts%param_value, pname, pval) + print*, opts%param_name + print*, opts%param_value + + endif ! if processing parameters + end do ! looping through arguments ! Early exits @@ -172,11 +194,6 @@ subroutine parse_command_args(opts, err, message) err = 1; message = trim(message)//"invalid --restart: "//trim(opts%restart_freq)//" (expect y|m|d|e|never)"; return end if end if - if (allocated(opts%progress_freq)) then - if (.not. is_valid_progress(opts%progress_freq)) then - err = 1; message = trim(message)//"invalid --progress: "//trim(opts%progress_freq)//" (expect m|d|h|never)"; return - end if - end if end subroutine parse_command_args @@ -226,7 +243,6 @@ subroutine printCommandHelp() print "(A)", "Optional:" print "(A)", " -r, --restart y|m|d|e|never" - print "(A)", " -p, --progress m|d|h|never" print "(A)", " -t, --tag Add tag to output filename" print "(A)", " -v, --version Print version info and exit" print "(A)", " -h, --help Print this help and exit" @@ -237,8 +253,8 @@ subroutine printCommandHelp() print "(A)", " fuse.exe -d camels-12345 -c ./control/FUSE_control.txt -m def" print "(A)", "" - print "(A)", " Default run with restart and progress output:" - print "(A)", " fuse.exe -d camels-12345 -c ./control/FUSE_control.txt -m def -r d -p h" + print "(A)", " Default run and write restart file every day:" + print "(A)", " fuse.exe -d camels-12345 -c ./control/FUSE_control.txt -m def -r d" print "(A)", "" print "(A)", " Run using parameter set index 17 from a sets file:" @@ -287,6 +303,45 @@ subroutine require_next(i, narg, opt, val, err, message) call get_arg(i+1, val) end subroutine require_next + subroutine split_param_kv(kv, name, val, err, message) + character(len=*), intent(in) :: kv + character(len=:), allocatable, intent(out) :: name, val + integer(i4b), intent(out) :: err + character(len=:), allocatable, intent(out) :: message + integer(i4b) :: p + + err = 0; message = "" + p = index(kv, '=') + if (p <= 1 .or. p >= len_trim(kv)) then + err = 1 + message = "expected NAME=VALUE after --param, got: "//trim(kv) + return + end if + + name = adjustl(kv(1:p-1)) + val = adjustl(kv(p+1:)) + + if (len_trim(name) == 0 .or. len_trim(val) == 0) then + err = 1 + message = "expected NAME=VALUE after --param, got: "//trim(kv) + return + end if + end subroutine split_param_kv + + subroutine parse_real_sp(s, x, err, message) + character(len=*), intent(in) :: s + real(sp), intent(out) :: x + integer, intent(out) :: err + character(len=:), allocatable, intent(out) :: message + integer(i4b) :: ios + err = 0; message = "" + read(s, *, iostat=ios) x + if (ios /= 0) then + err = 1 + message = "invalid real: "//trim(s) + end if + end subroutine parse_real_sp + subroutine parse_int(s, x, err, message) character(len=*), intent(in) :: s integer, intent(out) :: x @@ -315,6 +370,36 @@ pure function to_lower(s) result(t) end do end function to_lower + subroutine push_param(pnames, pvals, name, val) + use nrtype + implicit none + character(len=:), allocatable, intent(inout) :: pnames(:) + real(sp), allocatable, intent(inout) :: pvals(:) + character(len=*), intent(in) :: name + real(sp), intent(in) :: val + + character(len=:), allocatable :: new_names(:) + real(sp), allocatable :: new_vals(:) + integer :: n + + n = 0 + if (allocated(pvals)) n = size(pvals) + + allocate(character(len=len_trim(name)) :: new_names(n+1)) + allocate(new_vals(n+1)) + + if (n > 0) then + new_names(1:n) = pnames + new_vals(1:n) = pvals + end if + + new_names(n+1) = trim(name) + new_vals(n+1) = val + + call move_alloc(new_names, pnames) + call move_alloc(new_vals, pvals) + end subroutine push_param + pure logical function is_valid_mode(m) character(len=*), intent(in) :: m is_valid_mode = (trim(m) == 'def' .or. trim(m) == 'idx' .or. trim(m) == 'opt' .or. trim(m) == 'sce') @@ -325,11 +410,6 @@ pure logical function is_valid_restart(f) is_valid_restart = (trim(f) == 'y' .or. trim(f) == 'm' .or. trim(f) == 'd' .or. trim(f) == 'e' .or. trim(f) == 'never') end function is_valid_restart - pure logical function is_valid_progress(f) - character(len=*), intent(in) :: f - is_valid_progress = (trim(f) == 'm' .or. trim(f) == 'd' .or. trim(f) == 'h' .or. trim(f) == 'never') - end function is_valid_progress - end module parse_command_args_MODULE diff --git a/build/FUSE_SRC/prelim/uniquemodl.f90 b/build/FUSE_SRC/prelim/uniquemodl.f90 index e9de2a7..a2ea619 100644 --- a/build/FUSE_SRC/prelim/uniquemodl.f90 +++ b/build/FUSE_SRC/prelim/uniquemodl.f90 @@ -1,139 +1,149 @@ -SUBROUTINE UNIQUEMODL(NMOD) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2007; modified in 2008 to include rainfall errors -! Modified by Brian Henn to include snow model, 6/2013 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Creates an array of character strings that define different model combinations -! --------------------------------------------------------------------------------------- -! Modules Modified: -! ----------------- -! MODULE model_defn -! LIST_* = lists of options for * different model components -! AMODL%* = structure that holds all (NMOD) unique combinations -! --------------------------------------------------------------------------------------- -USE nrtype -USE model_defn -USE model_defnames -IMPLICIT NONE -! Output -INTEGER(I4B) :: NMOD ! number of model combinations -! Internal -INTEGER(I4B) :: ICOUNT ! loop through unique models -INTEGER(I4B) :: ISW_RFERR ! loop thru rainfall errors -INTEGER(I4B) :: ISW_ARCH1 ! loop thru upper layer architecture -INTEGER(I4B) :: ISW_ARCH2 ! loop thru lower layer architecture -INTEGER(I4B) :: ISW_QSURF ! loop thru surface runoff -INTEGER(I4B) :: ISW_QPERC ! loop thru percolation -INTEGER(I4B) :: ISW_ESOIL ! loop thru evaporation -INTEGER(I4B) :: ISW_QINTF ! loop thru interflow -INTEGER(I4B) :: ISW_Q_TDH ! loop thru time delay options -INTEGER(I4B) :: ISW_SNOWM ! loop thru snow model options -! Start procedure here -!err=0; message="UNIQUEMODL/ok" -! --------------------------------------------------------------------------------------- -! (1) POPULATE LISTS OF OPTIONS FOR THE DIFFERENT MODEL COMPONENTS -! --------------------------------------------------------------------------------------- -! rainfall error -LIST_RFERR(1)%MCOMPONENT = 'additive_e' ! additive rainfall error -LIST_RFERR(2)%MCOMPONENT = 'multiplc_e' ! multiplicative rainfall error -! upper-layer architecture -LIST_ARCH1(1)%MCOMPONENT = 'tension1_1' ! upper layer broken up into tension and free storage -LIST_ARCH1(2)%MCOMPONENT = 'tension2_1' ! tension storage sub-divided into recharge and excess -LIST_ARCH1(3)%MCOMPONENT = 'onestate_1' ! upper layer defined by a single state variable -! lower-layer architecture -- defines method for computing baseflow -LIST_ARCH2(1)%MCOMPONENT = 'tens2pll_2' ! tension reservoir plus two parallel tanks -LIST_ARCH2(2)%MCOMPONENT = 'unlimfrc_2' ! baseflow resvr of unlimited size (0-HUGE), frac rate -LIST_ARCH2(3)%MCOMPONENT = 'unlimpow_2' ! baseflow resvr of unlimited size (0-HUGE), power recession -LIST_ARCH2(4)%MCOMPONENT = 'fixedsiz_2' ! baseflow reservoir of fixed size -! surface runoff -LIST_QSURF(1)%MCOMPONENT = 'arno_x_vic' ! ARNO/Xzang/VIC parameterization (upper zone control) -LIST_QSURF(2)%MCOMPONENT = 'prms_varnt' ! PRMS variant (fraction of upper tension storage) -LIST_QSURF(3)%MCOMPONENT = 'tmdl_param' ! TOPMODEL parameterization (only valid for TOPMODEL qb) -! percolation -LIST_QPERC(1)%MCOMPONENT = 'perc_f2sat' ! water from (field cap to sat) avail for percolation -LIST_QPERC(2)%MCOMPONENT = 'perc_w2sat' ! water from (wilt pt to sat) avail for percolation -LIST_QPERC(3)%MCOMPONENT = 'perc_lower' ! perc defined by moisture content in lower layer (SAC) -! evaporation fluxes (lower layer evap = 0 for ['tension2_1','unlimfrc_2','unlimpow_2','topmdexp_2'] -LIST_ESOIL(1)%MCOMPONENT = 'sequential' ! sequential evaporation model -LIST_ESOIL(2)%MCOMPONENT = 'rootweight' ! root weighting -! interflow -LIST_QINTF(1)%MCOMPONENT = 'intflwnone' ! no interflow -LIST_QINTF(2)%MCOMPONENT = 'intflwsome' ! interflow -! time delay in runoff -LIST_Q_TDH(1)%MCOMPONENT = 'rout_gamma' ! use a Gamma distribution with shape parameter = 2.5 -LIST_Q_TDH(2)%MCOMPONENT = 'no_routing' ! no routing -! snow model switch -LIST_SNOWM(1)%MCOMPONENT = 'no_snowmod' ! no snow model -LIST_SNOWM(2)%MCOMPONENT = 'temp_index' ! temperature index snow model -! --------------------------------------------------------------------------------------- -! (2) LOOP THROUGH MODEL COMPONENTS AND DEFINE A SET OF UNIQUE MODELS -! --------------------------------------------------------------------------------------- -! sequence of model-building decisions -! a) define rainfall error -! b) define upper-layer architecture -! c) define lower-layer architecture -! d) define surface runoff method -! e) define percolation method -! f) define evaporation method -! g) define interflow method -! h) define time delay in runoff -ICOUNT = 0 ! initialize counter -! loop through snow model options -DO ISW_SNOWM=1,SIZE(LIST_SNOWM) -! (loop through time delay options) -DO ISW_Q_TDH=1,SIZE(LIST_Q_TDH) - ! (loop through interflow options) - DO ISW_QINTF=1,SIZE(LIST_QINTF) - ! (loop through evaporation options) - DO ISW_ESOIL=1,SIZE(LIST_ESOIL) - ! (loop through percolation options) - DO ISW_QPERC=1,SIZE(LIST_QPERC) - ! (loop through surface runoff options) - DO ISW_QSURF=1,SIZE(LIST_QSURF) - ! (loop through lower-layer architecture options) - DO ISW_ARCH2=1,SIZE(LIST_ARCH2) - ! (loop through upper-layer architecture options) - DO ISW_ARCH1=1,SIZE(LIST_ARCH1) - ! (loop through rainfall error options) - DO ISW_RFERR=1,SIZE(LIST_RFERR) - ! don't allow a lower tension tank when there are two upper ones - IF (LIST_ARCH1(ISW_ARCH1)%MCOMPONENT(1:10).EQ.'tension2_1'.AND. & - LIST_ARCH2(ISW_ARCH2)%MCOMPONENT(1:10).EQ.'tens2pll_2') CYCLE - ! don't allow percolation below field capacity if there are multiple upper tanks - IF (LIST_ARCH1(ISW_ARCH1)%MCOMPONENT(1:10).NE.'onestate_1'.AND. & - LIST_QPERC(ISW_QPERC)%MCOMPONENT(1:10).EQ.'perc_w2sat') CYCLE - ICOUNT = ICOUNT + 1 ! (increment counter) - IF (ICOUNT.LE.SIZE(AMODL)) THEN - ! save unique model combinations - AMODL(ICOUNT)%iRFERR = desc_str2int(LIST_RFERR(ISW_RFERR)%MCOMPONENT) - AMODL(ICOUNT)%iARCH1 = desc_str2int(LIST_ARCH1(ISW_ARCH1)%MCOMPONENT) - AMODL(ICOUNT)%iARCH2 = desc_str2int(LIST_ARCH2(ISW_ARCH2)%MCOMPONENT) - AMODL(ICOUNT)%iQSURF = desc_str2int(LIST_QSURF(ISW_QSURF)%MCOMPONENT) - AMODL(ICOUNT)%iQPERC = desc_str2int(LIST_QPERC(ISW_QPERC)%MCOMPONENT) - AMODL(ICOUNT)%iESOIL = desc_str2int(LIST_ESOIL(ISW_ESOIL)%MCOMPONENT) - AMODL(ICOUNT)%iQINTF = desc_str2int(LIST_QINTF(ISW_QINTF)%MCOMPONENT) - AMODL(ICOUNT)%iQ_TDH = desc_str2int(LIST_Q_TDH(ISW_Q_TDH)%MCOMPONENT) - AMODL(ICOUNT)%iSNOWM = desc_str2int(LIST_Q_TDH(ISW_SNOWM)%MCOMPONENT) - !write(*,'(i3,1x,7(a10,1x))') icount, amodl(icount) - ELSE - ! need to allocate more space - print *, 'insufficent space to hold model combinations' - stop - ENDIF - END DO ! RFERR - END DO ! ARCH1 - END DO ! ARCH2 - END DO ! QSURF - END DO ! QPERC - END DO ! ESOIL - END DO ! QINTF -END DO ! Q_TDH -END DO ! SNOWM -! --------------------------------------------------------------------------------------- -NMOD = ICOUNT -!pause -END SUBROUTINE UNIQUEMODL +module uniquemodl_module + implicit none + private + public :: uniquemodl + +contains + + + SUBROUTINE UNIQUEMODL(NMOD) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007; modified in 2008 to include rainfall errors + ! Modified by Brian Henn to include snow model, 6/2013 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Creates an array of character strings that define different model combinations + ! --------------------------------------------------------------------------------------- + ! Modules Modified: + ! ----------------- + ! MODULE model_defn + ! LIST_* = lists of options for * different model components + ! AMODL%* = structure that holds all (NMOD) unique combinations + ! --------------------------------------------------------------------------------------- + USE nrtype + USE model_defn + USE model_defnames + IMPLICIT NONE + ! Output + INTEGER(I4B) , intent(out) :: NMOD ! number of model combinations + ! Internal + INTEGER(I4B) :: ICOUNT ! loop through unique models + INTEGER(I4B) :: ISW_RFERR ! loop thru rainfall errors + INTEGER(I4B) :: ISW_ARCH1 ! loop thru upper layer architecture + INTEGER(I4B) :: ISW_ARCH2 ! loop thru lower layer architecture + INTEGER(I4B) :: ISW_QSURF ! loop thru surface runoff + INTEGER(I4B) :: ISW_QPERC ! loop thru percolation + INTEGER(I4B) :: ISW_ESOIL ! loop thru evaporation + INTEGER(I4B) :: ISW_QINTF ! loop thru interflow + INTEGER(I4B) :: ISW_Q_TDH ! loop thru time delay options + INTEGER(I4B) :: ISW_SNOWM ! loop thru snow model options + ! Start procedure here + !err=0; message="UNIQUEMODL/ok" + ! --------------------------------------------------------------------------------------- + ! (1) POPULATE LISTS OF OPTIONS FOR THE DIFFERENT MODEL COMPONENTS + ! --------------------------------------------------------------------------------------- + ! rainfall error + LIST_RFERR(1)%MCOMPONENT = 'additive_e' ! additive rainfall error + LIST_RFERR(2)%MCOMPONENT = 'multiplc_e' ! multiplicative rainfall error + ! upper-layer architecture + LIST_ARCH1(1)%MCOMPONENT = 'tension1_1' ! upper layer broken up into tension and free storage + LIST_ARCH1(2)%MCOMPONENT = 'tension2_1' ! tension storage sub-divided into recharge and excess + LIST_ARCH1(3)%MCOMPONENT = 'onestate_1' ! upper layer defined by a single state variable + ! lower-layer architecture -- defines method for computing baseflow + LIST_ARCH2(1)%MCOMPONENT = 'tens2pll_2' ! tension reservoir plus two parallel tanks + LIST_ARCH2(2)%MCOMPONENT = 'unlimfrc_2' ! baseflow resvr of unlimited size (0-HUGE), frac rate + LIST_ARCH2(3)%MCOMPONENT = 'unlimpow_2' ! baseflow resvr of unlimited size (0-HUGE), power recession + LIST_ARCH2(4)%MCOMPONENT = 'fixedsiz_2' ! baseflow reservoir of fixed size + ! surface runoff + LIST_QSURF(1)%MCOMPONENT = 'arno_x_vic' ! ARNO/Xzang/VIC parameterization (upper zone control) + LIST_QSURF(2)%MCOMPONENT = 'prms_varnt' ! PRMS variant (fraction of upper tension storage) + LIST_QSURF(3)%MCOMPONENT = 'tmdl_param' ! TOPMODEL parameterization (only valid for TOPMODEL qb) + ! percolation + LIST_QPERC(1)%MCOMPONENT = 'perc_f2sat' ! water from (field cap to sat) avail for percolation + LIST_QPERC(2)%MCOMPONENT = 'perc_w2sat' ! water from (wilt pt to sat) avail for percolation + LIST_QPERC(3)%MCOMPONENT = 'perc_lower' ! perc defined by moisture content in lower layer (SAC) + ! evaporation fluxes (lower layer evap = 0 for ['tension2_1','unlimfrc_2','unlimpow_2','topmdexp_2'] + LIST_ESOIL(1)%MCOMPONENT = 'sequential' ! sequential evaporation model + LIST_ESOIL(2)%MCOMPONENT = 'rootweight' ! root weighting + ! interflow + LIST_QINTF(1)%MCOMPONENT = 'intflwnone' ! no interflow + LIST_QINTF(2)%MCOMPONENT = 'intflwsome' ! interflow + ! time delay in runoff + LIST_Q_TDH(1)%MCOMPONENT = 'rout_gamma' ! use a Gamma distribution with shape parameter = 2.5 + LIST_Q_TDH(2)%MCOMPONENT = 'no_routing' ! no routing + ! snow model switch + LIST_SNOWM(1)%MCOMPONENT = 'no_snowmod' ! no snow model + LIST_SNOWM(2)%MCOMPONENT = 'temp_index' ! temperature index snow model + ! --------------------------------------------------------------------------------------- + ! (2) LOOP THROUGH MODEL COMPONENTS AND DEFINE A SET OF UNIQUE MODELS + ! --------------------------------------------------------------------------------------- + ! sequence of model-building decisions + ! a) define rainfall error + ! b) define upper-layer architecture + ! c) define lower-layer architecture + ! d) define surface runoff method + ! e) define percolation method + ! f) define evaporation method + ! g) define interflow method + ! h) define time delay in runoff + ICOUNT = 0 ! initialize counter + ! loop through snow model options + DO ISW_SNOWM=1,SIZE(LIST_SNOWM) + ! (loop through time delay options) + DO ISW_Q_TDH=1,SIZE(LIST_Q_TDH) + ! (loop through interflow options) + DO ISW_QINTF=1,SIZE(LIST_QINTF) + ! (loop through evaporation options) + DO ISW_ESOIL=1,SIZE(LIST_ESOIL) + ! (loop through percolation options) + DO ISW_QPERC=1,SIZE(LIST_QPERC) + ! (loop through surface runoff options) + DO ISW_QSURF=1,SIZE(LIST_QSURF) + ! (loop through lower-layer architecture options) + DO ISW_ARCH2=1,SIZE(LIST_ARCH2) + ! (loop through upper-layer architecture options) + DO ISW_ARCH1=1,SIZE(LIST_ARCH1) + ! (loop through rainfall error options) + DO ISW_RFERR=1,SIZE(LIST_RFERR) + ! don't allow a lower tension tank when there are two upper ones + IF (LIST_ARCH1(ISW_ARCH1)%MCOMPONENT(1:10).EQ.'tension2_1'.AND. & + LIST_ARCH2(ISW_ARCH2)%MCOMPONENT(1:10).EQ.'tens2pll_2') CYCLE + ! don't allow percolation below field capacity if there are multiple upper tanks + IF (LIST_ARCH1(ISW_ARCH1)%MCOMPONENT(1:10).NE.'onestate_1'.AND. & + LIST_QPERC(ISW_QPERC)%MCOMPONENT(1:10).EQ.'perc_w2sat') CYCLE + ICOUNT = ICOUNT + 1 ! (increment counter) + IF (ICOUNT.LE.SIZE(AMODL)) THEN + ! save unique model combinations + AMODL(ICOUNT)%iRFERR = desc_str2int(LIST_RFERR(ISW_RFERR)%MCOMPONENT) + AMODL(ICOUNT)%iARCH1 = desc_str2int(LIST_ARCH1(ISW_ARCH1)%MCOMPONENT) + AMODL(ICOUNT)%iARCH2 = desc_str2int(LIST_ARCH2(ISW_ARCH2)%MCOMPONENT) + AMODL(ICOUNT)%iQSURF = desc_str2int(LIST_QSURF(ISW_QSURF)%MCOMPONENT) + AMODL(ICOUNT)%iQPERC = desc_str2int(LIST_QPERC(ISW_QPERC)%MCOMPONENT) + AMODL(ICOUNT)%iESOIL = desc_str2int(LIST_ESOIL(ISW_ESOIL)%MCOMPONENT) + AMODL(ICOUNT)%iQINTF = desc_str2int(LIST_QINTF(ISW_QINTF)%MCOMPONENT) + AMODL(ICOUNT)%iQ_TDH = desc_str2int(LIST_Q_TDH(ISW_Q_TDH)%MCOMPONENT) + AMODL(ICOUNT)%iSNOWM = desc_str2int(LIST_Q_TDH(ISW_SNOWM)%MCOMPONENT) + !write(*,'(i3,1x,7(a10,1x))') icount, amodl(icount) + ELSE + ! need to allocate more space + print *, 'insufficent space to hold model combinations' + stop + ENDIF + END DO ! RFERR + END DO ! ARCH1 + END DO ! ARCH2 + END DO ! QSURF + END DO ! QPERC + END DO ! ESOIL + END DO ! QINTF + END DO ! Q_TDH + END DO ! SNOWM + ! --------------------------------------------------------------------------------------- + NMOD = ICOUNT + !pause + END SUBROUTINE UNIQUEMODL + +end module uniquemodl_module diff --git a/build/FUSE_SRC/runtime/get_time_windows.f90 b/build/FUSE_SRC/runtime/get_time_windows.f90 new file mode 100644 index 0000000..d6cda58 --- /dev/null +++ b/build/FUSE_SRC/runtime/get_time_windows.f90 @@ -0,0 +1,340 @@ +module time_windows_module + + use nrtype + use netcdf + use data_types, only: domain_type + use fuse_fileManager, only: date_start_sim, date_end_sim, date_start_eval, date_end_eval, numtim_sub_str + use time_io, only: date_extractor, juldayss + + implicit none + + private + public :: get_time_windows + public :: export_time_to_multiforce + + contains + + subroutine get_time_windows(ncid, domain, ierr, message) + + integer(i4b), intent(in) :: ncid + type(domain_type), intent(inout) :: domain + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + integer(i4b) :: nt + real(sp), allocatable :: time_steps(:) + character(len=1024) :: units_local + integer(i4b) :: ios + character(len=1024) :: cmessage + + ierr=0; message="get_time_windows/" + + ! ----- read forcing time axis ------------------------------------------------------ + + call read_time_axis(ncid, time_steps, units_local, nt, ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + + domain%info%time%nt_global = nt + domain%info%time%units = trim(units_local) + + ! ----- build julian-day axis ------------------------------------------------------- + + call build_julian_axis(time_steps, trim(units_local), domain%info%time%jdate_ref, domain%info%time%jdate, ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! ----- compute indices for sim/eval windows ---------------------------------------- + + ! simulation indices + call map_dates_to_indices(domain%info%time%jdate, date_start_sim, date_end_sim, & + domain%info%time%sim_beg, domain%info%time%sim_end, ierr, cmessage) + if (ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! evaluation indices + call map_dates_to_indices(domain%info%time%jdate, date_start_eval, date_end_eval, & + domain%info%time%eval_beg, domain%info%time%eval_end, ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! ----- validate window consistency ------------------------------------------------- + + call validate_windows(domain%info%time, ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! ----- derive simulation length ---------------------------------------------------- + + domain%info%time%nt_sim = domain%info%time%sim_end - domain%info%time%sim_beg + 1 + + ! ----- configure sub-period windowing ---------------------------------------------- + + ! convert sub-period string to integer + read(numtim_sub_str,*,iostat=ios) domain%info%time%nt_window + if(ios/=0) then + ierr=1; message=trim(message)//"cannot parse numtim_sub_str"; return + endif + + ! handle cases where sub-periods are undefined + if(domain%info%time%nt_window == -9999) then + domain%info%time%use_subperiods = .false. + domain%info%time%nt_window = domain%info%time%nt_sim + else + domain%info%time%use_subperiods = .true. + ! keep nt_window as user-chosen chunk size + endif + + ! ----- validate time-window configuration (subperiods allowed only in grid mode) --- + if( (.not. domain%info%space%grid_flag) .and. domain%info%time%use_subperiods ) then + ierr = 1 + message = trim(message)// & + "catchment mode requires running the full time series in one chunk; " // & + "set numtim_sub = -9999 in the filemanager." + return + endif + + ! ----- finalize -------------------------------------------------------------------- + + if(allocated(time_steps)) deallocate(time_steps) + + end subroutine get_time_windows + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- backwards compatibility: export to multiforce globals ------------------------- + + ! - New code stores all time-window metadata in domain%info%time (source of truth). + ! - Legacy routines still read multiforce globals (sim_beg, sim_end, numtim_sub, ...). + + subroutine export_time_to_multiforce(domain) + use multiforce, only: sim_beg, sim_end, eval_beg, eval_end, numtim_sim, numtim_sub, & + SUB_PERIODS_FLAG, istart + implicit none + type(domain_type), intent(in) :: domain + + sim_beg = domain%info%time%sim_beg + sim_end = domain%info%time%sim_end + eval_beg = domain%info%time%eval_beg + eval_end = domain%info%time%eval_end + + numtim_sim = domain%info%time%nt_sim + numtim_sub = domain%info%time%nt_window + SUB_PERIODS_FLAG = domain%info%time%use_subperiods + + istart = sim_beg + end subroutine + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + ! ----- helper routines --------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- helper: read time axis from NetCDF -------------------------------------------- + + subroutine read_time_axis(ncid, time_steps, units, nt, ierr, message) + + integer(i4b), intent(in) :: ncid + real(sp), allocatable, intent(out) :: time_steps(:) + character(len=*), intent(out) :: units + integer(i4b), intent(out) :: nt, ierr + character(*), intent(out) :: message + + integer(i4b) :: varid, dimids(1) + + ierr=0; message="read_time_axis/" + + ierr = nf90_inq_varid(ncid, "time", varid) + if(ierr/=nf90_noerr) then + message=trim(message)//"cannot find time variable"; return + endif + + ierr = nf90_inquire_variable(ncid, varid, dimids=dimids) + if(ierr/=nf90_noerr) then + message=trim(message)//trim(nf90_strerror(ierr)); return + endif + + ierr = nf90_inquire_dimension(ncid, dimids(1), len=nt) + if(ierr/=nf90_noerr) then + message=trim(message)//trim(nf90_strerror(ierr)); return + endif + + allocate(time_steps(nt), stat=ierr) + if(ierr/=0) then + message=trim(message)//"allocate(time_steps) failed"; return + endif + + ierr = nf90_get_var(ncid, varid, time_steps) + if(ierr/=nf90_noerr) then + message=trim(message)//trim(nf90_strerror(ierr)); return + endif + + ierr = nf90_get_att(ncid, varid, "units", units) + if(ierr/=nf90_noerr) then + message=trim(message)//"cannot read time units attribute"; return + endif + + end subroutine read_time_axis + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- helper: build julian axis ----------------------------------------------------- + + subroutine build_julian_axis(time_steps, units, jref, jdate, ierr, message) + + real(sp), intent(in) :: time_steps(:) + character(len=*), intent(in) :: units + real(sp), intent(out) :: jref + real(sp), allocatable, intent(out) :: jdate(:) + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + integer(i4b) :: iy,im,id,ih + character(len=1024) :: cmessage + real(sp) :: scale_to_days + + ierr=0; message="build_julian_axis/" + + ! extract reference date from the units string + call date_extractor(trim(units), iy, im, id, ih) + call juldayss(iy,im,id,ih, jref, ierr, cmessage) + if(ierr/=0) then; message=trim(message)//trim(cmessage); return; endif + + ! determine scaling factor to convert time_steps into days + scale_to_days = time_units_to_days(units, ierr, cmessage) + if(ierr/=0) then; message=trim(message)//trim(cmessage); return; endif + + ! build julian axis + allocate(jdate(size(time_steps)), stat=ierr) + if(ierr/=0) then; message=trim(message)//"allocate(jdate) failed"; return; endif + jdate = jref + time_steps * scale_to_days + + end subroutine build_julian_axis + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- helper: determine scaling factor to convert time_steps into days -------------- + + real(sp) function time_units_to_days(units, ierr, message) + implicit none + character(len=*), intent(in) :: units + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + character(len=:), allocatable :: u + integer(i4b) :: p + + ierr=0; message="time_units_to_days/" + + ! lower-case copy (simple approach) + u = tolower_str( trim(adjustl(units)) ) + + ! Look at the first token before a space + p = index(u, " ") + if(p <= 1) then + ierr=1; message=trim(message)//"cannot parse units string: "//trim(units) + time_units_to_days = 0._sp + return + endif + + select case (trim(u(1:p-1))) + case ("days", "day") + time_units_to_days = 1._sp + case ("hours", "hour") + time_units_to_days = 1._sp / 24._sp + case ("minutes", "minute", "mins", "min") + time_units_to_days = 1._sp / 1440._sp + case ("seconds", "second", "secs", "sec") + time_units_to_days = 1._sp / 86400._sp + case default + ierr=1 + message=trim(message)//"unsupported time unit: "//trim(u(1:p-1)) + time_units_to_days = 0._sp + end select + + end function time_units_to_days + + pure function tolower_str(s) result(out) + character(len=*), intent(in) :: s + character(len=len(s)) :: out + integer :: i + do i=1,len(s) + select case(s(i:i)) + case("A":"Z"); out(i:i) = achar(iachar(s(i:i)) + 32) + case default; out(i:i) = s(i:i) + end select + end do + end function tolower_str + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- helper: map start/end date strings to indices --------------------------------- + + subroutine map_dates_to_indices(jdate, date_start, date_end, i_beg, i_end, ierr, message) + + real(sp), intent(in) :: jdate(:) + character(len=*), intent(in) :: date_start, date_end + integer(i4b), intent(out) :: i_beg, i_end + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + integer(i4b) :: iy,im,id,ih + real(sp) :: j_start, j_end + character(len=1024) :: cmessage + + ierr=0; message="map_dates_to_indices/" + + ! start date + call date_extractor(trim(date_start), iy,im,id,ih) + call juldayss(iy,im,id,ih, j_start, ierr, cmessage) + if(ierr/=0) then; message=trim(message)//trim(cmessage); return; endif + + ! end date + call date_extractor(trim(date_end), iy,im,id,ih) + call juldayss(iy,im,id,ih, j_end, ierr, cmessage) + if(ierr/=0) then; message=trim(message)//trim(cmessage); return; endif + + ! validate + + if(j_start > j_end) then + ierr=1; message=trim(message)//"start date > end date"; return + endif + + if(j_start < minval(jdate) .or. j_end > maxval(jdate)) then + ierr=1; message=trim(message)//"requested window outside forcing range"; return + endif + + ! get indices in jdate vector + i_beg = minloc(abs(jdate - j_start), 1) + i_end = minloc(abs(jdate - j_end ), 1) + + end subroutine map_dates_to_indices + + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- helper: validate sim/eval logic ----------------------------------------------- + + subroutine validate_windows(ti, ierr, message) + + use data_types, only: time_info + type(time_info), intent(in) :: ti + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + ierr=0; message="validate_windows/" + + if(ti%eval_beg < ti%sim_beg) then + ierr=1; message=trim(message)//"eval start < sim start"; return + endif + if(ti%eval_end > ti%sim_end) then + ierr=1; message=trim(message)//"eval end > sim end"; return + endif + + end subroutine validate_windows + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + +end module time_windows_module diff --git a/build/FUSE_SRC/runtime/initfluxes.f90 b/build/FUSE_SRC/runtime/initfluxes.f90 index 230781d..dd41bab 100644 --- a/build/FUSE_SRC/runtime/initfluxes.f90 +++ b/build/FUSE_SRC/runtime/initfluxes.f90 @@ -42,8 +42,8 @@ SUBROUTINE INITFLUXES() M_FLUX%OFLOW_2B = 0._sp; W_FLUX%OFLOW_2B = 0._sp IF(SMODL%iSNOWM.EQ.iopt_temp_index) THEN !loop through snow model bands DO ISNW=1,N_BANDS - MBANDS(ISNW)%SNOWACCMLTN = 0._sp - MBANDS(ISNW)%SNOWMELT = 0._sp + MBANDS(ISNW)%var%SNOWACCMLTN = 0._sp + MBANDS(ISNW)%var%SNOWMELT = 0._sp END DO ENDIF M_FLUX%ERR_WATR_1 = 0._sp; W_FLUX%ERR_WATR_1 = 0._sp diff --git a/build/FUSE_SRC/runtime/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/util/alloc_domain.f90 b/build/FUSE_SRC/util/alloc_domain.f90 new file mode 100644 index 0000000..4fc0111 --- /dev/null +++ b/build/FUSE_SRC/util/alloc_domain.f90 @@ -0,0 +1,98 @@ +module alloc_domain_module + + USE nrtype + USE data_types, only: domain_type + + implicit none + private + public :: allocate_domain_data + public :: set_legacy_arrays + +CONTAINS + + subroutine allocate_domain_data(domain, ierr, message) + + implicit none + + type(domain_type), intent(inout) :: domain + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + integer(i4b) :: nx, ny, nt, nb + + ierr=0; message="allocate_domain_data/" + + ! define dimensions + nx = domain%info%space%nx_local ! NOTE: local to rank (MPI parallelization) + ny = domain%info%space%ny_local + nt = domain%info%time%nt_window + nb = domain%info%snow%n_bands + + ! allocate validity mask + allocate(domain%data%valid(nx,ny,nt), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate valid"; return; endif + + ! allocate ancillary forcing + allocate(domain%data%ancil(nx,ny), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate ancil"; return; endif + + ! allocate forcing window + allocate(domain%data%force(nx,ny,nt), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate force"; return; endif + + ! allocate state window + allocate(domain%data%state(nx,ny,nt+1), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate state"; return; endif + + ! allocate flux window + allocate(domain%data%flux(nx,ny,nt), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate flux"; return; endif + + ! allocate basin averages + allocate(domain%data%aForce(nt), domain%data%aRoute(nt), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate aForce/aRoute"; return; endif + + ! allocate routing if needed + allocate(domain%data%route(nx,ny,nt), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate route"; return; endif + + ! allocate bands + allocate(domain%data%bands(nx,ny,nb,nt+1), stat=ierr) + if(ierr/=0)then; message=trim(message)//"cannot allocate bands"; return; endif + + end subroutine allocate_domain_data + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- copy arrays in the domain%data structure to legacy arrays --------------------- + + subroutine set_legacy_arrays(domain) + + ! legacy modules + use multiforce, only: nSpat1, nSpat2, numtim_sub + use multiForce, only: gForce_3d, ancilF, aValid + use multiState, only: gState_3d + use multiRoute, only: AROUTE_3d + use multiBands, only: MBANDS_VAR_4d, N_BANDS + implicit none + + type(domain_type), intent(inout) :: domain + + ! ensure the spatial dimensions match what is in domain%info + nSpat1 = domain%info%space%nx_local ! NOTE: local to rank (MPI parallelization) + nSpat2 = domain%info%space%ny_local + numtim_sub = domain%info%time%nt_window + n_bands = domain%info%snow%n_bands + + ! copy arrays in the domain%data structure to legacy arrays + aValid = domain%data%valid ! validity mask + ancilF = domain%data%ancil ! ancillary forcing + gForce_3d = domain%data%force ! forcing window + gState_3d = domain%data%state ! state window + AROUTE_3d = domain%data%route ! routing window + MBANDS_VAR_4d = domain%data%bands ! elevation band window + + end subroutine set_legacy_arrays + +end module alloc_domain_module diff --git a/build/FUSE_SRC/util/alloc_scratch.f90 b/build/FUSE_SRC/util/alloc_scratch.f90 new file mode 100644 index 0000000..181e28f --- /dev/null +++ b/build/FUSE_SRC/util/alloc_scratch.f90 @@ -0,0 +1,161 @@ +module alloc_scratch_module + + + USE nrtype + use data_types, only: domain_info, fuse_work + + implicit none + private + public :: init_fuse_work + +CONTAINS + + subroutine init_fuse_work(info, work, ierr, message) + + use globaldata, only: NPAR_SNOW + implicit none + + type(domain_info), intent(in) :: info + type(fuse_work), intent(inout) :: work + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + integer(i4b) :: ib + integer(i4b) :: nBands, nState, nPar + + ierr=0; message="init_fuse_work/" + + ! identify dimensions + nBands = info%snow%n_bands + nState = info%config%nState + nPar = info%config%nParam + + ! If already initialized, don't reallocate unless sizes mismatch + if (work%is_initialized) then + if (size(work%state0)==nState .and. size(work%state1)==nState) return + call free_fuse_work(work, ierr, message) + if(ierr/=0) return + endif + + ! ---- allocate core state vectors ---- + allocate(work%state0(nState), work%state1(nState), stat=ierr) + if(ierr/=0) then + message=trim(message)//"cannot allocate state0/state1" + return + endif + + ! optional debug scratch + ! allocate(work%dSdt(nState), work%J(nState,nState), stat=ierr) + + ! ---- allocate differentiable parent derivatives ---- + allocate(work%fuseStruct%df_dS(nState), & + work%fuseStruct%df_dPar(nPar), & + work%fuseStruct%dL_dPar(nPar), stat=ierr) + if(ierr/=0) then + message=trim(message)//"cannot allocate fuseStruct derivatives" + return + endif + + ! ---- allocate elevation band containers ---- + allocate(work%fuseStruct%sbands(nBands), stat=ierr) + if(ierr/=0) then + message=trim(message)//"cannot allocate fuseStruct sbands" + return + endif + + ! ---- allocate per-band parameter derivative vectors ---- + do ib=1,nBands + allocate(work%fuseStruct%sbands(ib)%var%dSWE_dParam(nPar_snow), stat=ierr) + if(ierr/=0) then + message=trim(message)//"cannot allocate dSWE_dParam for band" + return + endif + work%fuseStruct%sbands(ib)%var%dSWE_dParam(:) = 0._sp + enddo + + ! ---- initialize the band snow vars once ---- + work%fuseStruct%sbands(:)%var%SWE = 0._sp + work%fuseStruct%sbands(:)%var%SNOWACCMLTN = 0._sp + work%fuseStruct%sbands(:)%var%SNOWMELT = 0._sp + work%fuseStruct%sbands(:)%var%DSWE_DT = 0._sp + + work%is_initialized = .true. + + end subroutine init_fuse_work + + ! ------------------------------------------------------------------------------------- + + subroutine free_fuse_work(work, ierr, message) + + implicit none + type(fuse_work), intent(inout) :: work + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + integer(i4b) :: ib, istat + + ierr = 0 + message = "free_fuse_work/" + + ! ---- state vectors ---- + if (allocated(work%state0)) then + deallocate(work%state0, stat=istat) + call note_fail("state0", istat) + endif + + if (allocated(work%state1)) then + deallocate(work%state1, stat=istat) + call note_fail("state1", istat) + endif + + ! ---- derivative arrays ---- + if (allocated(work%fuseStruct%df_dS)) then + deallocate(work%fuseStruct%df_dS, stat=istat) + call note_fail("fuseStruct%df_dS", istat) + endif + + if (allocated(work%fuseStruct%df_dPar)) then + deallocate(work%fuseStruct%df_dPar, stat=istat) + call note_fail("fuseStruct%df_dPar", istat) + endif + + if (allocated(work%fuseStruct%dL_dPar)) then + deallocate(work%fuseStruct%dL_dPar, stat=istat) + call note_fail("fuseStruct%dL_dPar", istat) + endif + + ! ---- elevation band structures ---- + if (allocated(work%fuseStruct%sbands)) then + + do ib = 1, size(work%fuseStruct%sbands) + if (allocated(work%fuseStruct%sbands(ib)%var%dSWE_dParam)) then + deallocate(work%fuseStruct%sbands(ib)%var%dSWE_dParam, stat=istat) + call note_fail("sbands%var%dSWE_dParam", istat) + endif + enddo + + deallocate(work%fuseStruct%sbands, stat=istat) + call note_fail("fuseStruct%sbands", istat) + + endif + + work%is_initialized = .false. + + contains + + subroutine note_fail(where, istat) + character(*), intent(in) :: where + integer(i4b), intent(in) :: istat + + if (istat /= 0) then + ! preserve the first nonzero stat as ierr + if (ierr == 0) ierr = istat + + ! append context (do not overwrite) + message = trim(message)//" dealloc_fail("//trim(where)//")" + endif + end subroutine note_fail + + end subroutine free_fuse_work + +end module alloc_scratch_module diff --git a/build/FUSE_SRC/util/fuse_fileManager.f90 b/build/FUSE_SRC/util/fuse_fileManager.f90 new file mode 100644 index 0000000..3391201 --- /dev/null +++ b/build/FUSE_SRC/util/fuse_fileManager.f90 @@ -0,0 +1,382 @@ +!****************************************************************** +! (C) Copyright 2009-2010 --- Dmitri Kavetski and Martyn Clark --- All rights reserved +!****************************************************************** +! Edited by Brian Henn to include snow model, 7/2013 +! Edited by Nans Addor to set simulation and evaluation periods, 11/2017 +! Modified by Martyn Clark to populate domain structure, 12/2025 +MODULE fuse_filemanager + + use nrtype + use kinds_dmsl_kit_FUSE,only:mik,mlk + use data_types, only: cli_options, domain_type + + implicit none + private + + public :: fuse_SetDirsUndPhiles + public :: export_filemanager_to_domain + public :: finalize_domain_config + public :: export_domain_to_legacy + + ! expose legacy globals + public :: SETNGS_PATH, INPUT_PATH, OUTPUT_PATH + public :: suffix_forcing, suffix_elev_bands + public :: FORCINGINFO, CONSTRAINTS, MOD_NUMERIX, M_DECISIONS + public :: MBANDS_INFO, MBANDS_NC + public :: FMODEL_ID, Q_ONLY_STR, Q_ONLY + public :: date_start_sim, date_end_sim, date_start_eval, date_end_eval, numtim_sub_str + public :: KSTOP_str, MAXN_str, PCENTO_str + + ! FUSE-wide pathlength + integer(mik),parameter::fusePathLen=512 + + ! defines the path for data files + CHARACTER(LEN=fusePathLen) :: SETNGS_PATH + CHARACTER(LEN=fusePathLen) :: INPUT_PATH + CHARACTER(LEN=fusePathLen) :: OUTPUT_PATH + + ! content of input directory + CHARACTER(LEN=fusePathLen) :: suffix_forcing ! suffix for forcing file + CHARACTER(LEN=fusePathLen) :: suffix_elev_bands ! suffix for elevation band file + + ! content of settings directory + CHARACTER(LEN=fusePathLen) :: M_DECISIONS ! definition of model decisions + CHARACTER(LEN=fusePathLen) :: CONSTRAINTS ! definition of parameter constraints + CHARACTER(LEN=fusePathLen) :: MOD_NUMERIX ! definition of numerical solution technique + CHARACTER(LEN=fusePathLen) :: FORCINGINFO ! info on forcing data files + CHARACTER(LEN=fusePathLen) :: MBANDS_INFO ! info on basin band data files ! not needed anymore + CHARACTER(LEN=fusePathLen) :: MBANDS_NC ! netcdf file defining the elevation bands + + ! content of output directory + CHARACTER(LEN=64) :: FMODEL_ID ! string defining FUSE model + CHARACTER(LEN=64) :: Q_ONLY_STR ! TRUE = restrict attention to simulated runoff + LOGICAL :: Q_ONLY ! .TRUE. = restrict attention to simulated runoff + + ! define simulation and evaluation periods + CHARACTER(len=20) :: date_start_sim ! date start simulation + CHARACTER(len=20) :: date_end_sim ! date end simulation + CHARACTER(len=20) :: date_start_eval ! date start evaluation period + CHARACTER(len=20) :: date_end_eval ! date end evaluation period + CHARACTER(len=20) :: numtim_sub_str ! number of time steps of subperiod (will be kept in memory) + + ! SCE parameters + CHARACTER(len=20) :: KSTOP_str ! number of shuffling loops the value must change by PCENTO + CHARACTER(len=20) :: MAXN_str ! maximum number of trials before optimization is terminated + CHARACTER(len=20) :: PCENTO_str ! the percentage + +contains + + ! ----- copies the globals into the domain structure ---------------------------------- + + ! NOTE: this should be called after call fuse_SetDirsUndPhiles(fuseFileManagerIn, ..) + + subroutine export_filemanager_to_domain(cli_opts, domain) + + implicit none + type(cli_options), intent(in) :: cli_opts ! command line interface options + type(domain_type), intent(inout) :: domain + + ! ----- file information ------------------------------------------------------------ + + ! directories + domain%info%files%setngs_path = trim(SETNGS_PATH) + domain%info%files%input_path = trim(INPUT_PATH) + domain%info%files%output_path = trim(OUTPUT_PATH) + + ! suffixes + domain%info%files%suffix_forcing = trim(suffix_forcing) + domain%info%files%suffix_elev_bands = trim(suffix_elev_bands) + + ! settings filenames + domain%info%files%forcinginfo = trim(FORCINGINFO) + domain%info%files%constraints = trim(CONSTRAINTS) + domain%info%files%mod_numerix = trim(MOD_NUMERIX) + domain%info%files%m_decisions = trim(M_DECISIONS) + + ! ----- configuration options ------------------------------------------------------- + + ! Convenience alias (already available via config%cli_opts%control_file) + domain%info%config%file_manager_file = trim(cli_opts%control_file) + + ! provenance: CLI options + domain%info%config%cli_opts = cli_opts ! control file, tags, etc. + + ! runtime information + domain%info%config%fmodel_id = trim(FMODEL_ID) + domain%info%config%q_only = Q_ONLY + + ! user-defined simulation/evaluation time periods: strings + domain%info%config%date_start_sim = trim(date_start_sim) + domain%info%config%date_end_sim = trim(date_end_sim) + domain%info%config%date_start_eval = trim(date_start_eval) + domain%info%config%date_end_eval = trim(date_end_eval) + + ! user-defined sub-window time slice length + domain%info%config%numtim_sub_str = trim(numtim_sub_str) + + ! user-defined SCE control parameters (used for SCE calibration runs) + domain%info%config%maxn_str = trim(MAXN_str) + domain%info%config%kstop_str = trim(KSTOP_str) + domain%info%config%pcento_str = trim(PCENTO_str) + + end subroutine export_filemanager_to_domain + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + subroutine finalize_domain_config(cli_opts, domain, ierr, message) + + implicit none + + type(cli_options), intent(in) :: cli_opts + type(domain_type), intent(inout) :: domain + integer(i4b), intent(out) :: ierr + character(*), intent(out) :: message + + character(len=256) :: dom_id, tag, run_mode + integer(i4b) :: ios + + ierr=0; message="finalize_domain_config/" + + dom_id = trim(cli_opts%domain_id) + run_mode = trim(cli_opts%runmode) + + tag = "" + if(allocated(cli_opts%tag)) tag = trim(cli_opts%tag) + + ! ---- derived input filenames ---- + domain%info%files%forcing_file = trim(dom_id)//trim(domain%info%files%suffix_forcing) + domain%info%files%elevbands_file = trim(dom_id)//trim(domain%info%files%suffix_elev_bands) + + ! ---- derived output base name ---- + domain%info%files%fname_tempry = trim(domain%info%files%output_path)// & + trim(dom_id)//'_'//trim(domain%info%config%fmodel_id)//'_'//trim(tag) + + domain%info%files%fname_netcdf_runs = trim(domain%info%files%fname_tempry)//'_runs_'//trim(run_mode)//'.nc' + domain%info%files%fname_netcdf_para = trim(domain%info%files%fname_tempry)//'_para_'//trim(run_mode)//'.nc' + + ! ---- parse numeric config ---- + read(domain%info%config%maxn_str, *, iostat=ios) domain%info%config%maxn + if(ios/=0) then; ierr=1; message=trim(message)//"cannot parse MAXN"; return; endif + + read(domain%info%config%kstop_str, *, iostat=ios) domain%info%config%kstop + if(ios/=0) then; ierr=1; message=trim(message)//"cannot parse KSTOP"; return; endif + + read(domain%info%config%pcento_str,*, iostat=ios) domain%info%config%pcento + if(ios/=0) then; ierr=1; message=trim(message)//"cannot parse PCENTO"; return; endif + + end subroutine finalize_domain_config + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- export domain config variables to legacy modules ------------------------------ + + subroutine export_domain_to_legacy(domain) + use model_defn, only: FNAME_TEMPRY, FNAME_NETCDF_RUNS, FNAME_NETCDF_PARA + use multiparam, only: MAXN, KSTOP, PCENTO + use multiforce, only: forcefile + + type(domain_type), intent(in) :: domain + + ! populate module model_defn + FNAME_TEMPRY = trim(domain%info%files%fname_tempry) + FNAME_NETCDF_RUNS = trim(domain%info%files%fname_netcdf_runs) + FNAME_NETCDF_PARA = trim(domain%info%files%fname_netcdf_para) + + ! populate module multiforce + forcefile = trim(domain%info%files%forcing_file) + + ! populate shared public variable in this module (fuse_filemanager) + MBANDS_NC = trim(domain%info%files%elevbands_file) + + ! populate module multiparam + MAXN = domain%info%config%maxn + KSTOP = domain%info%config%kstop + PCENTO = domain%info%config%pcento + + end subroutine export_domain_to_legacy + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + ! ----- sets directories and filenames for FUSE -------------------------------------- + + subroutine fuse_SetDirsUndPhiles(fuseMusterDirektorIn,fuseFileManagerIn,err,message) + ! Purpose: Sets direcotries and philenames for FUSE. + ! --- + ! Programmer: Dmitri Kavetski + ! History: + ! Darby St, 18/10/2009 AD - leid out basik frammenverk + ! Sonnental, 17/06/2012 AD - more general path handling + ! --- + ! Usage + ! fuseMusterDirektorIn = master direktor file (path to filemanager) + ! fuseFileManagerIn = global names/path file + ! --- + ! Comments: + ! 1. If present will try to use fuseMasterIn, otherwise default file. + ! if default not present in EXE path then uses default options + ! --- + use utilities_dmsl_kit_FUSE,only:getSpareUnit + + implicit none + + ! dummies + character(*),intent(in),optional::fuseMusterDirektorIn,fuseFileManagerIn + integer(mik),intent(out)::err + character(*),intent(out)::message + + ! registered settings + character(*),parameter::procnam="fuseSetDirsUndPhiles" + character(*),parameter::pathDelim="/\",defpathSymb="*",blank=" " + character(*),parameter::fuseMusterDirektorHeader="FUSE_MUSTERDIREKTOR_V1.0" + character(*),parameter::fuseFileManagerHeader="FUSE_FILEMANAGER_V1.5" + + ! locals + logical(mlk)::haveFMG,haveMUS + character(LEN=fusePathLen)::fuseMusterDirektor,fuseFileManager,defpath + character(LEN=100)::temp + integer(mik)::unt,i + + ! Start procedure here + err=0; message=procnam//"/ok"; defpath=blank + + haveMUS=present(fuseMusterDirektorIn); haveFMG=present(fuseFileManagerIn) + if(haveMUS)haveMUS=len_trim(fuseMusterDirektorIn)>0 + if(haveFMG)haveFMG=len_trim(fuseFileManagerIn)>0 ! check for zero-string + if(haveMUS.and.haveFMG)then + message="f-"//procnam//"/mustSpecifyEither(notBoth)& + &[fuseMusterDirektor.or.fuseFileManager]" + err=10; return + + elseif(haveFMG)then + fuseFileManager=fuseFileManagerIn + i=scan(fuseFileManager,pathDelim,back=.true.) + if(i>0)defpath=fuseFileManager(:i-1)//pathDelim(1:1) + print *, 'fuseFileManager:', TRIM(fuseFileManager) + + elseif(haveMUS)then + fuseMusterDirektor=fuseMusterDirektorIn + i=scan(fuseMusterDirektor,pathDelim,back=.true.) + if(i>0)defpath=fuseMusterDirektor(:i-1)//pathDelim(1:1) + print *, 'fuseMusterDirektor:', TRIM(fuseMusterDirektor) + + else + message="f-"//procnam//"/mustSpecifyEither& + &[fuseMusterDirektor.or.fuseFileManager]" + err=20; return + endif + + call getSpareUnit(unt,err,message) ! make sure 'unt' is actually available + + if(err/=0)then + message="f-"//procnam//"/weird/&"//message + err=100; return + endif + + ! Open muster-direktor and read it + if(.not.haveFMG)then ! grab it from the muster-direktor + + open(unt,file=fuseMusterDirektor,status="old",action="read",iostat=err) + if(err/=0)then + message="f-"//procnam//"/musterDirektorFileOpenError['"//trim(fuseMusterDirektor)//"']" + err=10; return + endif + + read(unt,*)temp + + if(temp/=fuseMusterDirektorHeader)then + message="f-"//procnam//"/unknownHeader&[file='"//trim(fuseMusterDirektor)//"']&& + &[header='"//trim(temp)//"']" + err=20; return + endif + + read(unt,*)fuseFileManager + close(unt) + + endif + + ! open file manager file + open(unt,file=fuseFileManager,status="old",action="read",iostat=err) + if(err/=0)then + message="f-"//procnam//"/fileManagerOpenError['"//trim(fuseFileManager)//"']" + err=10; return + endif + + read(unt,*)temp + if(temp/=fuseFileManagerHeader)then + message="f-"//procnam//"/unknownHeader&[file='"//trim(fuseFileManager)//"']&& + &[header="//trim(temp)//"]" + + message='This version of FUSE requires the file manager to follow the following format: '//trim(fuseFileManagerHeader)//' not '//trim(temp) + + err=20; return + endif + + read(unt,'(a)')temp + read(unt,*)SETNGS_PATH + read(unt,*)INPUT_PATH + read(unt,*)OUTPUT_PATH + + read(unt,'(a)')temp + read(unt,*)suffix_forcing + read(unt,*)suffix_elev_bands + + read(unt,'(a)')temp + read(unt,*)FORCINGINFO + read(unt,*)CONSTRAINTS + read(unt,*)MOD_NUMERIX + read(unt,*)M_DECISIONS + + read(unt,'(a)')temp + read(unt,*)FMODEL_ID + read(unt,*)Q_ONLY_STR + + read(unt,'(a)')temp + read(unt,*)date_start_sim + read(unt,*)date_end_sim + read(unt,*)date_start_eval + read(unt,*)date_end_eval + read(unt,*)numtim_sub_str + + read(unt,'(a)')temp + read(unt,*)MAXN_STR + read(unt,*)KSTOP_STR + read(unt,*)PCENTO_STR + + close(unt) + + ! Convert Q_ONLY to logical + if(Q_ONLY_STR=='TRUE')then + Q_ONLY = .TRUE. + elseif(Q_ONLY_STR=='FALSE')then + Q_ONLY = .FALSE. + else + message="Q_ONLY must be either TRUE or FALSE" + err=20; return + endif + + PRINT*, 'Q_ONLY', Q_ONLY + + ! process paths a bit + if(SETNGS_PATH(1:1)==defpathSymb)SETNGS_PATH=trim(defpath)//SETNGS_PATH(2:) + if( INPUT_PATH(1:1)==defpathSymb) INPUT_PATH=trim(defpath)//INPUT_PATH (2:) + if(OUTPUT_PATH(1:1)==defpathSymb)OUTPUT_PATH=trim(defpath)//OUTPUT_PATH(2:) + + PRINT *, 'Paths defined in file manager:' + PRINT *, 'SETNGS_PATH:', TRIM(SETNGS_PATH) + PRINT *, 'INPUT_PATH:', TRIM(INPUT_PATH) + PRINT *, 'OUTPUT_PATH:', TRIM(OUTPUT_PATH) + + PRINT *, 'Dates defined in file manager:' + PRINT *, 'date_start_sim:', TRIM(date_start_sim) + PRINT *, 'date_end_sim:', TRIM(date_end_sim) + PRINT *, 'date_start_eval:', TRIM(date_start_eval) + PRINT *, 'date_end_eval:', TRIM(date_end_eval) + PRINT *, 'numtim_sub_str:', TRIM(numtim_sub_str) + + ! End procedure here + endsubroutine fuse_SetDirsUndPhiles +!---------------------------------------------------- +END MODULE fuse_filemanager diff --git a/build/FUSE_SRC/util/getpar_str.f90 b/build/FUSE_SRC/util/getpar_str.f90 index bf3fd77..aeda85c 100644 --- a/build/FUSE_SRC/util/getpar_str.f90 +++ b/build/FUSE_SRC/util/getpar_str.f90 @@ -1,70 +1,75 @@ MODULE GETPAR_STR_MODULE -IMPLICIT NONE + + implicit none + private + public :: GETPAR_STR + CONTAINS -SUBROUTINE GETPAR_STR(PARNAME,METADAT) -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark, 2009 -! Modified by Brian Henn to include snow model, 6/2013 -! --------------------------------------------------------------------------------------- -! Purpose: -! -------- -! Inserts parameter metadata into data structures -! --------------------------------------------------------------------------------------- -USE nrtype ! variable types, etc. -USE data_types, ONLY : PARATT ! derived type for parameter metadata -USE multiparam, ONLY : PARMETA ! parameter metadata -IMPLICIT NONE -! input -CHARACTER(*), INTENT(IN) :: PARNAME ! parameter name -TYPE(PARATT), INTENT(OUT) :: METADAT ! parameter metadata -! --------------------------------------------------------------------------------------- -! model parameters -SELECTCASE(TRIM(PARNAME)) -CASE('RFERR_ADD'); METADAT = PARMETA%RFERR_ADD -CASE('RFERR_MLT'); METADAT = PARMETA%RFERR_MLT -CASE('RFH1_MEAN'); METADAT = PARMETA%RFH1_MEAN -CASE('RFH2_SDEV'); METADAT = PARMETA%RFH2_SDEV -CASE('RH1P_MEAN'); METADAT = PARMETA%RH1P_MEAN -CASE('RH1P_SDEV'); METADAT = PARMETA%RH1P_SDEV -CASE('RH2P_MEAN'); METADAT = PARMETA%RH2P_MEAN -CASE('RH2P_SDEV'); METADAT = PARMETA%RH2P_SDEV -CASE('MAXWATR_1'); METADAT = PARMETA%MAXWATR_1 -CASE('MAXWATR_2'); METADAT = PARMETA%MAXWATR_2 -CASE('FRACTEN'); METADAT = PARMETA%FRACTEN -CASE('FRCHZNE'); METADAT = PARMETA%FRCHZNE -CASE('FPRIMQB'); METADAT = PARMETA%FPRIMQB -CASE('RTFRAC1'); METADAT = PARMETA%RTFRAC1 -CASE('PERCRTE'); METADAT = PARMETA%PERCRTE -CASE('PERCEXP'); METADAT = PARMETA%PERCEXP -CASE('SACPMLT'); METADAT = PARMETA%SACPMLT -CASE('SACPEXP'); METADAT = PARMETA%SACPEXP -CASE('PERCFRAC'); METADAT = PARMETA%PERCFRAC -CASE('FRACLOWZ'); METADAT = PARMETA%FRACLOWZ -CASE('IFLWRTE'); METADAT = PARMETA%IFLWRTE -CASE('BASERTE'); METADAT = PARMETA%BASERTE -CASE('QB_POWR'); METADAT = PARMETA%QB_POWR -CASE('QB_PRMS'); METADAT = PARMETA%QB_PRMS -CASE('QBRATE_2A'); METADAT = PARMETA%QBRATE_2A -CASE('QBRATE_2B'); METADAT = PARMETA%QBRATE_2B -CASE('SAREAMAX'); METADAT = PARMETA%SAREAMAX -CASE('AXV_BEXP'); METADAT = PARMETA%AXV_BEXP -CASE('LOGLAMB'); METADAT = PARMETA%LOGLAMB -CASE('TISHAPE'); METADAT = PARMETA%TISHAPE -CASE('TIMEDELAY'); METADAT = PARMETA%TIMEDELAY -CASE('MBASE'); METADAT = PARMETA%MBASE -CASE('MFMAX'); METADAT = PARMETA%MFMAX -CASE('MFMIN'); METADAT = PARMETA%MFMIN -CASE('PXTEMP'); METADAT = PARMETA%PXTEMP -CASE('OPG'); METADAT = PARMETA%OPG -CASE('LAPSE'); METADAT = PARMETA%LAPSE -CASE DEFAULT - print *, 'parameter name (', TRIM(PARNAME), ') does not exist ' - IF (TRIM(PARNAME).EQ.'NO_CHILD1' .OR. TRIM(PARNAME).EQ.'NO_CHILD2') & - print *, ' * check the number of prior/hyper parameters specified ' - STOP -ENDSELECT -! --------------------------------------------------------------------------------------- -END SUBROUTINE GETPAR_STR + + SUBROUTINE GETPAR_STR(PARNAME,METADAT) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2009 + ! Modified by Brian Henn to include snow model, 6/2013 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Extract parameter metadata from metadata structures + ! --------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE data_types, ONLY : PARATT ! derived type for parameter metadata + USE multiparam, ONLY : PARMETA ! parameter metadata + IMPLICIT NONE + ! input + CHARACTER(*), INTENT(IN) :: PARNAME ! parameter name + TYPE(PARATT), INTENT(OUT) :: METADAT ! parameter metadata + ! --------------------------------------------------------------------------------------- + ! model parameters + SELECTCASE(TRIM(PARNAME)) + CASE('RFERR_ADD'); METADAT = PARMETA%RFERR_ADD + CASE('RFERR_MLT'); METADAT = PARMETA%RFERR_MLT + CASE('RFH1_MEAN'); METADAT = PARMETA%RFH1_MEAN + CASE('RFH2_SDEV'); METADAT = PARMETA%RFH2_SDEV + CASE('RH1P_MEAN'); METADAT = PARMETA%RH1P_MEAN + CASE('RH1P_SDEV'); METADAT = PARMETA%RH1P_SDEV + CASE('RH2P_MEAN'); METADAT = PARMETA%RH2P_MEAN + CASE('RH2P_SDEV'); METADAT = PARMETA%RH2P_SDEV + CASE('MAXWATR_1'); METADAT = PARMETA%MAXWATR_1 + CASE('MAXWATR_2'); METADAT = PARMETA%MAXWATR_2 + CASE('FRACTEN'); METADAT = PARMETA%FRACTEN + CASE('FRCHZNE'); METADAT = PARMETA%FRCHZNE + CASE('FPRIMQB'); METADAT = PARMETA%FPRIMQB + CASE('RTFRAC1'); METADAT = PARMETA%RTFRAC1 + CASE('PERCRTE'); METADAT = PARMETA%PERCRTE + CASE('PERCEXP'); METADAT = PARMETA%PERCEXP + CASE('SACPMLT'); METADAT = PARMETA%SACPMLT + CASE('SACPEXP'); METADAT = PARMETA%SACPEXP + CASE('PERCFRAC'); METADAT = PARMETA%PERCFRAC + CASE('FRACLOWZ'); METADAT = PARMETA%FRACLOWZ + CASE('IFLWRTE'); METADAT = PARMETA%IFLWRTE + CASE('BASERTE'); METADAT = PARMETA%BASERTE + CASE('QB_POWR'); METADAT = PARMETA%QB_POWR + CASE('QB_PRMS'); METADAT = PARMETA%QB_PRMS + CASE('QBRATE_2A'); METADAT = PARMETA%QBRATE_2A + CASE('QBRATE_2B'); METADAT = PARMETA%QBRATE_2B + CASE('SAREAMAX'); METADAT = PARMETA%SAREAMAX + CASE('AXV_BEXP'); METADAT = PARMETA%AXV_BEXP + CASE('LOGLAMB'); METADAT = PARMETA%LOGLAMB + CASE('TISHAPE'); METADAT = PARMETA%TISHAPE + CASE('TIMEDELAY'); METADAT = PARMETA%TIMEDELAY + CASE('MBASE'); METADAT = PARMETA%MBASE + CASE('MFMAX'); METADAT = PARMETA%MFMAX + CASE('MFMIN'); METADAT = PARMETA%MFMIN + CASE('PXTEMP'); METADAT = PARMETA%PXTEMP + CASE('OPG'); METADAT = PARMETA%OPG + CASE('LAPSE'); METADAT = PARMETA%LAPSE + CASE DEFAULT + print *, 'parameter name (', TRIM(PARNAME), ') does not exist ' + IF (TRIM(PARNAME).EQ.'NO_CHILD1' .OR. TRIM(PARNAME).EQ.'NO_CHILD2') & + print *, ' * check the number of prior/hyper parameters specified ' + STOP + ENDSELECT + ! --------------------------------------------------------------------------------------- + END SUBROUTINE GETPAR_STR END MODULE GETPAR_STR_MODULE diff --git a/build/FUSE_SRC/util/metaoutput.f90 b/build/FUSE_SRC/util/metaoutput.f90 index 7dd1901..77801b0 100644 --- a/build/FUSE_SRC/util/metaoutput.f90 +++ b/build/FUSE_SRC/util/metaoutput.f90 @@ -18,14 +18,16 @@ MODULE metaoutput IMPLICIT NONE private - public :: VARDESCRIBE ! make subroutine public - public :: VNAME, LNAME, VUNIT, isBand ! make metadata variables public - public :: NOUTVAR ! make number of output variables public + public :: VARDESCRIBE ! subroutine + public :: VNAME, LNAME, VUNIT ! metadata + public :: isBand, isFlux ! flags + public :: NOUTVAR 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 CONTAINS @@ -38,78 +40,78 @@ SUBROUTINE VARDESCRIBE() I=0 ! initialize counter ! model forcing - I=I+1; VNAME(I)='ppt '; LNAME(I)='precipitation rate '; VUNIT(I)='mm day-1 '; isBand(i)=.false. - I=I+1; VNAME(I)='pet '; LNAME(I)='potential evapotranspiration rate '; VUNIT(I)='mm day-1 '; isBand(i)=.false. - I=I+1; VNAME(I)='temp '; LNAME(I)='mean air temperature '; VUNIT(I)='deg.C '; isBand(i)=.false. - I=I+1; VNAME(I)='obsq '; LNAME(I)='observed runoff '; VUNIT(I)='mm timestep-1'; isBand(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. - I=I+1; VNAME(I)='tens_1a '; LNAME(I)='tension storage in the soil excess zone '; VUNIT(I)='mm '; isBand(i)=.false. - I=I+1; VNAME(I)='tens_1b '; LNAME(I)='tension storage in the soil recharge zone '; VUNIT(I)='mm '; isBand(i)=.false. - I=I+1; VNAME(I)='free_1 '; LNAME(I)='free storage in the upper layer '; VUNIT(I)='mm '; isBand(i)=.false. - I=I+1; VNAME(I)='watr_1 '; LNAME(I)='total storage in the upper layer '; VUNIT(I)='mm '; isBand(i)=.false. - I=I+1; VNAME(I)='tens_2 '; LNAME(I)='tension storage in the lower layer '; VUNIT(I)='mm '; isBand(i)=.false. - I=I+1; VNAME(I)='free_2 '; LNAME(I)='free storage in the lower layer '; VUNIT(I)='mm '; isBand(i)=.false. - I=I+1; VNAME(I)='free_2a '; LNAME(I)='free storage in the primary baseflow reservoir '; VUNIT(I)='mm '; isBand(i)=.false. - I=I+1; VNAME(I)='free_2b '; LNAME(I)='free storage in the secondary baseflow reservoir '; VUNIT(I)='mm '; isBand(i)=.false. - I=I+1; VNAME(I)='watr_2 '; LNAME(I)='total storage in the lower layer '; VUNIT(I)='mm '; isBand(i)=.false. - - ! snow states - I=I+1; VNAME(I)='swe_tot '; LNAME(I)='total storage as snow '; VUNIT(I)='mm '; isBand(i)=.false. - I=I+1; VNAME(I)='swe_z '; LNAME(I)='elevation band snow water equivalent '; VUNIT(I)='mm '; isBand(i)=.true. - - ! 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. - I=I+1; VNAME(I)='snwmelt_z '; LNAME(I)='band snowpack melt, in water equivalent '; VUNIT(I)='mm timestep-1'; isBand(i)=.true. - - ! model fluxes - I=I+1; VNAME(I)='eff_ppt '; LNAME(I)='effective precipitation rate '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. - I=I+1; VNAME(I)='satarea '; LNAME(I)='saturated area '; VUNIT(I)='- '; isBand(i)=.false. - I=I+1; VNAME(I)='qsurf '; LNAME(I)='surface runoff '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. - I=I+1; VNAME(I)='evap_1a '; LNAME(I)='evaporation from soil excess zone '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. - I=I+1; VNAME(I)='evap_1b '; LNAME(I)='evaporation from soil recharge zone '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. - I=I+1; VNAME(I)='evap_1 '; LNAME(I)='evaporation from the upper soil layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. - I=I+1; VNAME(I)='evap_2 '; LNAME(I)='evaporation from the lower soil layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. - I=I+1; VNAME(I)='rchr2excs '; LNAME(I)='flow from recharge zone to excess zone '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. - 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. - I=I+1; VNAME(I)='oflow_1 '; LNAME(I)='bucket overflow from upper soil layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. - 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. - I=I+1; VNAME(I)='qintf_1 '; LNAME(I)='interflow '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. - I=I+1; VNAME(I)='qperc_12 '; LNAME(I)='percolation from upper to lower soil layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. - I=I+1; VNAME(I)='qbase_2 '; LNAME(I)='baseflow '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. - I=I+1; VNAME(I)='qbase_2a '; LNAME(I)='baseflow from primary baseflow reservoir '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. - I=I+1; VNAME(I)='qbase_2b '; LNAME(I)='baseflow from secondary baseflow reservoir '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. - I=I+1; VNAME(I)='oflow_2 '; LNAME(I)='bucket overflow from lower soil layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. - I=I+1; VNAME(I)='oflow_2a '; LNAME(I)='bucket overflow from primary baseflow reservoir '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. - I=I+1; VNAME(I)='oflow_2b '; LNAME(I)='bucket overflow from secondary baseflow reservoir '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. - - ! 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. - I=I+1; VNAME(I)='err_tens_1a'; LNAME(I)='excessive extrapolation: upper excs tension storage'; VUNIT(I)='mm day-1 '; isBand(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. - I=I+1; VNAME(I)='err_free_1 '; LNAME(I)='excessive extrapolation: upper free storage '; VUNIT(I)='mm day-1 '; isBand(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. - I=I+1; VNAME(I)='err_tens_2 '; LNAME(I)='excessive extrapolation: lower tension storage '; VUNIT(I)='mm day-1 '; isBand(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. - I=I+1; VNAME(I)='err_free_2a'; LNAME(I)='excessive extrapolation: 1st baseflow reservoir '; VUNIT(I)='mm day-1 '; isBand(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. - I=I+1; VNAME(I)='err_watr_2 '; LNAME(I)='excessive extrapolation: lower total storage '; VUNIT(I)='mm day-1 '; isBand(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. - - ! model numerix - I=I+1; VNAME(I)='num_funcs '; LNAME(I)='number of function calls '; VUNIT(I)='- '; isBand(i)=.false. - I=I+1; VNAME(I)='numjacobian'; LNAME(I)='number of times the Jacobian is calculated '; VUNIT(I)='- '; isBand(i)=.false. - I=I+1; VNAME(I)='sub_accept' ; LNAME(I)='number of sub-steps accepted (taken) '; VUNIT(I)='- '; isBand(i)=.false. - I=I+1; VNAME(I)='sub_reject' ; LNAME(I)='number of sub-steps tried but rejected '; VUNIT(I)='- '; isBand(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. - I=I+1; VNAME(I)='max_iterns' ; LNAME(I)='maximum number of iterations in implicit euler '; VUNIT(I)='- '; isBand(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. - I=I+1; VNAME(I)='q_routed '; LNAME(I)='routed runoff '; VUNIT(I)='mm timestep-1'; isBand(i)=.false. + 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 diff --git a/build/Makefile b/build/Makefile index 8e2e36f..36bb858 100644 --- a/build/Makefile +++ b/build/Makefile @@ -97,7 +97,8 @@ DRIVER_EX = fuse.exe # Define the driver program and associated subroutines for the fidelity test FUSE_DRIVER = \ - get_fuse_prelim.f90 \ + setup_domain.f90 \ + setup_model_definition.f90 \ fuse_rmse.f90 functn.f90 \ sce_driver.f90 \ fuse_driver.f90 @@ -106,8 +107,7 @@ DRIVER = $(patsubst %, $(DRIVER_DIR)/%, $(FUSE_DRIVER)) # Manager modules FUSE_HOOKUP= \ kinds_dmsl_kit_FUSE.f90 \ - utilities_dmsl_kit_FUSE.f90 \ - fuse_fileManager.f90 + utilities_dmsl_kit_FUSE.f90 HOOKUP = $(patsubst %, $(HOOKUP_DIR)/%, $(FUSE_HOOKUP)) # Numerical Recipes utilities @@ -140,6 +140,9 @@ TIMUTILS = $(patsubst %, $(TIME_DIR)/%, $(FUSE_TIMEMS)) # Utility modules FUSE_UTILMS= \ + fuse_fileManager.f90 \ + alloc_domain.f90 \ + alloc_scratch.f90 \ metaoutput.f90 \ metaparams.f90 \ meta_stats.f90 \ @@ -235,8 +238,8 @@ FUSE_RUNTIME= \ conv_funcs.f90 \ clrsky_rad.f90 \ getPETgrid.f90 \ - get_mbands.f90 \ - get_time_indices.f90\ + get_time_windows.f90 \ + get_time_indices.f90 \ initfluxes.f90 \ set_all.f90 \ ode_int.f90 \ @@ -249,7 +252,9 @@ RUNTIME = $(patsubst %, $(RUNTIME_DIR)/%, $(FUSE_RUNTIME)) FUSE_NETCDF = \ handle_err.f90 \ extractor.f90 juldayss.f90 caldatss.f90 \ - get_gforce.f90 \ + domain_decomp.f90 \ + get_gforce.f90 \ + get_mbands.f90 \ get_smodel.f90 \ get_fparam.f90 \ def_params.f90 \ @@ -264,7 +269,7 @@ SCE = \ sce_16plus.o # ... and stitch it all together... -FUSE_ALL = $(HOOKUP) $(NRUTIL) $(DATAMS) $(TIMUTILS) $(UTILMS) \ +FUSE_ALL = $(HOOKUP) $(NRUTIL) $(DATAMS) $(UTILMS) $(TIMUTILS) \ $(NR_SUB) $(PHYSICS) $(MODGUT) $(SOLVER) $(PRELIM) $(RUNTIME) \ $(NETCDF) $(SCE) diff --git a/build/generated/fuseversion.inc b/build/generated/fuseversion.inc index 0765f8c..1659eb5 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 = '2025-12-23T15:25:46Z' -character(len=FUSE_GITBRANCH_LEN), parameter :: FUSE_GITBRANCH = 'feature/refactor' -character(len=FUSE_GITHASH_LEN), parameter :: FUSE_GITHASH = '931a21f36dd28801e3272fb784d3394f6dee61a2' +character(len=FUSE_BUILDTIME_LEN), parameter :: FUSE_BUILDTIME = '2025-12-26T18:14:02Z' +character(len=FUSE_GITBRANCH_LEN), parameter :: FUSE_GITBRANCH = 'feature/diffsnow' +character(len=FUSE_GITHASH_LEN), parameter :: FUSE_GITHASH = '35de9a5abda4b24e906685fa067f2b4c2b170c5f'