diff --git a/.gitignore b/.gitignore index dac24e4..647d25e 100644 --- a/.gitignore +++ b/.gitignore @@ -1,24 +1,36 @@ # rtf files *.rtf + # executables and bin directory bin site *.exe + # temporary files *~ *.swp + # any 'junk' files or directories *junk*/ *junk* + +# legacy SVN files +.svn/ + # sublime text workspace and project files *.sublime-project *.sublime-workspace + # cscope and ctags files *cscope* .tags* + # OS X .DS_Store files .DS_Store +# macOS debug symbol bundles +*.dSYM/ + # Compiled Object files *.slo *.lo 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_DRIVERS/.svn/all-wcprops b/build/FUSE_SRC/FUSE_DRIVERS/.svn/all-wcprops deleted file mode 100644 index 54f9b7e..0000000 --- a/build/FUSE_SRC/FUSE_DRIVERS/.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_DRIVERS/.svn/entries b/build/FUSE_SRC/FUSE_DRIVERS/.svn/entries deleted file mode 100644 index bc61e83..0000000 --- a/build/FUSE_SRC/FUSE_DRIVERS/.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_DRIVERS/.svn/text-base/qnewt_mcmc__driver.f90.svn-base b/build/FUSE_SRC/FUSE_DRIVERS/.svn/text-base/qnewt_mcmc__driver.f90.svn-base deleted file mode 100644 index aca9591..0000000 --- a/build/FUSE_SRC/FUSE_DRIVERS/.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_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/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)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/FUSE_ENGINE/multibands.f90 deleted file mode 100644 index 101928d..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/multibands.f90 +++ /dev/null @@ -1,39 +0,0 @@ -! Created by Brian Henn to allow multi-band snow modeling, 6/2013 -! Based on module MULTIFORCE by Martyn Clark -MODULE multibands - USE nrtype - TYPE BANDS ! for catchment scale modeling - INTEGER(I4B) :: NUM ! band number (-) - REAL(SP) :: Z_MID ! band mid-point elevation (m) - REAL(SP) :: AF ! fraction of basin area in band (-) - REAL(SP) :: SWE ! band snowpack water equivalent (mm) - REAL(SP) :: SNOWACCMLTN ! new snow accumulation in band (mm day-1) - REAL(SP) :: SNOWMELT ! snowmelt in band (mm day-1) - REAL(SP) :: DSWE_DT ! rate of change of band SWE (mm day-1) - ENDTYPE BANDS - - ! for distributed modeling MBANDS is split between time-independent and time-dependent charactertistics - - TYPE BANDS_INFO ! invariant characteristics - REAL(SP) :: Z_MID ! band mid-point elevation (m) - REAL(SP) :: AF ! fraction of basin area in band (-) - ENDTYPE BANDS_INFO - - TYPE BANDS_VAR ! time-dependent characteristics - REAL(SP) :: SWE ! band snowpack water equivalent (mm) - REAL(SP) :: SNOWACCMLTN ! new snow accumulation in band (mm day-1) - REAL(SP) :: SNOWMELT ! snowmelt in band (mm day-1) - REAL(SP) :: DSWE_DT ! rate of change of band SWE (mm day-1) - ENDTYPE BANDS_VAR - - ! -------------------------------------------------------------------------------------- - TYPE(BANDS),DIMENSION(:),ALLOCATABLE :: MBANDS ! basin band information - type(BANDS_INFO),dimension(:,:,:),ALLOCATABLE :: MBANDS_INFO_3d ! basin band information in space - type(BANDS_VAR),dimension(:,:,:,:),ALLOCATABLE :: MBANDS_VAR_4d ! basin band information in space plus time - - INTEGER(I4B) :: N_BANDS=0 ! number of bands, initialize to zero - REAL(SP) :: Z_FORCING ! elevation of forcing data (m) - REAL(SP),DIMENSION(:,:),ALLOCATABLE :: Z_FORCING_grid ! elevation of forcing data (m) for the 2D domain - LOGICAL(LGT),DIMENSION(:,:),ALLOCATABLE :: elev_mask ! mask domain - TRUE means the cell must be masked, i.e. not run - ! -------------------------------------------------------------------------------------- -END MODULE multibands diff --git a/build/FUSE_SRC/FUSE_ENGINE/multiforce.f90 b/build/FUSE_SRC/FUSE_ENGINE/multiforce.f90 deleted file mode 100644 index 90d6ec6..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/multiforce.f90 +++ /dev/null @@ -1,160 +0,0 @@ -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark -! Modified by Brian Henn to include snow model, 6/2013 -! Modified by Nans Addor to enable distributed modeling, 9/2016 -! Modified by Cyril Thébault to allow different metrics as objective function, 2024 -! --------------------------------------------------------------------------------------- -MODULE multiforce - USE nrtype - SAVE - ! -------------------------------------------------------------------------------------- - ! the time data structure (will have no spatial dimension) - TYPE TDATA - INTEGER(I4B) :: IY ! year - INTEGER(I4B) :: IM ! month - INTEGER(I4B) :: ID ! day - INTEGER(I4B) :: IH ! hour - INTEGER(I4B) :: IMIN ! minute - REAL(SP) :: DSEC ! second - REAL(SP) :: DTIME ! time in seconds since year dot - ENDTYPE TDATA - ! the response structure (will not have a spatial dimension) - TYPE VDATA - REAL(SP) :: OBSQ ! observed runoff (mm day-1) - END TYPE VDATA - ! ancillary forcing variables used to compute ET (will have a spatial dimension) - TYPE ADATA - REAL(SP) :: AIRTEMP ! air temperature (K) - REAL(SP) :: SPECHUM ! specific humidity (g/g) - REAL(SP) :: AIRPRES ! air pressure (Pa) - REAL(SP) :: SWDOWN ! downward sw radiation (W m-2) - REAL(SP) :: NETRAD ! net radiation (W m-2) - END TYPE ADATA - ! the forcing data structure (will have a spatial dimension) - TYPE FDATA - REAL(SP) :: PPT ! water input: rain + melt (mm day-1) - REAL(SP) :: TEMP ! temperature for snow model (deg.C) - REAL(SP) :: PET ! energy input: potential ET (mm day-1) - ENDTYPE FDATA - ! -------------------------------------------------------------------------------------- - ! general - INTEGER(I4B),PARAMETER :: STRLEN=256 ! length of the character string - ! time data structures - TYPE(tData) :: timDat ! model time structure - ! response data structures - TYPE(vData) :: valDat ! validation structure - TYPE(vData), DIMENSION(:,:,:), POINTER :: aValid ! all model validation data - ! forcing data structures - TYPE(FDATA), DIMENSION(:), POINTER :: CFORCE ! COPY of model forcing data - TYPE(FDATA), DIMENSION(:), POINTER :: AFORCE ! all model forcing data - TYPE(FDATA) :: MFORCE ! model forcing data for a single time step - TYPE(fData), DIMENSION(:,:), POINTER :: gForce ! model forcing data for a 2-d grid - TYPE(aData), DIMENSION(:,:), POINTER :: ancilF ! ancillary forcing data for the 2-d grid - TYPE(fData), DIMENSION(:,:,:), POINTER :: gForce_3d ! model forcing data for a 3-d grid (time as 3rd dimension) - TYPE(aData), DIMENSION(:,:,:), POINTER :: ancilF_3d ! ancillary forcing data for the 3-d grid - - ! timing information - note that numtim_in >= numtim_sim >= numtim_sub - CHARACTER(len=20) :: date_start_input ! date start input time series - CHARACTER(len=20) :: date_end_input ! date end input time series - - INTEGER(i4b) :: numtim_in=-1 ! number of time steps of input (atmospheric forcing) - INTEGER(i4b) :: numtim_sim=-1 ! number of time steps of FUSE simulations (including spin-up) - INTEGER(i4b) :: numtim_sub=-1 ! number of time steps of subperiod (will be kept in memory) - INTEGER(i4b) :: numtim_sub_cur=-1 ! number of time steps of current subperiod (allows for the last subperiod to be shorter) - INTEGER(i4b) :: itim_in=-1 ! indice within numtim_in - INTEGER(i4b) :: itim_sim=-1 ! indice within numtim_sim - INTEGER(i4b) :: itim_sub=-1 ! indice within numtim_sub - - INTEGER(i4b) :: sim_beg=-1 ! index for the start of the simulation in fuse_metric - INTEGER(i4b) :: sim_end=-1 ! index for the end of the simulation in fuse_metric - INTEGER(i4b) :: eval_beg=-1 ! index for the start of evaluation period - INTEGER(i4b) :: eval_end=-1 ! index for the end of the inference period - - INTEGER(i4b) :: istart=-1 ! index for start of inference period (in reduced array) - REAL(sp) :: jdayRef ! reference time (days) - REAL(sp) :: deltim=-1._dp ! length of time step (days) - - LOGICAL(LGT) :: SUB_PERIODS_FLAG ! .true. if subperiods are used to run FUSE - - ! dimension information - INTEGER(i4b) :: startSpat2=-1 ! number of points in 1st spatial dimension - INTEGER(i4b) :: nSpat1=-1 ! number of points in 1st spatial dimension - INTEGER(i4b) :: nSpat2=-1 ! number of points in 2nd spatial dimension - LOGICAL(LGT) :: GRID_FLAG ! spatial flag .true. if grid - REAL(sp) :: xlon ! longitude (degrees) for PET computation - REAL(sp) :: ylat ! latitude (degrees) for PET computation - REAL(sp),dimension(:),allocatable :: latitude ! latitude (degrees) - REAL(sp),dimension(:),allocatable :: longitude ! longitude (degrees) - CHARACTER(len=strLen),dimension(:),allocatable :: name_psets ! name of parameter sets - INTEGER(I4B) :: NUMPSET ! number of parameter sets - REAL(sp),dimension(:),allocatable :: time_steps ! time steps (days) - REAL(sp),dimension(:),allocatable :: julian_day_input ! time steps (julian days) - CHARACTER(len=strLen) :: latUnits ! units string for latitude - CHARACTER(len=strLen) :: lonUnits ! units string for longitude - CHARACTER(len=strLen) :: timeUnits ! units string for time - - ! filename - CHARACTER(len=StrLen) :: forcefile='undefined' ! name of forcing file - - ! name of time variables - CHARACTER(len=StrLen) :: vname_iy ='undefined' ! name of variable for year - CHARACTER(len=StrLen) :: vname_im ='undefined' ! name of variable for month - CHARACTER(len=StrLen) :: vname_id ='undefined' ! name of variable for day - CHARACTER(len=StrLen) :: vname_ih ='undefined' ! name of variable for hour - CHARACTER(len=StrLen) :: vname_imin ='undefined' ! name of variable for minute - CHARACTER(len=StrLen) :: vname_dsec ='undefined' ! name of variable for second - CHARACTER(len=StrLen) :: vname_dtime='undefined' ! name of variable for time - - ! number of forcing variables - INTEGER(i4b), PARAMETER :: nForce=7 ! see lines below - INTEGER(i4b) :: nInput=3 ! number of variable to retrieve from input file - - ! forcing variable names - CHARACTER(len=StrLen) :: vname_aprecip='undefined' ! variable name: precipitation - CHARACTER(len=StrLen) :: vname_potevap='undefined' ! variable name: potential ET - CHARACTER(len=StrLen) :: vname_airtemp='undefined' ! variable name: temperature - CHARACTER(len=StrLen) :: vname_q ='undefined' ! variable name: observed runoff - CHARACTER(len=StrLen) :: vname_spechum='undefined' ! variable name: specific humidity - CHARACTER(len=StrLen) :: vname_airpres='undefined' ! variable name: surface pressure - CHARACTER(len=StrLen) :: vname_swdown ='undefined' ! variable name: downward shortwave radiation - - ! indices for forcing variables - INTEGER(i4b),PARAMETER :: ilook_aprecip=1 ! named element in lCheck - INTEGER(i4b),PARAMETER :: ilook_potevap=2 ! named element in lCheck - INTEGER(i4b),PARAMETER :: ilook_airtemp=3 ! named element in lCheck - INTEGER(i4b),PARAMETER :: ilook_q=4 ! named element in lCheck - INTEGER(i4b),PARAMETER :: ilook_spechum=5 ! named element in lCheck - INTEGER(i4b),PARAMETER :: ilook_airpres=6 ! named element in lCheck - INTEGER(i4b),PARAMETER :: ilook_swdown =7 ! named element in lCheck - - ! NetCDF - INTEGER(i4b) :: ncid_forc=-1 ! NetCDF forcing file ID - INTEGER(i4b),DIMENSION(nForce) :: ncid_var ! NetCDF forcing variable ID - - ! indices for time data (only used in ASCII files) - INTEGER(i4b) :: ivarid_iy=-1 ! variable ID for year - INTEGER(i4b) :: ivarid_im=-1 ! variable ID for month - INTEGER(i4b) :: ivarid_id=-1 ! variable ID for day - INTEGER(i4b) :: ivarid_ih=-1 ! variable ID for hour - INTEGER(i4b) :: ivarid_imin=-1 ! variable ID for minute - INTEGER(i4b) :: ivarid_dsec=-1 ! variable ID for second - - ! indices for variables - INTEGER(i4b) :: ivarid_ppt=-1 ! variable ID for precipitation - INTEGER(i4b) :: ivarid_temp=-1 ! variable ID for temperature - INTEGER(i4b) :: ivarid_pet=-1 ! variable ID for potential ET - INTEGER(i4b) :: ivarid_q=-1 ! variable ID for runoff - - ! multipliers for variables to convert fluxes to mm/day - REAL(sp) :: amult_ppt=-1._dp ! convert precipitation to mm/day - REAL(sp) :: amult_pet=-1._dp ! convert potential ET to mm/day - REAL(sp) :: amult_q=-1._dp ! convert runoff to mm/day - - ! missing values - INTEGER(I4B),PARAMETER :: NA_VALUE=-9999 ! integer designating missing values - TODO: retrieve from NetCDF file - REAL(SP),PARAMETER :: NA_VALUE_SP=-9999 ! integer designating missing values - TODO: retrieve from NetCDF file - - ! -------------------------------------------------------------------------------------- -END MODULE multiforce diff --git a/build/FUSE_SRC/FUSE_ENGINE/multiroute.f90 b/build/FUSE_SRC/FUSE_ENGINE/multiroute.f90 deleted file mode 100644 index f9d046b..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/multiroute.f90 +++ /dev/null @@ -1,13 +0,0 @@ -MODULE multiroute - USE nrtype - USE model_defn,ONLY:NTDH_MAX - TYPE RUNOFF - REAL(SP) :: Q_INSTNT ! instantaneous runoff - REAL(SP) :: Q_ROUTED ! routed runoff - REAL(SP) :: Q_ACCURATE ! "accurate" runoff estimate (mm day-1) - END TYPE RUNOFF - REAL(SP), DIMENSION(NTDH_MAX) :: FUTURE ! runoff placed in future time steps - TYPE(RUNOFF), DIMENSION(:), POINTER :: AROUTE ! runoff for all time steps - TYPE(RUNOFF),dimension(:,:,:), allocatable :: AROUTE_3d ! runoff for all time steps on a grid - TYPE(RUNOFF) :: MROUTE ! runoff for one time step -END MODULE multiroute diff --git a/build/FUSE_SRC/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/parextract.f90 b/build/FUSE_SRC/FUSE_ENGINE/parextract.f90 deleted file mode 100644 index e9499d6..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/parextract.f90 +++ /dev/null @@ -1,237 +0,0 @@ -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 -END MODULE PAREXTRACT_MODULE diff --git a/build/FUSE_SRC/FUSE_ENGINE/varextract.f90 b/build/FUSE_SRC/FUSE_ENGINE/varextract.f90 deleted file mode 100644 index f73f766..0000000 --- a/build/FUSE_SRC/FUSE_ENGINE/varextract.f90 +++ /dev/null @@ -1,508 +0,0 @@ -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 - -! --------------------------------------------------------------------------------------- -! 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 - 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 - -! save the output -VAREXTRACT_3d = XVAR_3d - -! --------------------------------------------------------------------------------------- -END FUNCTION VAREXTRACT_3d - -END MODULE VAREXTRACT_MODULE diff --git a/build/FUSE_SRC/FUSE_HOOK/.svn/all-wcprops b/build/FUSE_SRC/FUSE_HOOK/.svn/all-wcprops deleted file mode 100644 index 53a94c3..0000000 --- a/build/FUSE_SRC/FUSE_HOOK/.svn/all-wcprops +++ /dev/null @@ -1,29 +0,0 @@ -K 25 -svn:wc:ra_dav:version-url -V 61 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_HOOK -END -fuse_stdDmdl_dmsl_mod.f90 -K 25 -svn:wc:ra_dav:version-url -V 87 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/61/trunk/FUSE_SRC/FUSE_HOOK/fuse_stdDmdl_dmsl_mod.f90 -END -fuse_fileManager.f90 -K 25 -svn:wc:ra_dav:version-url -V 82 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/53/trunk/FUSE_SRC/FUSE_HOOK/fuse_fileManager.f90 -END -make_batea_parfiles.f90 -K 25 -svn:wc:ra_dav:version-url -V 84 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/2/trunk/FUSE_SRC/FUSE_HOOK/make_batea_parfiles.f90 -END -kinds_dmsl_kit_FUSE.f90 -K 25 -svn:wc:ra_dav:version-url -V 85 -/UoNEnvEngGroup/FUSE/svn/!svn/ver/17/trunk/FUSE_SRC/FUSE_HOOK/kinds_dmsl_kit_FUSE.f90 -END diff --git a/build/FUSE_SRC/FUSE_HOOK/.svn/entries b/build/FUSE_SRC/FUSE_HOOK/.svn/entries deleted file mode 100644 index 4bda70b..0000000 --- a/build/FUSE_SRC/FUSE_HOOK/.svn/entries +++ /dev/null @@ -1,164 +0,0 @@ -10 - -dir -63 -https://venture1.projectlocker.com/UoNEnvEngGroup/FUSE/svn/trunk/FUSE_SRC/FUSE_HOOK -https://venture1.projectlocker.com/UoNEnvEngGroup/FUSE/svn - - - -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - -7fd0be38-6417-4f01-9cbe-fd474d0c6e94 - -fuse_stdDmdl_dmsl_mod.f90 -file - - - - -2013-06-12T18:10:48.587574Z -39ced71d302e33bbce25c39bbbfe4167 -2013-06-05T10:46:52.354320Z -61 -kavetski - - - - - - - - - - - - - - - - - - - - - -20234 - -fuse_fileManager.f90 -file - - - - -2013-06-12T18:10:48.587574Z -5b0dd2baa2d55f60df5547f8b6bc8240 -2012-06-17T20:33:43.707629Z -53 -kavetski - - - - - - - - - - - - - - - - - - - - - -5380 - -make_batea_parfiles.f90 -file - - - - -2013-06-12T18:10:48.587574Z -ff4fda670d59cb431a3d3bff3ba816cd -2009-10-17T03:04:46.490493Z -2 -kavetski - - - - - - - - - - - - - - - - - - - - - -1069 - -kinds_dmsl_kit_FUSE.f90 -file - - - - -2013-06-12T18:10:48.587574Z -b72e30114d8b693a9a45d52a8942f5fa -2010-01-08T05:59:16.181435Z -17 -kavetski - - - - - - - - - - - - - - - - - - - - - -7628 - diff --git a/build/FUSE_SRC/FUSE_HOOK/.svn/text-base/fuse_fileManager.f90.svn-base b/build/FUSE_SRC/FUSE_HOOK/.svn/text-base/fuse_fileManager.f90.svn-base deleted file mode 100644 index 2ed2801..0000000 --- a/build/FUSE_SRC/FUSE_HOOK/.svn/text-base/fuse_fileManager.f90.svn-base +++ /dev/null @@ -1,125 +0,0 @@ -!****************************************************************** -! (C) Copyright 2009-2010 --- Dmitri Kavetski and Martyn Clark --- All rights reserved -!****************************************************************** -MODULE fuse_filemanager -use kinds_dmsl_kit_FUSE -implicit none -public -! FUSE-wide pathlength -integer(mik),parameter::fusePathLen=256 -! defines the path for data files (and default values) -CHARACTER(LEN=fusePathLen) :: SETNGS_PATH='C:\DMITRI\My_Documents\FortranLibs\FUSE_MPC_V2\settings\' ! turbine -CHARACTER(LEN=fusePathLen) :: INPUT_PATH ='C:\DMITRI\My_Documents\FortranLibs\FUSE_MPC_V2\input\' ! turbine -CHARACTER(LEN=fusePathLen) :: OUTPUT_PATH='C:\DMITRI\My_Documents\FortranLibs\FUSE_MPC_V2\output\' ! turbine -! define name of control files (and default values) -CHARACTER(LEN=fusePathLen) :: M_DECISIONS='fuse_zDecisions.txt' ! definition of model decisions -CHARACTER(LEN=fusePathLen) :: CONSTRAINTS='fuse_zConstraints.txt' ! definition of parameter constraints -CHARACTER(LEN=fusePathLen) :: MOD_NUMERIX='fuse_zNumerix.txt' ! definition of numerical solution technique -! additional control files (not needed by the FUSE engines) -CHARACTER(LEN=fusePathLen) :: FORCINGINFO='forcinginfo.txt' ! info on forcing data files -CHARACTER(LEN=fusePathLen) :: BATEA_PARAM='batea_param.txt' ! definition of BATEA parameters -!---------------------------------------------------- -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 -! --- -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=" " -integer(mik),parameter::unt=1 !DK: need to either define units globally, or use getSpareUnit -character(*),parameter::fuseMusterDirektorHeader="FUSE_MUSTERDIREKTOR_V1.0" -character(*),parameter::fuseFileManagerHeader="FUSE_FILEMANAGER_V1.0" -! locals -logical(mlk)::haveFMG,haveMUS -character(LEN=fusePathLen)::fuseMusterDirektor,fuseFileManager,defpath -character(LEN=100)::temp -integer(mik)::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) -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/def_output.f90 b/build/FUSE_SRC/FUSE_NETCDF/def_output.f90 deleted file mode 100644 index 13b256d..0000000 --- a/build/FUSE_SRC/FUSE_NETCDF/def_output.f90 +++ /dev/null @@ -1,197 +0,0 @@ -SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,NPSET,NTIM) - - ! --------------------------------------------------------------------------------------- - ! Creator: - ! -------- - ! Martyn Clark, 2007 - ! --------------------------------------------------------------------------------------- - ! Purpose: - ! -------- - ! Define NetCDF output files -- time-varying model output - ! --------------------------------------------------------------------------------------- - - USE nrtype ! variable types, etc. - USE model_defn ! model definition (includes filename) - USE metaoutput ! metadata for all model variables - USE fuse_fileManager,only: Q_ONLY ! only write streamflow to output file? - USE multiforce, only: GRID_FLAG ! .true. if distributed - USE multiforce, only: latitude,longitude ! dimension arrays - USE multiforce, only: name_psets,time_steps ! dimension arrays - USE multiforce, only: latUnits,lonUnits ! units string - USE multiforce, only: timeUnits ! units string - USE multistate, only: ncid_out ! NetCDF output file ID - - IMPLICIT NONE - - ! input - INTEGER(I4B), INTENT(IN) :: NTIM ! number of time steps - INTEGER(I4B), INTENT(IN) :: nSpat1,nSpat2 ! length of spatial dimensions - INTEGER(I4B), INTENT(IN) :: NPSET ! number of parameter sets - - ! internal - REAL(MSP),DIMENSION(nspat1) :: longitude_msp ! desired variable (SINGLE PRECISION) - REAL(MSP),DIMENSION(nspat2) :: latitude_msp ! desired variable (SINGLE PRECISION) - REAL(SP),parameter :: NA_VALUE_OUT= -9999. ! NA_VALUE for output file - REAL(MSP) :: NA_VALUE_OUT_MSP ! NA_VALUE for output file - - LOGICAL(LGT) :: WRITE_VAR ! used to denote if the variable is written - INTEGER(I4B) :: IERR ! error code - INTEGER(I4B) :: NTIM_DIM ! time - INTEGER(I4B) :: lon_dim ! 1st spatial dimension - INTEGER(I4B) :: lat_dim ! 2nd spatial dimension - INTEGER(I4B) :: param_dim ! parameter set dimension - INTEGER(I4B) :: NMOD_DIM ! number of models - INTEGER(I4B), DIMENSION(:), ALLOCATABLE :: TVAR ! all dimensions - INTEGER(I4B) :: IVAR ! loop through variables - INTEGER(I4B) :: IVAR_ID ! variable ID - - INTEGER(I4B) :: CHID ! char position dimension id - INTEGER(I4B),parameter :: TDIMS=2 ! char position dimension id - INTEGER(I4B) :: TXDIMS(TDIMS) ! variable shape - INTEGER(I4B) :: TSTART(TDIMS), TCOUNT(TDIMS) - - include 'netcdf.inc' ! use netCDF libraries - - ! --------------------------------------------------------------------------------------- - CALL VARDESCRIBE() ! get list of variable descriptions - ! --------------------------------------------------------------------------------------- -! put file in define mode - print *, 'Create NetCDF file for runs:' - PRINT *, FNAME_NETCDF_RUNS - - IERR = NF_CREATE(TRIM(FNAME_NETCDF_RUNS),NF_CLOBBER,ncid_out); CALL HANDLE_ERR(IERR) - !IERR = NF_OPEN(TRIM(FNAME_NETCDF_RUNS),NF_WRITE,ncid_out); CALL HANDLE_ERR(IERR) - !IERR = NF_REDEF(ncid_out); CALL HANDLE_ERR(IERR) - - ! define dimensions - IERR = NF_DEF_DIM(ncid_out,'time',NF_UNLIMITED,NTIM_DIM); CALL HANDLE_ERR(IERR) !record dimension (unlimited length) - IERR = NF_DEF_DIM(ncid_out,'longitude',nSpat1,lon_dim); CALL HANDLE_ERR(IERR) - IERR = NF_DEF_DIM(ncid_out,'latitude',nSpat2,lat_dim); CALL HANDLE_ERR(IERR) - IF(.NOT.GRID_FLAG)THEN - IERR = NF_DEF_DIM(ncid_out,'param_set',NPSET,param_dim); CALL HANDLE_ERR(IERR) - ENDIF - - - ! define character-position dimension for strings of max length 40 - !IERR = NF_DEF_DIM(ncid_out, "chid", 40, CHID); CALL HANDLE_ERR(IERR) - - ! define a character-string variable - ! TXDIMS(1) = CHID ! character-position dimension first - ! TXDIMS(2) = NTIM_DIM ! record dimension ID - ! IERR = NF_DEF_VAR(ncid_out, 'param_set',NF_CHAR, TDIMS, TXDIMS, param_dim); CALL HANDLE_ERR(IERR) - - ! retrieve ID for the model and parameter dimensions - !IERR = NF_INQ_DIMID(ncid_out,'par',NPAR_DIM); CALL HANDLE_ERR(IERR) - !IERR = NF_INQ_DIMID(ncid_out,'mod',NMOD_DIM); CALL HANDLE_ERR(IERR) - - ! assign dimensions to indices: for efficiency reasons, param_dim should be - ! last, because it varies the slowest, but the NetCDF standard imposes - ! the unlimited dimension to be last. - - IF(.NOT.GRID_FLAG)THEN - allocate(TVAR(4)) - TVAR = (/lon_dim,lat_dim,param_dim,NTIM_DIM/) - ELSE - allocate(TVAR(3)) - TVAR = (/lon_dim,lat_dim,NTIM_DIM/) ! no parameter dimension in grid mode - ENDIF - - ! define time-varying output variables - DO IVAR=1,NOUTVAR - - ! check if there is a need to write the variable - see also put_output - ! uncomment variables that should be written to output file - IF (Q_ONLY) THEN - WRITE_VAR=.FALSE. - !IF (TRIM(VNAME(IVAR)).EQ.'ppt') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'pet') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'obsq') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'evap_1') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'evap_2') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'q_instnt') WRITE_VAR=.TRUE. - IF (TRIM(VNAME(IVAR)).EQ.'q_routed') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'watr_1') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'watr_2') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'swe_tot') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'qsurf') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'oflow_1') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'qintf_1') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'oflow_2') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'qbase_2') WRITE_VAR=.TRUE. - IF (.NOT.WRITE_VAR) CYCLE ! start new iteration of do loop, i.e. skip writting variable - ENDIF - - ! write the variable - IF(.NOT.GRID_FLAG)THEN - IERR = NF_DEF_VAR(ncid_out,TRIM(VNAME(IVAR)),NF_REAL,4,TVAR,IVAR_ID); CALL HANDLE_ERR(IERR) - ELSE - IERR = NF_DEF_VAR(ncid_out,TRIM(VNAME(IVAR)),NF_REAL,3,TVAR,IVAR_ID); CALL HANDLE_ERR(IERR) - ENDIF - - - IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'long_name',LEN_TRIM(LNAME(IVAR)),TRIM(LNAME(IVAR))) - CALL HANDLE_ERR(IERR) - IERR = NF_PUT_ATT_TEXT(ncid_out,IVAR_ID,'units',LEN_TRIM(VUNIT(IVAR)),TRIM(VUNIT(IVAR))) - CALL HANDLE_ERR(IERR) - !IERR = NF_DEF_VAR_FILL(ncid_out,IVAR_ID,0,NA_VALUE) ! define _FillValue for NetCDF4 files only - NA_VALUE_OUT_MSP=NA_VALUE_OUT - IERR = NF_PUT_ATT_REAL(ncid_out,IVAR_ID,'_FillValue',NF_FLOAT,1,NA_VALUE_OUT_MSP) - CALL HANDLE_ERR(IERR) - - END DO ! ivar - - ! define the time variable - ierr = nf_def_var(ncid_out,'time',nf_real,1,(/ntim_dim/),ivar_id); call handle_err(ierr) - ierr = nf_put_att_text(ncid_out,ivar_id,'units',len_trim(timeUnits),trim(timeUnits)) - call handle_err(ierr) - - ! define the latitude variable - ierr = nf_def_var(ncid_out,'latitude',nf_real,1,(/lat_dim/),ivar_id); call handle_err(ierr) - ierr = nf_put_att_text(ncid_out,ivar_id,'units',8,'degreesN'); call handle_err(ierr) - ierr = nf_put_att_text(ncid_out,ivar_id,'axis',1,'Y'); call handle_err(ierr) - - ! define the longitude variable - ierr = nf_def_var(ncid_out,'longitude',nf_real,1,(/lon_dim/),ivar_id); call handle_err(ierr) - ierr = nf_put_att_text(ncid_out,ivar_id,'units',8,'degreesE'); call handle_err(ierr) - ierr = nf_put_att_text(ncid_out,ivar_id,'axis',1,'X'); call handle_err(ierr) - - IF(.NOT.GRID_FLAG)THEN - ! define the param_set variable - ierr = nf_def_var(ncid_out,'param_set',nf_char,1,(/param_dim/),ivar_id); call handle_err(ierr) - ierr = nf_put_att_text(ncid_out,ivar_id,'units',1,'-'); call handle_err(ierr) - ENDIF - - ! end definitions - IERR = NF_ENDDEF(ncid_out); call handle_err(ierr) - - !IERR = NF_OPEN(TRIM(FNAME_NETCDF),NF_WRITE,ncid_out); CALL HANDLE_ERR(IERR) - latitude_msp=latitude ! convert to actual single precision - IERR = NF_INQ_VARID(ncid_out,'latitude',IVAR_ID); CALL HANDLE_ERR(IERR) ! get variable ID - IERR = NF_PUT_VARA_REAL(ncid_out,IVAR_ID,1,nspat2,latitude_msp); CALL HANDLE_ERR(IERR) ! write data - - longitude_msp=longitude ! convert to actual single precision - IERR = NF_INQ_VARID(ncid_out,'longitude',IVAR_ID); CALL HANDLE_ERR(IERR) ! get variable ID - IERR = NF_PUT_VARA_REAL(ncid_out,IVAR_ID,1,nspat1,longitude_msp); CALL HANDLE_ERR(IERR) ! write data - - !TSTART(1) = 1 ! start at beginning of variable - !TSTART(2) = 1 ! record number to write - !TCOUNT(1) = 20 ! number of chars to write - !TCOUNT(2) = 1 ! only write one record - - !IERR = NF_INQ_VARID(ncid_out,'param_set',IVAR_ID); CALL HANDLE_ERR(IERR) ! get variable ID - !IERR = NF_PUT_VARA_TEXT(ncid_out,IVAR_ID,1,NPSET,name_psets); CALL HANDLE_ERR(IERR) ! write data - !IERR = NF_PUT_VARA_TEXT(ncid_out,IVAR_ID,TSTART,TCOUNT,name_psets); CALL HANDLE_ERR(IERR) ! write data - - IF(.NOT.GRID_FLAG)THEN - PRINT *, 'NetCDF file for model runs defined with dimensions', nSpat1 , nSpat2, NPSET, NTIM - ELSE - PRINT *, 'NetCDF file for model runs defined with dimensions', nSpat1 , nSpat2, NTIM - ENDIF - - IERR = NF_ENDDEF(ncid_out) - IERR = NF_CLOSE(ncid_out) - - deallocate(TVAR) - -! --------------------------------------------------------------------------------------- -END SUBROUTINE DEF_OUTPUT diff --git a/build/FUSE_SRC/FUSE_NETCDF/put_output.f90 b/build/FUSE_SRC/FUSE_NETCDF/put_output.f90 deleted file mode 100644 index ed8bae8..0000000 --- a/build/FUSE_SRC/FUSE_NETCDF/put_output.f90 +++ /dev/null @@ -1,190 +0,0 @@ -SUBROUTINE PUT_OUTPUT(iSpat1,iSpat2,ITIM,IMOD,IPAR) - - ! --------------------------------------------------------------------------------------- - ! Creator: - ! -------- - ! Martyn Clark, 2007 - ! --------------------------------------------------------------------------------------- - ! Purpose: - ! -------- - ! write NetCDF output files - ! --------------------------------------------------------------------------------------- - USE nrtype ! variable types, etc. - USE model_defn ! model definition (includes filename) - USE metaoutput ! metadata for time-varying model output - USE varextract_module ! interface for the function to extract variables - USE fuse_fileManager,only: Q_ONLY ! only write streamflow to output file? - USE multiforce,ONLY: timDat ! time data - USE multistate, only: ncid_out ! NetCDF output file ID - - IMPLICIT NONE - ! input - INTEGER(I4B), INTENT(IN) :: iSpat1 ! index of 1st spatial dimension - INTEGER(I4B), INTENT(IN) :: iSpat2 ! index of 2nd spatial dimension - INTEGER(I4B), INTENT(IN) :: ITIM ! time step index - INTEGER(I4B), INTENT(IN) :: IMOD ! model index - INTEGER(I4B), INTENT(IN) :: IPAR ! parameter set index - ! internal - LOGICAL(LGT) :: WRITE_VAR ! used to denote if the variable is written - INTEGER(I4B) :: IERR ! error code - !INTEGER(I4B), DIMENSION(5) :: INDX ! indices for time series write - INTEGER(I4B), DIMENSION(3) :: INDX ! indices for time series write - INTEGER(I4B) :: IVAR ! loop through variables - REAL(SP) :: XVAR ! desired variable (SP NOT NECESSARILY SP) - REAL(MSP) :: AVAR ! desired variable (SINGLE PRECISION) - REAL(MSP) :: tDat ! time data - INTEGER(I4B) :: IVAR_ID ! variable ID - INCLUDE 'netcdf.inc' ! use netCDF libraries - ! --------------------------------------------------------------------------------------- - ! open file - IERR = NF_OPEN(TRIM(FNAME_NETCDF_RUNS),NF_WRITE,ncid_out); CALL HANDLE_ERR(IERR) - - ! define indices for model output - INDX = (/iSpat1,iSpat2,ITIM/) - - ! loop through time-varying model output - DO IVAR=1,NOUTVAR - - ! check if there is a need to write the variable - see also def_output - IF (Q_ONLY) THEN - WRITE_VAR=.FALSE. - !IF (TRIM(VNAME(IVAR)).EQ.'ppt') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'pet') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'obsq') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'evap_1') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'evap_2') WRITE_VAR=.TRUE. - IF (TRIM(VNAME(IVAR)).EQ.'q_instnt') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'q_routed') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'watr_1') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'watr_2') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'swe_tot') WRITE_VAR=.TRUE. - IF (.NOT.WRITE_VAR) CYCLE - ENDIF - - ! write the variable - XVAR = VAREXTRACT(VNAME(IVAR)); AVAR=XVAR ! get variable ivar - IERR = NF_INQ_VARID(ncid_out,TRIM(VNAME(IVAR)),IVAR_ID); CALL HANDLE_ERR(IERR) ! get variable ID - IERR = NF_PUT_VAR1_REAL(ncid_out,IVAR_ID,INDX,AVAR); CALL HANDLE_ERR(IERR) ! write data - - END DO ! (ivar) - - ! write the time - tDat = timDat%dtime ! convert to actual single precision - ierr = nf_inq_varid(ncid_out,'time',ivar_id); CALL handle_err(ierr) ! get variable ID for time - ierr = nf_put_var1_real(ncid_out,ivar_id,(/itim/),tDat); CALL handle_err(ierr) ! write time variable - - ! close NetCDF file - IERR = NF_CLOSE(ncid_out) - -END SUBROUTINE PUT_OUTPUT - -SUBROUTINE PUT_GOUTPUT_3D(istart_sim,istart_in,numtim,IPSET) - ! --------------------------------------------------------------------------------------- - ! Creator: - ! -------- - ! Nans Addor, based on Martyn Clark's 2007 PUT_OUTPUT - ! --------------------------------------------------------------------------------------- - ! Purpose: - ! -------- - ! write a 3D data structure to the NetCDF output file - ! --------------------------------------------------------------------------------------- - USE nrtype ! variable types, etc. - USE model_defn ! model definition (includes filename) - USE metaoutput ! metadata for time-varying model output - USE varextract_module ! interface for the function to extract variables - USE fuse_fileManager,only: Q_ONLY ! only write streamflow to output file? - - USE multiforce, ONLY: timDat,time_steps ! time data - USE multistate, only: ncid_out ! NetCDF output file ID - USE multiforce, ONLY: nspat1,nspat2,startSpat2 ! spatial dimensions - USE multiforce, ONLY: gForce_3d ! test only - USE multiforce, only: GRID_FLAG ! .true. if distributed - - IMPLICIT NONE - - ! input - INTEGER(I4B), INTENT(IN) :: istart_sim ! index start time step relative to numtim_sim - INTEGER(I4B), INTENT(IN) :: istart_in ! index start time step relative to numtim_in - for time dimension - INTEGER(I4B), INTENT(IN) :: numtim ! number of time steps to write - INTEGER(I4B), INTENT(IN) :: IPSET ! parameter set index - - ! internal - LOGICAL(LGT) :: WRITE_VAR ! used to denote if the variable is written - INTEGER(I4B) :: IERR ! error code - INTEGER(I4B), DIMENSION(:), ALLOCATABLE :: IND_START ! start indices - INTEGER(I4B), DIMENSION(:), ALLOCATABLE :: IND_COUNT ! count indices - INTEGER(I4B) :: IVAR ! loop through variables - REAL(SP) :: XVAR ! desired variable (SP NOT NECESSARILY SP) - REAL(MSP) :: AVAR ! desired variable (SINGLE PRECISION) - REAL(SP), DIMENSION(nspat1,nspat2,numtim) :: XVAR_3d ! desired variable (SINGLE PRECISION) - REAL(MSP), DIMENSION(nspat1,nspat2,numtim) :: AVAR_3d ! desired variable (SINGLE PRECISION) - REAL(MSP), DIMENSION(:), ALLOCATABLE :: tDat ! time data - REAL(SP), DIMENSION(:), ALLOCATABLE :: time_steps_sub ! time data - INTEGER(I4B) :: IVAR_ID ! variable ID - INCLUDE 'netcdf.inc' ! use netCDF libraries - - ! open file - IERR = NF_OPEN(TRIM(FNAME_NETCDF_RUNS),NF_WRITE,ncid_out); CALL HANDLE_ERR(IERR) - - ! define indices for model output - ! if enabling parallel output you need 1,startSpat2 instead of 1,1 below - - IF(.NOT.GRID_FLAG)THEN - allocate(IND_START(4),IND_COUNT(4)) - IND_START = (/1,1,IPSET,istart_sim/) ! the indices start at 1, i.e. first element in (1, 1, ..., 1) - IND_COUNT = (/nspat1,nspat2,1,numtim/) ! third element is 1 because we only write results for one parameter set at a time - ELSE - allocate(IND_START(3),IND_COUNT(3)) - IND_START = (/1,1,istart_sim/) ! no parameter dimension in grid mode - IND_COUNT = (/nspat1,nspat2,numtim/) - ENDIF - - PRINT *, 'IND_START=', IND_START - PRINT *, 'IND_COUNT=', IND_COUNT - - ! loop through time-varying model output - DO IVAR=1,NOUTVAR - - ! check if there is a need to write the variable - see also def_output - IF (Q_ONLY) THEN - WRITE_VAR=.FALSE. - !IF (TRIM(VNAME(IVAR)).EQ.'ppt') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'pet') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'obsq') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'evap_1') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'evap_2') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'q_instnt') WRITE_VAR=.TRUE. - IF (TRIM(VNAME(IVAR)).EQ.'q_routed') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'watr_1') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'watr_2') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'swe_tot') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'qsurf') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'oflow_1') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'qintf_1') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'oflow_2') WRITE_VAR=.TRUE. - !IF (TRIM(VNAME(IVAR)).EQ.'qbase_2') WRITE_VAR=.TRUE. - IF (.NOT.WRITE_VAR) CYCLE ! start new iteration of do loop, i.e. skip writting variable - ENDIF - - ! write the variable - XVAR_3d = VAREXTRACT_3d(VNAME(IVAR),numtim) ! get variable - AVAR_3d = XVAR_3d ! convert format - IERR = NF_INQ_VARID(ncid_out,TRIM(VNAME(IVAR)),IVAR_ID); CALL HANDLE_ERR(IERR) ! get variable ID - IERR = NF_PUT_VARA_REAL(ncid_out,IVAR_ID,IND_START,IND_COUNT,AVAR_3d); CALL HANDLE_ERR(IERR) ! write data - - END DO ! (ivar) - - ! write the time - allocate(tDat(numtim),time_steps_sub(numtim)) - - time_steps_sub = time_steps(istart_in:(istart_in+numtim-1)) ! extract time for subperiod - tDat = time_steps_sub ! convert to actual single precision - ierr = nf_inq_varid(ncid_out,'time',ivar_id); CALL handle_err(ierr) ! get variable ID for time - ierr = nf_put_vara_real(ncid_out,ivar_id,(/istart_sim/),(/numtim/),tDat); CALL handle_err(ierr) ! write time variable - - ! close NetCDF file - IERR = NF_CLOSE(ncid_out) - - deallocate(tDat,time_steps_sub,IND_START,IND_COUNT) - -END SUBROUTINE PUT_GOUTPUT_3D diff --git a/build/FUSE_SRC/FUSE_NETCDF/put_params.f90 b/build/FUSE_SRC/FUSE_NETCDF/put_params.f90 deleted file mode 100644 index 46430b9..0000000 --- a/build/FUSE_SRC/FUSE_NETCDF/put_params.f90 +++ /dev/null @@ -1,80 +0,0 @@ -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 -! --------------------------------------------------------------------------------------- - -! 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 - - 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 - - END DO ! (ivar) - - ! 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 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_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_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 diff --git a/build/FUSE_SRC/FUSE_DRIVERS/URS_driver.f90 b/build/FUSE_SRC/deprecated/FUSE_DMSL/URS_driver.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DRIVERS/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_DRIVERS/sobol.f90 b/build/FUSE_SRC/deprecated/FUSE_MAIN/sobol.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DRIVERS/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_MAIN/sobol.f90 b/build/FUSE_SRC/deprecated/FUSE_NUMERIX/sobol.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_MAIN/sobol.f90 rename to build/FUSE_SRC/deprecated/FUSE_NUMERIX/sobol.f90 diff --git a/build/FUSE_SRC/FUSE_DMSL/URS_driver.f90 b/build/FUSE_SRC/deprecated/FUSE_PARSENS/URS_driver.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_DMSL/URS_driver.f90 rename to build/FUSE_SRC/deprecated/FUSE_PARSENS/URS_driver.f90 diff --git a/build/FUSE_SRC/FUSE_DRIVERS/qnewt_mcmc__driver.f90 b/build/FUSE_SRC/deprecated/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/deprecated/FUSE_PARSENS/qnewt_mcmc__driver.f90 diff --git a/build/FUSE_SRC/FUSE_NUMERIX/sobol.f90 b/build/FUSE_SRC/deprecated/FUSE_PARSENS/sobol.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_NUMERIX/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_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_DMSL/functn.f90 b/build/FUSE_SRC/driver/functn.f90 similarity index 96% rename from build/FUSE_SRC/FUSE_DMSL/functn.f90 rename to build/FUSE_SRC/driver/functn.f90 index 91c0f4f..fa5acf7 100644 --- a/build/FUSE_SRC/FUSE_DMSL/functn.f90 +++ b/build/FUSE_SRC/driver/functn.f90 @@ -13,6 +13,7 @@ FUNCTION FUNCTN(NOPT,A) USE fuse_metric_module ! run model and compute the metric chosen as objective function USE multiforce, only: ncid_forc ! NetCDF forcing file ID USE fuse_fileManager,only:METRIC, TRANSFO ! metric and transformation requested in the filemanager +USE globaldata, only: nFUSE_eval ! # fuse evaluations IMPLICIT NONE ! input @@ -31,6 +32,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/driver/fuse_driver.f90 similarity index 90% rename from build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 rename to build/FUSE_SRC/driver/fuse_driver.f90 index 32b4cee..6874735 100644 --- a/build/FUSE_SRC/FUSE_DMSL/fuse_driver.f90 +++ b/build/FUSE_SRC/driver/fuse_driver.f90 @@ -24,6 +24,8 @@ 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 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 @@ -40,7 +42,7 @@ 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: NUMPSET ! number of parameter sets USE multiforce, only: ncid_forc ! NetCDF forcing file ID USE multiforce, only: ncid_var ! NetCDF forcing variable ID @@ -59,6 +61,7 @@ PROGRAM DISTRIBUTED_DRIVER USE getpar_str_module ! extracts parameter metadata USE par_insert_module ! inserts model parameters USE force_info_module,only:force_info ! get forcing info for NetCDF files +USE def_output_module,only:def_output ! define NetCDF output file USE get_gforce_module,only:read_ginfo ! get dimension lengths from the NetCDF file USE get_gforce_module,only:get_varid ! get netCDF ID for forcing variables USE get_gforce_module,only:get_gforce_3d ! get forcing @@ -84,14 +87,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? @@ -119,7 +123,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 @@ -127,7 +131,6 @@ 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) :: METRIC_VAL ! error from the simulation - ! --------------------------------------------------------------------------------------- ! SCE VARIABLES ! --------------------------------------------------------------------------------------- @@ -177,22 +180,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 ! --------------------------------------------------------------------------------------- @@ -256,6 +265,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) @@ -300,44 +310,15 @@ PROGRAM DISTRIBUTED_DRIVER #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 @@ -386,7 +367,7 @@ PROGRAM DISTRIBUTED_DRIVER CALL DEF_PARAMS(NUMPSET) ! define model parameters (initial CREATE) CALL DEF_SSTATS() ! define summary statistics (REDEF) -CALL DEF_OUTPUT(nSpat1,nSpat2,NUMPSET,numtim_sim) ! define model output time series (REDEF) +CALL DEF_OUTPUT(nSpat1,nSpat2,N_BANDS,NUMPSET,numtim_sim) ! define model output time series (REDEF) ! --------------------------------------------------------------------------------------- ! RUN FUSE IN DESIRED MODE @@ -415,22 +396,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) + FNAME_NETCDF_PARA_PRE=TRIM(OUTPUT_PATH)//file_param + PRINT *, 'Loading parameter set ',IPSET,':' - print *, 'Running FUSE with pre-defined parameter set' - CALL FUSE_METRIC(APAR,GRID_FLAG,NCID_FORC,METRIC_VAL,OUTPUT_FLAG,IPSET) - print *, 'Done running FUSE with pre-defined parameter set' + ! load specific parameter set + CALL GET_PRE_PARAM(FNAME_NETCDF_PARA_PRE,IPSET,ONEMOD,NUMPAR,APAR) - end do - - DEALLOCATE(name_psets) + print *, 'Running FUSE with pre-defined parameter set' + CALL FUSE_METRIC(APAR,GRID_FLAG,NCID_FORC,METRIC_VAL,OUTPUT_FLAG,1) ! last argument IPSET=1 + print *, 'Done running FUSE with pre-defined parameter set' ELSE IF(fuse_mode == 'calib_sce')THEN ! calibrate FUSE using SCE @@ -439,6 +413,10 @@ PROGRAM DISTRIBUTED_DRIVER 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 evaluations + ! convert from SP used in FUSE to MSP used in SCE ALLOCATE(APAR_MSP(NUMPAR),BL_MSP(NUMPAR),BU_MSP(NUMPAR),URAND_MSP(NUMPAR)) @@ -448,10 +426,16 @@ 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)) + ! 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,& diff --git a/build/FUSE_SRC/FUSE_DMSL/fuse_metric.f90 b/build/FUSE_SRC/driver/fuse_metric.f90 similarity index 62% rename from build/FUSE_SRC/FUSE_DMSL/fuse_metric.f90 rename to build/FUSE_SRC/driver/fuse_metric.f90 index c22a43b..d7ec781 100644 --- a/build/FUSE_SRC/FUSE_DMSL/fuse_metric.f90 +++ b/build/FUSE_SRC/driver/fuse_metric.f90 @@ -10,6 +10,7 @@ SUBROUTINE FUSE_METRIC(XPAR,GRID_FLAG,NCID_FORC,METRIC_VAL,OUTPUT_FLAG,IPSET,MPA ! Modified by Brian Henn to include snow model, 6/2013 ! Modified by Nans Addor to enable grid-based modeling, 9/2016 ! Modified by Cyril Thébault to allow different metrics as objective function, 2024 + ! Modified by Martyn Clark to call differentiable modeling routines, 12/2025 ! --------------------------------------------------------------------------------------- ! Purpose: ! -------- @@ -21,8 +22,13 @@ SUBROUTINE FUSE_METRIC(XPAR,GRID_FLAG,NCID_FORC,METRIC_VAL,OUTPUT_FLAG,IPSET,MPA 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 + 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 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 @@ -31,28 +37,36 @@ SUBROUTINE FUSE_METRIC(XPAR,GRID_FLAG,NCID_FORC,METRIC_VAL,OUTPUT_FLAG,IPSET,MPA 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 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 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 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_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 + ! differentiable model + use work_types, only: fuse_work ! bundles "everything" required to run fuse for a single cell + use get_bundle_module, only: get_bundle ! populate the fuse_work 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 @@ -71,7 +85,7 @@ SUBROUTINE FUSE_METRIC(XPAR,GRID_FLAG,NCID_FORC,METRIC_VAL,OUTPUT_FLAG,IPSET,MPA LOGICAL(LGT), INTENT(IN), OPTIONAL :: MPARAM_FLAG ! .FALSE. (used to turn off writing statistics) ! output - REAL(SP),INTENT(OUT) :: METRIC_VAL ! value of the metric chosen as objective function + REAL(SP),INTENT(OUT) :: METRIC_VAL ! metric ! internal LOGICAL(lgt),PARAMETER :: computePET=.FALSE. ! flag to compute PET @@ -94,10 +108,28 @@ SUBROUTINE FUSE_METRIC(XPAR,GRID_FLAG,NCID_FORC,METRIC_VAL,OUTPUT_FLAG,IPSET,MPA CHARACTER(LEN=CLEN) :: CMESSAGE ! error message of downwind routine INTEGER(I4B),PARAMETER::UNT=6 !1701 ! 6 + ! differentiable model + type(fuse_work) :: fuseStruct ! fuse work structure + ! --------------------------------------------------------------------------------------- ! allocate state vectors ALLOCATE(STATE0(NSTATE),STATE1(NSTATE),STAT=IERR) - IF (IERR.NE.0) STOP ' problem allocating space for state vectors in fuse_metric ' + IF (IERR.NE.0) STOP ' problem allocating space for state vectors in fuse_metric' + + ! 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) + 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)%var%dSWE_dParam(NPAR_SNOW), stat=ierr) + if(ierr/=0) STOP ' problem allocating space for the parameter derivatives' + fuseStruct%sbands(iBands)%var%dSWE_dparam(:) = 0._sp + end do ! increment parameter counter for model output IF (.NOT.PRESENT(MPARAM_FLAG)) THEN @@ -108,38 +140,57 @@ SUBROUTINE FUSE_METRIC(XPAR,GRID_FLAG,NCID_FORC,METRIC_VAL,OUTPUT_FLAG,IPSET,MPA ! 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 + ! 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(:)%info = MBANDS_INFO_3d(1,1,:) ! info structure, %AF, %Z_MID + endif + + 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 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 - 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 + + ! 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 + ! NOTE: %bands_var only copies the var components (OK because MBANDS_VAR_4d is legacy structure) DO iSpat2=1,nSpat2 DO iSpat1=1,nSpat1 - DO IBANDS=1,N_BANDS - MBANDS_VAR_4d(iSpat1,iSpat2,IBANDS,1)%SWE=0.0_sp ! band snowpack water equivalent (mm) - MBANDS_VAR_4d(iSpat1,iSpat2,IBANDS,1)%SNOWACCMLTN=0.0_sp ! new snow accumulation in band (mm day-1) - MBANDS_VAR_4d(iSpat1,iSpat2,IBANDS,1)%SNOWMELT=0.0_sp ! snowmelt in band (mm day-1) - MBANDS_VAR_4d(iSpat1,iSpat2,IBANDS,1)%DSWE_DT=0.0_sp ! rate of change of band SWE (mm day-1) - END DO - END DO - END DO - PRINT *, 'Snow states initiatlized over the 2D gridded domain ' - ENDIF + do iBands=1,n_bands + MBANDS_VAR_4d(iSpat1,iSpat2,iBands,1) = fuseStruct%sbands(iBands)%var%bands_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 ! if snow model is on ! allocate 3d data structure for fluxes ALLOCATE(W_FLUX_3d(nspat1,nspat2,numtim_sub)) @@ -153,7 +204,8 @@ SUBROUTINE FUSE_METRIC(XPAR,GRID_FLAG,NCID_FORC,METRIC_VAL,OUTPUT_FLAG,IPSET,MPA 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 @@ -178,16 +230,17 @@ SUBROUTINE FUSE_METRIC(XPAR,GRID_FLAG,NCID_FORC,METRIC_VAL,OUTPUT_FLAG,IPSET,MPA 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 ! 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) @@ -223,35 +276,68 @@ SUBROUTINE FUSE_METRIC(XPAR,GRID_FLAG,NCID_FORC,METRIC_VAL,OUTPUT_FLAG,IPSET,MPA ! initialize model fluxes CALL INITFLUXES() ! set weighted sum of fluxes to zero + ! populate fuse work structure + if(diff_mode==differentiable) call get_bundle(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) CASE(iopt_temp_index) ! load data from multidimensional arrays - Z_FORCING = Z_FORCING_grid(iSpat1,iSpat2) ! elevation of forcing data (m) - MBANDS%Z_MID = MBANDS_INFO_3d(iSpat1,iSpat2,:)%Z_MID ! band mid-point elevation (m) - MBANDS%AF = MBANDS_INFO_3d(iSpat1,iSpat2,:)%AF ! fraction of basin area in band (-) - MBANDS%SWE = MBANDS_VAR_4d(iSpat1,iSpat2,:,itim_sub)%SWE ! band snowpack water equivalent (mm) - MBANDS%SNOWACCMLTN = MBANDS_VAR_4d(iSpat1,iSpat2,:,itim_sub)%SNOWACCMLTN ! new snow accumulation in band (mm day-1) - MBANDS%SNOWMELT = MBANDS_VAR_4d(iSpat1,iSpat2,:,itim_sub)%SNOWMELT ! snowmelt in band (mm day-1) - MBANDS%DSWE_DT = MBANDS_VAR_4d(iSpat1,iSpat2,:,itim_sub)%DSWE_DT ! rate of change of band SWE (mm day-1) - - CALL UPDATE_SWE(DELTIM) + Z_FORCING = Z_FORCING_grid(iSpat1,iSpat2) ! elevation of forcing data (m) + 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 + ! NOTE: only copy the "var" variables + if(diff_mode == differentiable)then + fuseStruct%z_forcing = Z_FORCING + fuseStruct%sbands(:)%info = MBANDS(:)%info + fuseStruct%sbands(:)%var%bands_var = MBANDS(:)%var + endif ! if diff_mode == differentiable + + ! 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_metric: cannot identify diff_mode" + end select CASE(iopt_no_snowmod) CALL QRAINERROR() CASE DEFAULT - message="f-fuse_metric/SMODL%iSNOWM must be either iopt_temp_index or iopt_no_snowmod" - RETURN + message="fuse_metric/SMODL%iSNOWM must be either iopt_temp_index or iopt_no_snowmod" + print*, trim(message); stop 1 END SELECT - ! temporally integrate the ordinary differential equations - CALL ODE_INT(FUSE_SOLVE,STATE0,STATE1,DT_SUB,DT_FULL,IERR,MESSAGE) - IF (IERR.NE.0) THEN - PRINT *, TRIM(MESSAGE) - !PAUSE - ENDIF + ! ----- 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 + + ! differentiable code + case(differentiable) + + ! solve differentiable ODEs + call implicit_solve(fuseStruct, state0, state1, nState, ierr, cmessage) + + ! save fluxes + W_FLUX = fuseStruct%flux + + ! check options + case default; print*, "fuse_metric: 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 CALL Q_OVERLAND() @@ -273,14 +359,18 @@ SUBROUTINE FUSE_METRIC(XPAR,GRID_FLAG,NCID_FORC,METRIC_VAL,OUTPUT_FLAG,IPSET,MPA IF (SMODL%iSNOWM.EQ.iopt_temp_index) THEN + ! extract data from the FUSE structure + if(diff_mode == differentiable)then + Z_FORCING = fuseStruct%z_forcing + MBANDS%info = fuseStruct%sbands%info + MBANDS%var = fuseStruct%sbands%var%bands_var + 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 @@ -311,25 +401,22 @@ SUBROUTINE FUSE_METRIC(XPAR,GRID_FLAG,NCID_FORC,METRIC_VAL,OUTPUT_FLAG,IPSET,MPA ! 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 - 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 *, '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 - 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 ! 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 @@ -348,25 +435,34 @@ SUBROUTINE FUSE_METRIC(XPAR,GRID_FLAG,NCID_FORC,METRIC_VAL,OUTPUT_FLAG,IPSET,MPA ! 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() METRIC_VAL = MSTATS%METRIC_VAL + write(*,'(i6,1x,a6,1x,f12.6,1x,a20,1x,f12.6)') nFUSE_eval, "NSE = ", MSTATS%NASH_SUTT, "; TIME ELAPSED = ", t2-t1 + !if(nFUSE_eval > 10) stop "checking results" + ENDIF - PRINT *, 'Writing parameter values...' - CALL PUT_PARAMS(PCOUNT) - PRINT *, 'Writing model statistics...' + if(isPrint) PRINT *, 'Writing model statistics...' CALL PUT_SSTATS(PCOUNT) + ! deallocate parameter derivative vectors + do iBands=1,n_bands + 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_metric ' DEALLOCATE(STATE0,STATE1,STAT=IERR); IF (IERR.NE.0) STOP ' problem deallocating state vectors in fuse_metric' + 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_METRIC END MODULE FUSE_METRIC_MODULE 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/netcdf/def_output.f90 b/build/FUSE_SRC/netcdf/def_output.f90 new file mode 100644 index 0000000..e93e41f --- /dev/null +++ b/build/FUSE_SRC/netcdf/def_output.f90 @@ -0,0 +1,189 @@ +MODULE DEF_OUTPUT_MODULE + + USE nrtype ! variable types, etc. + + implicit none + + private + public :: DEF_OUTPUT + + contains + + SUBROUTINE DEF_OUTPUT(nSpat1,nSpat2,n_bands,NUMPAR,NTIM) + + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Martyn Clark to include elevation bands, 12/2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Define NetCDF output files -- time-varying model output + ! --------------------------------------------------------------------------------------- + + ! 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, 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 + USE multiforce, only: latitude,longitude ! dimension arrays + USE multiforce, only: name_psets,time_steps ! dimension arrays + 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 + + ! input + 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 + REAL(MSP) :: NA_VALUE_OUT_MSP ! NA_VALUE for output file + + LOGICAL(LGT) :: WRITE_VAR ! used to denote if the variable is written + INTEGER(I4B) :: IERR ! error code + INTEGER(I4B) :: NTIM_DIM ! time + INTEGER(I4B) :: lon_dim ! 1st spatial dimension + INTEGER(I4B) :: lat_dim ! 2nd spatial dimension + INTEGER(I4B) :: par_dim ! parameter dimension + INTEGER(I4B) :: band_dim ! band dimension + 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 + + include 'netcdf.inc' ! use netCDF libraries + + ! --------------------------------------------------------------------------------------- + CALL VARDESCRIBE() ! get list of variable descriptions + ! --------------------------------------------------------------------------------------- + + ! put file in define mode + print *, 'Create NetCDF file for runs:' + PRINT *, FNAME_NETCDF_RUNS + + IERR = NF_CREATE(TRIM(FNAME_NETCDF_RUNS),NF_CLOBBER,ncid_out); CALL HANDLE_ERR(IERR) + + ! 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, '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 + DO IVAR=1,NOUTVAR + + ! check if there is a need to write the variable - see also put_output + ! uncomment variables that should be written to output file + IF (Q_ONLY) THEN + WRITE_VAR=.FALSE. + IF (TRIM(VNAME(IVAR)).EQ.'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 + 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 + + ! define missing value + NA_VALUE_OUT_MSP=NA_VALUE_OUT + + ! 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) + + ! 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 + + ! define the time variable + ierr = nf_def_var(ncid_out,'time',nf_real,1,(/ntim_dim/),ivar_id); call handle_err(ierr) + ierr = nf_put_att_text(ncid_out,ivar_id,'units',len_trim(timeUnits),trim(timeUnits)) + call handle_err(ierr) + + ! define the latitude variable + ierr = nf_def_var(ncid_out,'latitude',nf_real,1,(/lat_dim/),ivar_id); call handle_err(ierr) + ierr = nf_put_att_text(ncid_out,ivar_id,'units',8,'degreesN'); call handle_err(ierr) + ierr = nf_put_att_text(ncid_out,ivar_id,'axis',1,'Y'); call handle_err(ierr) + + ! define the longitude variable + ierr = nf_def_var(ncid_out,'longitude',nf_real,1,(/lon_dim/),ivar_id); call handle_err(ierr) + ierr = nf_put_att_text(ncid_out,ivar_id,'units',8,'degreesE'); call handle_err(ierr) + ierr = nf_put_att_text(ncid_out,ivar_id,'axis',1,'X'); call handle_err(ierr) + + ! define the parameter set variable + ierr = nf_def_var(ncid_out,'param',nf_int,1,(/par_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) + + ! 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) + + latitude_msp=latitude ! convert to actual single precision + IERR = NF_INQ_VARID(ncid_out,'latitude',IVAR_ID); CALL HANDLE_ERR(IERR) ! get variable ID + IERR = NF_PUT_VARA_REAL(ncid_out,IVAR_ID,1,nspat2,latitude_msp); CALL HANDLE_ERR(IERR) ! write data + + longitude_msp=longitude ! convert to actual single precision + IERR = NF_INQ_VARID(ncid_out,'longitude',IVAR_ID); CALL HANDLE_ERR(IERR) ! get variable ID + IERR = NF_PUT_VARA_REAL(ncid_out,IVAR_ID,1,nspat1,longitude_msp); CALL HANDLE_ERR(IERR) ! write data + + 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) + + 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', nSpat1 , nSpat2, n_bands, NUMPAR, NTIM + + ! close output file + IERR = NF_CLOSE(ncid_out) + + ! --------------------------------------------------------------------------------------- + END SUBROUTINE DEF_OUTPUT + +END MODULE DEF_OUTPUT_MODULE diff --git a/build/FUSE_SRC/FUSE_NETCDF/def_params.f90 b/build/FUSE_SRC/netcdf/def_params.f90 similarity index 82% rename from build/FUSE_SRC/FUSE_NETCDF/def_params.f90 rename to build/FUSE_SRC/netcdf/def_params.f90 index 46b2cdb..94c6c88 100644 --- a/build/FUSE_SRC/FUSE_NETCDF/def_params.f90 +++ b/build/FUSE_SRC/netcdf/def_params.f90 @@ -10,10 +10,11 @@ SUBROUTINE DEF_PARAMS(NPAR) ! Define NetCDF output files -- parameter variables ! --------------------------------------------------------------------------------------- USE nrtype ! variable types, etc. -USE model_defn ! model definition (includes filename) +USE model_defn, only: FNAME_NETCDF_PARA ! model definition (includes filename) USE metaparams ! metadata for all model parameters USE multistats, ONLY: MSTATS ! model statistics structure USE multistate, only: ncid_out ! NetCDF output file ID +USE globaldata, only: FUSE_VERSION, FUSE_BUILDTIME, FUSE_GITBRANCH, FUSE_GITHASH IMPLICIT NONE ! input INTEGER(I4B), INTENT(IN) :: NPAR ! number of parameter sets @@ -61,6 +62,16 @@ SUBROUTINE DEF_PARAMS(NPAR) ! 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 + + ! 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) + + + IERR = NF_ENDDEF(ncid_out) IERR = NF_CLOSE(ncid_out) ! --------------------------------------------------------------------------------------- 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_ENGINE/get_mbands.f90 b/build/FUSE_SRC/netcdf/get_mbands.f90 similarity index 89% rename from build/FUSE_SRC/FUSE_ENGINE/get_mbands.f90 rename to build/FUSE_SRC/netcdf/get_mbands.f90 index f05a6ba..6a4e4c8 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/get_mbands.f90 +++ b/build/FUSE_SRC/netcdf/get_mbands.f90 @@ -160,7 +160,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 @@ -180,21 +180,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 @@ -220,14 +220,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 @@ -242,26 +242,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) 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/netcdf/put_output.f90 b/build/FUSE_SRC/netcdf/put_output.f90 new file mode 100644 index 0000000..aaedb82 --- /dev/null +++ b/build/FUSE_SRC/netcdf/put_output.f90 @@ -0,0 +1,234 @@ +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: + ! -------- + ! Nans Addor, based on Martyn Clark's 2007 PUT_OUTPUT + ! Modified by Marytn Clark to use the elevation band dimension and add parameter derivatives, 12/2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! write a 3D (or 4D) data structure to the NetCDF output file + ! --------------------------------------------------------------------------------------- + + ! 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 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 + 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 + + ! 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 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_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 + + 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 (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) + CALL HANDLE_ERR(IERR) + + ! 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.'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 + + ! 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' ); 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 + + ! 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 + 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_GOUTPUT_3D + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + SUBROUTINE PUT_OUTPUT(iSpat1, iSpat2, ITIM) + + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! write NetCDF output files + ! --------------------------------------------------------------------------------------- + + ! 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) :: 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(5) :: INDX ! indices for time series write + INTEGER(I4B), DIMENSION(3) :: INDX ! indices for time series write + INTEGER(I4B) :: IVAR ! loop through variables + REAL(SP) :: XVAR ! desired variable (SP NOT NECESSARILY SP) + REAL(MSP) :: AVAR ! desired variable (SINGLE PRECISION) + REAL(MSP) :: tDat ! time data + INTEGER(I4B) :: IVAR_ID ! variable ID + INCLUDE 'netcdf.inc' ! use netCDF libraries + ! --------------------------------------------------------------------------------------- + + ! open file + IERR = NF_OPEN(TRIM(FNAME_NETCDF_RUNS),NF_WRITE,ncid_out); CALL HANDLE_ERR(IERR) + + ! define indices for model output + INDX = (/iSpat1, iSpat2, ITIM/) + + ! loop through time-varying model output + DO IVAR=1,NOUTVAR + + ! check if there is a need to write the variable - see also def_output + IF (Q_ONLY) THEN + WRITE_VAR=.FALSE. + IF (TRIM(VNAME(IVAR)).EQ.'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 = VAREXTRACT(VNAME(IVAR)); AVAR=XVAR ! get variable ivar + IERR = NF_INQ_VARID(ncid_out,TRIM(VNAME(IVAR)),IVAR_ID); CALL HANDLE_ERR(IERR) ! get variable ID + IERR = NF_PUT_VAR1_REAL(ncid_out,IVAR_ID,INDX,AVAR); CALL HANDLE_ERR(IERR) ! write data + + END DO ! (ivar) + + ! write the time + tDat = timDat%dtime ! convert to actual single precision + ierr = nf_inq_varid(ncid_out,'time',ivar_id); CALL handle_err(ierr) ! get variable ID for time + ierr = nf_put_var1_real(ncid_out,ivar_id,(/itim/),tDat); CALL handle_err(ierr) ! write time variable + + ! close NetCDF file + IERR = NF_CLOSE(ncid_out) + + END SUBROUTINE PUT_OUTPUT + +END MODULE PUT_OUTPUT_MODULE diff --git a/build/FUSE_SRC/netcdf/put_params.f90 b/build/FUSE_SRC/netcdf/put_params.f90 new file mode 100644 index 0000000..2c4401c --- /dev/null +++ b/build/FUSE_SRC/netcdf/put_params.f90 @@ -0,0 +1,95 @@ +MODULE PUT_PARAMS_MODULE + + USE nrtype ! variable types, etc. + + implicit none + + private + public :: PUT_PARAMS + + contains + + SUBROUTINE PUT_PARAMS(IPAR) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Nans Addor to include snow module + ! Modified by Martyn Clark to write snow bands as a vector, 12/2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! write NetCDF output files -- model parameters + ! --------------------------------------------------------------------------------------- + USE model_defn, only: FNAME_NETCDF_PARA ! model definition structures (includes filename) + USE metaparams, only: NOUTPAR ! number of model parameters + USE metaparams, only: PNAME, PDESC, PUNIT ! metadata for all model parameters + USE metaparams, only: isBand ! logical flag to define vars with elevation dimension + USE multibands, only: MBANDS, N_BANDS ! information for elevation bands + USE parextract_module ! extract parameters + IMPLICIT NONE + ! input + INTEGER(I4B), INTENT(IN) :: IPAR ! parameter set index + ! internal + INTEGER(I4B) :: IERR,NCID ! error code; NetCDF ID + INTEGER(I4B), DIMENSION(1) :: INDX ! indices for parameter write + integer(i4b), dimension(2) :: start2 ! 2-d start vector + integer(i4b), dimension(2) :: count2 ! 2-d count vector + INTEGER(I4B) :: IVAR ! loop through parameters + REAL(SP) :: XPAR ! desired parameter + REAL(MSP) :: APAR ! convert to SP (need for SP write) + integer(i4b) :: ib ! index of elevation bands + REAL(SP) , DIMENSION(N_BANDS) :: XVEC ! desired vector + REAL(MSP) , DIMENSION(N_BANDS) :: AVEC ! convert to SP (need for SP write) + INTEGER(I4B) :: IVAR_ID ! variable ID + include 'netcdf.inc' ! use netCDF libraries + ! --------------------------------------------------------------------------------------- + + ! open file + IERR = NF_OPEN(TRIM(FNAME_NETCDF_PARA),NF_WRITE,NCID) + CALL HANDLE_ERR(IERR) + + ! define indices for model output + INDX = (/IPAR/) + + ! loop through model parameters + DO IVAR=1,NOUTPAR ! NOUTPAR is stored in module metaparams + + ! get variable ID + IERR = NF_INQ_VARID(NCID,TRIM(PNAME(IVAR)),IVAR_ID) + CALL HANDLE_ERR(IERR) + + ! standard scalar parameters + if(.not.isBand(iVar))then + + ! extract parameter and write data + XPAR = PAREXTRACT(PNAME(IVAR)); APAR=XPAR ! get parameter PNAME(IVAR) + IERR = NF_PUT_VAR1_REAL(NCID, IVAR_ID, INDX, APAR); CALL HANDLE_ERR(IERR) ! write data + + ! elevation band parameters + else + + ! extract vector + select case (trim(PNAME(IVAR))) + case ('AF') ; xVec(1:n_bands) = [ (MBANDS(ib)%info%AF, ib=1,n_bands) ] + case ('Z_MID'); xVec(1:n_bands) = [ (MBANDS(ib)%info%Z_MID, ib=1,n_bands) ] + case default; stop "put_params.f90: cannot identify elevation band variable" + end select + aVec = xVec ! use MSP to write single precision + + ! write row at par=IPAR + start2 = (/ IPAR, 1 /) + count2 = (/ 1, n_bands /) + IERR = NF_PUT_VARA_REAL(NCID, IVAR_ID, start2, count2, aVec(1:n_bands)) + CALL HANDLE_ERR(IERR) + + endif ! elevation band switch + + END DO ! (ivar) + + ! close NetCDF file + IERR = NF_CLOSE(NCID) + ! --------------------------------------------------------------------------------------- + END SUBROUTINE PUT_PARAMS + +END MODULE PUT_PARAMS_MODULE 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/physics/conserve_clamp.f90 b/build/FUSE_SRC/physics/conserve_clamp.f90 new file mode 100644 index 0000000..3c119ad --- /dev/null +++ b/build/FUSE_SRC/physics/conserve_clamp.f90 @@ -0,0 +1,303 @@ +module conserve_clamp_module + + ! data types + use nrtype ! variable types, etc. + use work_types, only: fuse_work ! fuse work structure + USE model_defn ! model definition structure + USE model_defnames + USE model_numerix + + implicit none + + private + public :: conserve_clamp + + contains + + SUBROUTINE conserve_clamp(fuseStruct,DT,ERROR_FLAG) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2009 + ! Modified by Martyn Clark to pass fuse work data structure, 12/2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Ensure states are within bounds, and disaggregate fluxes if necessary + ! - This routine handles the very rare case (less than one-in-a-million) where + ! the implicit Euler solver fails to converge + ! --------------------------------------------------------------------------------------- + IMPLICIT NONE + ! input/output + type(fuse_work) , intent(inout) :: fuseStruct ! fuse work structure + REAL(SP), INTENT(IN) :: DT ! time step + LOGICAL(LGT), INTENT(OUT) :: ERROR_FLAG ! .TRUE. if extrapolation error + ! internal + REAL(SP) :: XMIN ! very small number + INTEGER(I4B) :: ISTT ! loop through model states + REAL(SP) :: ERROR_LOSS ! error (L/T) + REAL(SP) :: TOTAL_LOSS ! total loss (L/T) + ! --------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + M_FLUX => fuseStruct%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/evap_lower_diff.f90 b/build/FUSE_SRC/physics/evap_lower_diff.f90 new file mode 100644 index 0000000..f8e0c78 --- /dev/null +++ b/build/FUSE_SRC/physics/evap_lower_diff.f90 @@ -0,0 +1,94 @@ +module EVAP_LOWER_DIFF_MODULE + + implicit none + + private + public :: EVAP_LOWER_DIFF + +contains + + SUBROUTINE EVAP_LOWER_DIFF(fuseStruct, want_dflux) + ! ------------------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Martyn Clark to create a differentiable model, 12/25 + ! ------------------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Computes evaporation from the lower soil layer + ! ------------------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE work_types, only: fuse_work ! fuse work data type + USE model_defn ! model definition structure + USE model_defnames + IMPLICIT NONE + ! input-output + type(fuse_work), intent(inout) :: fuseStruct ! fuse work structure + logical(lgt), intent(in), optional :: want_dflux ! if we want flux derivatives + ! internal + logical(lgt) :: comp_dflux ! flag to compute flux derivatives + ! ------------------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + 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) + ! ------------------------------------------------------------------------------------------------- + + ! check the need to compute flux derivatives + comp_dflux = .false.; if(present(want_dflux)) comp_dflux = want_dflux + + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH2) ! lower layer architecture + CASE(iopt_tens2pll_2,iopt_fixedsiz_2) + + ! ------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH1) + ! ------------------------------------------------------------------------------------ + CASE(iopt_tension1_1,iopt_onestate_1) ! lower-layer evap is valid + + ! ------------------------------------------------------------------------------------ + ! use different evaporation schemes for the lower layer + ! ----------------------------------------------------- + SELECT CASE(SMODL%iESOIL) + CASE(iopt_sequential) + M_FLUX%EVAP_2 = (MFORCE%PET-M_FLUX%EVAP_1) * (TSTATE%TENS_2/DPARAM%MAXTENS_2) + CASE(iopt_rootweight) + M_FLUX%EVAP_2 = MFORCE%PET * DPARAM%RTFRAC2 * (TSTATE%TENS_2/DPARAM%MAXTENS_2) + CASE DEFAULT + print *, "SMODL%iESOIL must be either iopt_sequential or iopt_rootweight" + END SELECT ! (evaporation schemes) + + ! ------------------------------------------------------------------------------------ + CASE(iopt_tension2_1) ! lower-layer evap is zero + M_FLUX%EVAP_2 = 0._sp + + ! ------------------------------------------------------------------------------------ + CASE DEFAULT + print *, "SMODL%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" + STOP + + ! ------------------------------------------------------------------------------------ + END SELECT ! (upper-layer architechure) + + ! -------------------------------------------------------------------------------------- + CASE(iopt_unlimfrc_2,iopt_unlimpow_2,iopt_topmdexp_2) + M_FLUX%EVAP_2 = 0._sp + + ! -------------------------------------------------------------------------------------- + CASE DEFAULT + print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" + print *, " iopt_topmdexp_2, or iopt_fixedsiz_2" + STOP + + END SELECT + ! --------------------------------------------------------------------------------------- + + end associate ! end association with variables in the data structures + END SUBROUTINE EVAP_LOWER_DIFF + +end module EVAP_LOWER_DIFF_module diff --git a/build/FUSE_SRC/physics/evap_upper_diff.f90 b/build/FUSE_SRC/physics/evap_upper_diff.f90 new file mode 100644 index 0000000..ac69b01 --- /dev/null +++ b/build/FUSE_SRC/physics/evap_upper_diff.f90 @@ -0,0 +1,139 @@ +module EVAP_UPPER_DIFF_module + + implicit none + + private + public :: EVAP_UPPER_DIFF + +contains + + SUBROUTINE EVAP_UPPER_DIFF(fuseStruct, want_dflux) + ! ------------------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Martyn Clark to create a differentiable model, 12/25 + ! ------------------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Computes evaporation from the upper soil layer + ! ------------------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE work_types, only: fuse_work ! fuse work type + USE model_defn ! model definition structure + USE model_defnames ! model definition names + use smoothers, only : sfrac, dsfrac ! smoothed fraction, derivative + IMPLICIT NONE + ! input-output + type(fuse_work), intent(inout) :: fuseStruct ! fuse work structure + logical(lgt), intent(in), optional :: want_dflux ! if we want flux derivatives + ! local variables + logical(lgt) :: comp_dflux ! flag to compute flux derivatives + integer(i4b) :: iState ! state index + real(sp) :: phi ! smoothed fraction of total tension storage (0,1] + real(sp) :: phi_1a ! smoothed fraction of primary tension storage (0,1] + real(sp) :: phi_1b ! smoothed fraction of secondary tension storage (0,1] + real(sp) :: maxRate ! maximum forcing + real(sp) :: maxRate_1a ! maximum forcing for the primary tension tank + real(sp) :: maxRate_1b ! maximum forcing for the secondary tension tank + real(sp) :: dphi_dx ! derivative in fraction w.r.t. storage + real(sp) :: devap_dx ! derivative in evaporation w.r.t. storage + real(sp), parameter :: ms=1.e-4_sp ! smoothing in sfrac(smax) function + ! ------------------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + 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 + + ! -------------------------------------------------------------------------------------- + CASE(iopt_tension2_1) ! tension storage sub-divided into recharge and excess + ! -------------------------------------------------------------------------------------- + + ! calculate the smoothed fraction of tension storage (NOTE: use WATR_1) + phi_1a = sfrac(TSTATE%TENS_1A, DPARAM%MAXTENS_1A, ms) + phi_1b = sfrac(TSTATE%TENS_1B, DPARAM%MAXTENS_1B, ms) + + ! calculate the maximum evap rate for the storage + SELECT CASE(SMODL%iESOIL) + CASE(iopt_sequential) + maxrate_1a = MFORCE%PET + maxrate_1b = MFORCE%PET - MFORCE%PET*phi_1a + CASE(iopt_rootweight) + maxrate_1a = MFORCE%PET * MPARAM%RTFRAC1 + maxrate_1b = MFORCE%PET * DPARAM%RTFRAC2 + CASE DEFAULT; stop "evap_upper: SMODL%iESOIL must be either iopt_sequential or iopt_rootweight" + END SELECT + + ! ----- compute flux ---------------------------------------------------------------- + M_FLUX%EVAP_1A = maxrate_1a*phi_1a + M_FLUX%EVAP_1B = maxrate_1b*phi_1b + M_FLUX%EVAP_1 = M_FLUX%EVAP_1A + M_FLUX%EVAP_1B + + ! ----- compute derivatives --------------------------------------------------------------------- + if(comp_dflux) stop "evap_upper: derivatives for iopt_tension2_1 not implemented yet" + + ! -------------------------------------------------------------------------------------- + CASE(iopt_tension1_1,iopt_onestate_1) ! single tension store or single state + ! -------------------------------------------------------------------------------------- + + ! zero fluxes not used + M_FLUX%EVAP_1A = 0._sp + M_FLUX%EVAP_1B = 0._sp + + select case(SMODL%iARCH1) + case(iopt_tension1_1); phi = sfrac(TSTATE%TENS_1, DPARAM%MAXTENS_1, ms) + case(iopt_onestate_1); phi = sfrac(TSTATE%WATR_1, DPARAM%MAXTENS_1, ms) ! NOTE: use WATR_1 + end select ! no need for default because checked above + + ! calculate the maximum evap rate for the upper layer + SELECT CASE(SMODL%iESOIL) + CASE(iopt_sequential); maxRate = MFORCE%PET + CASE(iopt_rootweight); maxRate = MFORCE%PET*MPARAM%RTFRAC1 + CASE DEFAULT; stop "evap_upper: SMODL%iESOIL must be either iopt_sequential or iopt_rootweight" + END SELECT ! (evaporation schemes) + + ! ----- compute flux ---------------------------------------------------------------- + M_FLUX%EVAP_1 = maxRate*phi + + ! ----- compute derivatives --------------------------------------------------------- + if(comp_dflux)then + + ! calculate the derivative in the smoothed fraction of tension storage + select case(SMODL%iARCH1) + case(iopt_tension1_1); dphi_dx = dsfrac(TSTATE%TENS_1, DPARAM%MAXTENS_1, ms) + case(iopt_onestate_1); dphi_dx = dsfrac(TSTATE%WATR_1, DPARAM%MAXTENS_1, ms) ! NOTE: use WATR_1 + end select ! no need for default because checked above + + ! calculate the derivative in the maximum rate + devap_dx = maxRate*dphi_dx + + ! populate derivative vector + do iState=1,nState + select case(cState(iState)%iSNAME) + case (iopt_TENS_1); dfx_dS(iState)%EVAP_1 = devap_dx ! exists if one tension tank + case (iopt_WATR_1); dfx_dS(iState)%EVAP_1 = devap_dx ! exists if one state in the upper layer + end select ! no default needed + end do ! looping through states + + endif ! if computing derivatives + + CASE DEFAULT; stop "evap_upper: SMODL%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" + END SELECT ! (upper-layer architecture) + + + end associate ! end association with variables in the data structures + END SUBROUTINE EVAP_UPPER_DIFF + +end module EVAP_UPPER_DIFF_module diff --git a/build/FUSE_SRC/physics/fix_ovshoot.f90 b/build/FUSE_SRC/physics/fix_ovshoot.f90 new file mode 100644 index 0000000..5467980 --- /dev/null +++ b/build/FUSE_SRC/physics/fix_ovshoot.f90 @@ -0,0 +1,161 @@ +module overshoot_module + + USE nrtype ! variable types, etc. + USE work_types, only: fuse_work ! fuse work data type + USE model_defn, only: CSTATE,NSTATE,SMODL ! model definition structures + USE model_defnames + implicit none + + private + public :: get_bounds + public :: fix_ovshoot + public :: sigmoid + +contains + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + ! Numerically-stable softplus with sharpness alpha + pure real(sp) function softplus(x, alpha) result(y) + implicit none + real(sp), intent(in) :: x, alpha + real(sp) :: ax + ax = alpha * x + if (ax > 0.0_sp) then + y = (ax + log(1.0_sp + exp(-ax))) / alpha + else + y = log(1.0_sp + exp(ax)) / alpha + end if + end function softplus + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + ! Sigmoid + pure real(sp) function sigmoid(z) result(s) + real(sp), intent(in) :: z + if (z >= 0._sp) then + s = 1._sp / (1._sp + exp(-z)) + else + s = exp(z) / (1._sp + exp(z)) + end if + end function sigmoid + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + SUBROUTINE fix_ovshoot(X_TRY, lower, upper, dclamp) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Apply soft constraints to model state variables + ! --------------------------------------------------------------------------------------- + ! input/output + REAL(SP), DIMENSION(:), INTENT(INOUT) :: X_TRY ! vector of model states + real(sp), dimension(:), intent(in) :: lower ! lower bound + real(sp), dimension(:), intent(in) :: upper ! upper bound + real(sp), dimension(:), intent(out) :: dclamp ! derivative + ! internal + integer(i4b) :: i ! index of model state variable + real(sp), parameter :: alpha=10_sp ! controls sharpness in smoothing + + do i=1,NSTATE + + ! hard constraints + x_try(i) = max( min(x_try(i), upper(i)), lower(i) ) + dclamp(i) = 1._sp + + ! ! apply soft constraint to model states + ! x_try(i) = lower(i) + softplus(x_try(i)-lower(i), alpha) - softplus(x_try(i)-upper(i), alpha) + ! + ! ! compute derivative in clamp + ! dclamp(i) = sigmoid( (x_try(i) - lower(i)) * alpha ) - sigmoid( (x_try(i) - upper(i)) * alpha ) + + end do ! looping through model state variables + + end subroutine fix_ovshoot + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + SUBROUTINE get_bounds(fuseStruct, lower, upper) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified to return lower and upper bounds by Martyn Clark, 12/2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Identify lower and upper bounds for the vector of model states + ! --------------------------------------------------------------------------------------- + USE model_numerix ! model numerix + IMPLICIT NONE + ! input/output + type(fuse_work), intent(in) :: fuseStruct ! fuse work structure + real(sp), dimension(:), intent(out) :: lower ! lower bound for states + real(sp), dimension(:), intent(out) :: upper ! upper bound for states + ! internal + REAL(SP) :: XMIN ! very small number + INTEGER(I4B) :: ISTT ! loop through model states + ! --------------------------------------------------------------------------------------- + associate(MPARAM => fuseStruct%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_bundle.f90 b/build/FUSE_SRC/physics/get_bundle.f90 new file mode 100644 index 0000000..5432157 --- /dev/null +++ b/build/FUSE_SRC/physics/get_bundle.f90 @@ -0,0 +1,44 @@ +module get_bundle_module + use nrtype + use work_types, only: fuse_work + USE model_defn, ONLY: NSTATE ! TODO: update to new structures + USE multiparam, ONLY: NUMPAR ! TODO: update to new structures + implicit none + +contains + + subroutine get_bundle(fuseStruct) + use multiforce, only: timDat + use multiforce, only: mForce + use multistate, only: mState + use multi_flux, only: m_flux + use multiparam, only: parMeta,mParam,dParam + implicit none + type(fuse_work), intent(inout) :: fuseStruct + integer(i4b) :: iState + integer(i4b) :: iParam + + ! populate fuse work structures + fuseStruct%time = timdat + fuseStruct%force = mForce + fuseStruct%state0 = mState + fuseStruct%state1 = mState + fuseStruct%flux = m_flux ! initialized at zero + fuseStruct%param_meta = parMeta + fuseStruct%param_adjust = mParam + fuseStruct%param_derive = dParam + + ! 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_bundle + + +end module get_bundle_module diff --git a/build/FUSE_SRC/physics/implicit_solve.f90 b/build/FUSE_SRC/physics/implicit_solve.f90 new file mode 100644 index 0000000..0849013 --- /dev/null +++ b/build/FUSE_SRC/physics/implicit_solve.f90 @@ -0,0 +1,360 @@ +module implicit_solve_module + + ! data types + use nrtype ! variable types, etc. + use work_types, only: fuse_work ! fuse work structure + + ! modules + use xtry_2_str_module ! puts state vector into FUSE state structure + use str_2_xtry_module ! puts FUSE state structure into state vector + + ! global data + use model_defn, only: nState ! number of state variables + use multiforce, only: dt => deltim ! time step + use globaldata, only: isDebug ! print flag + + use model_numerix, only: NUM_FUNCS ! number of function calls + use model_numerix, only: NUM_JACOBIAN ! number of times Jacobian is calculated + + implicit none + + private + public :: implicit_solve + + contains + + ! ----- calculate dx/dt=g(x) ----------------------------------------------------------- + subroutine dx_dt(fuseStruct, x_try, g_x, J_g) + use MOD_DERIVS_DIFF_module, only: MOD_DERIVS_DIFF ! compute dx/dt + implicit none + ! input + type(fuse_work) , intent(inout) :: fuseStruct ! fuse work structure + real(sp) , intent(in) :: x_try(:) ! trial state vector + ! output + real(sp) , intent(out) :: g_x(:) ! dx/dt=g(x) + real(sp) , intent(out) , optional :: J_g(:,:) ! flux Jacobian matrix + ! internal + logical(lgt) :: comp_dflux ! flag to compute flux derivatives + ! -------------------------------------------------------------------------------------- + + comp_dflux = present(J_g) + + ! put data in structure + call XTRY_2_STR(x_try, fuseStruct%state1) + + ! run the fuse physics + if (present(J_g)) then + call mod_derivs_diff(fuseStruct, g_x, J_g) + else + call mod_derivs_diff(fuseStruct, g_x) + end if + + ! track the total number of function calls + NUM_FUNCS = NUM_FUNCS + 1 + + end subroutine dx_dt + + ! ----- calculate the Jacobian of g(x) ------------------------------------------------- + SUBROUTINE jac_flux(fuseStruct, x_try, g_x, lower, upper, Jac) + IMPLICIT NONE + ! input-output + type(fuse_work) , intent(in) :: fuseStruct ! fuse work structure + REAL(SP), DIMENSION(:), INTENT(IN) :: g_x, lower, upper + REAL(SP), DIMENSION(:), INTENT(IN) :: x_try + REAL(SP), DIMENSION(:,:), INTENT(OUT) :: Jac + ! locals + type(fuse_work) :: fuseStruct_local + real(sp), parameter :: eps_rel = 1e-4_sp + real(sp), parameter :: eps_abs = 1e-6_sp ! or smaller, but NOT 1e-9 scale + real(sp), parameter :: h_min = 1e-8_sp + INTEGER(I4B) :: j,n + REAL(SP), DIMENSION(size(x_try)) :: x, xsav, g_ph + real(sp) :: h_try, h_act + + ! preliminaries + n = size(x) + fuseStruct_local = fuseStruct + x = x_try + xsav = x + + ! loop through columns + do j=1,n + + ! propose one-sided step (NOTE: negative) + h_try = -max(eps_rel*abs(xsav(j)), eps_abs) + + ! flip sign if necessary + if(xsav(j) + h_try < lower(j)) h_try = -h_try + + ! compute function from the perturbed vector + x(j) = xsav(j) + h_try + call dx_dt(fuseStruct_local, x, g_ph) + h_act = x(j) - xsav(j) + + ! compute column in the Jacobian + Jac(:,j) = (g_ph - g_x) / h_act + + ! safety: save full vector and data structure + fuseStruct_local = fuseStruct ! restores consistency after finite differencing + x = xsav + + end do ! looping through Jacobian columns + + NUM_JACOBIAN = NUM_JACOBIAN + 1 ! keep track of the number of iterations + end SUBROUTINE jac_flux + + ! ----- simple implicit solve for differentiable model -------------------------- + + subroutine implicit_solve(fuseStruct, x0, x1, nx, ierr, message, isVerbose) + USE nr, ONLY : lubksb,ludcmp + USE overshoot_module, only : get_bounds ! get state bounds + USE overshoot_module, only : fix_ovshoot ! fix overshoot (soft clamp) + USE conserve_clamp_module, only: conserve_clamp ! fix overshoot and disaggregate fluxes to conserve mass + USE model_numerix, only: ERR_ITER_FUNC ! Iteration convergence tolerance for function values + USE model_numerix, only: ERR_ITER_DX ! Iteration convergence tolerance for dx + implicit none + ! input-output + type(fuse_work), intent(inout) :: fuseStruct ! fuse work structure + real(sp) , intent(in) :: x0(:) ! state vector at start of step + real(sp) , intent(out) :: x1(:) ! state vector at end of step + integer(i4b) , intent(in) :: nx ! number of state variables + ! error cont ,ol + integer(i4b) , intent(out) :: ierr ! error code + character(*) , intent(out) :: message ! error message + logical(lgt) , intent(in), optional :: isVerbose ! flag for printing (subroutine argument) + logical(lgt) :: isPrint ! flag for printing (local flag) + ! internal: newton iterations + real(sp) :: x_old(nx) ! old trial state vector + real(sp) :: x_try(nx) ! trial state vector + real(sp) :: g_x(nx) ! dx/dt=g(x) + real(sp) :: res(nx) ! residual vector + real(sp) :: Ja(nx,nx) ! Jacobian matrix (flux) + real(sp) :: Jg(nx,nx) ! Jacobian matrix (flux) + real(sp) :: Jac(nx,nx) ! Jacobian matrix (full) + real(sp) :: dx(nx) ! state update + real(sp) :: phi ! half squared residual norm + real(sp) :: d ! determinant sign tracker + integer(i4b) :: indx(nx) ! LU pivot indices (row-swap bookkeeping) + integer(i4b) :: i ! index of state + integer(i4b) :: it ! index of newton iteration + integer(i4b), parameter :: maxit=100 ! maximum number of iterations + logical(lgt) :: converged ! flag for convergence + ! internal: backtracking line search w/ overshoot reject + real(sp) :: xnorm ! norm used in maximum step + real(sp) :: dxnorm ! norm used to evaluate step size + real(sp) :: stpmax ! the maximum step + real(sp) :: dxScale ! used to scale dx if dxnorm > stpmax + real(sp) :: gpsi(nx) ! function gradient: func = 0.5*sum(res*res) + real(sp) :: slope ! direction of decrease + real(sp) :: lambda ! backtrack length multiplier (lambda*dx) + real(sp) :: alamin ! minimum lambda + real(sp) :: lam_i ! maximum lambda for the i-th state + real(sp) :: lam_max ! maximum lambda + real(sp) :: lower(nx) ! lower bound + real(sp) :: upper(nx) ! lower bound + real(sp) :: dclamp(nx) ! derivative in the clamp + real(sp) :: x_trial(nx) ! state vector for backtrack + real(sp) :: g_trial(nx) ! dx/dt=g(x) for backtrack + real(sp) :: res_trial(nx) ! residual for backtrack + real(sp) :: phi_new ! half squared residual norm + integer(i4b) :: ls_it ! index of line search iteration + logical(lgt) :: ovshoot ! flag for overshoot + logical(lgt) :: accepted ! flag for accepting newton step + real(sp) :: phi_best ! best function evaluation + real(sp) :: x_best(nx) ! best state vector + real(sp) :: g_best(nx) ! dx/dt = g(x_best) + logical(lgt) :: have_best ! check if found a state vector + logical(lgt) :: isClamped ! check if fallback is clamped + ! algorithmic control parameters (most passed through MODULE model_numerix) + REAL(SP), PARAMETER :: TOLMIN=1.0e-10_sp ! check for spurious minima + REAL(SP), PARAMETER :: STPMX=100.0_sp ! maximum step in lnsrch + real(sp), parameter :: shrink = 0.5_sp + real(sp), parameter :: dampen = 0.1_sp + real(sp), parameter :: phi_rel_tol = 1e-5_sp ! 0.001% + real(sp), parameter :: phi_abs_tol = 1e-6_sp + real(sp), parameter :: epsb = 1.e-10_sp ! small safety margin + integer(i4b), parameter :: ls_max = 5 + ! ----- procedure starts here -------------------------------------------------------------------- + ! initialize error control + ierr=0; message='implicit_solve/' + + ! check dimension size + if (nx /= nState) stop "implicit_solve: nx /= nState" + + ! initialize check for best function evaluation + phi_best = huge(1._sp); have_best=.false. + + ! initialize number of calls + NUM_FUNCS = 0 ! number of function calls + NUM_JACOBIAN = 0 ! number of times Jacobian is calculated + + ! get the flag for printing + isPrint = .false.; if (present(isVerbose)) isPrint = isVerbose + + ! get the bounds for the state variables + ! NOTE: This can be done outside of the time and iteration loops (keeping here for now) + call get_bounds(fuseStruct, lower, upper) + + ! put state vector into the fuse data structure + call XTRY_2_STR(x0, fuseStruct%state0) + + ! intialize state vector (and soft clamp) + x_try = x0 + x_old = x_try + dclamp = 1._sp + + ! fix overshoot (only if necessary) + if(any(x_try < lower) .or. any(x_try > upper)) & + call fix_ovshoot(x_try, lower, upper, dclamp) + + ! define maximum step + xnorm = sqrt( sum(x_try*x_try) ) + stpmax = STPMX * max( xnorm, real(nx, sp) ) + + ! initialize flags + accepted = .false. + converged = .false. + + ! --- F(x), J(x), and objective phi + call dx_dt(fuseStruct, x_try, g_x, Jg) ! compute analytical Jacobian + res = x_try - (x0 + g_x*dt) + phi = 0.5_sp * dot_product(res, res) + + ! iterate + do it = 1, maxit + + ! save x + x_old = x_try + + ! check convergence + if (phi < ERR_ITER_FUNC) then + converged = .true. + exit ! exit iteration loop + end if + + ! --- compute residual Jacobian J(x) from flux Jacobian Jg(x) ---- + !call jac_flux(fuseStruct, x_try, g_x, lower, upper, Jg) + do i=1,nx + Jac(:,i) = -dt*Jg(:,i) + Jac(i,i) = Jac(i,i) + 1.0_sp + end do + + ! --- function gradient: before Jac is modified in ludcmp + gpsi = matmul(transpose(Jac), res) ! assumes func = 0.5_sp * sum(res*res) + + ! --- Solve J dx = -F (Newton step) + dx = -res + call ludcmp(Jac, indx, d) ! J overwritten with LU + call lubksb(Jac, indx, dx) ! dx becomes solution + + ! --- Modify dx + + ! modify dx if norm > stpmax + dxnorm = sqrt( sum(dx*dx) ) + if (dxnorm > stpmax) then + dxScale = stpmax / dxnorm + dx = dxScale * dx + end if + + ! modify dx if Newton step not descending for psi + slope = dot_product(gpsi, dx) + if (slope >= 0._sp) dx = -gpsi ! fallback + + ! implement active-set methods + do i=1,nx + if (x_try(i) <= lower(i)+epsb .and. dx(i) < 0._sp) dx(i)=0._sp + if (x_try(i) >= upper(i)-epsb .and. dx(i) > 0._sp) dx(i)=0._sp + end do + + ! ---- backtracking line search -------------- + + ! line search control + accepted = .false. ! flag to check if line search is accepted + alamin = ERR_ITER_DX / maxval( abs(dx) / max(abs(x_try), 1.0_sp) ) + + lambda = 1.0_sp + do ls_it = 1, ls_max + + ! update x + x_trial = x_try + lambda*dx + + ! shrink lambda until find a value in the feasible space + if(any(x_trial < lower) .or. any(x_trial > upper))then + lambda = lambda * shrink + cycle + endif + + ! compute function and function eval -- no need for the Jacobian here + call dx_dt(fuseStruct, x_trial, g_trial) + res_trial = x_trial - (x0 + dt*g_trial) + phi_new = 0.5_sp * dot_product(res_trial, res_trial) + + ! save best function evaluation + if (phi_new < phi_best) then + phi_best = phi_new + x_best = x_trial + g_best = g_trial + have_best = .true. + endif + + if (phi_new <= phi + phi_abs_tol) then + accepted = .true.; exit + endif + + ! update lambda + lambda = lambda * shrink + if (lambda < alamin) exit ! give up shrinking + + end do ! line search + + ! ----- fallback: try a small step ----- + if(.not. accepted)then + x_trial = x_try + dampen*dx + if(any(x_trial < lower) .or. any(x_trial > upper)) & + call fix_ovshoot(x_trial, lower, upper, dclamp) + end if ! (if accepted) + + ! recompute dx_dt because we need the Jacobian + x_try = x_trial + call dx_dt(fuseStruct, x_try, g_x, Jg) ! compute analytical Jacobian + res = x_try - (x0 + g_x*dt) + phi = 0.5_sp * dot_product(res, res) + + ! save best function evaluation + if (phi < phi_best) then + phi_best = phi + x_best = x_try + g_best = g_x + have_best = .true. + endif + + ! tiny-step convergence + if (maxval( abs(x_try - x_old) / max(abs(x_try), 1._sp) ) < ERR_ITER_DX) then + converged = .true. + exit ! exit iteration loop + end if + + end do ! loop through iterations + + ! ----- handle the extremely rare case of non-convergence ----- + if( .not. converged)then + + ! use explicit Euler if did not find anything + if( .not. have_best) call dx_dt(fuseStruct, x0, g_best) + + ! use dx/dt = g(x_best) + x_try = x0 + dt*g_best + + ! test bounds violations: if bounds exceeded, then clamp and disaggregate fluxes (conserve mass) + call XTRY_2_STR(x_try, fuseStruct%state1) + call conserve_clamp(fuseStruct, dt, isClamped) + print*, 'WARNING: '//trim(message)//"failed to converge: use best function evaluation. Clamp = ", isClamped + + endif ! if not converged + + ! save final state + x1 = x_try + + end subroutine implicit_solve + +end module implicit_solve_module diff --git a/build/FUSE_SRC/physics/mod_derivs_diff.f90 b/build/FUSE_SRC/physics/mod_derivs_diff.f90 new file mode 100644 index 0000000..fd0bb00 --- /dev/null +++ b/build/FUSE_SRC/physics/mod_derivs_diff.f90 @@ -0,0 +1,65 @@ +module MOD_DERIVS_DIFF_module + + USE nrtype + USE work_types, only: fuse_work + USE multistate_types, only: STATEV + USE qsatexcess_diff_module, only: qsatexcess_diff + USE evap_upper_diff_module, only: evap_upper_diff + USE evap_lower_diff_module, only: evap_lower_diff + USE qinterflow_diff_module, only: qinterflow_diff + USE qpercolate_diff_module, only: qpercolate_diff + USE q_baseflow_diff_module, only: q_baseflow_diff + USE q_misscell_diff_module, only: q_misscell_diff + USE mstate_rhs_diff_module, only: mstate_rhs_diff + + implicit none + + private + public :: MOD_DERIVS_DIFF + +contains + + SUBROUTINE MOD_DERIVS_DIFF(fuseStruct, g_x, J_g) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified to include snow model by Brian Henn, 6/2013 + ! Modified to include analytical derivatives by Martyn Clark, 12/2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! compute the time derivative (dx/dt) of all model states (x) + ! -------------------------------------------------------------------------------------- + implicit none + ! input + type(fuse_work) , intent(inout) :: fuseStruct ! fuse work structure + ! output + real(sp) , intent(out) :: g_x(:) ! dx/dt=g(x) + real(sp) , intent(out) , optional :: J_g(:,:) ! flux Jacobian matrix + ! internal + logical(lgt) :: comp_dflux ! flag to compute flux derivatives + ! -------------------------------------------------------------------------------------- + + ! check if Jacobian is desired + comp_dflux = present(J_g) + + ! compute fluxes + call qsatexcess_diff(fuseStruct, comp_dflux) ! compute the saturated area and surface runoff + call evap_upper_diff(fuseStruct, comp_dflux) ! compute evaporation from the upper layer + call evap_lower_diff(fuseStruct, comp_dflux) ! compute evaporation from the lower layer + call qinterflow_diff(fuseStruct, comp_dflux) ! compute interflow from free water in the upper layer + call qpercolate_diff(fuseStruct, comp_dflux) ! compute percolation from the upper to lower soil layers + call q_baseflow_diff(fuseStruct, comp_dflux) ! compute baseflow from the lower soil layer + call q_misscell_diff(fuseStruct, comp_dflux) ! compute miscellaneous fluxes (NOTE: need sat area, evap, and perc) + + ! compute the time derivative (dx/dt) of all model states (x) + if(comp_dflux)then + call mstate_rhs_diff(fuseStruct, g_x, J_g) + else + call mstate_rhs_diff(fuseStruct, g_x) + endif + + END SUBROUTINE MOD_DERIVS_DIFF + +end module MOD_DERIVS_DIFF_module diff --git a/build/FUSE_SRC/physics/mstate_rhs_diff.f90 b/build/FUSE_SRC/physics/mstate_rhs_diff.f90 new file mode 100644 index 0000000..68ae410 --- /dev/null +++ b/build/FUSE_SRC/physics/mstate_rhs_diff.f90 @@ -0,0 +1,115 @@ +module MSTATE_RHS_DIFF_module + + use globaldata, only: isDebug ! print flag + + implicit none + + private + public :: MSTATE_RHS_DIFF + +contains + + SUBROUTINE MSTATE_RHS_DIFF(fuseStruct, g_x, J_g) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Martyn Clark to create a differentiable model, 12/25 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Computes time derivatives of all states for all model combinations + ! --------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE work_types, only: fuse_work ! fuse work data type + USE model_defn ! model definition structure + USE model_defnames ! model names + use str_2_xtry_module ! puts FUSE state structure into state vector + ! input-output + type(fuse_work), intent(inout) :: fuseStruct ! fuse work structure + ! output + real(sp) , intent(out) :: g_x(:) ! dx/dt=g(x) + real(sp) , intent(out) , optional :: J_g(:,:) ! flux Jacobian matrix + ! internal + logical(lgt) :: comp_dflux ! flag to compute flux derivatives + ! ------------------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + M_FLUX => fuseStruct%flux , & ! fluxes + MPARAM => fuseStruct%param_adjust , & ! adjustable model parameters + DX_DT => fuseStruct%dx_dt & ! time derivative in states + ) ! (associate) + ! ------------------------------------------------------------------------------------------------- + + ! check if Jacobian is desired + comp_dflux = present(J_g) + + ! --------------------------------------------------------------------------------------- + ! (1) UPPER LAYER + ! --------------------------------------------------------------------------------------- + + ! compute time derivatives + SELECT CASE(SMODL%iARCH1) + CASE(iopt_tension2_1) ! tension storage sub-divided into recharge and excess + DX_DT%TENS_1A = M_FLUX%EFF_PPT - M_FLUX%QSURF - M_FLUX%EVAP_1A - M_FLUX%RCHR2EXCS + DX_DT%TENS_1B = M_FLUX%RCHR2EXCS - M_FLUX%EVAP_1B - M_FLUX%TENS2FREE_1 + DX_DT%FREE_1 = M_FLUX%TENS2FREE_1 - M_FLUX%QPERC_12 - M_FLUX%QINTF_1 - M_FLUX%OFLOW_1 + CASE(iopt_tension1_1) ! upper layer broken up into tension and free storage + DX_DT%TENS_1 = M_FLUX%EFF_PPT - M_FLUX%QSURF - M_FLUX%EVAP_1 - M_FLUX%TENS2FREE_1 + DX_DT%FREE_1 = M_FLUX%TENS2FREE_1 - M_FLUX%QPERC_12 - M_FLUX%QINTF_1 - M_FLUX%OFLOW_1 + CASE(iopt_onestate_1) ! upper layer defined by a single state variable + DX_DT%WATR_1 = M_FLUX%EFF_PPT - M_FLUX%QSURF - M_FLUX%EVAP_1 - M_FLUX%QPERC_12 - M_FLUX%QINTF_1 & + - M_FLUX%OFLOW_1 + CASE DEFAULT + print *, "SMODL%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" + STOP + END SELECT ! (upper layer architecture) + + ! compute Jacobian + if(comp_dflux)then + if(SMODL%iARCH1 /= iopt_onestate_1) stop "mstate_rhs: only iopt_onestate_1 currently implemented" + J_g(1,:) = -M_FLUX%EFF_PPT*fuseStruct%df_dS%SATAREA - fuseStruct%df_dS%EVAP_1 - fuseStruct%df_dS%QPERC_12 + endif + + ! --------------------------------------------------------------------------------------- + ! (2) LOWER LAYER + ! --------------------------------------------------------------------------------------- + + ! compute time derivatives + SELECT CASE(SMODL%iARCH2) + CASE(iopt_tens2pll_2) ! tension reservoir plus two parallel tanks + DX_DT%TENS_2 = M_FLUX%QPERC_12*(1._SP-MPARAM%PERCFRAC) - M_FLUX%EVAP_2 - M_FLUX%TENS2FREE_2 + DX_DT%FREE_2A = M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) + M_FLUX%TENS2FREE_2/2._SP - M_FLUX%QBASE_2A & + - M_FLUX%OFLOW_2A + DX_DT%FREE_2B = M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) + M_FLUX%TENS2FREE_2/2._SP - M_FLUX%QBASE_2B & + - M_FLUX%OFLOW_2B + CASE(iopt_unlimfrc_2,iopt_unlimpow_2,iopt_topmdexp_2,iopt_fixedsiz_2) ! single state + ! (NOTE: M_FLUX%OFLOW_2=0 for 'unlimfrc_2','unlimpow_2','topmdexp_2') + DX_DT%WATR_2 = M_FLUX%QPERC_12 - M_FLUX%EVAP_2 - M_FLUX%QBASE_2 - M_FLUX%OFLOW_2 + CASE DEFAULT + print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" + print *, " iopt_topmdexp_2, or iopt_fixedsiz_2" + STOP + END SELECT + + ! compute Jacobian + ! NOTE: assume M_FLUX%EVAP_2=0 and M_FLUX%OFLOW_2=0 + if(comp_dflux)then + if(SMODL%iARCH2 == iopt_tens2pll_2) stop "mstate_rhs: iopt_tens2pll_2 not currently implemented" + J_g(2,:) = fuseStruct%df_dS%QPERC_12 - fuseStruct%df_dS%QBASE_2 + endif + + ! --------------------------------------------------------------------------------------- + + ! --------------------------------------------------------------------------------------- + ! (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 + +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..5dd2813 --- /dev/null +++ b/build/FUSE_SRC/physics/q_baseflow_diff.f90 @@ -0,0 +1,109 @@ +module Q_BASEFLOW_DIFF_module + + implicit none + + private + public :: Q_BASEFLOW_DIFF + +contains + + + SUBROUTINE Q_BASEFLOW_DIFF(fuseStruct, want_dflux) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Martyn Clark to create a differentiable model, 12/25 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Computes the baseflow from the lower soil layer + ! --------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE work_types, only: fuse_work ! fuse work type + USE model_defn ! model definition structure + USE model_defnames + IMPLICIT NONE + ! input-output + type(fuse_work), intent(inout) :: fuseStruct ! fuse work structure + logical(lgt), intent(in), optional :: want_dflux ! if we want flux derivatives + ! derivatives + logical(lgt) :: comp_dflux ! flag to compute flux derivatives + integer(i4b) :: iState ! state index + real(sp) :: phi ! scaled water storage, phi=w/ws + real(sp) :: dqb_dw ! derivative in baseflow flux w.r.t. water store + ! ------------------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + 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 + + associate(qbsat=>DPARAM%QBSAT, w=>TSTATE%WATR_2, ws=>MPARAM%MAXWATR_2, p=>MPARAM%QB_POWR) + + ! ----- compute flux ------------------------------------------------------------------ + phi = w/ws + M_FLUX%QBASE_2 = qbsat*phi**p + + ! ----- compute derivative ------------------------------------------------------------ + if(comp_dflux) dqb_dw = (qbsat*p/ws)*phi**(p - 1._sp) + + end associate + + ! -------------------------------------------------------------------------------------- + CASE(iopt_topmdexp_2) ! topmodel exponential reservoir (-HUGE to HUGE) + M_FLUX%QBASE_2 = DPARAM%QBSAT * EXP( -(1. - TSTATE%WATR_2/MPARAM%MAXWATR_2) ) + if(comp_dflux) stop "q_baseflow: derivative not implemented yet for iopt_topmdexp_2" + + ! -------------------------------------------------------------------------------------- + CASE(iopt_fixedsiz_2) ! baseflow reservoir of fixed size + M_FLUX%QBASE_2 = MPARAM%BASERTE * (TSTATE%WATR_2/MPARAM%MAXWATR_2)**MPARAM%QB_POWR + if(comp_dflux) stop "q_baseflow: derivative not implemented yet for iopt_fixedsiz_2" + + ! -------------------------------------------------------------------------------------- + CASE DEFAULT + print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" + print *, " iopt_topmdexp_2, or iopt_fixedsiz_2" + STOP + ! -------------------------------------------------------------------------------------- + + END SELECT + ! --------------------------------------------------------------------------------------- + + ! populate derivative vector + if(comp_dflux)then + do iState=1,nState + select case(cState(iState)%iSNAME) + case (iopt_WATR_2); dfx_dS(iState)%QBASE_2 = dqb_dw ! exists if one state in the upper layer + end select ! no default needed + end do ! looping through states + endif + + end associate ! end association with variables in the data structures + END SUBROUTINE Q_BASEFLOW_DIFF + +end module Q_BASEFLOW_DIFF_module diff --git a/build/FUSE_SRC/physics/q_misscell_diff.f90 b/build/FUSE_SRC/physics/q_misscell_diff.f90 new file mode 100644 index 0000000..ae56313 --- /dev/null +++ b/build/FUSE_SRC/physics/q_misscell_diff.f90 @@ -0,0 +1,125 @@ +module Q_MISSCELL_DIFF_module + + implicit none + + private + public :: Q_MISSCELL_DIFF + +contains + + SUBROUTINE Q_MISSCELL_DIFF(fuseStruct, want_dflux) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Martyn Clark to create a differentiable model, 12/25 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Computes miscellaneous fluxes: + ! RCHR2EXCS = flow from recharge to excess (mm day-1) + ! TENS2FREE_1 = flow from tension storage to free storage in the upper layer (mm day-1) + ! TENS2FREE_2 = flow from tension storage to free storage in the lower layer (mm day-1) + ! OFLOW_1 = overflow from the upper soil layer (mm day-1) + ! OFLOW_2 = overflow from the lower soil layer (mm day-1) + ! --------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE work_types, only: fuse_work ! fuse work type + USE model_defn ! model definition structure + USE model_defnames + USE smoothers, only: smoother ! smoothing function + IMPLICIT NONE + ! input-output + type(fuse_work), intent(inout) :: fuseStruct ! fuse work structure + logical(lgt), intent(in), optional :: want_dflux ! if we want flux derivatives + ! internal + logical(lgt) :: comp_dflux ! flag to compute flux derivatives + REAL(SP), PARAMETER :: PSMOOTH=0.05_SP ! smoothing parameter + REAL(SP) :: W_FUNC ! result from smoother + ! ------------------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + M_FLUX => fuseStruct%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) + ! --------------------------------------------------------------------------------------- + + ! check the need to compute flux derivatives + comp_dflux = .false.; if(present(want_dflux)) comp_dflux = want_dflux + + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH1) + CASE(iopt_tension2_1) ! tension storage sub-divided into recharge and excess + ! compute flow from recharge to excess (mm s-1) + W_FUNC = SMOOTHER(TSTATE%TENS_1A,DPARAM%MAXTENS_1A,PSMOOTH) + M_FLUX%RCHR2EXCS = W_FUNC * (M_FLUX%EFF_PPT - M_FLUX%QSURF) + ! compute flow from tension storage to free storage (mm s-1) + W_FUNC = SMOOTHER(TSTATE%TENS_1B,DPARAM%MAXTENS_1B,PSMOOTH) + M_FLUX%TENS2FREE_1 = W_FUNC * M_FLUX%RCHR2EXCS + ! compute over-flow of free water + W_FUNC = SMOOTHER(TSTATE%FREE_1,DPARAM%MAXFREE_1,PSMOOTH) + M_FLUX%OFLOW_1 = W_FUNC * M_FLUX%TENS2FREE_1 + CASE(iopt_tension1_1) ! upper layer broken up into tension and free storage + ! no separate recharge zone (flux should never be used) + M_FLUX%RCHR2EXCS = 0._SP + ! compute flow from tension storage to free storage (mm s-1) + W_FUNC = SMOOTHER(TSTATE%TENS_1,DPARAM%MAXTENS_1,PSMOOTH) + M_FLUX%TENS2FREE_1 = W_FUNC * (M_FLUX%EFF_PPT - M_FLUX%QSURF) + ! compute over-flow of free water + W_FUNC = SMOOTHER(TSTATE%FREE_1,DPARAM%MAXFREE_1,PSMOOTH) + M_FLUX%OFLOW_1 = W_FUNC * M_FLUX%TENS2FREE_1 + CASE(iopt_onestate_1) ! upper layer defined by a single state variable + ! no tension stores + M_FLUX%RCHR2EXCS = 0._SP + M_FLUX%TENS2FREE_1 = 0._SP + ! compute over-flow of free water + if(SMODL%iQSURF == iopt_arno_x_vic)then + M_FLUX%OFLOW_1 = 0._sp ! no need for overflow since the vic parmaeterization is smoothed now + else + W_FUNC = SMOOTHER(TSTATE%WATR_1,MPARAM%MAXWATR_1,PSMOOTH) + M_FLUX%OFLOW_1 = W_FUNC * (M_FLUX%EFF_PPT - M_FLUX%QSURF) + endif + CASE DEFAULT + print *, "SMODL%iARCH1 must be iopt_tension2_1, iopt_tension1_1, or iopt_onestate_1" + STOP + END SELECT + + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iARCH2) + CASE(iopt_tens2pll_2) ! tension reservoir plus two parallel tanks + ! compute flow from tension storage to free storage (mm s-1) + W_FUNC = SMOOTHER(TSTATE%TENS_2,DPARAM%MAXTENS_2,PSMOOTH) + M_FLUX%TENS2FREE_2 = W_FUNC * M_FLUX%QPERC_12*(1._SP-MPARAM%PERCFRAC) + ! compute over-flow of free water in the primary reservoir + W_FUNC = SMOOTHER(TSTATE%FREE_2A,DPARAM%MAXFREE_2A,PSMOOTH) + M_FLUX%OFLOW_2A = W_FUNC * (M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) + M_FLUX%TENS2FREE_2/2._SP) + ! compute over-flow of free water in the secondary reservoir + W_FUNC = SMOOTHER(TSTATE%FREE_2B,DPARAM%MAXFREE_2B,PSMOOTH) + M_FLUX%OFLOW_2B = W_FUNC * (M_FLUX%QPERC_12*(MPARAM%PERCFRAC/2._SP) + M_FLUX%TENS2FREE_2/2._SP) + ! compute total overflow + M_FLUX%OFLOW_2 = M_FLUX%OFLOW_2A + M_FLUX%OFLOW_2B + CASE(iopt_fixedsiz_2) + ! no tension store + M_FLUX%TENS2FREE_2 = 0._SP + M_FLUX%OFLOW_2A = 0._SP + M_FLUX%OFLOW_2B = 0._SP + ! compute over-flow of free water + W_FUNC = SMOOTHER(TSTATE%WATR_2,MPARAM%MAXWATR_2,PSMOOTH) + M_FLUX%OFLOW_2 = W_FUNC * M_FLUX%QPERC_12 + CASE(iopt_unlimfrc_2,iopt_unlimpow_2,iopt_topmdexp_2) ! unlimited size + M_FLUX%TENS2FREE_2 = 0._SP + M_FLUX%OFLOW_2 = 0._SP + M_FLUX%OFLOW_2A = 0._SP + M_FLUX%OFLOW_2B = 0._SP + CASE DEFAULT + print *, "SMODL%iARCH2 must be iopt_tens2pll_2, iopt_unlimfrc_2, iopt_unlimpow_2" + print *, " iopt_topmdexp_2, or iopt_fixedsiz_2" + STOP + END SELECT + + end associate ! end association with variables in the data structures + END SUBROUTINE Q_MISSCELL_DIFF + +end module Q_MISSCELL_DIFF_module diff --git a/build/FUSE_SRC/physics/qinterflow_diff.f90 b/build/FUSE_SRC/physics/qinterflow_diff.f90 new file mode 100644 index 0000000..d2aaf84 --- /dev/null +++ b/build/FUSE_SRC/physics/qinterflow_diff.f90 @@ -0,0 +1,59 @@ +module QINTERFLOW_DIFF_module + + implicit none + + private + public :: QINTERFLOW_DIFF + +contains + + SUBROUTINE QINTERFLOW_DIFF(fuseStruct, want_dflux) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Martyn Clark to create a differentiable model, 12/25 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Computes the interflow from free water in the upper soil layer + ! --------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE work_types, only: fuse_work ! fuse work type + USE model_defn ! model definition structure + USE model_defnames + IMPLICIT NONE + ! input-output + type(fuse_work), intent(inout) :: fuseStruct ! fuse work structure + logical(lgt), intent(in), optional :: want_dflux ! if we want flux derivatives + ! internal + logical(lgt) :: comp_dflux ! flag to compute flux derivatives + ! ------------------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + M_FLUX => fuseStruct%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) + ! ------------------------------------------------------------------------------------------------- + + ! check the need to compute flux derivatives + comp_dflux = .false.; if(present(want_dflux)) comp_dflux = want_dflux + + ! --------------------------------------------------------------------------------------- + SELECT CASE(SMODL%iQINTF) + CASE(iopt_intflwsome) ! interflow + M_FLUX%QINTF_1 = MPARAM%IFLWRTE * (TSTATE%FREE_1/DPARAM%MAXFREE_1) + CASE(iopt_intflwnone) ! no interflow + M_FLUX%QINTF_1 = 0. + CASE DEFAULT ! check for errors + print *, "SMODL%iQINTF must be either iopt_intflwsome or iopt_intflwnone" + STOP + END SELECT + ! --------------------------------------------------------------------------------------- + + end associate ! end association with variables in the data structures + END SUBROUTINE QINTERFLOW_DIFF + +end module QINTERFLOW_DIFF_module diff --git a/build/FUSE_SRC/physics/qpercolate_diff.f90 b/build/FUSE_SRC/physics/qpercolate_diff.f90 new file mode 100644 index 0000000..28a6b45 --- /dev/null +++ b/build/FUSE_SRC/physics/qpercolate_diff.f90 @@ -0,0 +1,117 @@ +module QPERCOLATE_DIFF_module + + implicit none + + private + public :: QPERCOLATE_DIFF + +contains + + SUBROUTINE QPERCOLATE_DIFF(fuseStruct, want_dflux) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Martyn Clark to create a differentiable model, 12/25 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Computes the percolation from the upper soil layer to the lower soil layer + ! --------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE work_types, only: fuse_work ! fuse work type + USE model_defn ! model definition structure + USE model_defnames ! model definition names + use smoothers, only : sfrac, dsfrac ! smoothed fraction, derivative + IMPLICIT NONE + ! input-output + type(fuse_work), intent(inout) :: fuseStruct ! fuse work structure + logical(lgt), intent(in), optional :: want_dflux ! if we want flux derivatives + ! internal + logical(lgt) :: comp_dflux ! flag to compute flux derivatives + integer(i4b) :: iState ! state index + real(sp) :: phi ! smoothed fraction of free water + real(sp) :: dphi_dx ! derivative in smoothed fraction of free water + real(sp) :: df_dpsi ! derivative of flux w.r.t. fraction + real(sp) :: dqperc_dx ! derivative of percolation fux w.r.t. water state + REAL(SP) :: LZ_PD ! lower zone percolation demand + real(sp), parameter :: ms=1.e-4_sp ! smoothing in sfrac(smax) function + ! --------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + 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) + + ! -------------------------------------------------------------------------------------- + ! upper zone control + ! -------------------------------------------------------------------------------------- + CASE(iopt_perc_w2sat, iopt_perc_f2sat) + + ! short-cuts + associate(k=>MPARAM%PERCRTE, c=>MPARAM%PERCEXP) + + ! compute fractions + select case(SMODL%iQPERC) + case(iopt_perc_w2sat); phi = sfrac(TSTATE%WATR_1, MPARAM%MAXWATR_1, ms) + case(iopt_perc_f2sat); phi = sfrac(TSTATE%FREE_1, DPARAM%MAXFREE_1, ms) + end select ! no need for default since already in block + + ! ----- compute flux ---------------------------------------------------------------- + M_FLUX%QPERC_12 = k*phi**c + + ! ----- compute derivative ---------------------------------------------------------- + if(comp_dflux)then + + ! compute derivative in the fractions + select case(SMODL%iQPERC) + case(iopt_perc_w2sat); dphi_dx = dsfrac(TSTATE%WATR_1, MPARAM%MAXWATR_1, ms) + case(iopt_perc_f2sat); dphi_dx = dsfrac(TSTATE%FREE_1, DPARAM%MAXFREE_1, ms) + end select ! no need for default since already in block + + ! compute derivatives in the percolation flux + df_dpsi = k*c*phi**(c - 1._sp) ! derivative of flux w.r.t. fraction + dqperc_dx = df_dpsi*dphi_dx + + ! populate derivative vector + do iState=1,nState + select case(cState(iState)%iSNAME) + case (iopt_FREE_1); dfx_dS(iState)%QPERC_12 = dqperc_dx ! exists if separate free tank + case (iopt_WATR_1); dfx_dS(iState)%QPERC_12 = dqperc_dx ! exists if one state in the upper layer + end select ! no default needed + end do ! looping through states + + endif ! if computing derivatives + + end associate + + ! -------------------------------------------------------------------------------------- + ! lower zone control + ! -------------------------------------------------------------------------------------- + CASE(iopt_perc_lower) ! perc defined by moisture content in lower layer (SAC) + + ! ----- compute flux ---------------------------------------------------------------- + LZ_PD = 1._SP + MPARAM%SACPMLT*(1._SP - TSTATE%WATR_2/MPARAM%MAXWATR_2)**MPARAM%SACPEXP + M_FLUX%QPERC_12 = DPARAM%QBSAT*LZ_PD * (TSTATE%FREE_1/DPARAM%MAXFREE_1) + + ! ----- compute derivatives --------------------------------------------------------------------- + if(comp_dflux) stop "qpercolate: derivatives for iopt_perc_lower not implemented yet" + + CASE DEFAULT; stop "qpercolate: SMODL%iQPERC must be iopt_perc_f2sat, iopt_perc_w2sat, or iopt_perc_lower" + END SELECT + ! -------------------------------------------------------------------------------------- + + end associate ! end association with variables in the data structures + END SUBROUTINE QPERCOLATE_DIFF + +end module QPERCOLATE_DIFF_module diff --git a/build/FUSE_SRC/physics/qsatexcess_diff.f90 b/build/FUSE_SRC/physics/qsatexcess_diff.f90 new file mode 100644 index 0000000..901c0eb --- /dev/null +++ b/build/FUSE_SRC/physics/qsatexcess_diff.f90 @@ -0,0 +1,157 @@ +module QSATEXCESS_DIFF_MODULE + + implicit none + + private + public :: QSATEXCESS_DIFF + +contains + + SUBROUTINE QSATEXCESS_DIFF(fuseStruct, want_dflux) + ! ------------------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! Modified by Martyn Clark to create a differentiable model, 12/25 + ! ------------------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Computes the saturated area and surface runoff + ! ------------------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. + USE work_types, only: fuse_work ! fuse work type + USE model_defn ! model definition structure + USE model_defnames + USE nr, ONLY : gammp ! interface for the incomplete gamma function + USE smoothers, only : smax,dsmax ! smoothed max function, derivative + IMPLICIT NONE + ! input-output + type(fuse_work), intent(inout) :: fuseStruct ! fuse work structure + logical(lgt), intent(in), optional :: want_dflux ! if we want flux derivatives + ! internal variables -- vic + real(sp) :: u,xp ! temporary variables + real(sp) :: ds_dx ! derivative of saturated area w.r.t. x + real(sp) :: dx_du ! derivative of smooth max(u,0) w.r.t. u + real(sp) :: du_dw ! derivative of u w.r.t. w + real(sp) :: ds_dw ! derivative of saturated area w.r.t. w + ! internal variables -- topmodel + REAL(SP) :: TI_SAT ! topographic index where saturated + REAL(SP) :: TI_LOG ! critical value of topo index in log space + REAL(SP) :: TI_OFF ! offset in the Gamma distribution + REAL(SP) :: TI_SHP ! shape of the Gamma distribution + REAL(SP) :: TI_CHI ! CHI, see Sivapalan et al., 1987 + REAL(SP) :: TI_ARG ! argument of the Gamma function + REAL(SP) :: NO_ZERO=1.E-8 ! avoid divide by zero + ! derivatives + logical(lgt) :: comp_dflux ! flag to compute flux derivatives + integer(i4b) :: iState ! state index + real(sp), parameter :: ms=1.e-4_sp ! smoothing in smax function + ! ------------------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + 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) + + ! ------------------------------------------------------------------------------------------------ + ! ----- ARNO/Xzang/VIC parameterization (upper zone control) ------------------------------------- + ! ------------------------------------------------------------------------------------------------ + CASE(iopt_arno_x_vic) + + ! define variables + associate(w=>TSTATE%WATR_1, wmax=>MPARAM%MAXWATR_1, b=>MPARAM%AXV_BEXP) + + ! ----- compute flux ---------------------------------------------------------------------------- + u = 1._sp - w/wmax + xp = smax(u, 0._sp, ms) ! smooth version of max(u,0) + M_FLUX%SATAREA = 1._sp - xp**b + + ! ----- compute derivatives --------------------------------------------------------------------- + if(comp_dflux)then + + ! compute derivative w.r.t. saturated area + ds_dx = -b*xp**(b - 1._sp) ! derivative of saturated area w.r.t. xp + dx_du = dsmax(u, 0._sp, ms) ! derivative of smooth max(u,0) w.r.t. u + du_dw = -1._sp/wmax ! derivative of u w.r.t. w + ds_dw = du_dw*dx_du*ds_dx ! derivative of saturated area w.r.t. w + + ! since WATR_1 is the sum of individual state variables (e.g., WATR_1=TENS_1+FREE_1) simply copy derivative + do iState=1,nState + select case(cState(iState)%iSNAME) + case (iopt_TENS1A); dfx_dS(iState)%SATAREA = ds_dw ! exists if two tension tanks + case (iopt_TENS1B); dfx_dS(iState)%SATAREA = ds_dw ! exists if two tension tanks + case (iopt_TENS_1); dfx_dS(iState)%SATAREA = ds_dw ! exists if one tension tank + case (iopt_FREE_1); dfx_dS(iState)%SATAREA = ds_dw ! exists if separate free storage + case (iopt_WATR_1); dfx_dS(iState)%SATAREA = ds_dw ! exists if one state in the upper layer + end select ! no default needed + end do ! looping through states + + endif ! if want derivatives + + end associate + + ! ------------------------------------------------------------------------------------------------ + ! ----- PRMS variant (fraction of upper tension storage) ----------------------------------------- + ! ------------------------------------------------------------------------------------------------ + CASE(iopt_prms_varnt) + + ! ----- compute flux ---------------------------------------------------------------------------- + M_FLUX%SATAREA = MIN(TSTATE%TENS_1/DPARAM%MAXTENS_1, 1._sp) * MPARAM%SAREAMAX + + ! ----- compute derivatives --------------------------------------------------------------------- + if(comp_dflux) stop "qsatexcess: derivatives for iopt_prms_varnt not implemented yet" + + ! ------------------------------------------------------------------------------------------------ + ! ----- TOPMODEL parameterization (only valid for TOPMODEL qb) ----------------------------------- + ! ------------------------------------------------------------------------------------------------ + CASE(iopt_tmdl_param) + + ! ----- compute flux ---------------------------------------------------------------------------- + + ! compute the minimum value of the topographic index where the basin is saturated + ! (this is correct, as MPARAM%MAXWATR_2 is m*n -- units are meters**(1/n) + TI_SAT = DPARAM%POWLAMB / (TSTATE%WATR_2/MPARAM%MAXWATR_2 + NO_ZERO) + ! compute the saturated area + IF (TI_SAT.GT.DPARAM%MAXPOW) THEN + M_FLUX%SATAREA = 0. + ELSE + ! convert the topographic index to log space + TI_LOG = LOG( TI_SAT**MPARAM%QB_POWR ) + ! compute the saturated area (NOTE: critical value of the topographic index is in log space) + TI_OFF = 3._sp ! offset in the Gamma distribution (the "3rd" parameter) + TI_SHP = MPARAM%TISHAPE ! shape of the Gamma distribution (the "2nd" parameter) + TI_CHI = (MPARAM%LOGLAMB - TI_OFF) / MPARAM%TISHAPE ! Chi -- loglamb is the first parameter (mean) + TI_ARG = MAX(0._sp, TI_LOG - TI_OFF) / TI_CHI ! argument to the incomplete Gamma function + M_FLUX%SATAREA = 1._sp - GAMMP(TI_SHP, TI_ARG) ! GAMMP is the incomplete Gamma function + ENDIF + + ! ----- compute derivatives --------------------------------------------------------------------- + if(comp_dflux) stop "qsatexcess: derivatives for iopt_tmdl_param not implemented yet" + + ! ------------------------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------------------------ + ! check processed surface runoff selection + CASE DEFAULT + print *, "SMODL%iQSURF must be iopt_arno_x_vic, iopt_prms_varnt, or iopt_tmdl_param" + STOP + + END SELECT ! (different surface runoff options) + + ! ...and, compute surface runoff + ! ------------------------------ + M_FLUX%QSURF = M_FLUX%EFF_PPT * M_FLUX%SATAREA + + end associate ! end association with variables in the data structures + END SUBROUTINE QSATEXCESS_DIFF + +end module QSATEXCESS_DIFF_MODULE diff --git a/build/FUSE_SRC/physics/smoothers.f90 b/build/FUSE_SRC/physics/smoothers.f90 new file mode 100644 index 0000000..7ed972d --- /dev/null +++ b/build/FUSE_SRC/physics/smoothers.f90 @@ -0,0 +1,307 @@ +module smoothers + + implicit none + + private + public:: sigmoid,dsigmoid + public:: LOGISMOOTH + public:: smoother + public:: smax,dsmax + public:: smin,dsmin + public:: sfrac,dsfrac + public:: sclamp,dsclamp + +contains + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + PURE FUNCTION sfrac(x,xmax,ms) result(xf) + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Use smoothed min function to compute smooth fraction + ! --------------------------------------------------------------------------------------- + USE nrtype + implicit none + real(sp), intent(in) :: x ! x value + real(sp), intent(in) :: xmax ! maximum value + real(sp), intent(in) :: ms ! smoothing parameter + real(sp) :: xp ! smooth min(x,xmax) + real(sp) :: xf ! smooth fraction x/xmax + xp = xmax - smax(xmax - x, 0._sp, ms) ! smooth version of min(x, xmax) + xf = max(0._sp, xp) / xmax ! use max(0._sp, xp) to account for small neg values at zero + end function sfrac + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + PURE FUNCTION dsfrac(x,xmax,ms) result(dxf_dx) + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Get derivative of the smooth fraction + ! --------------------------------------------------------------------------------------- + USE nrtype + implicit none + real(sp), intent(in) :: x ! x value + real(sp), intent(in) :: xmax ! maximum value + real(sp), intent(in) :: ms ! smoothing parameter + real(sp) :: dxp_dx ! derivative of the max smoother + real(sp) :: dxf_dx ! derivative of the smoothed fraction + ! NOTE: ignore the hard clamp at zero (very small differences and not worth the extra expense) + dxp_dx = dsmax(xmax - x, 0._sp, ms) ! note signs cancel out + dxf_dx = dxp_dx / xmax + end function dsfrac + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + PURE FUNCTION smax(x,xmin,ms) result(xp) + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Compute smoothed max function following Kavetski and Kuczera (2007) + ! + ! Kavetski, D. and Kuczera, G., 2007. Model smoothing strategies to remove microscale + ! discontinuities and spurious secondary optima in objective functions in hydrological + ! calibration. Water Resources Research, 43(3). + ! --------------------------------------------------------------------------------------- + USE nrtype + implicit none + real(sp), intent(in) :: x ! x value + real(sp), intent(in) :: xmin ! minimum value + real(sp), intent(in) :: ms ! smoothing parameter + real(sp) :: srt ! sqrt(x*x + ms) + real(sp) :: xp ! smooth max(x,xmin) + srt = sqrt((x-xmin)**2 + ms) + xp = 0.5_sp*(x + xmin + srt) ! smooth max(x,xmin) + end function smax + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + PURE FUNCTION dsmax(x,xmin,ms) result(dxp) + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Compute derivative of smoothed max function of Kavetski and Kuczera (2007) + ! + ! Kavetski, D. and Kuczera, G., 2007. Model smoothing strategies to remove microscale + ! discontinuities and spurious secondary optima in objective functions in hydrological + ! calibration. Water Resources Research, 43(3). + ! --------------------------------------------------------------------------------------- + USE nrtype + implicit none + real(sp), intent(in) :: x ! x value + real(sp), intent(in) :: xmin ! minimum value + real(sp), intent(in) :: ms ! smoothing parameter + real(sp) :: u ! x-xmin + real(sp) :: srt ! sqrt(x*x + ms) + real(sp) :: dxp ! derivative of smooth max(x,xmin) + u = x-xmin + srt = sqrt(u*u + ms) + dxp = 0.5_sp*(1._sp + u/srt) ! derivative of smooth max(x,xmin) + end function dsmax + + ! --------------------------------------------------------------------------------------- + ! Extra helper functions + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! compute smin, sclamp, and derivatives + ! --------------------------------------------------------------------------------------- + + pure function smin(x, xmax, ms) result(xp) + use nrtype + implicit none + real(sp), intent(in) :: x, xmax, ms + real(sp) :: xp + xp = xmax - smax(xmax - x, 0._sp, ms) + end function smin + + pure function dsmin(x, xmax, ms) result(dxp) + use nrtype + implicit none + real(sp), intent(in) :: x, xmax, ms + real(sp) :: dxp + dxp = dsmax(xmax - x, 0._sp, ms) + end function dsmin + + pure function sclamp(x, xmin, xmax, ms) result(xp) + use nrtype + implicit none + real(sp), intent(in) :: x, xmin, xmax, ms + real(sp) :: xp + xp = smax( smin(x, xmax, ms), xmin, ms ) + end function sclamp + + pure function dsclamp(x, xmin, xmax, ms) result(dxp) + use nrtype + implicit none + real(sp), intent(in) :: x, xmin, xmax, ms + real(sp) :: v + real(sp) :: dxp + v = smin(x, xmax, ms) + dxp = dsmax(v, xmin, ms) * dsmin(x, xmax, ms) + end function dsclamp + + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + pure real(sp) function sigmoid(z, beta) result(s) + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! A simple sigmoid smoother centered on zero + ! --------------------------------------------------------------------------------------- + use nrtype + implicit none + real(sp), intent(in) :: z, beta + real(sp) :: zb + + zb = z/beta + + if (zb >= 0._sp) then + s = 1._sp / (1._sp + exp(-zb)) + else + s = exp(zb) / (1._sp + exp(zb)) + end if + + end function sigmoid + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + pure real(sp) function dsigmoid(s, beta) result(ds_dz) + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Derivative in the sigmoid w.r.t. z given already have the sigmoid + ! --------------------------------------------------------------------------------------- + use nrtype + implicit none + real(sp), intent(in) :: s, beta + ds_dz = (s/beta) * (1._sp - s) + end function dsigmoid + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + + PURE FUNCTION smoother(STATE,STATE_MAX,PSMOOTH) result(w_func) + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Provides the option of different smoothers + ! --------------------------------------------------------------------------------------- + USE nrtype + IMPLICIT NONE + REAL(SP), INTENT(IN) :: STATE ! model state + REAL(SP), INTENT(IN) :: STATE_MAX ! maximum model state + REAL(SP), INTENT(IN) :: PSMOOTH ! smoothing parameter (fraction of state) + real(sp) :: w_func ! smoothed threshold + real(sp) :: delta ! scale factor + + ! logistic smoothing (original) + w_func = LOGISMOOTH(STATE,STATE_MAX,PSMOOTH) + + ! qintic smoother (plays better with Newton) + !delta = MAX(PSMOOTH*STATE_MAX, 1.0e-6_SP*STATE_MAX) + !w_func = SMOOTHSTEP5_W(STATE,STATE_MAX,delta) + + end function smoother + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + PURE FUNCTION LOGISMOOTH(STATE,STATE_MAX,PSMOOTH) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2007 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Uses a logistic function to smooth the threshold at the top of a bucket + ! --------------------------------------------------------------------------------------- + USE nrtype + IMPLICIT NONE + REAL(SP), INTENT(IN) :: STATE ! model state + REAL(SP), INTENT(IN) :: STATE_MAX ! maximum model state + REAL(SP), INTENT(IN) :: PSMOOTH ! smoothing parameter (fraction of state) + real(sp) :: arg ! clamp argument + REAL(SP) :: ASMOOTH ! actual smoothing + REAL(SP) :: LOGISMOOTH ! FUNCTION name + ! --------------------------------------------------------------------------------------- + ASMOOTH = PSMOOTH*STATE_MAX ! actual smoothing + arg = -(STATE - (STATE_MAX - 5*ASMOOTH))/ASMOOTH ! argument + !arg = max(min(arg, 50._SP), -50._SP) ! clamp + LOGISMOOTH = 1._SP / ( 1._SP + EXP(arg) ) + ! --------------------------------------------------------------------------------------- + END FUNCTION LOGISMOOTH + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + PURE FUNCTION SMOOTHSTEP5_W(STATE, STATE_MAX, DELTA) RESULT(W) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Uses a qintic function to smooth the threshold at the top of a bucket + ! --------------------------------------------------------------------------------------- + USE nrtype + IMPLICIT NONE + REAL(SP), INTENT(IN) :: STATE, STATE_MAX, DELTA + REAL(SP) :: W, x + + x = (STATE - (STATE_MAX - DELTA)) / DELTA + IF (x <= 0._SP) THEN + W = 0._SP + ELSEIF (x >= 1._SP) THEN + W = 1._SP + ELSE + W = x*x*x*(10._SP + x*(-15._SP + 6._SP*x)) + END IF + END FUNCTION + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + PURE FUNCTION SMOOTHSTEP5_DWDS(STATE, STATE_MAX, DELTA) RESULT(DWDS) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark, 2025 + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Compute the derivative of the qintic function + ! --------------------------------------------------------------------------------------- + USE nrtype + IMPLICIT NONE + REAL(SP), INTENT(IN) :: STATE, STATE_MAX, DELTA + REAL(SP) :: DWDS, x + + IF (DELTA <= 0._SP) THEN + DWDS = 0._SP + RETURN + END IF + + x = (STATE - (STATE_MAX - DELTA)) / DELTA + IF (x <= 0._SP .OR. x >= 1._SP) THEN + DWDS = 0._SP + ELSE + DWDS = (30._SP * x*x * (1._SP - x)*(1._SP - x)) / DELTA + END IF + END FUNCTION + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + +end module smoothers diff --git a/build/FUSE_SRC/physics/update_swe_diff.f90 b/build/FUSE_SRC/physics/update_swe_diff.f90 new file mode 100644 index 0000000..5ea26b4 --- /dev/null +++ b/build/FUSE_SRC/physics/update_swe_diff.f90 @@ -0,0 +1,337 @@ +module update_swe_DIFF_MODULE + + USE model_defn ! model definition structure + USE model_defnames ! integer model definitions + USE globaldata, only : NA_VALUE_SP ! missing vale + + implicit none + + private + public :: update_swe_diff + +contains + + ! --------------------------------------------------------------------------------------- + pure logical function is_leap_year(y) + integer, intent(in) :: y + is_leap_year = (mod(y,4) == 0 .and. (mod(y,100) /= 0 .or. mod(y,400) == 0)) + end function is_leap_year + ! --------------------------------------------------------------------------------------- + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + SUBROUTINE UPDATE_SWE_DIFF(fuseStruct, DT, want_dparam) + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Brian Henn, as part of FUSE snow model implementation, 6/2013 + ! Based on subroutines QSATEXCESS and UPDATSTATE, by Martyn Clark + ! + ! Modified by Nans Addor to enable distributed modeling, 9/2016 + ! + ! Modified by Martyn Clark to extend to a differentiable model, 12/2025 + ! + ! --------------------------------------------------------------------------------------- + ! Purpose: + ! -------- + ! Computes the snow accumulation and melt from forcing data + ! Then updates the SWE band states based on the fluxes + ! --------------------------------------------------------------------------------------- + USE nrtype ! variable types, etc. (includes PI) + USE work_types, only: fuse_work ! fuse work type + use smoothers, only: smax, dsmax ! max smoothers + use smoothers, only: smin, dsmin ! min smoothers (based on smax, dsmax) + use smoothers, only: sigmoid, dsigmoid ! sigmoid smoothers + USE globaldata, only: NP => NPAR_SNOW ! number of snow parameters + USE globaldata, only: iMBASE, iMFMAX, iMFMIN, iPXTEMP, iOPG, iLAPSE, & ! indices in vectors + iPERR ! not a snow parameter but used in the snow model + USE multibands, only: N_BANDS ! number of elevation bands + IMPLICIT NONE + ! input + type(fuse_work) , intent(inout) :: fuseStruct ! fuse work structure + REAL(SP), INTENT(IN) :: DT ! length of the time step + logical(lgt), intent(in), optional :: want_dparam ! if we want parameter derivatives + ! ----- internal variables ----------------------------------------------------------------------------- + ! general + INTEGER(I4B) :: ISNW ! loop through snow model bands + REAL(SP) :: DZ ! vert. distance from forcing + real(sp) :: SWE_prev ! SWE at start of band update (mm) + ! melt factor + LOGICAL(LGT) :: LEAP ! leap year flag + REAL(SP) :: JDAY ! Julian day of year + integer(i4b) :: days_in_year ! number of days in year (365 or 366) + integer(i4b) :: phase_shift ! shift in sine curve in days (80 or 81) + real(sp) :: season01 ! seasonal cycle scaled to [0,1] + REAL(SP) :: MF ! melt factor (mm/deg.C-6hr) -- NOTE: check units + ! adjusted precipitation (after precipitation multiplier) + real(sp), parameter :: ms_mult=1.e-4_sp ! smoothing in smax function (additive precip error) + real(sp) :: precip_adj ! adjusted precipitation (after multiplicative/additive error) + ! temperature lapse (simple) + real(sp) :: xLapse ! scaled temperature lapse rate + REAL(SP) :: TEMP_Z ! band temperature at timestep + ! orographic precipitation multiplier (OPG) + real(sp) :: xOPG ! DZ * MPARAM%OPG/1000 -- scaled OPG (dimensionless) + real(sp) :: gate ! hard [0,1] gate on DZ + real(sp) :: fpos ! positive-side formula: 1 + x + real(sp) :: fneg ! megative-side formula: 1/(1-x) + real(sp) :: inv ! 1-x: demominator in negative-side formula: 1/(1-x) + real(sp) :: inv_safe ! safe denominator: max(1-x, eps_inv) + real(sp), parameter :: eps_inv=1.e-6_sp ! denominator floor: dimensionless + real(sp) :: OPG_mult ! final OPG multiplier + REAL(SP) :: PRECIP_Z ! band precipitation at timestep + ! partition rain from snow + real(sp) :: fsnow ! fraction of precip falling as snow (0–1) + real(sp) :: snow ! snowfall rate (mm/day) for this band + real(sp) :: rain ! rainfall rate (mm/day) for this band + real(sp), parameter :: beta_px=0.01_sp ! sigmoid width for snow/rain partition (degC) + ! snowmelt + real(sp), parameter :: ms_temp=1.e-4_sp ! smoothing in smax function (temperature) + real(sp) :: posTemp ! positive-part temperature term used for melt (degC), smoothed + real(sp) :: potMelt ! potential melt rate before capping (mm/day) + real(sp) :: meltCap ! maximum feasible melt rate from availability (mm/day) + real(sp) :: snowmelt ! final (capped) melt rate (mm/day) + real(sp) :: swe_eps=1.e-12_sp ! small value for the derivative switch in u_swe clamp + real(sp) :: u_swe ! pre-clamp SWE update + integer(i4b), parameter :: cumdays0(12) = [ & ! cumulative days before the start of each month + 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334 ] + integer(i4b) :: cumdays(12) ! cumulative days adjust for leap year + ! internal variables: paraneter derivatives + logical(lgt) :: comp_dparam ! flag to compute parameter derivatives + real(sp) :: df_dz ! precip partitioning + real(sp) :: active, dfpos_dOPG, dinv_dOPG, dfneg_dOPG, dmult_dOPG ! OPG + real(sp) :: dMF(NP), dPadj(NP), dPrecZ(NP), dTempZ(NP) ! derivative vectors + real(sp) :: dfsnow(NP), dsnow(NP), drain(NP) ! derivative vectors + real(sp) :: g_pos, dposTemp(NP), dpotMelt(NP), dsnowmelt(NP) ! derivative vectors + real(sp) :: g_u, dSWE(NP), dSWE_new(NP) ! persist dSWE between timesteps for each band + ! --------------------------------------------------------------------------------------- + ! associate variables with elements of data structure + associate(& + TIMDAT => fuseStruct%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, MBANDS(i)info + 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 + ! --------------------------------------------------------------------------------------- + + ! check the need to compute flux derivatives + comp_dparam = .false.; if(present(want_dparam)) comp_dparam = want_dparam + + ! zero derivatives for fluxes constant over elevation bands + if(comp_dparam)then + dMF(:) = 0._sp; dPadj(:) = 0._sp + endif + + ! ----- compute the melt factor --------------------------------------------------------- + + ! adjust cumulative days for leap year + leap = is_leap_year(timDat%IY) + cumdays = cumdays0; if (leap) cumdays(3:12) = cumdays(3:12) + 1 + + ! calculate day of year for melt factor calculation + jday = cumdays(timDat%IM) + timDat%ID + + ! seasonal cycle scaled to [0,1] + days_in_year = merge(366, 365, leap) + phase_shift = merge(81, 80, leap) ! keeps peak timing aligned across leap/non-leap + season01 = 0.5_sp * ( sin( (real(jday - phase_shift, sp) * 2._sp * PI) / real(days_in_year, sp) ) + 1._sp ) + + ! melt factor calculations + mf = MPARAM%MFMIN + season01*(MPARAM%MFMAX - MPARAM%MFMIN) + + ! compute derivatives + if(comp_dparam)then + + ! NOTE: MF = (1−season01)*MFMIN + season01*MFMAX + + dMF(iMFMIN) = 1._sp - season01 + dMF(iMFMAX) = season01 + + endif ! computing derivatives + + ! ----- add error to the precipiation --------------------------------------------------- + + SELECT CASE(SMODL%iRFERR) + CASE(iopt_additive_e); precip_adj = smax(MFORCE%PPT + MPARAM%RFERR_ADD, 0._sp, ms_mult) ! additive error + CASE(iopt_multiplc_e); precip_adj = MFORCE%PPT*MPARAM%RFERR_MLT ! multiplicative error + CASE DEFAULT; stop "swe_update_diff: unable to identify precip error model" + END SELECT + + ! compute derivatives + if(comp_dparam)then + + ! NOTE: parameter vector interprets theta(iPERR) as either RFERR_ADD or RFERR_MLT depending on SMODL%iRFERR + + SELECT CASE(SMODL%iRFERR) + CASE(iopt_additive_e); dPadj(iPERR) = dsmax(MFORCE%PPT + MPARAM%RFERR_ADD, 0._sp, ms_mult) ! additive error + CASE(iopt_multiplc_e); dPadj(iPERR) = MFORCE%PPT ! multiplicative error + CASE DEFAULT; stop "swe_update_diff: unable to identify precip error model" + END SELECT + + endif ! computing derivatives + + ! ----- check OPG ----------------------------------------------------------------------- + + if (MPARAM%OPG < 0._sp) then + stop "swe_update_diff: OPG < 0 not allowed with hard-gate OPG scheme" + end if + + ! --------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------- + + ! initialize effective precip + M_FLUX%EFF_PPT = 0._sp + + ! check band rea fractions sum to 1 + if (abs(sum(MBANDS(:)%info%AF) - 1._sp) > 1.e-6_sp) stop "Band area fractions do not sum to 1" + + ! loop through model bands + DO ISNW=1,N_BANDS + + ! save SWE + SWE_prev = MBANDS(ISNW)%var%SWE + + ! zero derivatives for elevation band fluxes + if(comp_dparam)then + dPrecZ(:) = 0._sp; dTempZ(:) = 0._sp + dfsnow(:) = 0._sp; dsnow(:) = 0._sp; drain(:) = 0._sp + dposTemp(:)=0._sp; dpotMelt(:)=0._sp; dsnowmelt(:)=0._sp + endif + + ! copy the stored sensitivity of SWE from the previous timestep to propagate it forward + if (comp_dparam) dSWE(:) = MBANDS(ISNW)%var%dSWE_dparam(:) + + ! --- use the Orographic Precipitation Gradient (OPG) to adjust precip for elevation --- + + ! dimensionless OPG + DZ = MBANDS(ISNW)%info%Z_MID - Z_FORC + xOPG = DZ * MPARAM%OPG / 1000._sp + + ! hard [0,1] gate by DZ sign (no smoothing): preserves original code from Henn et al. + gate = merge(1._sp, 0._sp, DZ >= 0._sp) ! gate = 1 if DZ >= 0 + + ! positive-side formula: 1 + x + fpos = 1._sp + xOPG + + ! negative-side formula: 1/(1-x), but with hard floor on denominator + inv = 1._sp - xOPG + inv_safe = max(inv, eps_inv) ! hard floor + fneg = 1._sp / inv_safe + + ! blended multiplier and band precip + OPG_mult = gate * fpos + (1._sp - gate) * fneg + PRECIP_Z = precip_adj * OPG_mult + + ! compute derivatives + if(comp_dparam)then + + ! derivative of fpos wrt OPG + dfpos_dOPG = DZ / 1000._sp + + ! derivative of fneg wrt OPG + active = merge(1._sp, 0._sp, inv >= eps_inv) ! deriv is zero if inv is clamped at eps_inv + dinv_dOPG = -(DZ / 1000._sp) ! inv = 1 - xOPG, xOPG = DZ*OPG/1000 + dfneg_dOPG = -(1._sp/(inv_safe*inv_safe)) * (active * dinv_dOPG) + + ! derivative of OPG_mult (ignore derivative of the hard gate) + dmult_dOPG = gate*dfpos_dOPG + (1._sp-gate)*dfneg_dOPG + + ! final derivatives + dPrecZ(:) = dPadj(:) * OPG_mult + dPrecZ(iOPG) = dPrecZ(iOPG) + precip_adj*dmult_dOPG + + endif ! computing derivatives + + ! ----- use the temperature lapse rate to adjust temperature for elevation ------------- + + xLapse = MPARAM%LAPSE/1000._sp ! scaled temperature lapse rate + TEMP_Z = MFORCE%TEMP + DZ*xLapse ! adjust for elevation using lapse rate + + ! compute derivatives + if(comp_dparam) dTempZ(iLAPSE) = DZ/1000._sp + + ! ----- calculate the (smoothed) snow accumulation ------------------------------------- + + ! snowfall and rainfall fluxes + fsnow = sigmoid(MPARAM%PXTEMP - TEMP_Z, beta_px) ! beta_px is the width, set small because originally a step function + snow = PRECIP_Z*fsnow + rain = PRECIP_Z*(1._sp - fsnow) + + MBANDS(ISNW)%var%SNOWACCMLTN = snow + + ! compute derivatives + if(comp_dparam)then + + df_dz = dsigmoid(fsnow, beta_px) ! d(fsnow)/d(z), z=PXTEMP - TEMP_Z + + dfsnow(iPXTEMP) = df_dz + dfsnow(:) = dfsnow(:) - df_dz * dTempZ(:) ! minus because z depends on -TEMP_Z + + dsnow(:) = dPrecZ(:)*fsnow + PRECIP_Z*dfsnow(:) + drain(:) = dPrecZ(:)*(1._sp - fsnow) - PRECIP_Z*dfsnow(:) + + endif ! computing derivatives + + ! ----- calculate the (smoothed) snow melt --------------------------------------------- + + ! potenital melt + posTemp = smax(TEMP_Z - MPARAM%MBASE, 0._sp, ms_temp) ! smoothed max(TEMP_Z - MPARAM%MBASE, 0) + potMelt = MF*posTemp ! mm day-1 + + ! cap snowmelt + meltCap = SWE_prev/DT + snowmelt = min(potMelt, meltCap) ! hard clamp: allow a kink at SWE=0 to avoid "ghost snow" + MBANDS(ISNW)%var%SNOWMELT = snowmelt + + ! compute derivatives + if(comp_dparam)then + + ! positive temperature: smoothed max(TEMP_Z - MPARAM%MBASE, 0) + g_pos = dsmax(TEMP_Z - MPARAM%MBASE, 0._sp, ms_temp) + dposTemp(:) = g_pos * dTempZ(:) + dposTemp(iMBASE) = dposTemp(iMBASE) - g_pos + + ! potential melt + dpotMelt(:) = dMF(:)*posTemp + MF*dposTemp(:) + + ! melt cap + dsnowmelt(:) = merge(dpotMelt(:), dSWE(:)/DT, potMelt <= meltcap) + + endif ! computing derivatives + + ! ----- update SWE --------------------------------------------------------------------- + + u_swe = SWE_prev + DT*(snow - snowmelt) + MBANDS(ISNW)%var%SWE = max(u_swe, 0._sp) ! hard clamp just removes numerical noise + + if(comp_dparam)then + g_u = merge(1._sp, 0._sp, u_swe > swe_eps) ! sensitivities zero in snow free periods + dSWE_new(:) = g_u * ( dSWE(:) + DT*(dsnow(:) - dsnowmelt(:)) ) + MBANDS(ISNW)%var%dSWE_dparam(:) = dSWE_new(:) + endif + + ! ----- calculate effective precip (rain + melt) --------------------------------------- + + M_FLUX%EFF_PPT = M_FLUX%EFF_PPT + MBANDS(ISNW)%info%AF * (rain + snowmelt) + + if(comp_dparam)then + fuseStruct%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 + +end module update_swe_DIFF_MODULE 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 76% rename from build/FUSE_SRC/FUSE_ENGINE/update_swe.f90 rename to build/FUSE_SRC/physics_orig/update_swe.f90 index 646f73f..90e8751 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/update_swe.f90 +++ b/build/FUSE_SRC/physics_orig/update_swe.f90 @@ -5,6 +5,7 @@ SUBROUTINE UPDATE_SWE(DT) ! Brian Henn, as part of FUSE snow model implementation, 6/2013 ! Based on subroutines QSATEXCESS and UPDATSTATE, by Martyn Clark ! Modified by Nans Addor to enable distributed modeling, 9/2016 +! Modified by Martyn Clark to enable the split info/var structure, 01/2026 ! --------------------------------------------------------------------------------------- ! Purpose: ! -------- @@ -59,60 +60,72 @@ SUBROUTINE UPDATE_SWE(DT) ! loop through model bands DO ISNW=1,N_BANDS - ! calculate forcing data for each band - DZ = MBANDS(ISNW)%Z_MID - Z_FORCING + ! --------------------------------------------------------------------------------------- + associate( & ! link to the info and var sub-structures in MBANDS (less invasive / more readable in code below) + z_mid => mbands(isnw)%info%z_mid, & + af => mbands(isnw)%info%af, & + swe => mbands(isnw)%var%swe, & + snowaccmltn => mbands(isnw)%var%snowaccmltn, & + snowmelt => mbands(isnw)%var%snowmelt, & + dswe_dt => mbands(isnw)%var%dswe_dt ) + + ! calculate forcing data for each band + DZ = Z_MID - Z_FORCING TEMP_Z = MFORCE%TEMP + DZ*MPARAM%LAPSE/1000._sp ! adjust for elevation using lapse rate IF (DZ.GT.0._sp) THEN ! adjust for elevation using OPG PRECIP_Z = MFORCE%PPT * (1._sp + DZ*MPARAM%OPG/1000._sp) ELSE PRECIP_Z = MFORCE%PPT / (1._sp - DZ*MPARAM%OPG/1000._sp) ENDIF - IF ((MBANDS(ISNW)%SWE.GT.0._sp).AND.(TEMP_Z.GT.MPARAM%MBASE)) THEN + IF ((SWE.GT.0._sp).AND.(TEMP_Z.GT.MPARAM%MBASE)) THEN ! calculate the initial snowmelt rate from the melt factor and the temperature - MBANDS(ISNW)%SNOWMELT = MF*(TEMP_Z - MPARAM%MBASE) ! MBANDS%SNOWMELT has units of mm day-1 + SNOWMELT = MF*(TEMP_Z - MPARAM%MBASE) ! MBANDS%SNOWMELT has units of mm day-1 ELSE - MBANDS(ISNW)%SNOWMELT = 0.0_sp + SNOWMELT = 0.0_sp ENDIF ! calculate the accumulation rate from the forcing data IF (TEMP_Z.LT.MPARAM%PXTEMP) THEN SELECT CASE(SMODL%iRFERR) CASE(iopt_additive_e) ! additive rainfall error - MBANDS(ISNW)%SNOWACCMLTN = MAX(0.0_sp, PRECIP_Z + MPARAM%RFERR_ADD) + SNOWACCMLTN = MAX(0.0_sp, PRECIP_Z + MPARAM%RFERR_ADD) CASE(iopt_multiplc_e) ! multiplicative rainfall error - MBANDS(ISNW)%SNOWACCMLTN = PRECIP_Z * MPARAM%RFERR_MLT + SNOWACCMLTN = PRECIP_Z * MPARAM%RFERR_MLT CASE DEFAULT ! check for errors print *, "SMODL%iRFERR must be either iopt_additive_e or iopt_multiplc_e" STOP END SELECT ELSE - MBANDS(ISNW)%SNOWACCMLTN = 0.0_sp + SNOWACCMLTN = 0.0_sp ENDIF ! update SWE, and check to ensure non-negative values - MBANDS(ISNW)%DSWE_DT = MBANDS(ISNW)%SNOWACCMLTN - MBANDS(ISNW)%SNOWMELT - IF ((MBANDS(ISNW)%SWE + MBANDS(ISNW)%DSWE_DT*DT).GE.0._sp) THEN - MBANDS(ISNW)%SWE = MBANDS(ISNW)%SWE + MBANDS(ISNW)%DSWE_DT*DT + DSWE_DT = SNOWACCMLTN - SNOWMELT + IF ((SWE + DSWE_DT*DT).GE.0._sp) THEN + SWE = SWE + DSWE_DT*DT ELSE ! reduce melt rate in case of negative SWE - MBANDS(ISNW)%SNOWMELT = MBANDS(ISNW)%SWE/DT + MBANDS(ISNW)%SNOWACCMLTN - MBANDS(ISNW)%SWE = 0.0_sp + SNOWMELT = SWE/DT + SNOWACCMLTN + SWE = 0.0_sp ENDIF ! calculate rainfall plus snowmelt IF (TEMP_Z.GT.MPARAM%PXTEMP) THEN SELECT CASE(SMODL%iRFERR) CASE(iopt_additive_e) ! additive rainfall error - M_FLUX%EFF_PPT = M_FLUX%EFF_PPT + MBANDS(ISNW)%AF * & - (MAX(0.0_sp, PRECIP_Z + MPARAM%RFERR_ADD) + MBANDS(ISNW)%SNOWMELT) + M_FLUX%EFF_PPT = M_FLUX%EFF_PPT + AF * & + (MAX(0.0_sp, PRECIP_Z + MPARAM%RFERR_ADD) + SNOWMELT) CASE(iopt_multiplc_e) ! multiplicative rainfall error - M_FLUX%EFF_PPT = M_FLUX%EFF_PPT + MBANDS(ISNW)%AF * & - (PRECIP_Z * MPARAM%RFERR_MLT + MBANDS(ISNW)%SNOWMELT) + M_FLUX%EFF_PPT = M_FLUX%EFF_PPT + AF * & + (PRECIP_Z * MPARAM%RFERR_MLT + SNOWMELT) CASE DEFAULT ! check for errors print *, "SMODL%iRFERR must be either iopt_additive_e or iopt_multiplc_e" STOP END SELECT ELSE - M_FLUX%EFF_PPT = M_FLUX%EFF_PPT + MBANDS(ISNW)%AF * MBANDS(ISNW)%SNOWMELT + M_FLUX%EFF_PPT = M_FLUX%EFF_PPT + AF * SNOWMELT ENDIF -END DO + + end associate + +END DO ! looping through bands END SUBROUTINE UPDATE_SWE diff --git a/build/FUSE_SRC/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/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 99% rename from build/FUSE_SRC/FUSE_ENGINE/bucketsize.f90 rename to build/FUSE_SRC/prelim/bucketsize.f90 index cfcb526..0afbd0e 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/bucketsize.f90 +++ b/build/FUSE_SRC/prelim/bucketsize.f90 @@ -12,6 +12,7 @@ SUBROUTINE BUCKETSIZE() ! ----------------- ! MODULE multiparam -- bucket sizes stored in MODULE multiparam ! --------------------------------------------------------------------------------------- +USE nrtype USE multiparam ! model parameters IMPLICIT NONE ! --------------------------------------------------------------------------------------- diff --git a/build/FUSE_SRC/FUSE_ENGINE/force_info.f90 b/build/FUSE_SRC/prelim/force_info.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/force_info.f90 rename to build/FUSE_SRC/prelim/force_info.f90 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 97% rename from build/FUSE_SRC/FUSE_ENGINE/init_state.f90 rename to build/FUSE_SRC/prelim/init_state.f90 index ea88d82..1358d3c 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/init_state.f90 +++ b/build/FUSE_SRC/prelim/init_state.f90 @@ -13,6 +13,7 @@ SUBROUTINE INIT_STATE(FRAC) ! ----------------- ! Model states in MODULE multistate ! --------------------------------------------------------------------------------------- +USE nrtype USE multiparam ! model parameters USE multistate ! model states USE multibands ! model snow bands @@ -35,7 +36,7 @@ SUBROUTINE INIT_STATE(FRAC) FSTATE%WATR_2 = MPARAM%MAXWATR_2 * FRAC ! snow model, assume no snow at start DO ISNW=1,N_BANDS - MBANDS(ISNW)%SWE = 0.0_sp + MBANDS(ISNW)%VAR%SWE = 0.0_sp END DO ! (routed runoff) FUTURE = 0._sp diff --git a/build/FUSE_SRC/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/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/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_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 97% rename from build/FUSE_SRC/FUSE_ENGINE/initfluxes.f90 rename to build/FUSE_SRC/runtime/initfluxes.f90 index 230781d..dd41bab 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/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/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/metrics.f90 b/build/FUSE_SRC/runtime/metrics.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/metrics.f90 rename to build/FUSE_SRC/runtime/metrics.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 93% rename from build/FUSE_SRC/FUSE_ENGINE/set_all.f90 rename to build/FUSE_SRC/runtime/set_all.f90 index ed3d0e7..071dc0e 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/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/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/sce_driver.f90 b/build/FUSE_SRC/sce/sce_driver.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_SCE/sce_driver.f90 rename to build/FUSE_SRC/sce/sce_driver.f90 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/share/globaldata.f90 b/build/FUSE_SRC/share/globaldata.f90 new file mode 100644 index 0000000..070d824 --- /dev/null +++ b/build/FUSE_SRC/share/globaldata.f90 @@ -0,0 +1,36 @@ +MODULE globaldata + + USE nrtype + + implicit none + include "fuseversion.inc" + + ! 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 + + ! original code + logical(lgt), save :: isOriginal=.true. + + ! print flag + 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 + +end MODULE globaldata diff --git a/build/FUSE_SRC/share/model_defn_data.f90 b/build/FUSE_SRC/share/model_defn_data.f90 new file mode 100644 index 0000000..3b85981 --- /dev/null +++ b/build/FUSE_SRC/share/model_defn_data.f90 @@ -0,0 +1,56 @@ +MODULE model_defn + + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark + ! Modified by Brian Henn to include snow model, 6/2013 + ! Modified by Martyn Clark to separate type definitions from data storage, 01/2026 + ! --------------------------------------------------------------------------------------- + + USE nrtype + USE model_defn_types, only: DESC, UMODEL, SNAMES, FNAMES + + USE globaldata, only: FUSE_VERSION + + implicit none + private + + public :: NDEC, NTDH_MAX, NSTATE, N_FLUX + public :: LIST_RFERR, LIST_ARCH1, LIST_ARCH2, LIST_QSURF, LIST_QPERC, LIST_ESOIL, LIST_QINTF, LIST_Q_TDH, LIST_SNOWM + public :: FNAME_PREFIX, FNAME_TEMPRY, FNAME_ASCII + public :: FNAME_NETCDF_RUNS, FNAME_NETCDF_PARA, FNAME_NETCDF_PARA_SCE, FNAME_NETCDF_PARA_PRE + public :: AMODL, SMODL, CSTATE, C_FLUX + + ! list of combinations in each model component + INTEGER, PARAMETER :: NDEC = 9 ! number of model decisions + TYPE(DESC), DIMENSION(2) :: LIST_RFERR ! rainfall error + TYPE(DESC), DIMENSION(3) :: LIST_ARCH1 ! upper-layer architecture + TYPE(DESC), DIMENSION(4) :: LIST_ARCH2 ! lower-layer architecture + TYPE(DESC), DIMENSION(3) :: LIST_QSURF ! surface runoff + TYPE(DESC), DIMENSION(3) :: LIST_QPERC ! percolation + TYPE(DESC), DIMENSION(2) :: LIST_ESOIL ! evaporation + TYPE(DESC), DIMENSION(2) :: LIST_QINTF ! interflow + TYPE(DESC), DIMENSION(2) :: LIST_Q_TDH ! time delay in runoff + TYPE(DESC), DIMENSION(2) :: LIST_SNOWM ! snow model + + ! max steps in routing function + INTEGER(I4B),PARAMETER::NTDH_MAX=500 + + ! model definitions + CHARACTER(LEN=256) :: FNAME_NETCDF_RUNS ! NETCDF output filename for model runs + CHARACTER(LEN=256) :: FNAME_NETCDF_PARA ! NETCDF output filename for model parameters + CHARACTER(LEN=256) :: FNAME_NETCDF_PARA_SCE ! NETCDF output filename for model parameters produced by SCE + CHARACTER(LEN=256) :: FNAME_NETCDF_PARA_PRE ! NETCDF filename for pre-defined model parameters set + CHARACTER(LEN=256) :: FNAME_PREFIX ! prefix for desired output files + CHARACTER(LEN=256) :: FNAME_TEMPRY ! prefix for temporary output files + CHARACTER(LEN=256) :: FNAME_ASCII ! ASCII output filename + TYPE(UMODEL),DIMENSION(5000) :: AMODL ! (model definition -- all) + TYPE(UMODEL) :: SMODL ! (model definition -- single model) + TYPE(SNAMES),DIMENSION(7) :: CSTATE ! (list of model states for SMODL) + TYPE(FNAMES),DIMENSION(50) :: C_FLUX ! (list of model fluxes for SMODL) + INTEGER(I4B) :: NSTATE=0 ! number of model states + INTEGER(I4B) :: N_FLUX=0 ! number of model fluxes + ! -------------------------------------------------------------------------------------- + +END MODULE model_defn diff --git a/build/FUSE_SRC/FUSE_ENGINE/model_defnames.f90 b/build/FUSE_SRC/share/model_defnames.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/model_defnames.f90 rename to build/FUSE_SRC/share/model_defnames.f90 diff --git a/build/FUSE_SRC/FUSE_ENGINE/model_numerix.f90 b/build/FUSE_SRC/share/model_numerix.f90 similarity index 96% rename from build/FUSE_SRC/FUSE_ENGINE/model_numerix.f90 rename to build/FUSE_SRC/share/model_numerix.f90 index 8aefa42..030073e 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/model_numerix.f90 +++ b/build/FUSE_SRC/share/model_numerix.f90 @@ -30,6 +30,9 @@ MODULE model_numerix ! 6. Method used to process the small interval at the end of a time step INTEGER(I4B), PARAMETER :: STEP_TRUNC=0, LOOK_AHEAD=1, STEP_ABSORB=2 INTEGER(I4B) :: SMALL_ENDSTEP +! 7. Flag for differentiable model +integer(i4b), parameter :: original=0, differentiable=1 +integer(i4b) :: diff_mode ! --------------------------------------------------------------------------------------- ! (B) PARAMETERS ! --------------------------------------------------------------------------------------- diff --git a/build/FUSE_SRC/share/multi_flux_data.f90 b/build/FUSE_SRC/share/multi_flux_data.f90 new file mode 100644 index 0000000..9673397 --- /dev/null +++ b/build/FUSE_SRC/share/multi_flux_data.f90 @@ -0,0 +1,22 @@ +MODULE multi_flux + + USE nrtype + + USE multi_flux_types, only: FLUXES + + implicit none + private + + public :: M_FLUX, FLUX_0, FLUX_1, FDFLUX, W_FLUX, W_FLUX_3d + public :: CURRENT_DT + + TYPE(FLUXES) :: M_FLUX ! model fluxes + TYPE(FLUXES) :: FLUX_0 ! model fluxes at start of step + TYPE(FLUXES) :: FLUX_1 ! model fluxes at end of step + TYPE(FLUXES), DIMENSION(:), POINTER :: FDFLUX=>NULL() ! finite difference fluxes + TYPE(FLUXES) :: W_FLUX ! weighted sum of model fluxes over a time step + TYPE(FLUXES), dimension(:,:,:), allocatable :: W_FLUX_3d ! weighted sum of model fluxes over a time step for several time steps + + REAL(SP) :: CURRENT_DT ! current time step (days) + +END MODULE multi_flux diff --git a/build/FUSE_SRC/share/multibands_data.f90 b/build/FUSE_SRC/share/multibands_data.f90 new file mode 100644 index 0000000..7fa4406 --- /dev/null +++ b/build/FUSE_SRC/share/multibands_data.f90 @@ -0,0 +1,30 @@ +MODULE multibands + + ! Created by Brian Henn to allow multi-band snow modeling, 6/2013 + ! Based on module MULTIFORCE by Martyn Clark + + ! Modified by Martyn Clark to separate type definitions from data storage, 01/2026 + + USE nrtype + + USE multibands_types, only: BANDS, BANDS_INFO, BANDS_VAR + + implicit none + private + + public :: N_BANDS + public :: MBANDS, MBANDS_INFO_3d, MBANDS_VAR_4d + public :: Z_FORCING, Z_FORCING_grid, elev_mask + + ! -------------------------------------------------------------------------------------- + TYPE(BANDS),DIMENSION(:),ALLOCATABLE :: MBANDS ! basin band information + type(BANDS_INFO),dimension(:,:,:),ALLOCATABLE :: MBANDS_INFO_3d ! basin band information in space + type(BANDS_VAR),dimension(:,:,:,:),ALLOCATABLE :: MBANDS_VAR_4d ! basin band information in space plus time + + INTEGER(I4B) :: N_BANDS=0 ! number of bands, initialize to zero + REAL(SP) :: Z_FORCING ! elevation of forcing data (m) + REAL(SP),DIMENSION(:,:),ALLOCATABLE :: Z_FORCING_grid ! elevation of forcing data (m) for the 2D domain + LOGICAL(LGT),DIMENSION(:,:),ALLOCATABLE :: elev_mask ! mask domain - TRUE means the cell must be masked, i.e. not run + ! -------------------------------------------------------------------------------------- + +END MODULE multibands diff --git a/build/FUSE_SRC/FUSE_ENGINE/multiconst.f90 b/build/FUSE_SRC/share/multiconst.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/multiconst.f90 rename to build/FUSE_SRC/share/multiconst.f90 diff --git a/build/FUSE_SRC/share/multiforce_data.f90 b/build/FUSE_SRC/share/multiforce_data.f90 new file mode 100644 index 0000000..cd077b2 --- /dev/null +++ b/build/FUSE_SRC/share/multiforce_data.f90 @@ -0,0 +1,185 @@ +MODULE multiforce + + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark + ! Modified by Brian Henn to include snow model, 6/2013 + ! Modified by Nans Addor to enable distributed modeling, 9/2016 + ! Modified by Cyril Thébault to allow different metrics as objective function, 2024 + ! Modified by Martyn Clark to separate type definitions from data storage, 01/2026 + ! --------------------------------------------------------------------------------------- + + USE nrtype + + USE multiforce_types, only: TDATA, VDATA, ADATA, FDATA + + implicit none + private + + public :: forcefile + + public :: ncid_forc, ncid_var + + public :: nForce, nInput + + public :: timDat, valDat, aValid + public :: AFORCE, CFORCE, MFORCE + public :: ancilF, ancilF_3d + public :: gForce, gForce_3d + + public :: date_start_input, date_end_input + public :: numtim_in, numtim_sim, numtim_sub, numtim_sub_cur + public :: itim_in, itim_sim, itim_sub + public :: sim_beg, sim_end, eval_beg, eval_end + public :: istart, jdayRef + public :: deltim + + public :: SUB_PERIODS_FLAG, GRID_FLAG + + public :: startSpat2, nSpat1, nSpat2 + public :: xlon, ylat, latitude, longitude + public :: latUnits, lonUnits, timeUnits + + public :: time_steps, julian_day_input + + public :: NUMPSET, name_psets + + public :: vname_iy, vname_im, vname_id, vname_ih, vname_imin, vname_dsec, vname_dtime + + public :: vname_aprecip, vname_potevap, vname_airtemp, vname_q, vname_spechum, vname_airpres, vname_swdown + public :: ilook_aprecip, ilook_potevap, ilook_airtemp, ilook_q, ilook_spechum, ilook_airpres, ilook_swdown + + public :: ivarid_iy, ivarid_im, ivarid_id, ivarid_ih, ivarid_imin, ivarid_dsec + public :: ivarid_ppt, ivarid_temp, ivarid_pet, ivarid_q + + public :: amult_ppt, amult_pet, amult_q + + public :: NA_VALUE, NA_VALUE_SP + + SAVE + + ! general + INTEGER(I4B),PARAMETER :: STRLEN=256 ! length of the character string + + ! time data structures + TYPE(tData) :: timDat ! model time structure + + ! response data structures + TYPE(vData) :: valDat ! validation structure + TYPE(vData), DIMENSION(:,:,:), POINTER :: aValid ! all model validation data + + ! forcing data structures + TYPE(FDATA), DIMENSION(:), POINTER :: AFORCE ! all model forcing data + TYPE(FDATA), DIMENSION(:), POINTER :: CFORCE ! COPY of model forcing data + TYPE(FDATA) :: MFORCE ! model forcing data for a single time step + TYPE(aData), DIMENSION(:,:), POINTER :: ancilF ! ancillary forcing data for the 2-d grid + TYPE(fData), DIMENSION(:,:), POINTER :: gForce ! model forcing data for a 2-d grid + TYPE(fData), DIMENSION(:,:,:), POINTER :: gForce_3d ! model forcing data for a 3-d grid (time as 3rd dimension) + TYPE(aData), DIMENSION(:,:,:), POINTER :: ancilF_3d ! ancillary forcing data for the 3-d grid + + ! NetCDF + + CHARACTER(len=StrLen) :: forcefile = 'undefined' ! name of forcing file + + INTEGER(i4b), PARAMETER :: nForce = 7 ! number of forcing variables + INTEGER(i4b) :: nInput = 3 ! number of variable to retrieve from input file + + INTEGER(i4b) :: ncid_forc = -1 ! NetCDF forcing file ID + INTEGER(i4b), DIMENSION(nForce) :: ncid_var ! NetCDF forcing variable ID + + ! timing information - note that numtim_in >= numtim_sim >= numtim_sub + + CHARACTER(len=20) :: date_start_input ! date start input time series + CHARACTER(len=20) :: date_end_input ! date end input time series + + INTEGER(i4b) :: numtim_in = -1 ! number of time steps of input (atmospheric forcing) + INTEGER(i4b) :: numtim_sim = -1 ! number of time steps of FUSE simulations (including spin-up) + INTEGER(i4b) :: numtim_sub = -1 ! number of time steps of subperiod (will be kept in memory) + INTEGER(i4b) :: numtim_sub_cur = -1 ! number of time steps of current subperiod (allows for the last subperiod to be shorter) + INTEGER(i4b) :: itim_in = -1 ! indice within numtim_in + INTEGER(i4b) :: itim_sim = -1 ! indice within numtim_sim + INTEGER(i4b) :: itim_sub = -1 ! indice within numtim_sub + + INTEGER(i4b) :: sim_beg = -1 ! index for the start of the simulation in fuse_metric + INTEGER(i4b) :: sim_end = -1 ! index for the end of the simulation in fuse_metric + INTEGER(i4b) :: eval_beg = -1 ! index for the start of evaluation period + INTEGER(i4b) :: eval_end = -1 ! index for the end of the inference period + + INTEGER(i4b) :: istart = -1 ! index for start of inference period (in reduced array) + REAL(sp) :: jdayRef ! reference time (days) + REAL(sp) :: deltim = -1._dp ! length of time step (days) + + LOGICAL(LGT) :: SUB_PERIODS_FLAG ! .true. if subperiods are used to run FUSE + LOGICAL(LGT) :: GRID_FLAG ! spatial flag .true. if grid + + ! dimension information + + INTEGER(i4b) :: startSpat2 = -1 ! number of points in 1st spatial dimension + INTEGER(i4b) :: nSpat1 = -1 ! number of points in 1st spatial dimension + INTEGER(i4b) :: nSpat2 = -1 ! number of points in 2nd spatial dimension + REAL(sp) :: xlon ! longitude (degrees) for PET computation + REAL(sp) :: ylat ! latitude (degrees) for PET computation + REAL(sp),dimension(:),allocatable :: latitude ! latitude (degrees) + REAL(sp),dimension(:),allocatable :: longitude ! longitude (degrees) + CHARACTER(len=strLen) :: latUnits ! units string for latitude + CHARACTER(len=strLen) :: lonUnits ! units string for longitude + CHARACTER(len=strLen) :: timeUnits ! units string for time + + REAL(sp),dimension(:),allocatable :: time_steps ! time steps (days) + REAL(sp),dimension(:),allocatable :: julian_day_input ! time steps (julian days) + + INTEGER(I4B) :: NUMPSET ! number of parameter sets + CHARACTER(len=strLen),dimension(:),allocatable :: name_psets ! name of parameter sets + + ! name of time variables + CHARACTER(len=StrLen) :: vname_iy = 'undefined' ! name of variable for year + CHARACTER(len=StrLen) :: vname_im = 'undefined' ! name of variable for month + CHARACTER(len=StrLen) :: vname_id = 'undefined' ! name of variable for day + CHARACTER(len=StrLen) :: vname_ih = 'undefined' ! name of variable for hour + CHARACTER(len=StrLen) :: vname_imin = 'undefined' ! name of variable for minute + CHARACTER(len=StrLen) :: vname_dsec = 'undefined' ! name of variable for second + CHARACTER(len=StrLen) :: vname_dtime = 'undefined' ! name of variable for time + + ! forcing variable names + CHARACTER(len=StrLen) :: vname_aprecip = 'undefined' ! variable name: precipitation + CHARACTER(len=StrLen) :: vname_potevap = 'undefined' ! variable name: potential ET + CHARACTER(len=StrLen) :: vname_airtemp = 'undefined' ! variable name: temperature + CHARACTER(len=StrLen) :: vname_q = 'undefined' ! variable name: observed runoff + CHARACTER(len=StrLen) :: vname_spechum = 'undefined' ! variable name: specific humidity + CHARACTER(len=StrLen) :: vname_airpres = 'undefined' ! variable name: surface pressure + CHARACTER(len=StrLen) :: vname_swdown = 'undefined' ! variable name: downward shortwave radiation + + ! indices for forcing variables + INTEGER(i4b),PARAMETER :: ilook_aprecip = 1 ! named element in lCheck + INTEGER(i4b),PARAMETER :: ilook_potevap = 2 ! named element in lCheck + INTEGER(i4b),PARAMETER :: ilook_airtemp = 3 ! named element in lCheck + INTEGER(i4b),PARAMETER :: ilook_q = 4 ! named element in lCheck + INTEGER(i4b),PARAMETER :: ilook_spechum = 5 ! named element in lCheck + INTEGER(i4b),PARAMETER :: ilook_airpres = 6 ! named element in lCheck + INTEGER(i4b),PARAMETER :: ilook_swdown = 7 ! named element in lCheck + + ! indices for time data (only used in ASCII files) + INTEGER(i4b) :: ivarid_iy = -1 ! variable ID for year + INTEGER(i4b) :: ivarid_im = -1 ! variable ID for month + INTEGER(i4b) :: ivarid_id = -1 ! variable ID for day + INTEGER(i4b) :: ivarid_ih = -1 ! variable ID for hour + INTEGER(i4b) :: ivarid_imin = -1 ! variable ID for minute + INTEGER(i4b) :: ivarid_dsec = -1 ! variable ID for second + + ! indices for variables + INTEGER(i4b) :: ivarid_ppt = -1 ! variable ID for precipitation + INTEGER(i4b) :: ivarid_temp = -1 ! variable ID for temperature + INTEGER(i4b) :: ivarid_pet = -1 ! variable ID for potential ET + INTEGER(i4b) :: ivarid_q = -1 ! variable ID for runoff + + ! multipliers for variables to convert fluxes to mm/day + REAL(sp) :: amult_ppt = -1._dp ! convert precipitation to mm/day + REAL(sp) :: amult_pet = -1._dp ! convert potential ET to mm/day + REAL(sp) :: amult_q = -1._dp ! convert runoff to mm/day + + ! missing values + INTEGER(I4B),PARAMETER :: NA_VALUE = -9999 ! integer designating missing values - TODO: retrieve from NetCDF file + REAL(SP),PARAMETER :: NA_VALUE_SP = -9999._sp ! integer designating missing values - TODO: retrieve from NetCDF file + +END MODULE multiforce diff --git a/build/FUSE_SRC/share/multiparam_data.f90 b/build/FUSE_SRC/share/multiparam_data.f90 new file mode 100644 index 0000000..2fc8071 --- /dev/null +++ b/build/FUSE_SRC/share/multiparam_data.f90 @@ -0,0 +1,37 @@ +MODULE multiparam + + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark + ! Modified by Brian Henn to include snow model, 6/2013 + ! Modified by Martyn Clark to separate type definitions from data storage, 01/2026 + ! --------------------------------------------------------------------------------------- + + USE nrtype + USE multiparam_types, only: PARATT ! included for legacy for routines that USE multiparam + USE multiparam_types, only: PARADJ, PARDVD, PARINFO, PAR_ID + + implicit none + private + + public :: PARATT, PARADJ, PARDVD, PARINFO, PAR_ID + + public :: MAXPAR, NUMPAR + public :: APARAM, MPARAM, DPARAM + public :: PARMETA, LPARAM + public :: SOBOL_INDX + + INTEGER(I4B), PARAMETER :: MAXPAR=50 ! maximum number of parameters for a single model + INTEGER(I4B) :: NUMPAR ! number of model parameters for current model + + TYPE(PARADJ), DIMENSION(:), POINTER :: APARAM=>null() ! all model parameter sets; DK/2008/10/21: explicit null + TYPE(PARADJ) :: MPARAM ! single model parameter set + TYPE(PARDVD) :: DPARAM ! derived model parameters + + TYPE(PARINFO) :: PARMETA ! parameter metadata (all parameters) + TYPE(PAR_ID), DIMENSION(MAXPAR) :: LPARAM ! list of model parameter names (need to modify to 16 for SCE) + + INTEGER(I4B) :: SOBOL_INDX ! code to re-assemble Sobol parameters + +END MODULE multiparam diff --git a/build/FUSE_SRC/share/multiroute_data.f90 b/build/FUSE_SRC/share/multiroute_data.f90 new file mode 100644 index 0000000..e1f3111 --- /dev/null +++ b/build/FUSE_SRC/share/multiroute_data.f90 @@ -0,0 +1,20 @@ +MODULE multiroute + + USE nrtype + USE model_defn,ONLY:NTDH_MAX + USE multiroute_types, only: RUNOFF + + implicit none + private + + public :: FUTURE + public :: AROUTE, AROUTE_3d + public :: MROUTE + + REAL(SP), DIMENSION(NTDH_MAX) :: FUTURE ! runoff placed in future time steps + + TYPE(RUNOFF), DIMENSION(:), POINTER :: AROUTE ! runoff for all time steps + TYPE(RUNOFF),dimension(:,:,:), allocatable :: AROUTE_3d ! runoff for all time steps on a grid + TYPE(RUNOFF) :: MROUTE ! runoff for one time step + +END MODULE multiroute diff --git a/build/FUSE_SRC/share/multistate_data.f90 b/build/FUSE_SRC/share/multistate_data.f90 new file mode 100644 index 0000000..ce1c1ec --- /dev/null +++ b/build/FUSE_SRC/share/multistate_data.f90 @@ -0,0 +1,44 @@ +MODULE multistate + + USE nrtype + USE multistate_types, only: STATEV, M_TIME + + implicit none + private + + public :: STATEV, M_TIME + + public :: gState, gState_3d + + public :: ASTATE, FSTATE, MSTATE, TSTATE, BSTATE, ESTATE, DSTATE + public :: DYDT_0, DYDT_1, DY_DT, DYDT_OLD + public :: HSTATE + + public :: ncid_out + public :: fracState0 + + ! variable definitions (grid) + type(statev),dimension(:,:),pointer :: gState ! (grid of model states) + type(statev),dimension(:,:,:),pointer :: gState_3d ! (grid of model states with a time dimension) + + ! variable definitions (one cell) + TYPE(STATEV) :: ASTATE ! (model states at the start of full timestep) + TYPE(STATEV) :: FSTATE ! (model states at start of sub-timestep) + TYPE(STATEV) :: MSTATE ! (model states at start/middle of sub-timestep) + TYPE(STATEV) :: TSTATE ! (temporary copy of model states) + TYPE(STATEV) :: BSTATE ! (temporary copy of model states) + TYPE(STATEV) :: ESTATE ! (temporary copy of model states) + TYPE(STATEV) :: DSTATE ! (default model states) + TYPE(STATEV) :: DYDT_0 ! (derivative of model states at start of sub-step) + TYPE(STATEV) :: DYDT_1 ! (derivative of model states at end of sub-step) + TYPE(STATEV) :: DY_DT ! (derivative of model states) + TYPE(STATEV) :: DYDT_OLD ! (derivative of model states for final solution) + TYPE(M_TIME) :: HSTATE ! (time interval to advance model states) + + ! NetCDF + integer(i4b) :: ncid_out = -1 ! NetCDF output file ID + + ! initial store fraction (initialization) + real(sp), parameter :: fracState0 = 0.25_sp + +END MODULE multistate diff --git a/build/FUSE_SRC/share/multistats_data.f90 b/build/FUSE_SRC/share/multistats_data.f90 new file mode 100644 index 0000000..4008e09 --- /dev/null +++ b/build/FUSE_SRC/share/multistats_data.f90 @@ -0,0 +1,16 @@ +MODULE multistats + + USE nrtype + USE multistats_types, only: SUMMARY + + implicit none + private + + public :: MSTATS, MOD_IX, PCOUNT, FCOUNT + + TYPE(SUMMARY) :: MSTATS ! (model summary statistics) + INTEGER(I4B) :: MOD_IX = 1 ! (model index) + INTEGER(I4B) :: PCOUNT ! (number of parameter sets in model output files) + INTEGER(I4B) :: FCOUNT ! (number of model simulations) + +END MODULE multistats diff --git a/build/FUSE_SRC/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/logismooth.f90 b/build/FUSE_SRC/solver_orig/logismooth.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_ENGINE/logismooth.f90 rename to build/FUSE_SRC/solver_orig/logismooth.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/types/data_types.f90 b/build/FUSE_SRC/types/data_types.f90 new file mode 100644 index 0000000..46771e4 --- /dev/null +++ b/build/FUSE_SRC/types/data_types.f90 @@ -0,0 +1,70 @@ +module data_types + + use nrtype + + use multiforce_types, only: ADATA, FDATA, VDATA + use multibands_types, only: BANDS_VAR + use multistate_types, only: STATEV + use multi_flux_types, only: FLUXES + use multiroute_types, only: RUNOFF + + private + public :: coord_data, domain_data + + ! ------------------------------------------------------------------------------------- + + type :: coord_data + + logical(lgt) :: is_curvilinear = .false. ! true if lat/lon are 2D + logical(lgt) :: is_point_list = .false. ! true if nx=1 and lat/lon are 1D over ny + + ! 2D rectilinear OR point-list + real(sp), allocatable :: lon_1d(:) ! nx or ny depending on layout + real(sp), allocatable :: lat_1d(:) + + ! 2D curvilinear + real(sp), allocatable :: lon_2d(:,:) ! (nx_local, ny_local) + real(sp), allocatable :: lat_2d(:,:) + + ! optional IDs (int is usually safest) + integer(i4b), allocatable :: cell_id(:,:) ! always stored locally as (nx_local, ny_local) + + end type coord_data + + ! ------------------------------------------------------------------------------------- + + type :: domain_data + + ! coordinate information + type(coord_data) :: coords + + ! 2D ancillary forcing (optional, for PET etc.) + type(ADATA), allocatable :: ancil(:,:) ! (nx_local, ny_local) + + ! 3D forcing window (nx_local, ny_local, numtim_sub) + type(FDATA), allocatable :: force(:,:,:) ! force_3d + + ! 3D state window (nx_local, ny_local, numtim_sub+1) + type(STATEV), allocatable :: state(:,:,:) ! state_3d + + ! 3D flux window (nx_local, ny_local, numtim_sub) + type(FLUXES), allocatable :: flux(:,:,:) ! flux_3d + + ! 3D routing window (nx_local, ny_local, numtim_sub) + type(RUNOFF), allocatable :: route(:,:,:) ! route_3d + + ! 4D snow-band state window (nx_local, ny_local, n_bands, numtim_sub+1) + type(BANDS_VAR), allocatable :: bands(:,:,:,:) ! bands_var_4d + + ! 3D observed discharge / validity (optional) + type(VDATA), allocatable :: valid(:,:,:) ! (nx_local, ny_local, numtim_sub) + + ! basin-average time series for output convenience + type(FDATA), allocatable :: aForce(:) ! (numtim_sub) + type(RUNOFF), allocatable :: aRoute(:) ! (numtim_sub) + + end type domain_data + + ! ------------------------------------------------------------------------------------- + +end module data_types diff --git a/build/FUSE_SRC/types/info_types.f90 b/build/FUSE_SRC/types/info_types.f90 new file mode 100644 index 0000000..8721942 --- /dev/null +++ b/build/FUSE_SRC/types/info_types.f90 @@ -0,0 +1,182 @@ +module info_types + + use nrtype + + use multiparam_types, only: par_id + + private + public :: cli_options + public :: fuse_info + + ! -------------------------------------------------------------------------------------- + + type :: mpi_info + logical(lgt) :: enabled = .false. + integer(i4b) :: rank = 0 + integer(i4b) :: nproc = 1 + end type mpi_info + + ! ------------------------------------------------------------------------------------- + + ! options for the command-line interface + + type :: cli_options + character(len=:), allocatable :: tag ! string to add to output file + character(len=:), allocatable :: control_file + character(len=:), allocatable :: domain_id + character(len=:), allocatable :: runmode ! def/idx/opt/sce + character(len=:), allocatable :: sets_file ! for idx,opt + integer(i4b) :: indx = -1 ! for idx + character(len=:), allocatable :: restart_freq ! y/m/d/e/never + logical(lgt) :: show_version = .false. + logical(lgt) :: show_help = .false. + character(len=:), allocatable :: param_name(:) ! list of parameter names + real(sp), allocatable :: param_value(:) ! list of parameter values + end type cli_options + + ! ------------------------------------------------------------------------------------- + + type :: space_info + + ! global dimensions (full forcing file) + integer(i4b) :: nx_global = 1 + integer(i4b) :: ny_global = 1 + + ! local dimensions (after MPI split) + integer(i4b) :: nx_local = 1 + integer(i4b) :: ny_local = 1 + + ! decomposition along y dimension + integer(i4b) :: y_start_global = 1 + integer(i4b) :: y_end_global = 1 + + ! mode flag + logical(lgt) :: grid_flag = .false. + + end type space_info + + ! ------------------------------------------------------------------------------------- + + type :: time_info + + ! forcing axis (global) + integer(i4b) :: nt_global = 0 + + ! simulation & evaluation indices into forcing time axis + integer(i4b) :: sim_beg = 1 + integer(i4b) :: sim_end = 1 + integer(i4b) :: eval_beg = 1 + integer(i4b) :: eval_end = 1 + + ! derived lengths + integer(i4b) :: nt_sim = 0 + + ! subperiod / windowing + logical(lgt) :: use_subperiods = .false. + integer(i4b) :: nt_window = 0 ! (= numtim_sub) + integer(i4b) :: nt_window_cur = 0 ! runtime: current window length + + ! bookkeeping for time axis + character(len=:), allocatable :: units + real(sp) :: jdate_ref = 0._sp + real(sp), allocatable :: jdate(:) ! julian day for each forcing record + + end type time_info + + ! ------------------------------------------------------------------------------------- + + type :: snow_info + integer(i4b) :: n_bands = 0 + end type snow_info + + ! ------------------------------------------------------------------------------------- + + type :: file_info + + ! directories + character(len=512) :: setngs_path = "" + character(len=512) :: input_path = "" + character(len=512) :: output_path = "" + + ! settings filenames (relative or absolute) + character(len=512) :: forcinginfo = "" + character(len=512) :: constraints = "" + character(len=512) :: mod_numerix = "" + character(len=512) :: m_decisions = "" + + ! domain-derived input suffixes + character(len=512) :: suffix_forcing = "" + character(len=512) :: suffix_elev_bands = "" + + ! actual input filenames for this domain (derived once dom_id known) + character(len=512) :: forcing_file = "" ! dom_id//suffix_forcing + character(len=512) :: elevbands_file = "" ! dom_id//suffix_elev_bands + + ! output base name + concrete outputs + character(len=512) :: fname_tempry = "" + character(len=512) :: fname_netcdf_runs = "" + character(len=512) :: fname_netcdf_para = "" + + end type file_info + + ! ------------------------------------------------------------------------------------- + + type :: run_config + + ! provenance + character(len=512) :: file_manager_file = "" + + ! CLI options + type(cli_options) :: cli_opts + + ! model selection + character(len=64) :: fmodel_id = "" + + ! model information + integer(i4b) :: nState = -9999 + integer(i4b) :: nParam = -9999 + + ! list of model parameters + type(par_id), allocatable :: listParam(:) + + ! run flags + logical(lgt) :: q_only = .false. + + ! requested time windows (strings as read from filemanager) + character(len=20) :: date_start_sim = "" + character(len=20) :: date_end_sim = "" + character(len=20) :: date_start_eval = "" + character(len=20) :: date_end_eval = "" + character(len=20) :: numtim_sub_str = "" + + ! parsed / derived values (optional convenience) + integer(i4b) :: numtim_sub = -9999 ! parsed from numtim_sub_str + + ! output dimension for number of parameter sets + integer(i4b) :: nSets + + ! SCE settings (store as numeric types) + integer(i4b) :: maxn = -9999 + integer(i4b) :: kstop = -9999 + real(sp) :: pcento = -9999._sp + + ! store raw strings too if you care about provenance + character(len=20) :: maxn_str = "" + character(len=20) :: kstop_str = "" + character(len=20) :: pcento_str = "" + + end type run_config + + ! ------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------- + + type :: fuse_info + type(mpi_info) :: mpi + type(space_info) :: space + type(time_info) :: time + type(snow_info) :: snow + type(file_info) :: files + type(run_config) :: config + end type fuse_info + +end module info_types diff --git a/build/FUSE_SRC/types/model_defn_types.f90 b/build/FUSE_SRC/types/model_defn_types.f90 new file mode 100644 index 0000000..a22acf9 --- /dev/null +++ b/build/FUSE_SRC/types/model_defn_types.f90 @@ -0,0 +1,48 @@ +MODULE model_defn_types + + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark + ! Modified by Brian Henn to include snow model, 6/2013 + ! Modified by Martyn Clark to separate data tyoes from data store, 01/2026 + ! --------------------------------------------------------------------------------------- + + USE nrtype + + implicit none + private + + public :: DESC, UMODEL, SNAMES, FNAMES + + ! description of model component + TYPE DESC + CHARACTER(LEN=16) :: MCOMPONENT ! description of model component + END TYPE DESC + + ! structure that holds (x) unique combinations + TYPE UMODEL + INTEGER(I4B) :: MODIX ! model index + CHARACTER(LEN=256) :: MNAME ! model name + INTEGER(I4B) :: iRFERR + INTEGER(I4B) :: iARCH1 + INTEGER(I4B) :: iARCH2 + INTEGER(I4B) :: iQSURF + INTEGER(I4B) :: iQPERC + INTEGER(I4B) :: iESOIL + INTEGER(I4B) :: iQINTF + INTEGER(I4B) :: iQ_TDH + INTEGER(I4B) :: iSNOWM ! snow + END TYPE UMODEL + + ! structure to hold model state names + TYPE SNAMES + INTEGER(I4B) :: iSNAME ! integer value of state name + END TYPE SNAMES + + ! structure to hold model flux names + TYPE FNAMES + CHARACTER(LEN=16) :: FNAME ! state name + END TYPE FNAMES + +END MODULE model_defn_types diff --git a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multi_flux.f90.svn-base b/build/FUSE_SRC/types/multi_flux_types.f90 similarity index 84% rename from build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multi_flux.f90.svn-base rename to build/FUSE_SRC/types/multi_flux_types.f90 index 9fbe26a..c4411f4 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/.svn/text-base/multi_flux.f90.svn-base +++ b/build/FUSE_SRC/types/multi_flux_types.f90 @@ -1,5 +1,12 @@ -MODULE multi_flux +MODULE multi_flux_types + USE nrtype + + implicit none + private + + public :: FLUXES + TYPE FLUXES REAL(SP) :: EFF_PPT ! effective precipitation (mm day-1) REAL(SP) :: SATAREA ! saturated area (-) @@ -32,10 +39,5 @@ MODULE multi_flux REAL(SP) :: ERR_FREE_2B ! excessive extrapolation: storage in the secondary resvr (mm day-1) REAL(SP) :: CHK_TIME ! time elapsed during time step (days) ENDTYPE FLUXES - TYPE(FLUXES) :: M_FLUX ! model fluxes - TYPE(FLUXES) :: FLUX_0 ! model fluxes at start of step - TYPE(FLUXES) :: FLUX_1 ! model fluxes at end of step - TYPE(FLUXES), DIMENSION(:), POINTER :: FDFLUX=>NULL() ! finite difference fluxes - TYPE(FLUXES) :: W_FLUX ! weighted sum of model fluxes over a time step - REAL(SP) :: CURRENT_DT ! current time step (days) -END MODULE multi_flux + +END MODULE multi_flux_types diff --git a/build/FUSE_SRC/types/multibands_types.f90 b/build/FUSE_SRC/types/multibands_types.f90 new file mode 100644 index 0000000..8691c67 --- /dev/null +++ b/build/FUSE_SRC/types/multibands_types.f90 @@ -0,0 +1,37 @@ +MODULE multibands_types + + ! Created by Brian Henn to allow multi-band snow modeling, 6/2013 + ! Based on module MULTIFORCE by Martyn Clark + + ! Modified by Martyn Clark to separate type definitions from data storage, 01/2026 + + USE nrtype + + implicit none + private + + public :: BANDS, BANDS_INFO, BANDS_VAR + + ! MBANDS is split between time-independent and time-dependent charactertistics + + TYPE BANDS_INFO ! invariant characteristics + INTEGER(I4B) :: NUM ! band number (-) + REAL(SP) :: Z_MID ! band mid-point elevation (m) + REAL(SP) :: AF ! fraction of basin area in band (-) + ENDTYPE BANDS_INFO + + TYPE BANDS_VAR ! time-dependent characteristics + REAL(SP) :: SWE ! band snowpack water equivalent (mm) + REAL(SP) :: SNOWACCMLTN ! new snow accumulation in band (mm day-1) + REAL(SP) :: SNOWMELT ! snowmelt in band (mm day-1) + REAL(SP) :: DSWE_DT ! rate of change of band SWE (mm day-1) + ENDTYPE BANDS_VAR + + ! Combined structure + + TYPE BANDS + type(BANDS_INFO) :: info + type(BANDS_VAR) :: var + ENDTYPE BANDS + +END MODULE multibands_types diff --git a/build/FUSE_SRC/types/multiforce_types.f90 b/build/FUSE_SRC/types/multiforce_types.f90 new file mode 100644 index 0000000..8a40f9b --- /dev/null +++ b/build/FUSE_SRC/types/multiforce_types.f90 @@ -0,0 +1,52 @@ +MODULE multiforce_types + + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark + ! Modified by Brian Henn to include snow model, 6/2013 + ! Modified by Nans Addor to enable distributed modeling, 9/2016 + ! Modified by Cyril Thébault to allow different metrics as objective function, 2024 + ! Modified by Martyn Clark to separate type definitions from data storage, 01/2026 + ! --------------------------------------------------------------------------------------- + + USE nrtype + + implicit none + private + + public :: TDATA, VDATA, ADATA, FDATA + + ! the time data structure (will have no spatial dimension) + TYPE TDATA + INTEGER(I4B) :: IY ! year + INTEGER(I4B) :: IM ! month + INTEGER(I4B) :: ID ! day + INTEGER(I4B) :: IH ! hour + INTEGER(I4B) :: IMIN ! minute + REAL(SP) :: DSEC ! second + REAL(SP) :: DTIME ! time in seconds since year dot + ENDTYPE TDATA + + ! the response structure (will not have a spatial dimension) + TYPE VDATA + REAL(SP) :: OBSQ ! observed runoff (mm day-1) + END TYPE VDATA + + ! ancillary forcing variables used to compute ET (will have a spatial dimension) + TYPE ADATA + REAL(SP) :: AIRTEMP ! air temperature (K) + REAL(SP) :: SPECHUM ! specific humidity (g/g) + REAL(SP) :: AIRPRES ! air pressure (Pa) + REAL(SP) :: SWDOWN ! downward sw radiation (W m-2) + REAL(SP) :: NETRAD ! net radiation (W m-2) + END TYPE ADATA + + ! the forcing data structure (will have a spatial dimension) + TYPE FDATA + REAL(SP) :: PPT ! water input: rain + melt (mm day-1) + REAL(SP) :: TEMP ! temperature for snow model (deg.C) + REAL(SP) :: PET ! energy input: potential ET (mm day-1) + ENDTYPE FDATA + +END MODULE multiforce_types diff --git a/build/FUSE_SRC/FUSE_ENGINE/multiparam.f90 b/build/FUSE_SRC/types/multiparam_types.f90 similarity index 90% rename from build/FUSE_SRC/FUSE_ENGINE/multiparam.f90 rename to build/FUSE_SRC/types/multiparam_types.f90 index dd1188e..6062732 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/multiparam.f90 +++ b/build/FUSE_SRC/types/multiparam_types.f90 @@ -1,12 +1,21 @@ -! --------------------------------------------------------------------------------------- -! Creator: -! -------- -! Martyn Clark -! Modified by Brian Henn to include snow model, 6/2013 -! --------------------------------------------------------------------------------------- -MODULE multiparam +MODULE multiparam_types + + ! --------------------------------------------------------------------------------------- + ! Creator: + ! -------- + ! Martyn Clark + ! Modified by Brian Henn to include snow model, 6/2013 + ! Modified by Martyn Clark to separate type definitions from data storage, 01/2026 + ! --------------------------------------------------------------------------------------- + USE nrtype - USE model_defn,ONLY:NTDH_MAX + USE model_defn, ONLY: NTDH_MAX + + implicit none + private + + public :: PARATT, PARINFO, PARADJ, PARDVD, PAR_ID + ! -------------------------------------------------------------------------------------- ! (1) PARAMETER METADATA ! -------------------------------------------------------------------------------------- @@ -29,6 +38,7 @@ MODULE multiparam CHARACTER(LEN=256) :: CHILD1 ! name of 1st parameter child CHARACTER(LEN=256) :: CHILD2 ! name of 2nd parameter child END TYPE PARATT + ! data structure to hold metadata for each parameter TYPE PARINFO ! rainfall error parameters (adjustable) @@ -78,6 +88,7 @@ MODULE multiparam TYPE(PARATT) :: OPG ! precipitation gradient (-) TYPE(PARATT) :: LAPSE ! temperature gradient (deg. C) ENDTYPE PARINFO + ! -------------------------------------------------------------------------------------- ! (2) ADJUSTABLE PARAMETERS ! -------------------------------------------------------------------------------------- @@ -129,6 +140,7 @@ MODULE multiparam REAL(SP) :: OPG ! precipitation gradient (-) REAL(SP) :: LAPSE ! temperature gradient (deg. C) END TYPE PARADJ + ! -------------------------------------------------------------------------------------- ! (3) DERIVED PARAMETERS ! -------------------------------------------------------------------------------------- @@ -153,22 +165,12 @@ MODULE multiparam REAL(SP), DIMENSION(NTDH_MAX) :: FRAC_FUTURE ! fraction of runoff in future time steps INTEGER(I4B) :: NTDH_NEED ! number of time-steps with non-zero routing contribution END TYPE PARDVD + ! -------------------------------------------------------------------------------------- ! (4) LIST OF PARAMETERS FOR A GIVEN MODEL ! -------------------------------------------------------------------------------------- TYPE PAR_ID CHARACTER(LEN=9) :: PARNAME ! list of parameter names ENDTYPE PAR_ID - ! -------------------------------------------------------------------------------------- - ! (5) FINAL DATA STRUCTURES - ! -------------------------------------------------------------------------------------- - INTEGER(I4B), PARAMETER :: MAXPAR=50 ! maximum number of parameters for a single model - TYPE(PARADJ), DIMENSION(:), POINTER :: APARAM=>null() ! all model parameter sets; DK/2008/10/21: explicit null - TYPE(PARADJ) :: MPARAM ! single model parameter set - TYPE(PARDVD) :: DPARAM ! derived model parameters - TYPE(PARINFO) :: PARMETA ! parameter metadata (all parameters) - TYPE(PAR_ID), DIMENSION(MAXPAR) :: LPARAM ! list of model parameter names (need to modify to 16 for SCE) - INTEGER(I4B) :: NUMPAR ! number of model parameters for current model - INTEGER(I4B) :: SOBOL_INDX ! code to re-assemble Sobol parameters - ! -------------------------------------------------------------------------------------- -END MODULE multiparam + +END MODULE multiparam_types diff --git a/build/FUSE_SRC/types/multiroute_types.f90 b/build/FUSE_SRC/types/multiroute_types.f90 new file mode 100644 index 0000000..3b98045 --- /dev/null +++ b/build/FUSE_SRC/types/multiroute_types.f90 @@ -0,0 +1,16 @@ +MODULE multiroute_types + + USE nrtype + + implicit none + private + + public :: RUNOFF + + TYPE RUNOFF + REAL(SP) :: Q_INSTNT ! instantaneous runoff + REAL(SP) :: Q_ROUTED ! routed runoff + REAL(SP) :: Q_ACCURATE ! "accurate" runoff estimate (mm day-1) + END TYPE RUNOFF + +END MODULE multiroute_types diff --git a/build/FUSE_SRC/types/multistate_types.f90 b/build/FUSE_SRC/types/multistate_types.f90 new file mode 100644 index 0000000..e40f59d --- /dev/null +++ b/build/FUSE_SRC/types/multistate_types.f90 @@ -0,0 +1,37 @@ +MODULE multistate_types + + USE nrtype + + implicit none + private + + public :: STATEV, M_TIME + + ! -------------------------------------------------------------------------------------- + ! model state structure + ! -------------------------------------------------------------------------------------- + TYPE STATEV + ! snow layer + REAL(SP) :: SWE_TOT ! total storage as snow (mm) + ! upper layer + REAL(SP) :: WATR_1 ! total storage in layer1 (mm) + REAL(SP) :: TENS_1 ! tension storage in layer1 (mm) + REAL(SP) :: FREE_1 ! free storage in layer 1 (mm) + REAL(SP) :: TENS_1A ! storage in the recharge zone (mm) + REAL(SP) :: TENS_1B ! storage in the lower zone (mm) + ! lower layer + REAL(SP) :: WATR_2 ! total storage in layer2 (mm) + REAL(SP) :: TENS_2 ! tension storage in layer2 (mm) + REAL(SP) :: FREE_2 ! free storage in layer2 (mm) + REAL(SP) :: FREE_2A ! storage in the primary resvr (mm) + REAL(SP) :: FREE_2B ! storage in the secondary resvr (mm) + END TYPE STATEV + + ! -------------------------------------------------------------------------------------- + ! model time structure + ! -------------------------------------------------------------------------------------- + TYPE M_TIME + REAL(SP) :: STEP ! (time interval to advance model states) + END TYPE M_TIME + +END MODULE multistate_types diff --git a/build/FUSE_SRC/FUSE_ENGINE/multistats.f90 b/build/FUSE_SRC/types/multistats_types.f90 similarity index 85% rename from build/FUSE_SRC/FUSE_ENGINE/multistats.f90 rename to build/FUSE_SRC/types/multistats_types.f90 index d950cd9..f3f4ffd 100644 --- a/build/FUSE_SRC/FUSE_ENGINE/multistats.f90 +++ b/build/FUSE_SRC/types/multistats_types.f90 @@ -1,10 +1,21 @@ -MODULE multistats +MODULE multistats_types + USE nrtype + + implicit none + private + + public :: SUMMARY + + ! -------------------------------------------------------------------------------------- + TYPE SUMMARY - ! DMSL diagnostix + + ! DMSL diagnostix REAL(SP) :: VAR_RESIDUL ! variance of the model residuals REAL(SP) :: LOGP_SIMULN ! log density of the model simulation REAL(SP) :: JUMP_TAKEN ! defines a jump in the MCMC production run + ! comparisons between model output and observations REAL(SP) :: QOBS_MEAN ! mean observed runoff (mm day-1) REAL(SP) :: QSIM_MEAN ! mean simulated runoff (mm day-1) @@ -19,6 +30,7 @@ MODULE multistats REAL(SP) :: KGEP ! Kling-Gupta Efficiency' score REAL(SP) :: MAE ! Mean absolute error REAL(SP) :: METRIC_VAL ! value of the metric chosen as objective function + ! attributes of model output REAL(SP) :: NUM_RMSE ! error of the approximate solution REAL(SP) :: NUM_FUNCS ! number of function calls @@ -28,12 +40,10 @@ MODULE multistats REAL(SP) :: NUMSUB_NOCONV ! number of sub-steps tried that did not converge INTEGER(I4B) :: MAXNUM_ITERNS ! maximum number of iterations in implicit scheme REAL(SP), DIMENSION(20) :: NUMSUB_PROB ! probability distribution for number of sub-steps + ! error checking CHARACTER(LEN=1024) :: ERR_MESSAGE ! error message + ENDTYPE SUMMARY - ! final data structures - TYPE(SUMMARY) :: MSTATS ! (model summary statistics) - INTEGER(I4B) :: MOD_IX=1 ! (model index) - INTEGER(I4B) :: PCOUNT ! (number of parameter sets in model output files) - INTEGER(I4B) :: FCOUNT ! (number of model simulations) -END MODULE multistats + +END MODULE multistats_types diff --git a/build/FUSE_SRC/types/work_types.f90 b/build/FUSE_SRC/types/work_types.f90 new file mode 100644 index 0000000..2c1ee0f --- /dev/null +++ b/build/FUSE_SRC/types/work_types.f90 @@ -0,0 +1,60 @@ +module work_types + + ! data types + + use nrtype + + use multiforce_types, only: TDATA, VDATA, ADATA, FDATA + use multibands_types, only: BANDS, BANDS_INFO, BANDS_VAR + use multiparam_types, only: PARATT, PARINFO, PARADJ, PARDVD, PAR_ID + use multistate_types, only: STATEV, M_TIME + use multi_flux_types, only: FLUXES + use multiroute_types, only: RUNOFF + + use multistats_types, only: SUMMARY + + private + + public :: bands_var_diff, ebands + public :: fuse_work + + ! -------------------------------------------------------------------------------------- + + ! dSWE/dParam for each elevation band + + type, extends(bands_var) :: bands_var_diff + real(sp), allocatable :: dSWE_dParam(:) + end type bands_var_diff + + ! extended bands structure + type ebands + type(bands_info) :: info + type(bands_var_diff) :: var + end type ebands + + ! -------------------------------------------------------------------------------------- + + ! omnibus structure that bundles "everything" required to run fuse for a single cell + + type fuse_work + 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 + 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 + 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) + logical(lgt) :: is_initialized = .false. + end type fuse_work + +end module work_types diff --git a/build/FUSE_SRC/FUSE_HOOK/fuse_fileManager.f90 b/build/FUSE_SRC/util/fuse_fileManager.f90 similarity index 100% rename from build/FUSE_SRC/FUSE_HOOK/fuse_fileManager.f90 rename to build/FUSE_SRC/util/fuse_fileManager.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/util/metaoutput.f90 b/build/FUSE_SRC/util/metaoutput.f90 new file mode 100644 index 0000000..77801b0 --- /dev/null +++ b/build/FUSE_SRC/util/metaoutput.f90 @@ -0,0 +1,121 @@ +MODULE metaoutput + + ! --------------------------------------------------------------------------------------- + ! 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 ! 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 + ! --------------------------------------------------------------------------------------- + + SUBROUTINE VARDESCRIBE() + implicit none + INTEGER(I4B) :: I ! loop through variables + + I=0 ! initialize counter + + ! model forcing + I=I+1; VNAME(I)='ppt '; LNAME(I)='precipitation rate '; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='pet '; LNAME(I)='potential evapotranspiration rate '; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='temp '; LNAME(I)='mean air temperature '; VUNIT(I)='deg.C '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='obsq '; LNAME(I)='observed runoff '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.false. + + ! model states + I=I+1; VNAME(I)='tens_1 '; LNAME(I)='tension storage in the upper layer '; VUNIT(I)='mm '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='tens_1a '; LNAME(I)='tension storage in the soil excess zone '; VUNIT(I)='mm '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='tens_1b '; LNAME(I)='tension storage in the soil recharge zone '; VUNIT(I)='mm '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='free_1 '; LNAME(I)='free storage in the upper layer '; VUNIT(I)='mm '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='watr_1 '; LNAME(I)='total storage in the upper layer '; VUNIT(I)='mm '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='tens_2 '; LNAME(I)='tension storage in the lower layer '; VUNIT(I)='mm '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='free_2 '; LNAME(I)='free storage in the lower layer '; VUNIT(I)='mm '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='free_2a '; LNAME(I)='free storage in the primary baseflow reservoir '; VUNIT(I)='mm '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='free_2b '; LNAME(I)='free storage in the secondary baseflow reservoir '; VUNIT(I)='mm '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='watr_2 '; LNAME(I)='total storage in the lower layer '; VUNIT(I)='mm '; isBand(i)=.false.; isFlux(i)=.false. + + ! snow states + I=I+1; VNAME(I)='swe_tot '; LNAME(I)='total storage as snow '; VUNIT(I)='mm '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='swe_z '; LNAME(I)='elevation band snow water equivalent '; VUNIT(I)='mm '; isBand(i)=.true. ; isFlux(i)=.false. + + ! snow fluxes + I=I+1; VNAME(I)='snwacml_z '; LNAME(I)='new band snowpack accumulation, in water equivalent'; VUNIT(I)='mm timestep-1'; isBand(i)=.true. ; isFlux(i)=.false. + I=I+1; VNAME(I)='snwmelt_z '; LNAME(I)='band snowpack melt, in water equivalent '; VUNIT(I)='mm timestep-1'; isBand(i)=.true. ; isFlux(i)=.false. + + ! model fluxes + I=I+1; VNAME(I)='eff_ppt '; LNAME(I)='effective precipitation rate '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='satarea '; LNAME(I)='saturated area '; VUNIT(I)='- '; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='qsurf '; LNAME(I)='surface runoff '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='evap_1a '; LNAME(I)='evaporation from soil excess zone '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='evap_1b '; LNAME(I)='evaporation from soil recharge zone '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='evap_1 '; LNAME(I)='evaporation from the upper soil layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='evap_2 '; LNAME(I)='evaporation from the lower soil layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='rchr2excs '; LNAME(I)='flow from recharge zone to excess zone '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='tens2free_1'; LNAME(I)='flow from tension to free storage, lower layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='oflow_1 '; LNAME(I)='bucket overflow from upper soil layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='tens2free_2'; LNAME(I)='flow from tension to free storage, lower layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='qintf_1 '; LNAME(I)='interflow '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='qperc_12 '; LNAME(I)='percolation from upper to lower soil layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='qbase_2 '; LNAME(I)='baseflow '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='qbase_2a '; LNAME(I)='baseflow from primary baseflow reservoir '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='qbase_2b '; LNAME(I)='baseflow from secondary baseflow reservoir '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='oflow_2 '; LNAME(I)='bucket overflow from lower soil layer '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='oflow_2a '; LNAME(I)='bucket overflow from primary baseflow reservoir '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + I=I+1; VNAME(I)='oflow_2b '; LNAME(I)='bucket overflow from secondary baseflow reservoir '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.true. + + ! errors in model states (due to excessive extrapolation) + I=I+1; VNAME(I)='err_tens_1 '; LNAME(I)='excessive extrapolation: upper tension storage '; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='err_tens_1a'; LNAME(I)='excessive extrapolation: upper excs tension storage'; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='err_tens_1b'; LNAME(I)='excessive extrapolation: upper rech tension storage'; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='err_free_1 '; LNAME(I)='excessive extrapolation: upper free storage '; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='err_watr_1 '; LNAME(I)='excessive extrapolation: upper total storage '; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='err_tens_2 '; LNAME(I)='excessive extrapolation: lower tension storage '; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='err_free_2 '; LNAME(I)='excessive extrapolation: lower free storage '; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='err_free_2a'; LNAME(I)='excessive extrapolation: 1st baseflow reservoir '; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='err_free_2b'; LNAME(I)='excessive extrapolation: 2nd baseflow reservoir '; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='err_watr_2 '; LNAME(I)='excessive extrapolation: lower total storage '; VUNIT(I)='mm day-1 '; isBand(i)=.false.; isFlux(i)=.false. + + ! time check + I=I+1; VNAME(I)='chk_time '; LNAME(I)='length of time step included in weighted average '; VUNIT(I)='days '; isBand(i)=.false.; isFlux(i)=.false. + + ! model numerix + I=I+1; VNAME(I)='num_funcs '; LNAME(I)='number of function calls '; VUNIT(I)='- '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='numjacobian'; LNAME(I)='number of times the Jacobian is calculated '; VUNIT(I)='- '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='sub_accept' ; LNAME(I)='number of sub-steps accepted (taken) '; VUNIT(I)='- '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='sub_reject' ; LNAME(I)='number of sub-steps tried but rejected '; VUNIT(I)='- '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='sub_noconv' ; LNAME(I)='number of sub-steps tried that did not converge '; VUNIT(I)='- '; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='max_iterns' ; LNAME(I)='maximum number of iterations in implicit euler '; VUNIT(I)='- '; isBand(i)=.false.; isFlux(i)=.false. + + ! model runoff (for BATEA, assumed to be last) + I=I+1; VNAME(I)='q_instnt '; LNAME(I)='instantaneous runoff '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.false. + I=I+1; VNAME(I)='q_routed '; LNAME(I)='routed runoff '; VUNIT(I)='mm timestep-1'; isBand(i)=.false.; isFlux(i)=.false. + + print *, 'Setting NOUTVAR (number of forcing, state and flux variables) to', I + NOUTVAR=I + + END SUBROUTINE VARDESCRIBE + +END MODULE metaoutput diff --git a/build/FUSE_SRC/util/metaparams.f90 b/build/FUSE_SRC/util/metaparams.f90 new file mode 100644 index 0000000..41cc6dd --- /dev/null +++ b/build/FUSE_SRC/util/metaparams.f90 @@ -0,0 +1,119 @@ +MODULE metaparams + + ! --------------------------------------------------------------------------------------- + ! 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/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/util/parextract.f90 b/build/FUSE_SRC/util/parextract.f90 new file mode 100644 index 0000000..7eba011 --- /dev/null +++ b/build/FUSE_SRC/util/parextract.f90 @@ -0,0 +1,129 @@ +MODULE PAREXTRACT_MODULE + + 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/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/util/varextract.f90 b/build/FUSE_SRC/util/varextract.f90 new file mode 100644 index 0000000..dbb1767 --- /dev/null +++ b/build/FUSE_SRC/util/varextract.f90 @@ -0,0 +1,247 @@ +MODULE VAREXTRACT_MODULE + + USE nrtype ! variable types, etc. + + IMPLICIT NONE + + 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 + + + +END MODULE VAREXTRACT_MODULE 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 30683d2..8b5fb2e 100755 --- a/build/Makefile +++ b/build/Makefile @@ -2,24 +2,54 @@ # Makefile to compile FUSE #======================================================================== +.DEFAULT_GOAL := all + #======================================================================== -# PART 0: Define directory paths +# Define directory paths #======================================================================== # Define core directory below which everything resides -F_MASTER = $(CURDIR)/../ +FUSE_ROOT = $(abspath $(CURDIR)/..) # Core directory that contains FUSE source code -F_KORE_DIR = $(F_MASTER)build/FUSE_SRC/ +FUSE_SOURCE_DIR = $(FUSE_ROOT)/build/FUSE_SRC/ # Location of the compiled modules -MOD_PATH = $(F_MASTER)build/ +MOD_PATH = $(FUSE_ROOT)/build/ # Define the directory for the executables -EXE_PATH = $(F_MASTER)bin/ +EXE_PATH = $(FUSE_ROOT)/bin/ + +#======================================================================== +# Define an include file (fuseversion.inc) with version info +#======================================================================== + +GENINC := $(FUSE_ROOT)/build/generated +VERSIONFILE := $(GENINC)/fuseversion.inc + +VERSION := $(shell git -C $(FUSE_ROOT) describe --tags --abbrev=0 2>/dev/null || echo "no-tag") +BUILDTIME := $(shell date -u +"%Y-%m-%dT%H:%M:%SZ") +GITBRANCH := $(shell git -C $(FUSE_ROOT) rev-parse --abbrev-ref HEAD 2>/dev/null || echo "detached") +GITHASH := $(shell git -C $(FUSE_ROOT) rev-parse HEAD 2>/dev/null || echo "unknown") + +$(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 1: Define the libraries, driver programs, and executables +# Define the libraries, driver programs, and executables #======================================================================== # default Fortran compiler is set to `gfortran` @@ -85,225 +115,278 @@ LIBS += -L$(HDF5_LIB_DIR) -lhdf5 -lhdf5_hl -L$(NETCDF_F_LIB) -lnetcdff -L$(NETCD $(info INCLUDES are $(INCLUDES)) $(info LIBS are $(LIBS)) -# Define the driver program and associated subroutines for the fidelity test -FUSE_DRIVER = \ - sobol.f90 \ - fuse_metric.f90 \ - functn.f90 \ - fuse_driver.f90 -DRIVER = $(patsubst %, $(DRIVER_DIR)/%, $(FUSE_DRIVER)) - -# Define the executables -DRIVER_EX = fuse.exe - #======================================================================== -# PART 2: Assemble all of the FUSE sub-routines +# Assemble all of the FUSE sub-routines #======================================================================== # 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 = $(FUSE_SOURCE_DIR)numrec +HOOKUP_DIR = $(FUSE_SOURCE_DIR)hookup +DRIVER_DIR = $(FUSE_SOURCE_DIR)driver +NETCDF_DIR = $(FUSE_SOURCE_DIR)netcdf +SHARE_DIR = $(FUSE_SOURCE_DIR)share +TYPES_DIR = $(FUSE_SOURCE_DIR)types +PRELIM_DIR = $(FUSE_SOURCE_DIR)prelim +RUNTIME_DIR = $(FUSE_SOURCE_DIR)runtime +PHYSICS_DIR = $(FUSE_SOURCE_DIR)physics +OLDPHYS_DIR = $(FUSE_SOURCE_DIR)physics_orig +SOLVER_DIR = $(FUSE_SOURCE_DIR)solver_orig +UTILMS_DIR = $(FUSE_SOURCE_DIR)util +SCE_DIR = $(FUSE_SOURCE_DIR)sce +TIME_DIR = $(FUSE_SOURCE_DIR)netcdf -# Utility modules -FUSE_UTILMS= \ - kinds_dmsl_kit_FUSE.f90 \ - utilities_dmsl_kit_FUSE.f90 \ - fuse_fileManager.f90 -UTILMS = $(patsubst %, $(HOOKUP_DIR)/%, $(FUSE_UTILMS)) +# Define the executables +DRIVER_EX = fuse.exe + +# Define the driver program and associated subroutines +FUSE_DRIVER = +#FUSE_DRIVER += setup_domain.f90 +#FUSE_DRIVER += setup_model_definition.f90 +FUSE_DRIVER += fuse_metric.f90 functn.f90 +#FUSE_DRIVER += sce_driver.f90 +FUSE_DRIVER += fuse_driver.f90 +DRIVER = $(patsubst %, $(DRIVER_DIR)/%, $(FUSE_DRIVER)) + +# Manager modules +FUSE_HOOKUP = +FUSE_HOOKUP += kinds_dmsl_kit_FUSE.f90 +FUSE_HOOKUP += utilities_dmsl_kit_FUSE.f90 +HOOKUP = $(patsubst %, $(HOOKUP_DIR)/%, $(FUSE_HOOKUP)) # Numerical Recipes utilities -FUSE_NRUTIL= \ - nrtype.f90 \ - nr.f90 nrutil.f90 +FUSE_NRUTIL = +FUSE_NRUTIL += nrtype.f90 +FUSE_NRUTIL += nr.f90 nrutil.f90 NRUTIL = $(patsubst %, $(NUMREC_DIR)/%, $(FUSE_NRUTIL)) -# Data modules -FUSE_DATAMS= \ - model_defn.f90 \ - model_defnames.f90 \ - multiconst.f90 \ - multiforce.f90 \ - multibands.f90 \ - multiparam.f90 \ - multistate.f90 \ - multi_flux.f90 \ - multiroute.f90 \ - multistats.f90 \ - model_numerix.f90 -DATAMS = $(patsubst %, $(ENGINE_DIR)/%, $(FUSE_DATAMS)) +# Global data (needs to be defined before model_defn) +G_DATA = $(SHARE_DIR)/globaldata.f90 + +# Model definition +FUSE_MODDEF = +FUSE_MODDEF += $(TYPES_DIR)/model_defn_types.f90 +FUSE_MODDEF += $(SHARE_DIR)/model_defn_data.f90 +MODDEF = $(FUSE_MODDEF) # no patetrn substitution needed + +# Data types +FUSE_TYPES = +FUSE_TYPES += multiforce_types.f90 +FUSE_TYPES += multibands_types.f90 +FUSE_TYPES += multiparam_types.f90 +FUSE_TYPES += multistate_types.f90 +FUSE_TYPES += multi_flux_types.f90 +FUSE_TYPES += multiroute_types.f90 +FUSE_TYPES += multistats_types.f90 +FUSE_TYPES += work_types.f90 +FUSE_TYPES += info_types.f90 +FUSE_TYPES += data_types.f90 +TYPES = $(patsubst %, $(TYPES_DIR)/%, $(FUSE_TYPES)) + +# combined type+data (mimic legacy code) +FUSE_SHARE = +FUSE_SHARE += multiconst.f90 +FUSE_SHARE += model_defnames.f90 +FUSE_SHARE += model_numerix.f90 +FUSE_SHARE += multiforce_data.f90 +FUSE_SHARE += multibands_data.f90 +FUSE_SHARE += multiparam_data.f90 +FUSE_SHARE += multistate_data.f90 +FUSE_SHARE += multi_flux_data.f90 +FUSE_SHARE += multiroute_data.f90 +FUSE_SHARE += multistats_data.f90 +SHARE = $(patsubst %, $(SHARE_DIR)/%, $(FUSE_SHARE)) + +# combine data modules together +DATAMS = $(G_DATA) $(MODDEF) $(TYPES) $(SHARE) # Time I/O modules -FUSE_TIMEMS= \ - time_io.f90 +FUSE_TIMEMS = +FUSE_TIMEMS += time_io.f90 TIMUTILS = $(patsubst %, $(TIME_DIR)/%, $(FUSE_TIMEMS)) -# Information modules -FUSE_INFOMS= \ - metaoutput.f90 \ - metaparams.f90 \ - meta_stats.f90 \ - selectmodl.f90 \ - putpar_str.f90 \ - getpar_str.f90 \ - par_insert.f90 \ - parextract.f90 \ - varextract.f90 \ - sumextract.f90 \ - str_2_xtry.f90 \ - xtry_2_str.f90 -INFOMS = $(patsubst %, $(ENGINE_DIR)/%, $(FUSE_INFOMS)) +# Utility modules +FUSE_UTILMS = +FUSE_UTILMS += fuse_fileManager.f90 +#FUSE_UTILMS += alloc_domain.f90 +#FUSE_UTILMS += alloc_scratch.f90 +FUSE_UTILMS += metaoutput.f90 +FUSE_UTILMS += metaparams.f90 +FUSE_UTILMS += meta_stats.f90 +FUSE_UTILMS += selectmodl.f90 +FUSE_UTILMS += putpar_str.f90 +FUSE_UTILMS += getpar_str.f90 +FUSE_UTILMS += par_insert.f90 +FUSE_UTILMS += parextract.f90 +FUSE_UTILMS += varextract.f90 +FUSE_UTILMS += sumextract.f90 +FUSE_UTILMS += str_2_xtry.f90 +FUSE_UTILMS += xtry_2_str.f90 +UTILMS = $(patsubst %, $(UTILMS_DIR)/%, $(FUSE_UTILMS)) # Numerical Recipes -FUSE_NR_SUB= \ - ludcmp.f90 \ - lubksb.f90 \ - svbksb.f90 \ - svdcmp.f90 \ - pythag.f90 \ - gammln.f90 \ - gammp.f90 \ - gcf.f90 \ - gser.f90 +FUSE_NR_SUB = +FUSE_NR_SUB += ludcmp.f90 lubksb.f90 svbksb.f90 svdcmp.f90 pythag.f90 +FUSE_NR_SUB += gammln.f90 gammp.f90 gcf.f90 gser.f90 NR_SUB = $(patsubst %, $(NUMREC_DIR)/%, $(FUSE_NR_SUB)) -# Model guts -FUSE_MODGUT=\ - mod_derivs.f90 \ - update_swe.f90 \ - qrainerror.f90 \ - qsatexcess.f90 \ - evap_upper.f90 \ - evap_lower.f90 \ - qinterflow.f90 \ - qpercolate.f90 \ - q_baseflow.f90 \ - q_misscell.f90 \ - logismooth.f90 \ - mstate_eqn.f90 \ - fix_states.f90 \ - meanfluxes.f90 \ - wgt_fluxes.f90 \ - updatstate.f90 \ - q_overland.f90 -MODGUT = $(patsubst %, $(ENGINE_DIR)/%, $(FUSE_MODGUT)) - -# Solver -FUSE_SOLVER= \ - interfaceb.f90 \ - limit_xtry.f90 \ - viol_state.f90 \ - fuse_deriv.f90 \ - fmin.f90 \ - fdjac_ode.f90 \ - flux_deriv.f90 \ - disaggflux.f90 \ - fuse_sieul.f90 \ - newtoniter.f90 \ - lnsrch.f90 -SOLVER = $(patsubst %, $(ENGINE_DIR)/%, $(FUSE_SOLVER)) - -# Define routines for FUSE preliminaries -FUSE_PRELIM= \ - ascii_util.f90 \ - uniquemodl.f90 \ - getnumerix.f90 \ - getparmeta.f90 \ - assign_stt.f90 \ - assign_flx.f90 \ - assign_par.f90 \ - adjust_stt.f90 \ - par_derive.f90 \ - bucketsize.f90 \ - mean_tipow.f90 \ - qbsaturatn.f90 \ - qtimedelay.f90 \ - init_stats.f90 \ - init_state.f90 -PRELIM = $(patsubst %, $(ENGINE_DIR)/%, $(FUSE_PRELIM)) - -FUSE_MODRUN= \ - metrics.f90 \ - conv_funcs.f90 \ - force_info.f90 \ - clrsky_rad.f90 \ - getPETgrid.f90 \ - get_mbands.f90 \ - get_time_indices.f90\ - initfluxes.f90 \ - set_all.f90 \ - ode_int.f90 \ - fuse_solve.f90 \ - comp_stats.f90 \ - mean_stats.f90 -MODRUN = $(patsubst %, $(ENGINE_DIR)/%, $(FUSE_MODRUN)) - -# Define NetCDF routines -FUSE_NETCDF = \ - handle_err.f90 \ - extractor.f90 juldayss.f90 caldatss.f90 \ - get_gforce.f90 \ - get_smodel.f90 \ - get_fparam.f90 \ - def_params.f90 \ - def_output.f90 \ - def_sstats.f90 \ - put_params.f90 \ - put_output.f90 \ - put_sstats.f90 +# FUSE physics (differentiable model) +FUSE_PHYSICS = +FUSE_PHYSICS += smoothers.f90 +FUSE_PHYSICS += get_bundle.f90 +FUSE_PHYSICS += update_swe_diff.f90 +FUSE_PHYSICS += qsatexcess_diff.f90 +FUSE_PHYSICS += evap_upper_diff.f90 +FUSE_PHYSICS += evap_lower_diff.f90 +FUSE_PHYSICS += qinterflow_diff.f90 +FUSE_PHYSICS += qpercolate_diff.f90 +FUSE_PHYSICS += q_baseflow_diff.f90 +FUSE_PHYSICS += q_misscell_diff.f90 +FUSE_PHYSICS += mstate_rhs_diff.f90 +FUSE_PHYSICS += mod_derivs_diff.f90 +FUSE_PHYSICS += conserve_clamp.f90 +FUSE_PHYSICS += fix_ovshoot.f90 +FUSE_PHYSICS += implicit_solve.f90 +PHYSICS = $(patsubst %, $(PHYSICS_DIR)/%, $(FUSE_PHYSICS)) + +# Old physics (model "guts") +FUSE_MODGUT = +FUSE_MODGUT += mod_derivs.f90 +FUSE_MODGUT += update_swe.f90 +FUSE_MODGUT += qrainerror.f90 +FUSE_MODGUT += qsatexcess.f90 +FUSE_MODGUT += evap_upper.f90 +FUSE_MODGUT += evap_lower.f90 +FUSE_MODGUT += qinterflow.f90 +FUSE_MODGUT += qpercolate.f90 +FUSE_MODGUT += q_baseflow.f90 +FUSE_MODGUT += q_misscell.f90 +FUSE_MODGUT += mstate_eqn.f90 +FUSE_MODGUT += fix_states.f90 +FUSE_MODGUT += meanfluxes.f90 +FUSE_MODGUT += wgt_fluxes.f90 +FUSE_MODGUT += updatstate.f90 +FUSE_MODGUT += q_overland.f90 +MODGUT = $(patsubst %, $(OLDPHYS_DIR)/%, $(FUSE_MODGUT)) + +# Old solver +FUSE_SOLVER = +FUSE_SOLVER += interfaceb.f90 +FUSE_SOLVER += limit_xtry.f90 +FUSE_SOLVER += logismooth.f90 +FUSE_SOLVER += viol_state.f90 +FUSE_SOLVER += fuse_deriv.f90 +FUSE_SOLVER += fmin.f90 fdjac_ode.f90 flux_deriv.f90 disaggflux.f90 +FUSE_SOLVER += fuse_sieul.f90 +FUSE_SOLVER += newtoniter.f90 lnsrch.f90 +SOLVER = $(patsubst %, $(SOLVER_DIR)/%, $(FUSE_SOLVER)) + +# FUSE preliminaries +FUSE_PRELIM = +#FUSE_PRELIM += parse_command_args.f90 +FUSE_PRELIM += ascii_util.f90 +FUSE_PRELIM += uniquemodl.f90 +FUSE_PRELIM += getnumerix.f90 +FUSE_PRELIM += force_info.f90 +FUSE_PRELIM += getparmeta.f90 +FUSE_PRELIM += assign_stt.f90 +FUSE_PRELIM += assign_flx.f90 +FUSE_PRELIM += assign_par.f90 +FUSE_PRELIM += adjust_stt.f90 +FUSE_PRELIM += par_derive.f90 +FUSE_PRELIM += bucketsize.f90 +FUSE_PRELIM += mean_tipow.f90 +FUSE_PRELIM += qbsaturatn.f90 +FUSE_PRELIM += qtimedelay.f90 +FUSE_PRELIM += init_stats.f90 +FUSE_PRELIM += init_state.f90 +PRELIM = $(patsubst %, $(PRELIM_DIR)/%, $(FUSE_PRELIM)) + +# FUSE runtime +FUSE_RUNTIME = +FUSE_RUNTIME += metrics.f90 +FUSE_RUNTIME += conv_funcs.f90 +FUSE_RUNTIME += clrsky_rad.f90 +FUSE_RUNTIME += getPETgrid.f90 +#FUSE_RUNTIME += get_time_windows.f90 +FUSE_RUNTIME += get_time_indices.f90 +FUSE_RUNTIME += initfluxes.f90 +FUSE_RUNTIME += set_all.f90 +FUSE_RUNTIME += ode_int.f90 +FUSE_RUNTIME += fuse_solve.f90 +FUSE_RUNTIME += comp_stats.f90 +FUSE_RUNTIME += mean_stats.f90 +RUNTIME = $(patsubst %, $(RUNTIME_DIR)/%, $(FUSE_RUNTIME)) + +# NetCDF routines +FUSE_NETCDF = +FUSE_NETCDF += handle_err.f90 +FUSE_NETCDF += extractor.f90 juldayss.f90 caldatss.f90 +#FUSE_NETCDF += domain_decomp.f90 +FUSE_NETCDF += get_gforce.f90 +FUSE_NETCDF += get_mbands.f90 +FUSE_NETCDF += get_smodel.f90 +FUSE_NETCDF += get_fparam.f90 +FUSE_NETCDF += def_params.f90 +FUSE_NETCDF += def_output.f90 +FUSE_NETCDF += def_sstats.f90 +FUSE_NETCDF += put_params.f90 +FUSE_NETCDF += put_output.f90 +FUSE_NETCDF += put_sstats.f90 NETCDF = $(patsubst %, $(NETCDF_DIR)/%, $(FUSE_NETCDF)) -SCE = \ - sce_16plus.o +SCE = sce_16plus.o # ... and stitch it all together... -FUSE_ALL = \ - $(UTILMS) \ - $(NRUTIL) \ - $(DATAMS) \ - $(TIMUTILS) \ - $(INFOMS) \ - $(NR_SUB) \ - $(MODGUT) \ - $(SOLVER) \ - $(PRELIM) \ - $(MODRUN) \ - $(NETCDF) \ - $(SCE) - -#===================== -# PART 3: Compile fuse -#===================== +FUSE_ALL = +FUSE_ALL += $(HOOKUP) +FUSE_ALL += $(NRUTIL) +FUSE_ALL += $(DATAMS) +FUSE_ALL += $(UTILMS) +FUSE_ALL += $(TIMUTILS) +FUSE_ALL += $(NR_SUB) +FUSE_ALL += $(PHYSICS) +FUSE_ALL += $(MODGUT) +FUSE_ALL += $(SOLVER) +FUSE_ALL += $(PRELIM) +FUSE_ALL += $(RUNTIME) +FUSE_ALL += $(NETCDF) +FUSE_ALL += $(SCE) + +#============= +# Compile fuse +#============= + # Define flags based on specified compiler ifeq ($(FC),ifort) FFLAGS_NORMA = -O3 -FR -auto -fltconsistency -fpe0 -fpp - FFLAGS_DEBUG = -O0 -p -g -debug -warn all -check all -FR -auto -WB -traceback -fltconsistency -fpe0 -fpp + FFLAGS_DEBUG = -O0 -g -debug -warn all -check all -FR -auto -WB -traceback -fltconsistency -fpe0 -fpp FFLAGS_FIXED = -O2 -c -fixed endif ifeq ($(FC),gfortran) FFLAGS_NORMA = -O3 -ffree-line-length-none -fmax-errors=0 -cpp - FFLAGS_DEBUG = -p -g -Wall -ffree-line-length-none -fmax-errors=0 -fbacktrace -fcheck=bounds -cpp + FFLAGS_DEBUG = -g -Wall -ffree-line-length-none -fmax-errors=0 -fbacktrace -fcheck=bounds -cpp FFLAGS_FIXED = -O2 -c -ffixed-form endif # Default flags -FFLAGS = $(FFLAGS_NORMA) +FFLAGS = $(FFLAGS_NORMA) -I$(GENINC) # Target-specific flags for 'debug' target -debug: FFLAGS = $(FFLAGS_DEBUG) +debug: FFLAGS = $(FFLAGS_DEBUG) -I$(GENINC) debug: compile # Special provision for gcc>13 ifeq ($(FC),gfortran) - GFORTRAN_VERSION := $(shell gfortran -dumpversion | cut -d. -f1) - $(info compiler version is $(GFORTRAN_VERSION)) - GFORTRAN_GT_13 := $(shell expr $(GFORTRAN_VERSION) \>= 13) + GFORTRAN_VERSION_STR := $(shell gfortran -dumpfullversion -dumpversion 2>/dev/null) + GFORTRAN_MAJOR := $(firstword $(subst ., ,$(GFORTRAN_VERSION_STR))) + $(info compiler version is $(GFORTRAN_MAJOR)) + + GFORTRAN_MAJOR ?= 0 # if GFORTRAN_MAJOR is empty + + GFORTRAN_GT_13 := $(shell [ "$(GFORTRAN_MAJOR)" -ge 13 ] && echo 1 || echo 0) + ifeq ($(GFORTRAN_GT_13),1) FFLAGS += -fallow-argument-mismatch endif @@ -333,7 +416,7 @@ sce_16plus.o: $(SCE_DIR)/sce_16plus.f all: compile install clean # compile target -compile: sce_16plus.o +compile: sce_16plus.o $(VERSIONFILE) $(FC) $(FUSE_ALL) $(DRIVER) \ $(FFLAGS) $(LIBS) $(INCLUDES) -o $(DRIVER_EX) @@ -348,8 +431,5 @@ install: mkdir -p $(EXE_PATH) mv $(DRIVER_EX) $(EXE_PATH) -# describe how to compile SCE code written in Fortran 77 -sce_16plus.o: $(SCE_DIR)/sce_16plus.f - $(FC) $(FFLAGS_FIXED) -c $(SCE_DIR)/sce_16plus.f - -.PHONY: debug +.PHONY: all compile install clean debug +.PHONY: $(VERSIONFILE) diff --git a/build/generated/fuseversion.inc b/build/generated/fuseversion.inc new file mode 100644 index 0000000..40f3245 --- /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 = '2026-02-17T23:37:32Z' +character(len=FUSE_GITBRANCH_LEN), parameter :: FUSE_GITBRANCH = 'wip/diffmod-foundation' +character(len=FUSE_GITHASH_LEN), parameter :: FUSE_GITHASH = '98abe3c8134fda8632549c207fac60bd6b09be1e' diff --git a/docs/install/install_fuse.md b/docs/install/install_fuse.md index ecbaa1b..b872afc 100644 --- a/docs/install/install_fuse.md +++ b/docs/install/install_fuse.md @@ -1,23 +1,41 @@ -## Notes on the computing environment +# FUSE Installation -This page will guide you through the installation of FUSE. Before you get started, please note that: +We have successfully installed FUSE on a number of Unix-like (\*nix) operating +systems, including Linux and Darwin (Mac OS X). -1. below we assume that you will be compiling and running FUSE in a Linux/UNIX environment - for OS X/macOS, see this [page](https://summa.readthedocs.io/en/latest/installation/SUMMA_on_OS_X/) of the SUMMA manual, -2. you will need a Fortran compiler: FUSE was developed and tested using `ifort`, which we recommend if you have no previous experience with Fortran compilers - note that on HPCs, you might have to load specific modules to use the compiler (in which case, try `module avail` and then `module add [your/module/version/compiler]`), -3. you will need access to the NetCDF and HDF libraries: use the libraries compiled with the compiler you selected above, the path to these libraries are machine dependent (so paths for another machine probably will not work on your machine). To find these paths, ask administrators or users of your machine, or, if you have to load modules containing the libraries, once loaded, type `module show [your/module/version/compiler]`. +To compile FUSE, change into the `build/` directory inside your FUSE installation and run `make`: +``` +cd /path/to/fuse/build +make +``` -## 1. Fork the FUSE repository and adapt the Makefile -1. Fork the [FUSE repository](https://github.com/naddor/fuse) to a directory `$(MASTER)` on your machine (see the [SUMMA manual](http://summa.readthedocs.io/en/latest/development/SUMMA_and_git/) for a step-by-step procedure). -2. Edit the `Makefile` in `$(MASTER)/build/` by defining: - * the name of the master directory (line 10), - * the fortran compiler (lines 31-32, optional, we recommend that you define it when compiling the code, see 2. above), - * the path to the NetCDF and HDF libraries (`NCDF_PATH` and `HDF_PATH`, lines 38-46, see 3. above, provide the paths associated with the compiler you selected). +Test by: +`/path/to/fuse/bin/fuse.exe` -## 2. Compile FUSE -In spring 2020, we spruced up the FUSE Makefile. Until then, it used to require the separate compilation of the shuffled complex evolution (SCE, used for automated parameter estimation), as SCE code is in Fortran77. Now, SCE compilation is taken care of by the Makefile. To compile FUSE: +# Dependencies -1. Change directory to `$(MASTER)/build/` and compile FUSE by typing `make FC=ifort` (or `make FC=gfortran` if you prefer to use `gfortran`). +To compile FUSE, you will need: + +### A Fortran compiler -2. Try running FUSE by typing `./fuse.exe`. If the output is `1st command-line argument is missing (fileManager)`, you have probably compiled FUSE correctly. But there might still be issues related to the libraries. To find out, download the [test data](../test_data/) and run the [test cases](../test_cases/). + We have successfully used the intel Fortran compiler (`ifort`, version 17.x) and the GNU Fortran compiler (`gfortran`, version 6 or higher), the latter of which is freely available. Since we do not use any compiler-specific extensions, you should be able to compile FUSE with other Fortran compilers as well. If you do not have a Fortran compiler, you can install `gfortran` for free. The easiest way is to use a package manager (e.g., Homebrew). Note that `gfortran` is installed as part of the `gcc` compiler suite (for Homebrew, `brew install gcc`). - +### The NetCDF libraries + + [NetCDF](http://www.unidata.ucar.edu/software/netcdf/) or the Network Common Data Format is a set of software libraries and self-describing, machine-independent data formats that support the creation, access, and sharing of array-oriented scientific data. For Homebrew, you can install NetCDF library as `brew install netcdf-fortran`. Most \*nix package managers include a NetCDF port. Note that you need to ensure that: + + - You have NetCDF version 4.x; + - The NetCDF libraries are compiled with the same compiler as you plan to use for compiling FUSE (if you installed NetCDF via Homebrew, and you compile FUSE using the Homebrew gfortran, you’re almost always consistent); and + - You have the NetCDF Fortran library installed (`libnetcdff.*`) and not just the C-version. + +### A copy of the FUSE source code from [this repo](https://github.com/CH-EARTH/fuse) + + You have a number of options: + + - If you just want to use the latest stable release of FUSE, then simply look for the [latest release](https://github.com/CH-EARTH/fuse/releases); + - If you want the latest and greatest (and potentially erroneous), download a copy of the [development branch](https://github.com/CH-EARTH/fuse/tree/develop) (or clone it); + - If you may want to do FUSE development, then fork the repo on github and start editing your own copy. + +### pkg-config + + `pkg-config` is a command-line tool that helps software builds find the right compiler and linker flags for installed libraries (like HDF5, netCDF, etc.). After it’s installed, you can use `pkg-config` in build systems (Makefiles, CMake, configure scripts) to automatically discover the correct -I include paths and -L/-l library flags, instead of you having to set those paths manually. In FUSE `pkg-config` is used in the Makefile. diff --git a/mkdocs.yml b/mkdocs.yml index 65001cd..9bb0df9 100644 --- a/mkdocs.yml +++ b/mkdocs.yml @@ -1,5 +1,7 @@ site_name: FUSE manual -repo_url: https://github.com/naddor/fuse +repo_url: https://github.com/CH-Earth/fuse +site_url: https://ch-earth.github.io/fuse/ +edit_uri: edit/develop/docs/ docs_dir: docs theme: name: readthedocs @@ -12,6 +14,7 @@ nav: - Test cases: 'install/test_cases.md' - Execution: - Overview: 'modes/overview.md' + - Arguments: 'modes/arguments.md' - Model structure: 'modes/structure.md' - Parameter modes: 'modes/execution_modes.md' - Spatial modes: 'modes/spatial_modes.md'