commit ab55f478ba96bb05f9c22c35ab617138e97dde27 Author: David Williams Date: Tue Oct 15 11:12:13 2024 +0200 Initial commit. diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..84a0185 --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +/obj/ +.#* +/bin/ +src/model/ +/src/parser/keys.f90 diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..080089c --- /dev/null +++ b/Makefile @@ -0,0 +1,152 @@ +SHELL = /bin/bash +.SUFFIXES : +.SUFFIXES : .f .o +src = ./src/ +build = ./obj/ +bin = ./bin/ + +###################################################################### +version=localdw-1.0 +###################################################################### + +#IFORT VERSION (DEFAULT) +FC = ifort +FFLAGS = -O2 -openmp -mkl -heap-arrays -module $(build) -cpp +#-openmp -complex-limited-range -xW -i-static -ip -ftz -no-prec-div -opt-prefetch -heap-arrays -align dcommons -mkl -mcmodel=medium +DBGFLAGS = -debug -check -check bounds #-warn uncalled -warn nousage -warn nounused -openmp -warn -warn notruncated_source +DBGFLAGS+= -pg + +#MODERN IFORT VERSION (for compiling on laptops) +NEWFFLAGS =-O2 -qopenmp -qmkl -heap-arrays -module $(build) -cpp -g + +#GFORTRAN (INVOKED VIA MAKE GFORTRAN) +GNUFC = gfortran #You can get newer versions of gfortran, if you perform "scl enable devtoolset-10 bash" in your shell first +GNUQFC = /opt/rh/devtoolset-10/root/bin/gfortran +GNUFFLAGS = -O3 -ffast-math -march=native -p -opt-prefetch -fopenmp -std=legacy -llapack -cpp -J$(build) #Note that for new version of gfortran you might have to add -std=legacy or -fallow-argument-mismatch to compile random.f without errors! +#-fallow-argument-mismatch +GNUDBGFLAGS = -fcheck=bounds -fcheck=do -fcheck=mem -fcheck=pointer -p -Og #-gdwarf-5 -O0 -Wall + +#MPI VERSION (INVOKED VIA MAKE MPI) +MPIFC=mpif90 +MPIFFLAGS = -fcx-limited-range -O3 -ffast-math -march=native -p -opt-prefetch -falign-commons -mcmodel=large -fopenmp -J$(build) -llapack -cpp -Dmpi_version #TODO: Check if all these flags are necessary! +#Syntax for running mpi calculations: +# - 1 machine with 12 cores: mpirun -np 12 genetic test.genetic +# - 4 machine with 12 cores: mpirun -np 48 --hostfile nodes.txt genetic test.genetic +# - nodes.txt specifies the nodes on which the program will run, the first mentioned note will perform the master thread +# - you have to start the calculation from the node with the master thread and have running sleep jobs for the other notes +# - TODO: Write a job file / submission script that automatizes this procedure + +#mpirun -np 48 --hostfile nodes.txt genetic s_test-dist9-freeze.genetic > s_test-dist9-freeze.out & + +###################################################################### + +#Extend search path for files (both .f and .incl files) +VPATH += $(src) +VPATH += $(src)parser +VPATH += $(src)parser/lib +VPATH += $(src)model + +###################################################################### + +#Define objects for different Program parts (sorted in order of compilation) +parserlib_obj = strings.o long_keyread.o fileread.o keyread.o long_write.o +parser_obj = io_parameters.o keys.o dim_parameter.o parameterkeys.o parse_errors.o parser.o + +datamodule_obj = data_module.o #Compile this module before your model files and the genetic files + +model_obj = ptr_structure.o ctrans.o model.o weight.o adia.o + +mod_incl = mod_const.incl so_param.incl + +random_obj = $(addprefix $(build), random.o) + +genetic_obj = data_transform.o init.o write.o funcs.o marq.o lbfgsb.o idxsrt_mod.o fit_MeX.o mpi_fit_MeX.o genetic.o #content of data_transform and write is user specific, interfaces are fixed + +objects = $(addprefix $(build), $(parserlib_obj) $(parser_obj) $(datamodule_obj) $(model_obj) $(genetic_obj) ) + +#Note: Since we are using modules, you have carefully choose the order of compilation and take dependencies between modules and subroutines into account! + +###################################################################### + +# define main goal +main = genetic + + +# define main compilation +gfortran: override FC = $(GNUFC) +gfortran: override FFLAGS = $(GNUFFLAGS) +gfortran: $(main) + +$(main) : dirs $(random_obj) $(objects) + $(FC) $(FFLAGS) $(random_obj) $(objects) -o $(bin)$(main) +$(build)%.o : %.f + $(FC) -c $(FFLAGS) $^ -o $@ + + +$(model_obj) : $(mod_incl) +###################################################################### + +# define name of additional recipes +.PHONY: clean neat remake debug test mpi gfortran gqfortran profile tar dirs + +# define additionational recipes +trash= *__genmod* $(addprefix $(build),*__genmod* *.mod) +clean: + $(RM) $(objects) $(trash) + +neat: clean + $(RM) $(random_obj) + +remake: clean $(main) + +dirs: + @mkdir -p $(build) $(bin) + +debug: override FFLAGS += $(DBGFLAGS) +debug: clean $(main) + cp $(infile) $(bin) + $(bin)$(main) $(bin)$(infile) | tee debug.out + +modern: override FFLAGS = $(NEWFFLAGS) +modern: $(main) + +gqfortran: override FC = $(GNUQFC) +gqfortran: override FFLAGS = $(GNUFFLAGS) +gqfortran: $(main) + +gdebug: override FC = $(GNUFC) +gdebug: override FFLAGS = $(GNUFFLAGS) $(GNUDBGFLAGS) +gdebug: clean $(main) + +mpi: override FC = $(MPIFC) +mpi: override FFLAGS = $(MPIFFLAGS) +mpi: $(main) + +infile=hi-sing1-sig.genetic + +gtest: override FC = $(GNUFC) +gtest: override FFLAGS = $(GNUFFLAGS) +gtest: clean $(main) + cp $(infile) $(bin) + $(bin)$(main) $(bin)$(infile) | tee test.out + +gprofile: override FC = $(GNUFC) +gprofile: override FFLAGS = $(GNUFFLAGS) -pg +gprofile: clean $(main) + cp $(infile) $(bin) + + + +test: clean $(main) + cp $(infile) $(bin) + $(bin)$(main) $(bin)$(infile) | tee test.out + +profile: override FFLAGS += -pg +profile: clean test + date > profile + gprof $(bin)$(main) gmon.out >> profile + +timestamp=$(shell date +"%FT%H-%M-%S") +tar: + date > INFO + tar --exclude-backups --exclude-vcs -czf tardir/geneticsrc_$(timestamp).tar src/ obj/ bin/ Makefile INFO diff --git a/src/accuracy_constants.f b/src/accuracy_constants.f new file mode 100644 index 0000000..ed7d817 --- /dev/null +++ b/src/accuracy_constants.f @@ -0,0 +1,11 @@ + module accuracy_constants + use iso_fortran_env + implicit none +! integer, parameter :: racc = real32 !real*4 + integer, parameter :: racc = real64 !real*8 +! integer, parameter :: racc = real128 !real*16 + +! integer, parameter :: iacc = int16 !int*2 + integer, parameter :: iacc = int32 !int*4 +! integer, parameter :: iacc = int64 !int*8 + end module diff --git a/src/data_module.f b/src/data_module.f new file mode 100644 index 0000000..9713923 --- /dev/null +++ b/src/data_module.f @@ -0,0 +1,54 @@ + module data_module + + implicit none + + double precision,protected, dimension(:,:), allocatable :: q_m + double precision,protected, dimension(:,:), allocatable :: x1_m + double precision,protected, dimension(:,:), allocatable :: x2_m + double precision,protected, dimension(:,:), allocatable :: y_m + double precision,protected, dimension(:,:), allocatable :: wt_m + double precision,protected, dimension(:,:), allocatable :: ny_m + + contains + + !------------------------------ + + subroutine init_data(numdatpt,q,x1,x2,y,wt,ny) + + use dim_parameter, only: qn, ntot + + implicit none + + integer i,numdatpt + double precision q(qn,*) + double precision x1(qn,*) + double precision x2(qn,*) + double precision y(ntot,*) + double precision wt(ntot,*) + double precision ny(ntot,*) + + allocate(q_m(qn,numdatpt)) + allocate(x1_m(qn,numdatpt)) + allocate(x2_m(qn,numdatpt)) + allocate(y_m(ntot,numdatpt)) + allocate(wt_m(ntot,numdatpt)) + allocate(ny_m(ntot,numdatpt)) + + do i=1,numdatpt + q_m(1:qn,i)=q(1:qn,i) + x1_m(1:qn,i)=x1(1:qn,i) + x2_m(1:qn,i)=x2(1:qn,i) + y_m(1:ntot,i)=y(1:ntot,i) + wt_m(1:ntot,i)=wt(1:ntot,i) + ny_m(1:ntot,i)=ny(1:ntot,i) + enddo + + end subroutine + + !------------------------------ + + subroutine dealloc_data() + deallocate(q_m,x1_m,x2_m,y_m,wt_m,ny_m) + end subroutine + + end module data_module diff --git a/src/dim_parameter.f b/src/dim_parameter.f new file mode 100644 index 0000000..2df7a0b --- /dev/null +++ b/src/dim_parameter.f @@ -0,0 +1,36 @@ + module dim_parameter + use io_parameters,only: maxpar_keys + implicit none + integer,parameter :: max_ntot = 200 ,max_par = 600 + !Standard + integer :: qn,qn_read,ntot,numdatpt + integer :: nstat,ndiab,nci + !Fabian +! integer :: numdatpt +! integer,parameter :: qn=9,ntot=162,nstat=8,ndiab=22,nci=7 + + integer :: sets + integer, allocatable :: ndata(:) + logical :: hybrid, anagrad,lbfgs + integer :: lbfgs_corr + double precision :: facspread + logical :: log_convergence +! Weight Parameter + double precision :: wt_en2ci + double precision, allocatable :: wt_en(:),wt_ci(:) !< parameters for weightingroutine, nstat or ndiab long +! which coord to use for plotting + integer, allocatable :: plot_coord(:) + +! pst vector + integer pst(2,maxpar_keys) + +! thresholds for error calculation + double precision, allocatable :: rms_thr(:) + + contains + + subroutine dealloc_dim() + deallocate(ndata,wt_ci,wt_en,rms_thr,plot_coord) + end subroutine + + end module diff --git a/src/fit_MeX.f b/src/fit_MeX.f new file mode 100644 index 0000000..b77234b --- /dev/null +++ b/src/fit_MeX.f @@ -0,0 +1,500 @@ + module fit_mod + implicit none + contains + + +! > Routine to controll the genetic fitting algorithm + subroutine fit(q,x1,x2,y,frms,difper,wt,par,p_spread,mut, + > npar,p_act,seed,gtype,nset,nsel,chkpnt,old,iter,maxit, + $ micit,ny,filename) + use idxsrt_mod, only: idxsrt + use dim_parameter,only: qn,numdatpt,ntot + use init_mod,only: actinit + use write_mod,only: write_output +#ifdef mpi_version + use mpi +#endif + implicit none + +! MPI Variables +#ifdef mpi_version + integer ierror,my_rank,workernum,mpi_control_data(4) +#endif + +! Input variables (not changed within this subroutine). + double precision q(qn,numdatpt),x1(qn,numdatpt),x2(qn,numdatpt)!< coordinates/input values + double precision y(ntot,numdatpt),ny(ntot,numdatpt) !< Output/(energie and ci) values + double precision wt(ntot,numdatpt) !< weights + integer npar !< number of parameters + integer nset !< number of parameter sets + integer maxit !< maximum number of macroiterations + integer micit !< maximum number of microiterations (i.e. LM iterations) + + !Fabian 15.03.2022: Used for babies or parent generation + integer gtype!< type of random number generator --> is this ever really used?? + integer nsel !< number of parents selected for having babies + integer seed !< random seed for babies generation + double precision p_spread(npar) + double precision difper, mut + + !Fabian 15.03.2022: Used for checkfile + character(len=80) :: chkpnt + character(len=10) :: writer + integer iter + double precision old !< old rms + + !Fabian 15.03.2022: Used for wrout + character(len=80) filename + + !Fabian 15.03.2022: Used in parameter initialization + integer p_act(npar) !< array that contains info if a parameter is active or not == equivalent to ma in mrqmin + + +! Input/output variables (changed/updated within this subroutine) + double precision par(npar,nset) !< parameters + +! Output variables + double precision frms !< best rms after macro iteration + +! Internal variables + integer i +! logical conver, ldum !< logicals for checking if calculation is converged + logical ldum !< logicals for checking if calculation is converged + integer start + logical enough_parents + integer mfit !< number of active parameters + integer flag !< flag for write routine for fitting status(converged,maxiterationsreach,no convergence) + +! Fabian 12.04. These are automatic arrays, maybe make them allocated or static + integer idx(nset) !< array for sorting the parameter sets after their rms + double precision rms(nset) !< array that contains rms of all parameter sets + integer lauf !< counter for macroiteration + double precision newpar(npar,nset) !< temporary storage array before parents&babies + integer iact(npar) !< array pointing to the position of active parameters + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +#ifdef mpi_version + call MPI_Comm_rank(MPI_COMM_WORLD, my_rank, ierror) +#endif + + +!> Initialize mfit,iact + call actinit(p_act,iact,mfit,npar) + +#ifdef mpi_version + call bcastact(p_act,npar) + call MPI_Bcast(mfit, 1, MPI_INT, 0, MPI_COMM_WORLD,ierror) +#endif + + +!> Initialize rms vector + + rms=0.d0 + rms(1:nset)=1d10 + +!> Write number of the present iteration and increase start to iter, if it is a restarted fit + + if (iter.ne.1) then + write(6,*) 'Genetic restart, proceed with iteration', iter + endif + start=iter + +!> Start the genetic algorithm that consists of maxit macroiterations + + do lauf=start,maxit + + write(6,*) '' + write(6,'(150("#"))') + write(6,*) '' + write(6,'(''Iteration:'',i5)') lauf + + !ATTENTION: THIS SUBROUTINE IS THE PARALLIZED SECTION !!! + + !Perform optimization for the parameter sets of generation lauf + call fit_sets(lauf,nset,npar,par,rms, + $ p_act,mfit,micit) + + !------------------------------------------------------------------------- + + !Sort the rms vector and assign the set number to each rms + call idxsrt(rms,idx,nset) + + !write out sorted errors and indicate with which set each error was obtained + do i=1,nset + write(6,'(A8,I3,A8,F12.8,A8,I3)') 'Rank:', i,'RMS:', rms(i), + $ 'Set',idx(i) + enddo + + !write best rms onto the output variable frms + frms=rms(1) + +!------------------------------------------------------------------------- + + !Resort the parameter array sucht that the parameter sets with the lowest rms are listed first + newpar(1:npar,1:nset)=par(1:npar,idx(1:nset)) + par(1:npar,1:nset)=newpar(1:npar,1:nset) + +!------------------------------------------------------------------------- + + !Return if maximum number of macro iterations is reached + if (lauf.ge.maxit) return + +!------------------------------------------------------------------------- + + !Prepare next iteration of the genetic algorithm + + !Select the best parameter sets and sufficiently distinct sets as parents for the next iteration + !Note: After parents, the first nsel entries of par and rms contain the parents + !Note: However, rms is not strictly sorted after this (especially if the best parameter set were too similar) + call parents(par,rms,difper,npar,idx,nset,nsel,p_act,mfit + $ ,enough_parents) + + !Check for convergence of genetic algorithm, i.e. whether the generation of new parents leads to + !a decrease of the rms as well as sufficiently distinct parameter set; return if convergence is reached + ldum=conver(old,rms,idx,nsel) + +! initialize flag for write routine + flag=1 +! set converged flag for write routine + if (ldum) flag=2 +! write intermediate output + call write_output(q,x1,x2,y,wt,par,p_act,p_spread, + > nset,npar,flag,lauf) + + if (ldum) return +! call flush +! flush(6) + + !Check if there are enough parents for next macro iteration + if (enough_parents .eqv. .false.) then + write(6,*) "Warning: Found too few different parents + $ for next macroiteration, exit genetic algorithm" + exit + endif + + !Generate new parameter sets and proceed to the next iteration + call babies(par,p_spread,mut,npar,mfit,nset,nsel,iact, + $ seed,gtype) + iter=iter+1 + !------------------------------------------------------------------------- + + !write checkpoint: +! writer='write' +! call chkfile(chkpnt,par,npar,p_act,seed,gtype,nset,iter, +! & old,writer) + + !------------------------------------------------------------------------- + + enddo + + write(6,*) "Finished fit, return to main program" + + end subroutine + +C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + subroutine fit_sets(lauf,nset,npar,par,rms, + $ p_act,mfit,micit) + use dim_parameter,only: lbfgs + use marq_mod,only: mrqmin + use lbfgsb_mod,only: lbfgs_driver +#ifndef mpi_version + use omp_lib +#else + use mpi + integer ierror,my_rank + integer workernum +#endif +! Input variables + integer lauf !number of the current macroiteration + integer nset !number of parameter sets + integer npar !number of parameters + +!Input / output variables + double precision par(npar,nset) !< parameters + double precision rms(nset) !< array that contains rms of all parameter sets + +! Input variables (necessary solely for mrqmin) + integer p_act(npar) !< array that contains info if a parameter is active or not == equivalent to ma in mrqmin + integer mfit !< number of active parameters + integer micit ! number of microiterations + +! Internal variables in parallel section + double precision lrms !< rms for one parameter set + double precision lpar(npar) !array for one parameter set !Fabian 31.03.2022: New test to reduce sice of parameters + integer i,j + +! Internal variables for OpenMP + double precision startzeit,endzeit,start_totzeit,end_totzeit + integer thread_num +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + + !> ATTENTION: THIS IS THE PARALLIZED SECTION !!! + + !> Perform non-linear least squares fit for each parameter set: +#ifdef mpi_version +! write(*,*) 'mpi_version' + start_totzeit=MPI_Wtime() + call MPI_Comm_size(MPI_COMM_WORLD, workernum, ierror) + call workshare(workernum, par, rms, npar, nset) + end_totzeit=MPI_Wtime() +#else + start_totzeit=omp_get_wtime() +!$omp parallel do schedule(dynamic) +!$omp& default(shared) +!$omp& private(i,j,lpar,lrms,thread_num,startzeit,endzeit) + do i=lauf,nset +! > Fabian 15.03.2022: Variable for timing the duration of optimizing one parameter set + startzeit=omp_get_wtime() !Fabian + + !> Write the parameters and the initial rms for this set onto private variables + lpar(1:npar)=par(1:npar,i) + lrms=rms(i) + + !Fabian 05.04.2022: Here I could separate the active and inactive parameters and perform the LM optimization purely with the active params + !Fabian 05.04.2022: However, this would require to store the inactive parameter and the vector that decides if a variable is active onto a module since I need it in funcs then! + + + !> Levenberg-Marquardt-Optimization of the current parameter set + !Fabian 16.03.2022: This version might be MPI compatible since it contains purely of private variables + !Fabian 16.03.2022: Use this instead of the above, if the data is declared global via a module and pst is only then used when necessary! + + if(lbfgs) then + call lbfgs_driver(lpar,npar,p_act,mfit, + & lrms,micit,i) + else + call mrqmin(lpar,npar,p_act,mfit, + & lrms,micit,i) + endif + + !> Write the optimized parameters and the optimized rms back onto the arrays that collect all parameters and rms + par(1:npar,i)=lpar(1:npar) + rms(i)=lrms + + !> Fabian 15.03.2022: Some output for timing the duration of optimizing one parameter set + thread_num = omp_get_thread_num() + endzeit=omp_get_wtime() + write(6,*) 'Thread', thread_num ,'Time:', endzeit-startzeit + + !> Write output for the spezific set of parameters + write(6,99) i, rms(i), rms(i)*219474.69d0 + 99 format('Set:',i5,5x,'RMS:',g16.6,3x,'(',f16.6,' cm-1)') + + enddo +!$omp end parallel do + end_totzeit=omp_get_wtime() +#endif + write(6,*) 'Total time for Macroiteration: ' + > ,end_totzeit-start_totzeit + + write(6,*) 'Finished parallel fit for Iteration', lauf + + end subroutine + + +C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +C% SUBROUTINE PARENTS(...) +C% +C% subroutine to select the parent parameter sets according to their +C% RMS error +C% +C % variables: +C % par: parameter vector (double[npar,nset]) +C % rms: error for each set (double[nset]) +C % difper: +C % npar: number of parameters (int) +C % idx: sorted indeces according to rms(1..nset) (int[nset]) +C % nset: number of sets +C % nsel: number of selected parents +C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine parents(par,rms,difper,npar,idx,nset,nsel,p_act,mfit + $ ,enough_parents) + implicit none + integer i, j, k, nset, idx(nset), npar, nsel, p_act(npar), mfit + double precision par(npar,nset), dum(npar,nset), rms(nset), last + double precision thr + double precision difper, drms(nset) + integer dum_idx(nset), rank_parent(nsel) +! logical difchk + logical enough_parents + + thr=1.d-8 + dum=0.d0 + dum_idx = 0 + rank_parent = 0 + drms=0.d0 + +c write the best parameter set on the dummy + dum(1:npar,1)=par(1:npar,1) + dum_idx(1)=idx(1) + rank_parent(1) = 1 + !Choose exactly (beside the best parameter set) nsel-1 parameter sets as new parents and write them on dum + !These parents are selected according to the lowest possible rms AND sufficient dissimilarity + !to the overall best parameter sets + last=1.d14 + k=1 + do i=1,nset + if (difchk(dum,par(1:npar,i),difper,k,npar,p_act,mfit,nset)) + > then + k=k+1 + dum(1:npar,k)=par(1:npar,i) + drms(k)=rms(i) + dum_idx(k) = idx(i) + rank_parent(k) = i + endif + if (k.eq.nsel) exit + enddo + + !Terminate programm if too few parents are found + enough_parents=.true. + if(k.lt.nsel) then + enough_parents=.false. + endif + + !Copy the selected parent parameter sets back to the array par + do i=2,nsel + par(1:npar,i)=dum(1:npar,i) + rms(i)=drms(i) + enddo + + !Write out some information on the chosen parent parameter sets + write(6,*) 'nsel:', nsel + write(6,*) + write(6,*) 'Selected parents:' + do j=1,nsel + write(6,201) rank_parent(j), rms(j), dum_idx(j) + write(6,200) (par(k,j), k=1,npar) + enddo + 200 format('Par:',6g16.7) + 201 format('>>> Rank:',i5,' RMS:' ,g14.4,' set:',i5,' <<<' ) + +! call flush +! flush(6) + + end subroutine + +!---------------------------------------------------------------------- +! function to check whether new parameter set is sufficiently different +! from already selected sets: + logical function difchk(dum,par,difper,k,npar,p_act,mfit,nset) + implicit none + integer i, j, k, npar, p_act(npar), mfit,nset + double precision dum(npar,nset), par(npar), per, thr, difper + double precision epsilon + parameter(epsilon=1d-8) + +!.. this threshold specifies that parameter set must have an average +! difference of at least 1% with respect to any other selected set. + thr=1.d0-difper + if (thr.gt.0.99d0) thr=0.99d0 !avoids no difference + difchk=.true. + do i=1,k + per=0.d0 + !Calculate relative difference between between current set (par) and the already selected sets (dum) + do j=1,npar + if (p_act(j).ge.1) then !Added flexible value for p_act; Nicole 15.12.2022; only active parameters are counted + per=per+(min(dum(j,i),par(j))+epsilon) + $ /(max(dum(j,i),par(j))+epsilon) + endif + enddo + per=per/mfit !Modified Version that only active parameters are counted; Fabian 14.12.2021 + !Discard the current set if it is too similar to one already selected + if (per.gt.thr) then + difchk=.false. + return + endif + enddo + + end function + +!-------------------------------------------------------------------- +! subroutine to create the baby sets of parameters from the selected +! parent sets + subroutine babies(par,p_spread,mut,npar,mfit,nset,nsel,iact, + $ seed,gtype) + implicit none + +c functions + double precision rn !gets one random number + + integer i, j, k, npar, nset, nsel, mfit, iact(npar) + double precision par(npar,nset), p_spread(npar), mut, dum + + integer seed,gtype + + !loop over all dieing sets (only the nsel parent sets survive) + do i=nsel+1,nset + !loop over all active parameters + do j=1,mfit + !picking a random parameter set of the first nsel parent sets !(Fabian 16.03.2022: Add feature, to ensure that at least one baby is generated from each parent?) + k=int(rn(seed,gtype,0)*nsel)+1 !Fabian 08.04.2022: Even though seed isnt passed here, the rn call is dependent on the earlier initialized seed + !writing the j'th parameter of the selected parent set onto the j'th parameter of the i'th of the remaining sets (only the active parameters are copied) + !(Fabian 16.03.2022: This way, I recombinate a number of parents to new babies. However, recombination might not be good, if these parent sets are relatively distinct; maybe use only two parent sets for recombination?) + par(iact(j),i)=par(iact(j),k) + !select whether the j'th parameter of this new set is mutated !(Fabian 16.03.2022: Add feature, to ensure that at least one parameter is mutated?) + if (rn(seed,gtype,0).lt.mut) then + dum=rn(seed,gtype,0) - 0.5d0 + dum=dum*p_spread(iact(j)) + par(iact(j),i)=par(iact(j),i)*(1.d0+dum) + endif + enddo + enddo + end subroutine + +!----------------------------------------------------------------------- +! check convergence of genetic algorithm + function conver(old,rms,idx,nsel) + implicit none + integer i, j, nsel, idx(*), baby + double precision rms(*), new, old, thresh, percent, thrper + logical conver + + !Thresholds and initializiation + conver=.false. + thresh=old*1.d-3 + thrper=0.2d0 + +! Lets use all values in the selected subset: + j=nsel + baby=0 + +! Calculate average error for the nsel best parameter sets + new=0.d0 + do i=1,j + new=new+rms(i) + enddo + new=new/dble(j) + +! calculate the number of selected parent sets that were originally babies in the previous iteration + do i=1,nsel + if (idx(i).gt.nsel) baby=baby+1 + enddo +! calculate the percentage + percent=dble(baby)/dble(nsel) + +! some output + write(6,100) baby + write(6,101) new, j + write(6,*) + 100 format('Number of babies in chosen subsets:', i3) + 101 format('Average RMS error of chosen subsets:', g12.4, + $ ' / averaged values:', i4) + + write(6,110) percent*100.d0 + write(6,111) old, new, old-new + 110 format('Percent babies:',f6.1) + 111 format('Old RMS:',d12.4,' New RMS:',d12.4,' Diff:',d12.4) + + !Set convergence to true if + !1. too few previous babies are among the new parents + !2. or the average rms of the selected parents between the current & previous macro iteration is sufficiently small + conver=(percent.le.thrper).and.(abs(new-old).lt.thresh) + write(6,*) 'Convergence:', conver + + !Set average rms of this iteration to the comparison variable old for the next iteration + old=new + + end function + + end module fit_mod diff --git a/src/funcs.f b/src/funcs.f new file mode 100644 index 0000000..39583eb --- /dev/null +++ b/src/funcs.f @@ -0,0 +1,132 @@ + module funcs_mod + implicit none + logical,parameter:: dbg =.false. + double precision, parameter:: thr_grad_diff = 1.d-3 + contains + + subroutine funcs(n,p,ymod,dymod,npar,p_act,skip) +! use dim_parameter,only:ntot,ndiab,anagrad + use dim_parameter,only:ntot,ndiab,anagrad,nstat,nci !Fabian + use data_module,only: x1_m + use adia_mod,only: adia +! In variables + integer n, npar, p_act(npar) + double precision ymod(ntot) + double precision p(npar) + logical skip +! out variables + double precision dymod(ntot,npar) + double precision dum_dymod(ntot,npar) + logical diff(ntot,npar) +! internal varibales + double precision ew(ndiab),ev(ndiab,ndiab) ! eigenvalues(ew) and eigenvectors(ev) + integer i,j + logical,parameter:: dbg =.false. + + skip=.false. + diff=.false. +! get adiabatic energies: + call adia(n,p,npar,ymod,ew,ev,skip) + if(skip) return + + if(eigchk(ew,nci)) then !Fabian: since pseudo-inverse is only calculated for first nci eigenvalues and their ci-vectors, if changed the check to nci + dymod = 0.d0 + if(dbg) write(6,*)'funcs skipping point,n: ',n + return + endif +! compute gradient with respect to parameter vector: + if(anagrad) then + write(6,*) 'ERROR: NOT SUPPORTED.' + stop + else +! compute gradients numerically + call num_grad(dymod,n,p,npar,p_act,skip) + endif + end subroutine + +!---------------------------------------------------------------------- +! compute gradient of adiabatic energies nummerically with respect to parameters: + subroutine num_grad(dymod,n,p,npar,p_act,skip) + use dim_parameter,only: ntot,ndiab + use adia_mod,only: adia + integer n, i, j, npar + integer p_act(npar) + double precision ymod(ntot), dymod(ntot,npar), p(npar) + double precision dp(npar) + logical skip + double precision ew(ndiab),ev(ndiab,ndiab) +! determine finite differences for each parameter: + call pdiff(p,dp,npar) + +! generate numerical gradients for all parameters individually + do i=1,npar + + do j=1,ntot + dymod(j,i)=0.d0 + enddo + +! calculate gradient for active parameter, for inactive parameter gradient is always zero +! Nicole: added flexible value of p_act + if (p_act(i).ge.1) then + +! change parameter in forward direction + p(i)=p(i)+dp(i) + call adia(n,p,npar,ymod,ew,ev,skip) + if (skip) then + p(i)=p(i)-dp(i) + return + endif + do j=1,ntot + dymod(j,i)=ymod(j) + enddo + +! change parameter in backward direction + p(i)=p(i)-2.d0*dp(i) + call adia(n,p,npar,ymod,ew,ev,skip) + if (skip) then + p(i)=p(i)+2.d0*dp(i) + return + endif + do j=1,ntot + dymod(j,i)=(dymod(j,i)-ymod(j))/(2.d0*dp(i)) !Form symmetric difference quotient + enddo + +! restore original parameter + p(i)=p(i)+dp(i) + endif + enddo + end subroutine num_grad +!---------------------------------------------------------------------- +! determine appropriate finite differences for each parameter: + subroutine pdiff(p,dp,npar) + integer i, npar + double precision p(npar), dp(npar) +! double precision, parameter :: d = 1.d-4 + double precision, parameter :: d = 1.d-6 !Standard +! double precision, parameter :: d = 1.d-8 + double precision, parameter :: thr = 1.d-12 + do i=1,npar + dp(i)=abs(p(i)*d) + if (dp(i).lt.thr) dp(i)=thr + enddo + end subroutine pdiff + +!-------------------------------------------------------------------------------------- +!.. check vector of eigenvalues for (near) degeneragies + logical function eigchk(v,n) +!.. on input: + integer n + double precision v(n) +!.. local variables: + double precision thr + parameter (thr=1.d-8) !threshold for degeneracy + integer j + eigchk=.false. + do j=1,n-1 + if (abs((v(j+1)-v(j))).lt.thr) then + eigchk=.true. + return + endif + enddo + end function eigchk + end module funcs_mod diff --git a/src/genetic.f b/src/genetic.f new file mode 100644 index 0000000..17b2648 --- /dev/null +++ b/src/genetic.f @@ -0,0 +1,163 @@ + program genetic +! module for dimensioning parameters + use dim_parameter,only: qn,ntot,numdatpt,dealloc_dim + !data module + use data_module, only: init_data, dealloc_data +! parser module + use parser, only: les +! matrix derivatives module +! use matrix_derivatives, only: dealloc_dw_ptr +! monome module +! use monome_module, only: dealloc_vwzprec +! diab3D precalculate module +! use diab3D_precalculate, only: dealloc_diab3D +! parameter initialization module + use init_mod,only: rinit,pinit +! fitting module + use fit_mod,only: fit +! writing module + use write_mod,only: write_output +! MPI module +#ifdef mpi_version + use mpi +#endif + + implicit none + +! Declare Variables +! MPI variables +#ifdef mpi_version + integer my_rank,ierror,threadnum,stopnum,ping(8),i +#endif +! Data variables + double precision, allocatable :: q_in(:,:),x1_in(:,:),x2_in(:,:) + double precision, allocatable :: y_in(:,:),wt_in(:,:) +! Fiting Model Parameters + double precision, allocatable :: p(:),par(:,:) !< vector(npar) for the values of read parameters + integer, allocatable :: p_act(:) !< vector(npar) containing 0 or 1 defining if corresponding parameters are activ in Fit + double precision, allocatable :: p_spread(:),prange(:,:) !< vector(npar) for the spread values for each parameter + integer npar !< read length of parameter arrays +! Fit control Parameters + integer seed !< Seed for RNG + integer nset !< number of diffrent parameter sets + logical freeze !< determines if parameters are active + double precision mut, difper !< percentage of selected Parents, number of mutations in parents, minimum diffrence between selected parents + integer nsel !< number of selected parameter sets for parents + integer gtype !< type of RNG used + integer maxit, micit ! seed,gtype,nset,maxit,micit,nsel,mut,difper,freeze) + + allocate(par(npar,nset),prange(2,npar)) + allocate(x1_in(qn,numdatpt),x2_in(qn,numdatpt)) + + call rinit(p,prange,p_spread,p_act,npar) + par=0.d0 + par(1:npar,1)=p(1:npar) + call pinit(par,prange,npar,nset,seed,gtype) + + +!------------------------------------------------- + call data_transform(q_in,x1_in,x2_in,y_in,wt_in,p,npar,p_act) + !Fabian: Read data into module + call init_data(numdatpt,q_in,x1_in,x2_in,y_in,wt_in,y_in) + +!------------------------------------------------- +#ifdef mpi_version + if(my_rank.eq.0) then +#endif + call write_output(q_in,x1_in,x2_in,y_in,wt_in,par,p_act,p_spread, + > nset,npar,0,0) +#ifdef mpi_version + endif +#endif + + !------------------------------------------------- + + !Fabian: THIS IS THE PLACE WHERE MY ROUTINES START THERE EXECUTION + !Fabian: We should either include these into Maiks routines or remove it from the fitting routines + chkpnt='test' + filename='test2' + old=1.e+5 + iter=1 + + +#ifdef mpi_version + if(my_rank.eq.0) then +#endif + if(.not.freeze) then + call fit(q_in,x1_in,x2_in,y_in,rms,difper,wt_in, + $ par,p_spread,mut,npar,p_act, + $ seed,gtype,nset,nsel,chkpnt,old,iter, + $ maxit,micit,y_in, + $ filename) + endif +#ifdef mpi_version + else + call mpi_rest_control(micit,npar) + endif +#endif + +#ifdef mpi_version + if(my_rank.eq.0) then +#endif + call write_output(q_in,x1_in,x2_in,y_in,wt_in,par,p_act,p_spread, + > nset,npar,1,iter) +#ifdef mpi_version + endif +#endif + +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +! Final cleanup of programm (quit MPI, deallocate data, etc.) + +#ifdef mpi_version + if(my_rank.eq.0) then + call MPI_Comm_size(MPI_COMM_WORLD,threadnum,ierror) + stopnum = 0 + do i = 1,threadnum-1 + call MPI_Send(stopnum, 1, MPI_INTEGER, + $ i, 69, MPI_COMM_WORLD, ping, ierror) + enddo + call MPI_Barrier(MPI_COMM_WORLD, ierror) + endif +#endif + + deallocate(q_in,x1_in,x2_in,y_in,wt_in, + $ p,par,p_act,p_spread,prange) + call dealloc_data + call dealloc_dim +! call dealloc_dw_ptr +! call dealloc_vwzprec +! call dealloc_diab3D + +#ifdef mpi_version + call MPI_Barrier(MPI_COMM_WORLD, ierror) + call MPI_Finalize(ierror) +#endif + + + end program diff --git a/src/idxsrt_mod.f b/src/idxsrt_mod.f new file mode 100644 index 0000000..b9f5d21 --- /dev/null +++ b/src/idxsrt_mod.f @@ -0,0 +1,35 @@ + module idxsrt_mod + implicit none + contains +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! % SUBROUTINE IDXSRT(...) +! % +! % indices are sorted by ascending values of x, that means if you go +! % throug x(idx(1..n)) from one to n, you will get an list of growing +! % values +! % +! % variables: +! % idx: indeces which are going to be sorted(int[n]) +! % n: number of indices (int) +! % x: array of values (real[n])) +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine idxsrt(x,idx,n) + integer i, j, k, n, idx(n) + double precision x(n), dum + do i=1,n + idx(i)=i + enddo + do i=1,n + do j=i+1,n + if (x(j).lt.x(i)) then + dum=x(i) + x(i)=x(j) + x(j)=dum + k=idx(i) + idx(i)=idx(j) + idx(j)=k + endif + enddo + enddo + end subroutine idxsrt + end module idxsrt_mod diff --git a/src/init.f b/src/init.f new file mode 100644 index 0000000..69962a5 --- /dev/null +++ b/src/init.f @@ -0,0 +1,107 @@ + module init_mod + implicit none + contains + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!% SUBROUTINE RINIT +!% +!% Subroutine to define the allowed range for each parameter: +!% for the moment this is a distribution around zero with a given width +!% for each parameter +!% +!% Input variables: +!% par: Parameter vectot (double[]) +!% spread: Spread of each parameter (double[]) +!% ma: Active cards for every parameter (int[]) +!% npar: Number of Parameters +!% +!% Output variables +!% prange: Spread interval vector (double[]) +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine rinit(par,prange,p_spread,p_act,npar) + implicit none + integer i,npar,p_act(npar) + double precision par(npar), prange(2,npar), p_spread(npar),de,dum + !minimum absolute spread + double precision minspread + parameter(minspread=1.d-4) + + do i=1,npar + if (abs(p_act(i)).eq.0) p_spread(i)=0.d0 + dum=par(i) + if (abs(dum).lt.1.d-6) dum=minspread + de=abs(dum*p_spread(i)/2.d0) + prange(1,i)=par(i)-de + prange(2,i)=par(i)+de + enddo + + end subroutine + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!% SUBROUTINE PINIT(...) +!% +!% subroutine to initialize the nset parameter sets with random +!% numbers in the range defined by prange +!% +!% Input Variables: +!% par: parameter vector (double[]) +!% prange: Spread interval vector (double[]) +!% npar: number of parameters (int) +!% nset: number of sets (int) +!% seed: seed for random.f (int) +!% gtype: selects random number generator (int) +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine pinit(par,prange,npar,nset,seed,gtype) + implicit none + + integer i, j, npar, nset, seed, gtype,cont + double precision par(npar,nset), prange(2,npar), rn, dum + +!.. initialize new random number stream: + cont=1 + dum=rn(seed,gtype,cont) + +!.. create all the parameter sets by random numbers + !continue with the initialized random number stream + cont=0 + do i=2,nset + do j=1,npar + par(j,i)=prange(1,j)+rn(seed,gtype,cont) * + $ (prange(2,j)-prange(1,j)) + enddo + enddo + end subroutine + + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!% SUBROUTINE ACTINIT(...) +!% +!% subroutine to select the active parameters and assign their indices +!% +!% Input Variables: +!% p_act: vector of active cards +!% npar: total number of parameters +!% +!% Output Variables: +!% iact: list of active parameters +!% mfit: number of active parameters +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine actinit(p_act,iact,mfit,npar) + implicit none + + integer i, npar, p_act(npar), iact(npar), mfit + + mfit=0 + iact=0 + do i=1,npar +! Nicole: added flexible value of p_act + if (p_act(i).ge.1) then + mfit=mfit+1 + iact(mfit)=i + endif + enddo + + end subroutine + + end module init_mod diff --git a/src/lbfgsb.f b/src/lbfgsb.f new file mode 100644 index 0000000..b803459 --- /dev/null +++ b/src/lbfgsb.f @@ -0,0 +1,4808 @@ + module lbfgsb_mod + contains + + subroutine lbfgs_driver(par,npar,p_act,mfit,rms,micit,set) + use dim_parameter,only: lbfgs_corr, log_convergence + implicit none + + !Input variables + integer npar !Number of parameters + double precision par(npar) !Parameters + integer p_act(npar) !Decider if parameter is active or inactive + integer mfit !Number of active parameters + double precision rms !root mean square + integer micit !number of maximum micro iterations + integer set !number of current set + + !Internals + double precision beta(npar) !beta = J^T * dy with dy = y_in - y_mod + double precision chisq,ochisq,dum + logical skip + integer i + + !Variables regarding the LBFGS + + integer nmax, mmax !nmax= maximum parameter number; mmax= maximum number of limited memory corrections + parameter (nmax=1024, mmax=100) !Fabian TO-DO: Add them to the global variables on a module + + character*60 task, csave + logical lsave(4) + integer n, m, iprint, + + nbd(nmax), iwa(3*nmax), isave(44) + double precision f, factr, pgtol, + + x(nmax), l(nmax), u(nmax), g(nmax), dsave(29), + + wa(2*mmax*nmax + 5*nmax + 11*mmax*mmax + 8*mmax) + + + !Added by fabian + double precision x_prev(nmax) + double precision scale + character*80 file_name + integer id_plot + + if(npar.gt.nmax) then + write(6,*) 'In lbfgs: npar:',npar,' exceeds nmax:',nmax + stop + endif + + !Decide which level of output is desired (see setulb for further description) +! iprint = 101 !maximum level of output at each iteration +! iprint = 0 !some output at end of the last iteration + iprint = -1 !no output at all + + !Tolerances in LBFGS-supplied stopping criteria + !(currently inactive, since we use our own stopping criteria that are analogous to those from Levenberg-Marquardt) + factr=0.d0 + pgtol=0.d0 + + !Specify the dimension of our optimization problem and the number of limited memory corrections + n=npar + m=lbfgs_corr + + if(m.gt.mmax) then + write(6,*) 'In lbfgs: m:',m,' exceeds mmax:',mmax + stop + endif + + !Set boundaries on variables (l=lower bound,u=upper bound) + nbd=0 + l=0.d0 + u=0.d0 + do i=1,npar + !inactive parameter + if (p_act(i).eq.0) then + nbd(i)=2 + l(i)=par(i) + u(i)=par(i) + !active parameter + else + nbd(i)=0 + endif + enddo + + !Init parameter vector as well as some work arrays + wa=0.d0 + iwa=0 + x=0.d0 + do i=1,npar + x(i)=par(i) + enddo + + !Fabian Test: Try to scale f and g + scale=1.d0 + + !Init ochisq + call lbfgs_values(x(1:npar),n,p_act,mfit,beta,chisq,skip) + ochisq=chisq*scale + +! Termination if micit=0, i.e. only genetic algorithm and no LBFGS-B optimization + if (micit.eq.0) then + rms=dsqrt(chisq/scale) + return + endif + + !Fabian: Init x_prev which has been added for tracking the stepsizes in parameter space for debugging purposes + x_prev=0.d0 + do i=1,npar + x_prev(i)=x(i) + enddo + + !Open logging file + if(log_convergence) then + id_plot=6666+set + write (file_name,"('conv_bfgs_set',i0,'.dat')") set + open(id_plot,file=trim(file_name),action='write') + write (id_plot,69) + 69 format ('#LBFGS',/, + + '#it = iteration number',/, + + '#nf = number of function evaluations',/, + + '#stepl = step length used',/, + + '#tstep = norm of the displacement (total step)',/, + + '#projg = norm of the projected gradient',/, + + '#f = function value') + write (id_plot,123) + 123 format ('#',3x,'it',3x,'nf',3x,'stepl',4x,'pstep',5x, + $ 'projg',8x,'f') + endif + + !TO-DO: Add zeroth iteration to get initial error + + +c ATTENTION: Now the LBFGS algorithm starts its execution, do not touch unless you are familiar with the underlying code + +c We start the LBFGS iteration by initializing task. +c + task = 'START' + +c ------- the beginning of the loop ---------- + + 111 continue + +c This is the call to the L-BFGS-B code. + + call setulb(n,m,x,l,u,nbd,f,g,factr,pgtol,wa,iwa,task,iprint, + + csave,lsave,isave,dsave) + + if (task(1:2) .eq. 'FG') then + +c the minimization routine has returned to request the +c function f and gradient g values at the current x. + + !Get function value + call lbfgs_values(x(1:npar),n,p_act,mfit,beta,chisq,skip) + f = chisq*scale + +c Compute gradient g for the sample problem. + g=0.d0 + do i=1,npar + g(i)=-1.d0*scale*beta(i)!-1 since beta = J^T * dy with dy = y_in - y_mod + enddo + +c go back to the minimization routine. + goto 111 + + endif + + + if (task(1:5) .eq. 'NEW_X') then + + !Update x_prev to the new x + do i=1,npar + x_prev(i)=x(i) + enddo + + !Write logging information + if(log_convergence) then + write(id_plot,124) isave(30),isave(34),dsave(14), + $ dsave(4)*dsave(14),sum(g**2),f + 124 format(1x,2(1x,i4),1p,2(2x,e8.1),1p,2(1x,e10.3)) + endif + + !Termination conditions as in Levenberg-Marquardt + if (isave(34) .ge. micit) then !TO-DO: Maybe replace by isave(30) = iteration number! + task='STOP: TOTAL NO. of f AND g EVALUATIONS EXCEEDS LIMIT' + write(6,'(''Warning: lbfgsb not converged!'')') + endif + + if (isave(36) .ge. 25) then + task='STOP: 25 consecutive non accepted steps!' + write(6,*) 'Warning: 25 consecutive non accepted steps!' + endif + + if (f.gt.1.d3) then + task='STOP: chi^2 unreasonable' + write(6,*) 'chi^2 unreasonable!',f,isave(34) + endif + +! if(dsave(13).lt.1.d-6) then !dsave(13) is maximum of gradient not the norm of the step!!! + if(dsave(4)*dsave(14).lt.1.d-6) then + task='STOP: change of parameters converged' + write(6,*) 'change of parameters converged',dsave(13), + $ isave(34) + endif + + dum=max(f,ochisq)/min(f,ochisq) - 1.d0 + if(dum.lt.1.d-4.and.isave(34).gt.1) then + task='STOP: change of chi^2 converged' + write(6,*) 'change of chi^2 converged',dum,isave(34) + endif + + !Overwrite optimal error and return to lbfgs code + if(f.lt.ochisq) ochisq=f + goto 111 + + endif + +c the minimization routine has returned with a new iterate, +c and we have opted to continue the iteration. + +c ---------- the end of the loop ------------- + +c If task is neither FG nor NEW_X we terminate execution. + +c ATTENTION: Now the LBFGS algorithm has finished, prepare your output variables + + rms=sqrt(f/scale) + do i=1,npar + par(i)=x(i) + enddo + + if(log_convergence) close(id_plot) + + end subroutine lbfgs_driver + + +!########################################################################################### + + + subroutine lbfgs_values(par,npar,p_act,mfit,beta,chisq,skip) + use dim_parameter, only: ntot,qn,numdatpt,nstat,hybrid + use data_module, only: x1_m,x2_m,y_m,wt_m,ny_m + use funcs_mod,only: funcs + implicit none + + integer npar + double precision par(npar) + integer p_act(npar) + integer mfit + + double precision beta(npar) + double precision chisq + logical skip + + double precision ymod(ntot) !< fitted datapoints (for one geometry) + double precision dy(ntot) !< difference between ab-initio and fitted datapoints + double precision dyda(ntot,npar) !gradient of datapoints (for one geometry) with respect to the parameters + + integer i,l,n !< iteration variables + + skip=.false. + beta=0.d0 + chisq=0.d0 + + do i=1,numdatpt + + call funcs(i,par,ymod,dyda,npar,p_act,skip) + if (skip) return + + if(hybrid) then + + do n=1,ntot + dy(n)=y_m(n,i)-ymod(n) + do l=1,npar + beta(l)=beta(l)+ !(wt*J)^T*(wt*delta_y) + $ (dy(n)*dyda(n,l))*(wt_m(n,i)*wt_m(n,i)) + enddo + chisq=chisq+(dy(n)*dy(n))*(wt_m(n,i)*wt_m(n,i)) + enddo + + else + + do n=1,nstat + dy(n)=y_m(n,i)-ymod(n) + do l=1,npar + beta(l)=beta(l)+ !(wt*J)^T*(wt*delta_y) + $ (dy(n)*dyda(n,l))*(wt_m(n,i)*wt_m(n,i)) + enddo + chisq=chisq+(dy(n)*dy(n))*(wt_m(n,i)*wt_m(n,i)) + enddo + + endif + + enddo + + end subroutine lbfgs_values + + +!########################################################################################### + +! THE FOLLOWING CODE IS A COPY OF THE LBFGS-B Algorithm from Nocedal et al. + +!########################################################################################### + + +c +c L-BFGS-B is released under the “New BSD License” (aka “Modified BSD License” +c or “3-clause license”) +c Please read attached file License.txt +c +c=========== L-BFGS-B (version 3.0. April 25, 2011 =================== +c +c This is a modified version of L-BFGS-B. Minor changes in the updated +c code appear preceded by a line comment as follows +c +c c-jlm-jn +c +c Major changes are described in the accompanying paper: +c +c Jorge Nocedal and Jose Luis Morales, Remark on "Algorithm 778: +c L-BFGS-B: Fortran Subroutines for Large-Scale Bound Constrained +c Optimization" (2011). To appear in ACM Transactions on +c Mathematical Software, +c +c The paper describes an improvement and a correction to Algorithm 778. +c It is shown that the performance of the algorithm can be improved +c significantly by making a relatively simple modication to the subspace +c minimization phase. The correction concerns an error caused by the use +c of routine dpmeps to estimate machine precision. +c +c The total work space **wa** required by the new version is +c +c 2*m*n + 11m*m + 5*n + 8*m +c +c the old version required +c +c 2*m*n + 12m*m + 4*n + 12*m +c +c +c J. Nocedal Department of Electrical Engineering and +c Computer Science. +c Northwestern University. Evanston, IL. USA +c +c +c J.L Morales Departamento de Matematicas, +c Instituto Tecnologico Autonomo de Mexico +c Mexico D.F. Mexico. +c +c March 2011 +c +c============================================================================= + subroutine setulb(n, m, x, l, u, nbd, f, g, factr, pgtol, wa, iwa, + + task, iprint, csave, lsave, isave, dsave) + + character*60 task, csave + logical lsave(4) + integer n, m, iprint, + + nbd(n), iwa(3*n), isave(44) + double precision f, factr, pgtol, x(n), l(n), u(n), g(n), +c +c-jlm-jn + + wa(2*m*n + 5*n + 11*m*m + 8*m), dsave(29) + +c ************ +c +c Subroutine setulb +c +c This subroutine partitions the working arrays wa and iwa, and +c then uses the limited memory BFGS method to solve the bound +c constrained optimization problem by calling mainlb. +c (The direct method will be used in the subspace minimization.) +c +c n is an integer variable. +c On entry n is the dimension of the problem. +c On exit n is unchanged. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric corrections +c used to define the limited memory matrix. +c On exit m is unchanged. +c +c x is a double precision array of dimension n. +c On entry x is an approximation to the solution. +c On exit x is the current approximation. +c +c l is a double precision array of dimension n. +c On entry l is the lower bound on x. +c On exit l is unchanged. +c +c u is a double precision array of dimension n. +c On entry u is the upper bound on x. +c On exit u is unchanged. +c +c nbd is an integer array of dimension n. +c On entry nbd represents the type of bounds imposed on the +c variables, and must be specified as follows: +c nbd(i)=0 if x(i) is unbounded, +c 1 if x(i) has only a lower bound, +c 2 if x(i) has both lower and upper bounds, and +c 3 if x(i) has only an upper bound. +c On exit nbd is unchanged. +c +c f is a double precision variable. +c On first entry f is unspecified. +c On final exit f is the value of the function at x. +c +c g is a double precision array of dimension n. +c On first entry g is unspecified. +c On final exit g is the value of the gradient at x. +c +c factr is a double precision variable. +c On entry factr >= 0 is specified by the user. The iteration +c will stop when +c +c (f^k - f^{k+1})/max{|f^k|,|f^{k+1}|,1} <= factr*epsmch +c +c where epsmch is the machine precision, which is automatically +c generated by the code. Typical values for factr: 1.d+12 for +c low accuracy; 1.d+7 for moderate accuracy; 1.d+1 for extremely +c high accuracy. +c On exit factr is unchanged. +c +c pgtol is a double precision variable. +c On entry pgtol >= 0 is specified by the user. The iteration +c will stop when +c +c max{|proj g_i | i = 1, ..., n} <= pgtol +c +c where pg_i is the ith component of the projected gradient. +c On exit pgtol is unchanged. +c +c wa is a double precision working array of length +c (2mmax + 5)nmax + 12mmax^2 + 12mmax. +c +c iwa is an integer working array of length 3nmax. +c +c task is a working string of characters of length 60 indicating +c the current job when entering and quitting this subroutine. +c +c iprint is an integer variable that must be set by the user. +c It controls the frequency and type of output generated: +c iprint<0 no output is generated; +c iprint=0 print only one line at the last iteration; +c 0100 print details of every iteration including x and g; +c When iprint > 0, the file iterate.dat will be created to +c summarize the iteration. +c +c csave is a working string of characters of length 60. +c +c lsave is a logical working array of dimension 4. +c On exit with 'task' = NEW_X, the following information is +c available: +c If lsave(1) = .true. then the initial X has been replaced by +c its projection in the feasible set; +c If lsave(2) = .true. then the problem is constrained; +c If lsave(3) = .true. then each variable has upper and lower +c bounds; +c +c isave is an integer working array of dimension 44. +c On exit with 'task' = NEW_X, the following information is +c available: +c isave(22) = the total number of intervals explored in the +c search of Cauchy points; +c isave(26) = the total number of skipped BFGS updates before +c the current iteration; +c isave(30) = the number of current iteration; +c isave(31) = the total number of BFGS updates prior the current +c iteration; +c isave(33) = the number of intervals explored in the search of +c Cauchy point in the current iteration; +c isave(34) = the total number of function and gradient +c evaluations; +c isave(36) = the number of function value or gradient +c evaluations in the current iteration; +c if isave(37) = 0 then the subspace argmin is within the box; +c if isave(37) = 1 then the subspace argmin is beyond the box; +c isave(38) = the number of free variables in the current +c iteration; +c isave(39) = the number of active constraints in the current +c iteration; +c n + 1 - isave(40) = the number of variables leaving the set of +c active constraints in the current iteration; +c isave(41) = the number of variables entering the set of active +c constraints in the current iteration. +c +c dsave is a double precision working array of dimension 29. +c On exit with 'task' = NEW_X, the following information is +c available: +c dsave(1) = current 'theta' in the BFGS matrix; +c dsave(2) = f(x) in the previous iteration; +c dsave(3) = factr*epsmch; +c dsave(4) = 2-norm of the line search direction vector; +c dsave(5) = the machine precision epsmch generated by the code; +c dsave(7) = the accumulated time spent on searching for +c Cauchy points; +c dsave(8) = the accumulated time spent on +c subspace minimization; +c dsave(9) = the accumulated time spent on line search; +c dsave(11) = the slope of the line search function at +c the current point of line search; +c dsave(12) = the maximum relative step length imposed in +c line search; +c dsave(13) = the infinity norm of the projected gradient; +c dsave(14) = the relative step length in the line search; +c dsave(15) = the slope of the line search function at +c the starting point of the line search; +c dsave(16) = the square of the 2-norm of the line search +c direction vector. +c +c Subprograms called: +c +c L-BFGS-B Library ... mainlb. +c +c +c References: +c +c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited +c memory algorithm for bound constrained optimization'', +c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. +c +c [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: a +c limited memory FORTRAN code for solving bound constrained +c optimization problems'', Tech. Report, NAM-11, EECS Department, +c Northwestern University, 1994. +c +c (Postscript files of these papers are available via anonymous +c ftp to eecs.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.) +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ +c-jlm-jn + integer lws,lr,lz,lt,ld,lxp,lwa, + + lwy,lsy,lss,lwt,lwn,lsnd + + if (task .eq. 'START') then + isave(1) = m*n + isave(2) = m**2 + isave(3) = 4*m**2 + isave(4) = 1 ! ws m*n + isave(5) = isave(4) + isave(1) ! wy m*n + isave(6) = isave(5) + isave(1) ! wsy m**2 + isave(7) = isave(6) + isave(2) ! wss m**2 + isave(8) = isave(7) + isave(2) ! wt m**2 + isave(9) = isave(8) + isave(2) ! wn 4*m**2 + isave(10) = isave(9) + isave(3) ! wsnd 4*m**2 + isave(11) = isave(10) + isave(3) ! wz n + isave(12) = isave(11) + n ! wr n + isave(13) = isave(12) + n ! wd n + isave(14) = isave(13) + n ! wt n + isave(15) = isave(14) + n ! wxp n + isave(16) = isave(15) + n ! wa 8*m + endif + lws = isave(4) + lwy = isave(5) + lsy = isave(6) + lss = isave(7) + lwt = isave(8) + lwn = isave(9) + lsnd = isave(10) + lz = isave(11) + lr = isave(12) + ld = isave(13) + lt = isave(14) + lxp = isave(15) + lwa = isave(16) + + call mainlb(n,m,x,l,u,nbd,f,g,factr,pgtol, + + wa(lws),wa(lwy),wa(lsy),wa(lss), wa(lwt), + + wa(lwn),wa(lsnd),wa(lz),wa(lr),wa(ld),wa(lt),wa(lxp), + + wa(lwa), + + iwa(1),iwa(n+1),iwa(2*n+1),task,iprint, + + csave,lsave,isave(22),dsave) + + return + + end subroutine + +c======================= The end of setulb ============================= + + subroutine mainlb(n, m, x, l, u, nbd, f, g, factr, pgtol, ws, wy, + + sy, ss, wt, wn, snd, z, r, d, t, xp, wa, + + index, iwhere, indx2, task, + + iprint, csave, lsave, isave, dsave) + implicit none + character*60 task, csave + logical lsave(4) + integer n, m, iprint, nbd(n), index(n), + + iwhere(n), indx2(n), isave(23) + double precision f, factr, pgtol, + + x(n), l(n), u(n), g(n), z(n), r(n), d(n), t(n), +c-jlm-jn + + xp(n), + + wa(8*m), + + ws(n, m), wy(n, m), sy(m, m), ss(m, m), + + wt(m, m), wn(2*m, 2*m), snd(2*m, 2*m), dsave(29) + +c ************ +c +c Subroutine mainlb +c +c This subroutine solves bound constrained optimization problems by +c using the compact formula of the limited memory BFGS updates. +c +c n is an integer variable. +c On entry n is the number of variables. +c On exit n is unchanged. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric +c corrections allowed in the limited memory matrix. +c On exit m is unchanged. +c +c x is a double precision array of dimension n. +c On entry x is an approximation to the solution. +c On exit x is the current approximation. +c +c l is a double precision array of dimension n. +c On entry l is the lower bound of x. +c On exit l is unchanged. +c +c u is a double precision array of dimension n. +c On entry u is the upper bound of x. +c On exit u is unchanged. +c +c nbd is an integer array of dimension n. +c On entry nbd represents the type of bounds imposed on the +c variables, and must be specified as follows: +c nbd(i)=0 if x(i) is unbounded, +c 1 if x(i) has only a lower bound, +c 2 if x(i) has both lower and upper bounds, +c 3 if x(i) has only an upper bound. +c On exit nbd is unchanged. +c +c f is a double precision variable. +c On first entry f is unspecified. +c On final exit f is the value of the function at x. +c +c g is a double precision array of dimension n. +c On first entry g is unspecified. +c On final exit g is the value of the gradient at x. +c +c factr is a double precision variable. +c On entry factr >= 0 is specified by the user. The iteration +c will stop when +c +c (f^k - f^{k+1})/max{|f^k|,|f^{k+1}|,1} <= factr*epsmch +c +c where epsmch is the machine precision, which is automatically +c generated by the code. +c On exit factr is unchanged. +c +c pgtol is a double precision variable. +c On entry pgtol >= 0 is specified by the user. The iteration +c will stop when +c +c max{|proj g_i | i = 1, ..., n} <= pgtol +c +c where pg_i is the ith component of the projected gradient. +c On exit pgtol is unchanged. +c +c ws, wy, sy, and wt are double precision working arrays used to +c store the following information defining the limited memory +c BFGS matrix: +c ws, of dimension n x m, stores S, the matrix of s-vectors; +c wy, of dimension n x m, stores Y, the matrix of y-vectors; +c sy, of dimension m x m, stores S'Y; +c ss, of dimension m x m, stores S'S; +c yy, of dimension m x m, stores Y'Y; +c wt, of dimension m x m, stores the Cholesky factorization +c of (theta*S'S+LD^(-1)L'); see eq. +c (2.26) in [3]. +c +c wn is a double precision working array of dimension 2m x 2m +c used to store the LEL^T factorization of the indefinite matrix +c K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c +c where E = [-I 0] +c [ 0 I] +c +c snd is a double precision working array of dimension 2m x 2m +c used to store the lower triangular part of +c N = [Y' ZZ'Y L_a'+R_z'] +c [L_a +R_z S'AA'S ] +c +c z(n),r(n),d(n),t(n), xp(n),wa(8*m) are double precision working arrays. +c z is used at different times to store the Cauchy point and +c the Newton point. +c xp is used to safeguard the projected Newton direction +c +c sg(m),sgo(m),yg(m),ygo(m) are double precision working arrays. +c +c index is an integer working array of dimension n. +c In subroutine freev, index is used to store the free and fixed +c variables at the Generalized Cauchy Point (GCP). +c +c iwhere is an integer working array of dimension n used to record +c the status of the vector x for GCP computation. +c iwhere(i)=0 or -3 if x(i) is free and has bounds, +c 1 if x(i) is fixed at l(i), and l(i) .ne. u(i) +c 2 if x(i) is fixed at u(i), and u(i) .ne. l(i) +c 3 if x(i) is always fixed, i.e., u(i)=x(i)=l(i) +c -1 if x(i) is always free, i.e., no bounds on it. +c +c indx2 is an integer working array of dimension n. +c Within subroutine cauchy, indx2 corresponds to the array iorder. +c In subroutine freev, a list of variables entering and leaving +c the free set is stored in indx2, and it is passed on to +c subroutine formk with this information. +c +c task is a working string of characters of length 60 indicating +c the current job when entering and leaving this subroutine. +c +c iprint is an INTEGER variable that must be set by the user. +c It controls the frequency and type of output generated: +c iprint<0 no output is generated; +c iprint=0 print only one line at the last iteration; +c 0100 print details of every iteration including x and g; +c When iprint > 0, the file iterate.dat will be created to +c summarize the iteration. +c +c csave is a working string of characters of length 60. +c +c lsave is a logical working array of dimension 4. +c +c isave is an integer working array of dimension 23. +c +c dsave is a double precision working array of dimension 29. +c +c +c Subprograms called +c +c L-BFGS-B Library ... cauchy, subsm, lnsrlb, formk, +c +c errclb, prn1lb, prn2lb, prn3lb, active, projgr, +c +c freev, cmprlb, matupd, formt. +c +c Minpack2 Library ... timer +c +c Linpack Library ... dcopy, ddot. +c +c +c References: +c +c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited +c memory algorithm for bound constrained optimization'', +c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. +c +c [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: FORTRAN +c Subroutines for Large Scale Bound Constrained Optimization'' +c Tech. Report, NAM-11, EECS Department, Northwestern University, +c 1994. +c +c [3] R. Byrd, J. Nocedal and R. Schnabel "Representations of +c Quasi-Newton Matrices and their use in Limited Memory Methods'', +c Mathematical Programming 63 (1994), no. 4, pp. 129-156. +c +c (Postscript files of these papers are available via anonymous +c ftp to eecs.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.) +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + logical prjctd,cnstnd,boxed,updatd,wrk + character*3 word + integer i,k,nintol,itfile,iback,nskip, + + head,col,iter,itail,iupdat, + + nseg,nfgv,info,ifun, + + iword,nfree,nact,ileave,nenter +! double precision theta,fold,ddot,dr,rr,tol, !Original + double precision theta,fold,dr,rr,tol, !Fabian + + xstep,sbgnrm,ddum,dnorm,dtd,epsmch, + + cpu1,cpu2,cachyt,sbtime,lnscht,time1,time2, + + gd,gdold,stp,stpmx,time + double precision one,zero + parameter (one=1.0d0,zero=0.0d0) + + if (task .eq. 'START') then + + epsmch = epsilon(one) + + call timer(time1) + +c Initialize counters and scalars when task='START'. + +c for the limited memory BFGS matrices: + col = 0 + head = 1 + theta = one +! write(6,*) 'FF: Set theta to 1d3' +! theta = 1.d3 !Fabian + iupdat = 0 + updatd = .false. + iback = 0 + itail = 0 + iword = 0 + nact = 0 + ileave = 0 + nenter = 0 + fold = zero + dnorm = zero + cpu1 = zero + gd = zero + stpmx = zero + sbgnrm = zero + stp = zero + gdold = zero + dtd = zero + +c for operation counts: + iter = 0 + nfgv = 0 + nseg = 0 + nintol = 0 + nskip = 0 + nfree = n + ifun = 0 +c for stopping tolerance: + tol = factr*epsmch + +c for measuring running time: + cachyt = 0 + sbtime = 0 + lnscht = 0 + +c 'word' records the status of subspace solutions. + word = '---' + +c 'info' records the termination information. + info = 0 + + itfile = 8 + if (iprint .ge. 1) then +c open a summary file 'iterate.dat' + open (8, file = 'iterate.dat', status = 'unknown') + endif + +c Check the input arguments for errors. + + call errclb(n,m,factr,l,u,nbd,task,info,k) + if (task(1:5) .eq. 'ERROR') then + call prn3lb(n,x,f,task,iprint,info,itfile, + + iter,nfgv,nintol,nskip,nact,sbgnrm, + + zero,nseg,word,iback,stp,xstep,k, + + cachyt,sbtime,lnscht) + return + endif + + call prn1lb(n,m,l,u,x,iprint,itfile,epsmch) + +c Initialize iwhere & project x onto the feasible set. + + call active(n,l,u,nbd,x,iwhere,iprint,prjctd,cnstnd,boxed) + +c The end of the initialization. + + else +c restore local variables. + + prjctd = lsave(1) + cnstnd = lsave(2) + boxed = lsave(3) + updatd = lsave(4) + + nintol = isave(1) + itfile = isave(3) + iback = isave(4) + nskip = isave(5) + head = isave(6) + col = isave(7) + itail = isave(8) + iter = isave(9) + iupdat = isave(10) + nseg = isave(12) + nfgv = isave(13) + info = isave(14) + ifun = isave(15) + iword = isave(16) + nfree = isave(17) + nact = isave(18) + ileave = isave(19) + nenter = isave(20) + + theta = dsave(1) + fold = dsave(2) + tol = dsave(3) + dnorm = dsave(4) + epsmch = dsave(5) + cpu1 = dsave(6) + cachyt = dsave(7) + sbtime = dsave(8) + lnscht = dsave(9) + time1 = dsave(10) + gd = dsave(11) + stpmx = dsave(12) + sbgnrm = dsave(13) + stp = dsave(14) + gdold = dsave(15) + dtd = dsave(16) + +c After returning from the driver go to the point where execution +c is to resume. + + if (task(1:5) .eq. 'FG_LN') goto 666 + if (task(1:5) .eq. 'NEW_X') goto 777 + if (task(1:5) .eq. 'FG_ST') goto 111 + if (task(1:4) .eq. 'STOP') then + if (task(7:9) .eq. 'CPU') then +c restore the previous iterate. + call dcopy(n,t,1,x,1) + call dcopy(n,r,1,g,1) + f = fold + endif + goto 999 + endif + endif + +c Compute f0 and g0. + + task = 'FG_START' +c return to the driver to calculate f and g; reenter at 111. + goto 1000 + 111 continue + nfgv = 1 + +c Compute the infinity norm of the (-) projected gradient. + + call projgr(n,l,u,nbd,x,g,sbgnrm) + + if (iprint .ge. 1) then + write (6,1002) iter,f,sbgnrm + write (itfile,1003) iter,nfgv,sbgnrm,f + endif + if (sbgnrm .le. pgtol) then +c terminate the algorithm. + task = 'CONVERGENCE: NORM_OF_PROJECTED_GRADIENT_<=_PGTOL' + goto 999 + endif + +c ----------------- the beginning of the loop -------------------------- + + 222 continue + if (iprint .ge. 99) write (6,1001) iter + 1 + iword = -1 +c + if (.not. cnstnd .and. col .gt. 0) then +c skip the search for GCP. + call dcopy(n,x,1,z,1) + wrk = updatd + nseg = 0 + goto 333 + endif + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c Compute the Generalized Cauchy Point (GCP). +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + call timer(cpu1) + + call cauchy(n,x,l,u,nbd,g,indx2,iwhere,t,d,z, + + m,wy,ws,sy,wt,theta,col,head, + + wa(1),wa(2*m+1),wa(4*m+1),wa(6*m+1),nseg, + + iprint, sbgnrm, info, epsmch) + + + if (info .ne. 0) then +c singular triangular system detected; refresh the lbfgs memory. + if(iprint .ge. 1) write (6, 1005) + info = 0 + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + call timer(cpu2) + cachyt = cachyt + cpu2 - cpu1 + goto 222 + endif + call timer(cpu2) + cachyt = cachyt + cpu2 - cpu1 + nintol = nintol + nseg + +c Count the entering and leaving variables for iter > 0; +c find the index set of free and active variables at the GCP. + + call freev(n,nfree,index,nenter,ileave,indx2, + + iwhere,wrk,updatd,cnstnd,iprint,iter) + nact = n - nfree + + 333 continue + +c If there are no free variables or B=theta*I, then +c skip the subspace minimization. + + if (nfree .eq. 0 .or. col .eq. 0) goto 555 + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c Subspace minimization. +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + call timer(cpu1) + +c Form the LEL^T factorization of the indefinite +c matrix K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c where E = [-I 0] +c [ 0 I] + + if (wrk) call formk(n,nfree,index,nenter,ileave,indx2,iupdat, + + updatd,wn,snd,m,ws,wy,sy,theta,col,head,info) + if (info .ne. 0) then +c nonpositive definiteness in Cholesky factorization; +c refresh the lbfgs memory and restart the iteration. + if(iprint .ge. 1) write (6, 1006) + info = 0 + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + call timer(cpu2) + sbtime = sbtime + cpu2 - cpu1 + goto 222 + endif + +c compute r=-Z'B(xcp-xk)-Z'g (using wa(2m+1)=W'(xcp-x) +c from 'cauchy'). + call cmprlb(n,m,x,g,ws,wy,sy,wt,z,r,wa,index, + + theta,col,head,nfree,cnstnd,info) + if (info .ne. 0) goto 444 + +c-jlm-jn call the direct method. + + call subsm( n, m, nfree, index, l, u, nbd, z, r, xp, ws, wy, + + theta, x, g, col, head, iword, wa, wn, iprint, info) + + 444 continue + if (info .ne. 0) then +c singular triangular system detected; +c refresh the lbfgs memory and restart the iteration. + if(iprint .ge. 1) write (6, 1005) + info = 0 + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + call timer(cpu2) + sbtime = sbtime + cpu2 - cpu1 + goto 222 + endif + + call timer(cpu2) + sbtime = sbtime + cpu2 - cpu1 + 555 continue + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c Line search and optimality tests. +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c Generate the search direction d:=z-x. + + do 40 i = 1, n + d(i) = z(i) - x(i) + 40 continue + call timer(cpu1) + + !Fabian Debug +! write(6,*) 'FF: Search direction' +! write(6,'(5F12.8)') d(1:n) + + + 666 continue + + call lnsrlb(n,l,u,nbd,x,f,fold,gd,gdold,g,d,r,t,z,stp,dnorm, + + dtd,xstep,stpmx,iter,ifun,iback,nfgv,info,task, + + boxed,cnstnd,csave,isave(22),dsave(17)) + + + if (info .ne. 0 .or. iback .ge. 20) then +c restore the previous iterate. + call dcopy(n,t,1,x,1) + call dcopy(n,r,1,g,1) + f = fold + if (col .eq. 0) then +c abnormal termination. + if (info .eq. 0) then + info = -9 +c restore the actual number of f and g evaluations etc. + nfgv = nfgv - 1 + ifun = ifun - 1 + iback = iback - 1 + endif + task = 'ABNORMAL_TERMINATION_IN_LNSRCH' + iter = iter + 1 + goto 999 + else +c refresh the lbfgs memory and restart the iteration. + if(iprint .ge. 1) write (6, 1008) + if (info .eq. 0) nfgv = nfgv - 1 + info = 0 + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + task = 'RESTART_FROM_LNSRCH' + call timer(cpu2) + lnscht = lnscht + cpu2 - cpu1 + goto 222 + endif + else if (task(1:5) .eq. 'FG_LN') then +c return to the driver for calculating f and g; reenter at 666. + goto 1000 + else +c calculate and print out the quantities related to the new X. + call timer(cpu2) + lnscht = lnscht + cpu2 - cpu1 + iter = iter + 1 + +c Compute the infinity norm of the projected (-)gradient. + + call projgr(n,l,u,nbd,x,g,sbgnrm) + +c Print iteration information. + + call prn2lb(n,x,f,g,iprint,itfile,iter,nfgv,nact, + + sbgnrm,nseg,word,iword,iback,stp,xstep) + goto 1000 + endif + 777 continue + +c Test for termination. + + if (sbgnrm .le. pgtol) then +c terminate the algorithm. + task = 'CONVERGENCE: NORM_OF_PROJECTED_GRADIENT_<=_PGTOL' + goto 999 + endif + + ddum = max(abs(fold), abs(f), one) + if ((fold - f) .le. tol*ddum) then +c terminate the algorithm. + task = 'CONVERGENCE: REL_REDUCTION_OF_F_<=_FACTR*EPSMCH' + if (iback .ge. 10) info = -5 +c i.e., to issue a warning if iback>10 in the line search. + goto 999 + endif + +c Compute d=newx-oldx, r=newg-oldg, rr=y'y and dr=y's. + + do 42 i = 1, n + r(i) = g(i) - r(i) + 42 continue + rr = ddot(n,r,1,r,1) + if (stp .eq. one) then + dr = gd - gdold + ddum = -gdold + else + dr = (gd - gdold)*stp + call dscal(n,stp,d,1) + ddum = -gdold*stp + endif + + if (dr .le. epsmch*ddum) then +c skip the L-BFGS update. + nskip = nskip + 1 + updatd = .false. + if (iprint .ge. 1) write (6,1004) dr, ddum + goto 888 + endif + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c Update the L-BFGS matrix. +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + updatd = .true. + iupdat = iupdat + 1 + +c Update matrices WS and WY and form the middle matrix in B. + + call matupd(n,m,ws,wy,sy,ss,d,r,itail, + + iupdat,col,head,theta,rr,dr,stp,dtd) + +c Form the upper half of the pds T = theta*SS + L*D^(-1)*L'; +c Store T in the upper triangular of the array wt; +c Cholesky factorize T to J*J' with +c J' stored in the upper triangular of wt. + + call formt(m,wt,sy,ss,col,theta,info) + + if (info .ne. 0) then +c nonpositive definiteness in Cholesky factorization; +c refresh the lbfgs memory and restart the iteration. + if(iprint .ge. 1) write (6, 1007) + info = 0 + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + goto 222 + endif + +c Now the inverse of the middle matrix in B is + +c [ D^(1/2) O ] [ -D^(1/2) D^(-1/2)*L' ] +c [ -L*D^(-1/2) J ] [ 0 J' ] + + 888 continue + +c -------------------- the end of the loop ----------------------------- + + goto 222 + 999 continue + call timer(time2) + time = time2 - time1 + call prn3lb(n,x,f,task,iprint,info,itfile, + + iter,nfgv,nintol,nskip,nact,sbgnrm, + + time,nseg,word,iback,stp,xstep,k, + + cachyt,sbtime,lnscht) + 1000 continue + +c Save local variables. + + lsave(1) = prjctd + lsave(2) = cnstnd + lsave(3) = boxed + lsave(4) = updatd + + isave(1) = nintol + isave(3) = itfile + isave(4) = iback + isave(5) = nskip + isave(6) = head + isave(7) = col + isave(8) = itail + isave(9) = iter + isave(10) = iupdat + isave(12) = nseg + isave(13) = nfgv + isave(14) = info + isave(15) = ifun + isave(16) = iword + isave(17) = nfree + isave(18) = nact + isave(19) = ileave + isave(20) = nenter + + dsave(1) = theta + dsave(2) = fold + dsave(3) = tol + dsave(4) = dnorm + dsave(5) = epsmch + dsave(6) = cpu1 + dsave(7) = cachyt + dsave(8) = sbtime + dsave(9) = lnscht + dsave(10) = time1 + dsave(11) = gd + dsave(12) = stpmx + dsave(13) = sbgnrm + dsave(14) = stp + dsave(15) = gdold + dsave(16) = dtd + + 1001 format (//,'ITERATION ',i5) + 1002 format + + (/,'At iterate',i5,4x,'f= ',1p,d12.5,4x,'|proj g|= ',1p,d12.5) + 1003 format (2(1x,i4),5x,'-',5x,'-',3x,'-',5x,'-',5x,'-',8x,'-',3x, + + 1p,2(1x,d10.3)) + 1004 format (' ys=',1p,e10.3,' -gs=',1p,e10.3,' BFGS update SKIPPED') + 1005 format (/, + +' Singular triangular system detected;',/, + +' refresh the lbfgs memory and restart the iteration.') + 1006 format (/, + +' Nonpositive definiteness in Cholesky factorization in formk;',/, + +' refresh the lbfgs memory and restart the iteration.') + 1007 format (/, + +' Nonpositive definiteness in Cholesky factorization in formt;',/, + +' refresh the lbfgs memory and restart the iteration.') + 1008 format (/, + +' Bad direction in the line search;',/, + +' refresh the lbfgs memory and restart the iteration.') + + return + + end subroutine + +c======================= The end of mainlb ============================= + + subroutine active(n, l, u, nbd, x, iwhere, iprint, + + prjctd, cnstnd, boxed) + + logical prjctd, cnstnd, boxed + integer n, iprint, nbd(n), iwhere(n) + double precision x(n), l(n), u(n) + +c ************ +c +c Subroutine active +c +c This subroutine initializes iwhere and projects the initial x to +c the feasible set if necessary. +c +c iwhere is an integer array of dimension n. +c On entry iwhere is unspecified. +c On exit iwhere(i)=-1 if x(i) has no bounds +c 3 if l(i)=u(i) +c 0 otherwise. +c In cauchy, iwhere is given finer gradations. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer nbdd,i + double precision zero + parameter (zero=0.0d0) + +c Initialize nbdd, prjctd, cnstnd and boxed. + + nbdd = 0 + prjctd = .false. + cnstnd = .false. + boxed = .true. + +c Project the initial x to the easible set if necessary. + + do 10 i = 1, n + if (nbd(i) .gt. 0) then + if (nbd(i) .le. 2 .and. x(i) .le. l(i)) then + if (x(i) .lt. l(i)) then + prjctd = .true. + x(i) = l(i) + endif + nbdd = nbdd + 1 + else if (nbd(i) .ge. 2 .and. x(i) .ge. u(i)) then + if (x(i) .gt. u(i)) then + prjctd = .true. + x(i) = u(i) + endif + nbdd = nbdd + 1 + endif + endif + 10 continue + +c Initialize iwhere and assign values to cnstnd and boxed. + + do 20 i = 1, n + if (nbd(i) .ne. 2) boxed = .false. + if (nbd(i) .eq. 0) then +c this variable is always free + iwhere(i) = -1 + +c otherwise set x(i)=mid(x(i), u(i), l(i)). + else + cnstnd = .true. + if (nbd(i) .eq. 2 .and. u(i) - l(i) .le. zero) then +c this variable is always fixed + iwhere(i) = 3 + else + iwhere(i) = 0 + endif + endif + 20 continue + + if (iprint .ge. 0) then + if (prjctd) write (6,*) + + 'The initial X is infeasible. Restart with its projection.' + if (.not. cnstnd) + + write (6,*) 'This problem is unconstrained.' + endif + + if (iprint .gt. 0) write (6,1001) nbdd + + 1001 format (/,'At X0 ',i9,' variables are exactly at the bounds') + + return + + end subroutine + +c======================= The end of active ============================= + + subroutine bmv(m, sy, wt, col, v, p, info) + + integer m, col, info + double precision sy(m, m), wt(m, m), v(2*col), p(2*col) + +c ************ +c +c Subroutine bmv +c +c This subroutine computes the product of the 2m x 2m middle matrix +c in the compact L-BFGS formula of B and a 2m vector v; +c it returns the product in p. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric corrections +c used to define the limited memory matrix. +c On exit m is unchanged. +c +c sy is a double precision array of dimension m x m. +c On entry sy specifies the matrix S'Y. +c On exit sy is unchanged. +c +c wt is a double precision array of dimension m x m. +c On entry wt specifies the upper triangular matrix J' which is +c the Cholesky factor of (thetaS'S+LD^(-1)L'). +c On exit wt is unchanged. +c +c col is an integer variable. +c On entry col specifies the number of s-vectors (or y-vectors) +c stored in the compact L-BFGS formula. +c On exit col is unchanged. +c +c v is a double precision array of dimension 2col. +c On entry v specifies vector v. +c On exit v is unchanged. +c +c p is a double precision array of dimension 2col. +c On entry p is unspecified. +c On exit p is the product Mv. +c +c info is an integer variable. +c On entry info is unspecified. +c On exit info = 0 for normal return, +c = nonzero for abnormal return when the system +c to be solved by dtrsl is singular. +c +c Subprograms called: +c +c Linpack ... dtrsl. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i,k,i2 + double precision sum + + if (col .eq. 0) return + +c PART I: solve [ D^(1/2) O ] [ p1 ] = [ v1 ] +c [ -L*D^(-1/2) J ] [ p2 ] [ v2 ]. + +c solve Jp2=v2+LD^(-1)v1. + p(col + 1) = v(col + 1) + do 20 i = 2, col + i2 = col + i + sum = 0.0d0 + do 10 k = 1, i - 1 + sum = sum + sy(i,k)*v(k)/sy(k,k) + 10 continue + p(i2) = v(i2) + sum + 20 continue +c Solve the triangular system + call dtrsl(wt,m,col,p(col+1),11,info) + if (info .ne. 0) return + +c solve D^(1/2)p1=v1. + do 30 i = 1, col + p(i) = v(i)/sqrt(sy(i,i)) + 30 continue + +c PART II: solve [ -D^(1/2) D^(-1/2)*L' ] [ p1 ] = [ p1 ] +c [ 0 J' ] [ p2 ] [ p2 ]. + +c solve J^Tp2=p2. + call dtrsl(wt,m,col,p(col+1),01,info) + if (info .ne. 0) return + +c compute p1=-D^(-1/2)(p1-D^(-1/2)L'p2) +c =-D^(-1/2)p1+D^(-1)L'p2. + do 40 i = 1, col + p(i) = -p(i)/sqrt(sy(i,i)) + 40 continue + do 60 i = 1, col + sum = 0.d0 + do 50 k = i + 1, col + sum = sum + sy(k,i)*p(col+k)/sy(i,i) + 50 continue + p(i) = p(i) + sum + 60 continue + + return + + end subroutine + +c======================== The end of bmv =============================== + + subroutine cauchy(n, x, l, u, nbd, g, iorder, iwhere, t, d, xcp, + + m, wy, ws, sy, wt, theta, col, head, p, c, wbp, + + v, nseg, iprint, sbgnrm, info, epsmch) + implicit none + integer n, m, head, col, nseg, iprint, info, + + nbd(n), iorder(n), iwhere(n) + double precision theta, epsmch, + + x(n), l(n), u(n), g(n), t(n), d(n), xcp(n), + + wy(n, col), ws(n, col), sy(m, m), + + wt(m, m), p(2*m), c(2*m), wbp(2*m), v(2*m) + +c ************ +c +c Subroutine cauchy +c +c For given x, l, u, g (with sbgnrm > 0), and a limited memory +c BFGS matrix B defined in terms of matrices WY, WS, WT, and +c scalars head, col, and theta, this subroutine computes the +c generalized Cauchy point (GCP), defined as the first local +c minimizer of the quadratic +c +c Q(x + s) = g's + 1/2 s'Bs +c +c along the projected gradient direction P(x-tg,l,u). +c The routine returns the GCP in xcp. +c +c n is an integer variable. +c On entry n is the dimension of the problem. +c On exit n is unchanged. +c +c x is a double precision array of dimension n. +c On entry x is the starting point for the GCP computation. +c On exit x is unchanged. +c +c l is a double precision array of dimension n. +c On entry l is the lower bound of x. +c On exit l is unchanged. +c +c u is a double precision array of dimension n. +c On entry u is the upper bound of x. +c On exit u is unchanged. +c +c nbd is an integer array of dimension n. +c On entry nbd represents the type of bounds imposed on the +c variables, and must be specified as follows: +c nbd(i)=0 if x(i) is unbounded, +c 1 if x(i) has only a lower bound, +c 2 if x(i) has both lower and upper bounds, and +c 3 if x(i) has only an upper bound. +c On exit nbd is unchanged. +c +c g is a double precision array of dimension n. +c On entry g is the gradient of f(x). g must be a nonzero vector. +c On exit g is unchanged. +c +c iorder is an integer working array of dimension n. +c iorder will be used to store the breakpoints in the piecewise +c linear path and free variables encountered. On exit, +c iorder(1),...,iorder(nleft) are indices of breakpoints +c which have not been encountered; +c iorder(nleft+1),...,iorder(nbreak) are indices of +c encountered breakpoints; and +c iorder(nfree),...,iorder(n) are indices of variables which +c have no bound constraits along the search direction. +c +c iwhere is an integer array of dimension n. +c On entry iwhere indicates only the permanently fixed (iwhere=3) +c or free (iwhere= -1) components of x. +c On exit iwhere records the status of the current x variables. +c iwhere(i)=-3 if x(i) is free and has bounds, but is not moved +c 0 if x(i) is free and has bounds, and is moved +c 1 if x(i) is fixed at l(i), and l(i) .ne. u(i) +c 2 if x(i) is fixed at u(i), and u(i) .ne. l(i) +c 3 if x(i) is always fixed, i.e., u(i)=x(i)=l(i) +c -1 if x(i) is always free, i.e., it has no bounds. +c +c t is a double precision working array of dimension n. +c t will be used to store the break points. +c +c d is a double precision array of dimension n used to store +c the Cauchy direction P(x-tg)-x. +c +c xcp is a double precision array of dimension n used to return the +c GCP on exit. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric corrections +c used to define the limited memory matrix. +c On exit m is unchanged. +c +c ws, wy, sy, and wt are double precision arrays. +c On entry they store information that defines the +c limited memory BFGS matrix: +c ws(n,m) stores S, a set of s-vectors; +c wy(n,m) stores Y, a set of y-vectors; +c sy(m,m) stores S'Y; +c wt(m,m) stores the +c Cholesky factorization of (theta*S'S+LD^(-1)L'). +c On exit these arrays are unchanged. +c +c theta is a double precision variable. +c On entry theta is the scaling factor specifying B_0 = theta I. +c On exit theta is unchanged. +c +c col is an integer variable. +c On entry col is the actual number of variable metric +c corrections stored so far. +c On exit col is unchanged. +c +c head is an integer variable. +c On entry head is the location of the first s-vector (or y-vector) +c in S (or Y). +c On exit col is unchanged. +c +c p is a double precision working array of dimension 2m. +c p will be used to store the vector p = W^(T)d. +c +c c is a double precision working array of dimension 2m. +c c will be used to store the vector c = W^(T)(xcp-x). +c +c wbp is a double precision working array of dimension 2m. +c wbp will be used to store the row of W corresponding +c to a breakpoint. +c +c v is a double precision working array of dimension 2m. +c +c nseg is an integer variable. +c On exit nseg records the number of quadratic segments explored +c in searching for the GCP. +c +c sg and yg are double precision arrays of dimension m. +c On entry sg and yg store S'g and Y'g correspondingly. +c On exit they are unchanged. +c +c iprint is an INTEGER variable that must be set by the user. +c It controls the frequency and type of output generated: +c iprint<0 no output is generated; +c iprint=0 print only one line at the last iteration; +c 0100 print details of every iteration including x and g; +c When iprint > 0, the file iterate.dat will be created to +c summarize the iteration. +c +c sbgnrm is a double precision variable. +c On entry sbgnrm is the norm of the projected gradient at x. +c On exit sbgnrm is unchanged. +c +c info is an integer variable. +c On entry info is 0. +c On exit info = 0 for normal return, +c = nonzero for abnormal return when the the system +c used in routine bmv is singular. +c +c Subprograms called: +c +c L-BFGS-B Library ... hpsolb, bmv. +c +c Linpack ... dscal dcopy, daxpy. +c +c +c References: +c +c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited +c memory algorithm for bound constrained optimization'', +c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. +c +c [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: FORTRAN +c Subroutines for Large Scale Bound Constrained Optimization'' +c Tech. Report, NAM-11, EECS Department, Northwestern University, +c 1994. +c +c (Postscript files of these papers are available via anonymous +c ftp to eecs.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.) +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + logical xlower,xupper,bnded + integer i,j,col2,nfree,nbreak,pointr, + + ibp,nleft,ibkmin,iter + double precision f1,f2,dt,dtm,tsum,dibp,zibp,dibp2,bkmin, +! + tu,tl,wmc,wmp,wmw,ddot,tj,tj0,neggi,sbgnrm, !Original + + tu,tl,wmc,wmp,wmw,tj,tj0,neggi,sbgnrm, !Fabian + + f2_org + double precision one,zero + parameter (one=1.0d0,zero=0.0d0) + +c Check the status of the variables, reset iwhere(i) if necessary; +c compute the Cauchy direction d and the breakpoints t; initialize +c the derivative f1 and the vector p = W'd (for theta = 1). + + if (sbgnrm .le. zero) then + if (iprint .ge. 0) write (6,*) 'Subgnorm = 0. GCP = X.' + call dcopy(n,x,1,xcp,1) + return + endif + bnded = .true. + nfree = n + 1 + nbreak = 0 + ibkmin = 0 + bkmin = zero + col2 = 2*col + f1 = zero + if (iprint .ge. 99) write (6,3010) + +! write(6,*) "tt" +! write(6,'(5F12.8)') t(1:n) + +c We set p to zero and build it up as we determine d. + + do 20 i = 1, col2 + p(i) = zero + 20 continue + +c In the following loop we determine for each variable its bound +c status and its breakpoint, and update p accordingly. +c Smallest breakpoint is identified. + + do 50 i = 1, n + neggi = -g(i) + if (iwhere(i) .ne. 3 .and. iwhere(i) .ne. -1) then +c if x(i) is not a constant and has bounds, +c compute the difference between x(i) and its bounds. + if (nbd(i) .le. 2) tl = x(i) - l(i) + if (nbd(i) .ge. 2) tu = u(i) - x(i) + +c If a variable is close enough to a bound +c we treat it as at bound. + xlower = nbd(i) .le. 2 .and. tl .le. zero + xupper = nbd(i) .ge. 2 .and. tu .le. zero + +c reset iwhere(i). + iwhere(i) = 0 + if (xlower) then + if (neggi .le. zero) iwhere(i) = 1 + else if (xupper) then + if (neggi .ge. zero) iwhere(i) = 2 + else + if (abs(neggi) .le. zero) iwhere(i) = -3 + endif + endif + pointr = head + if (iwhere(i) .ne. 0 .and. iwhere(i) .ne. -1) then + d(i) = zero + else + d(i) = neggi + f1 = f1 - neggi*neggi +c calculate p := p - W'e_i* (g_i). + do 40 j = 1, col + p(j) = p(j) + wy(i,pointr)* neggi + p(col + j) = p(col + j) + ws(i,pointr)*neggi + pointr = mod(pointr,m) + 1 + 40 continue + if (nbd(i) .le. 2 .and. nbd(i) .ne. 0 + + .and. neggi .lt. zero) then +c x(i) + d(i) is bounded; compute t(i). + nbreak = nbreak + 1 + iorder(nbreak) = i + t(nbreak) = tl/(-neggi) + if (nbreak .eq. 1 .or. t(nbreak) .lt. bkmin) then + bkmin = t(nbreak) + ibkmin = nbreak + endif + else if (nbd(i) .ge. 2 .and. neggi .gt. zero) then +c x(i) + d(i) is bounded; compute t(i). + nbreak = nbreak + 1 + iorder(nbreak) = i + t(nbreak) = tu/neggi + if (nbreak .eq. 1 .or. t(nbreak) .lt. bkmin) then + bkmin = t(nbreak) + ibkmin = nbreak + endif + else +c x(i) + d(i) is not bounded. + nfree = nfree - 1 + iorder(nfree) = i + if (abs(neggi) .gt. zero) bnded = .false. + endif + endif + 50 continue + +c The indices of the nonzero components of d are now stored +c in iorder(1),...,iorder(nbreak) and iorder(nfree),...,iorder(n). +c The smallest of the nbreak breakpoints is in t(ibkmin)=bkmin. + + if (theta .ne. one) then +c complete the initialization of p for theta not= one. + call dscal(col,theta,p(col+1),1) + endif + +c Initialize GCP xcp = x. + + call dcopy(n,x,1,xcp,1) + + if (nbreak .eq. 0 .and. nfree .eq. n + 1) then +c is a zero vector, return with the initial xcp as GCP. +! write(6,*) 'FF: initial xcp equal to GCP' + if (iprint .gt. 100) write (6,1010) (xcp(i), i = 1, n) + return + endif + +c Initialize c = W'(xcp - x) = 0. + + do 60 j = 1, col2 + c(j) = zero + 60 continue + +c Initialize derivative f2. + + f2 = -theta*f1 + f2_org = f2 + if (col .gt. 0) then + call bmv(m,sy,wt,col,p,v,info) + if (info .ne. 0) return + f2 = f2 - ddot(col2,v,1,p,1) + endif + dtm = -f1/f2 + tsum = zero + nseg = 1 + if (iprint .ge. 99) + + write (6,*) 'There are ',nbreak,' breakpoints ' + +c If there are no breakpoints, locate the GCP and return. + + if (nbreak .eq. 0) goto 888 + + nleft = nbreak + iter = 1 + + + tj = zero + +c------------------- the beginning of the loop ------------------------- + + 777 continue + +c Find the next smallest breakpoint; +c compute dt = t(nleft) - t(nleft + 1). + + tj0 = tj + if (iter .eq. 1) then +c Since we already have the smallest breakpoint we need not do +c heapsort yet. Often only one breakpoint is used and the +c cost of heapsort is avoided. + tj = bkmin + ibp = iorder(ibkmin) + else + if (iter .eq. 2) then +c Replace the already used smallest breakpoint with the +c breakpoint numbered nbreak > nlast, before heapsort call. + if (ibkmin .ne. nbreak) then + t(ibkmin) = t(nbreak) + iorder(ibkmin) = iorder(nbreak) + endif +c Update heap structure of breakpoints +c (if iter=2, initialize heap). + endif + call hpsolb(nleft,t,iorder,iter-2) + tj = t(nleft) + ibp = iorder(nleft) + endif + + dt = tj - tj0 + + if (dt .ne. zero .and. iprint .ge. 100) then + write (6,4011) nseg,f1,f2 + write (6,5010) dt + write (6,6010) dtm + endif + +c If a minimizer is within this interval, locate the GCP and return. + + if (dtm .lt. dt) goto 888 + +c Otherwise fix one variable and +c reset the corresponding component of d to zero. + + tsum = tsum + dt + nleft = nleft - 1 + iter = iter + 1 + dibp = d(ibp) + d(ibp) = zero + if (dibp .gt. zero) then + zibp = u(ibp) - x(ibp) + xcp(ibp) = u(ibp) + iwhere(ibp) = 2 + else + zibp = l(ibp) - x(ibp) + xcp(ibp) = l(ibp) + iwhere(ibp) = 1 + endif + if (iprint .ge. 100) write (6,*) 'Variable ',ibp,' is fixed.' + if (nleft .eq. 0 .and. nbreak .eq. n) then +c all n variables are fixed, +c return with xcp as GCP. + dtm = dt + goto 999 + endif + +c Update the derivative information. + + nseg = nseg + 1 + dibp2 = dibp**2 + +c Update f1 and f2. + +c temporarily set f1 and f2 for col=0. + f1 = f1 + dt*f2 + dibp2 - theta*dibp*zibp + f2 = f2 - theta*dibp2 + + if (col .gt. 0) then +c update c = c + dt*p. + call daxpy(col2,dt,p,1,c,1) + +c choose wbp, +c the row of W corresponding to the breakpoint encountered. + pointr = head + do 70 j = 1,col + wbp(j) = wy(ibp,pointr) + wbp(col + j) = theta*ws(ibp,pointr) + pointr = mod(pointr,m) + 1 + 70 continue + +c compute (wbp)Mc, (wbp)Mp, and (wbp)M(wbp)'. + call bmv(m,sy,wt,col,wbp,v,info) + if (info .ne. 0) return + wmc = ddot(col2,c,1,v,1) + wmp = ddot(col2,p,1,v,1) + wmw = ddot(col2,wbp,1,v,1) + +c update p = p - dibp*wbp. + call daxpy(col2,-dibp,wbp,1,p,1) + +c complete updating f1 and f2 while col > 0. + f1 = f1 + dibp*wmc + f2 = f2 + 2.0d0*dibp*wmp - dibp2*wmw + endif + + f2 = max(epsmch*f2_org,f2) + if (nleft .gt. 0) then + dtm = -f1/f2 + goto 777 +c to repeat the loop for unsearched intervals. + else if(bnded) then + f1 = zero + f2 = zero + dtm = zero + else + dtm = -f1/f2 + endif + +c------------------- the end of the loop ------------------------------- + + 888 continue + if (iprint .ge. 99) then + write (6,*) + write (6,*) 'GCP found in this segment' + write (6,4010) nseg,f1,f2 + write (6,6010) dtm + endif + if (dtm .le. zero) dtm = zero + tsum = tsum + dtm + +c Move free variables (i.e., the ones w/o breakpoints) and +c the variables whose breakpoints haven't been reached. + +! write(6,*) 'FF:tsum=',tsum +! write(6,*) 'FF:d=' +! write(6,'(5F12.8)') d(1:n) + + call daxpy(n,tsum,d,1,xcp,1) + + 999 continue + +c Update c = c + dtm*p = W'(x^c - x) +c which will be used in computing r = Z'(B(x^c - x) + g). + + if (col .gt. 0) call daxpy(col2,dtm,p,1,c,1) + if (iprint .gt. 100) write (6,1010) (xcp(i),i = 1,n) + if (iprint .ge. 99) write (6,2010) + + 1010 format ('Cauchy X = ',/,(4x,1p,6(1x,d11.4))) + 2010 format (/,'---------------- exit CAUCHY----------------------',/) + 3010 format (/,'---------------- CAUCHY entered-------------------') + 4010 format ('Piece ',i3,' --f1, f2 at start point ',1p,2(1x,d11.4)) + 4011 format (/,'Piece ',i3,' --f1, f2 at start point ', + + 1p,2(1x,d11.4)) + 5010 format ('Distance to the next break point = ',1p,d11.4) + 6010 format ('Distance to the stationary point = ',1p,d11.4) + + return + + end subroutine + +c====================== The end of cauchy ============================== + + subroutine cmprlb(n, m, x, g, ws, wy, sy, wt, z, r, wa, index, + + theta, col, head, nfree, cnstnd, info) + + logical cnstnd + integer n, m, col, head, nfree, info, index(n) + double precision theta, + + x(n), g(n), z(n), r(n), wa(4*m), + + ws(n, m), wy(n, m), sy(m, m), wt(m, m) + +c ************ +c +c Subroutine cmprlb +c +c This subroutine computes r=-Z'B(xcp-xk)-Z'g by using +c wa(2m+1)=W'(xcp-x) from subroutine cauchy. +c +c Subprograms called: +c +c L-BFGS-B Library ... bmv. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i,j,k,pointr + double precision a1,a2 + + if (.not. cnstnd .and. col .gt. 0) then + do 26 i = 1, n + r(i) = -g(i) + 26 continue + else + do 30 i = 1, nfree + k = index(i) + r(i) = -theta*(z(k) - x(k)) - g(k) + 30 continue + call bmv(m,sy,wt,col,wa(2*m+1),wa(1),info) + if (info .ne. 0) then + info = -8 + return + endif + pointr = head + do 34 j = 1, col + a1 = wa(j) + a2 = theta*wa(col + j) + do 32 i = 1, nfree + k = index(i) + r(i) = r(i) + wy(k,pointr)*a1 + ws(k,pointr)*a2 + 32 continue + pointr = mod(pointr,m) + 1 + 34 continue + endif + + return + + end subroutine + +c======================= The end of cmprlb ============================= + + subroutine errclb(n, m, factr, l, u, nbd, task, info, k) + + character*60 task + integer n, m, info, k, nbd(n) + double precision factr, l(n), u(n) + +c ************ +c +c Subroutine errclb +c +c This subroutine checks the validity of the input data. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i + double precision one,zero + parameter (one=1.0d0,zero=0.0d0) + +c Check the input arguments for errors. + + if (n .le. 0) task = 'ERROR: N .LE. 0' + if (m .le. 0) task = 'ERROR: M .LE. 0' + if (factr .lt. zero) task = 'ERROR: FACTR .LT. 0' + +c Check the validity of the arrays nbd(i), u(i), and l(i). + + do 10 i = 1, n + if (nbd(i) .lt. 0 .or. nbd(i) .gt. 3) then +c return + task = 'ERROR: INVALID NBD' + info = -6 + k = i + endif + if (nbd(i) .eq. 2) then + if (l(i) .gt. u(i)) then +c return + task = 'ERROR: NO FEASIBLE SOLUTION' + info = -7 + k = i + endif + endif + 10 continue + + return + + end subroutine + +c======================= The end of errclb ============================= + + subroutine formk(n, nsub, ind, nenter, ileave, indx2, iupdat, + + updatd, wn, wn1, m, ws, wy, sy, theta, col, + + head, info) + + integer n, nsub, m, col, head, nenter, ileave, iupdat, + + info, ind(n), indx2(n) + double precision theta, wn(2*m, 2*m), wn1(2*m, 2*m), + + ws(n, m), wy(n, m), sy(m, m) + logical updatd + +c ************ +c +c Subroutine formk +c +c This subroutine forms the LEL^T factorization of the indefinite +c +c matrix K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c where E = [-I 0] +c [ 0 I] +c The matrix K can be shown to be equal to the matrix M^[-1]N +c occurring in section 5.1 of [1], as well as to the matrix +c Mbar^[-1] Nbar in section 5.3. +c +c n is an integer variable. +c On entry n is the dimension of the problem. +c On exit n is unchanged. +c +c nsub is an integer variable +c On entry nsub is the number of subspace variables in free set. +c On exit nsub is not changed. +c +c ind is an integer array of dimension nsub. +c On entry ind specifies the indices of subspace variables. +c On exit ind is unchanged. +c +c nenter is an integer variable. +c On entry nenter is the number of variables entering the +c free set. +c On exit nenter is unchanged. +c +c ileave is an integer variable. +c On entry indx2(ileave),...,indx2(n) are the variables leaving +c the free set. +c On exit ileave is unchanged. +c +c indx2 is an integer array of dimension n. +c On entry indx2(1),...,indx2(nenter) are the variables entering +c the free set, while indx2(ileave),...,indx2(n) are the +c variables leaving the free set. +c On exit indx2 is unchanged. +c +c iupdat is an integer variable. +c On entry iupdat is the total number of BFGS updates made so far. +c On exit iupdat is unchanged. +c +c updatd is a logical variable. +c On entry 'updatd' is true if the L-BFGS matrix is updatd. +c On exit 'updatd' is unchanged. +c +c wn is a double precision array of dimension 2m x 2m. +c On entry wn is unspecified. +c On exit the upper triangle of wn stores the LEL^T factorization +c of the 2*col x 2*col indefinite matrix +c [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c +c wn1 is a double precision array of dimension 2m x 2m. +c On entry wn1 stores the lower triangular part of +c [Y' ZZ'Y L_a'+R_z'] +c [L_a+R_z S'AA'S ] +c in the previous iteration. +c On exit wn1 stores the corresponding updated matrices. +c The purpose of wn1 is just to store these inner products +c so they can be easily updated and inserted into wn. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric corrections +c used to define the limited memory matrix. +c On exit m is unchanged. +c +c ws, wy, sy, and wtyy are double precision arrays; +c theta is a double precision variable; +c col is an integer variable; +c head is an integer variable. +c On entry they store the information defining the +c limited memory BFGS matrix: +c ws(n,m) stores S, a set of s-vectors; +c wy(n,m) stores Y, a set of y-vectors; +c sy(m,m) stores S'Y; +c wtyy(m,m) stores the Cholesky factorization +c of (theta*S'S+LD^(-1)L') +c theta is the scaling factor specifying B_0 = theta I; +c col is the number of variable metric corrections stored; +c head is the location of the 1st s- (or y-) vector in S (or Y). +c On exit they are unchanged. +c +c info is an integer variable. +c On entry info is unspecified. +c On exit info = 0 for normal return; +c = -1 when the 1st Cholesky factorization failed; +c = -2 when the 2st Cholesky factorization failed. +c +c Subprograms called: +c +c Linpack ... dcopy, dpofa, dtrsl. +c +c +c References: +c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited +c memory algorithm for bound constrained optimization'', +c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. +c +c [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: a +c limited memory FORTRAN code for solving bound constrained +c optimization problems'', Tech. Report, NAM-11, EECS Department, +c Northwestern University, 1994. +c +c (Postscript files of these papers are available via anonymous +c ftp to eecs.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.) +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer m2,ipntr,jpntr,iy,is,jy,js,is1,js1,k1,i,k, + + col2,pbegin,pend,dbegin,dend,upcl +! double precision ddot,temp1,temp2,temp3,temp4 !Original + double precision temp1,temp2,temp3,temp4 !Fabian + double precision one,zero + parameter (one=1.0d0,zero=0.0d0) + +c Form the lower triangular part of +c WN1 = [Y' ZZ'Y L_a'+R_z'] +c [L_a+R_z S'AA'S ] +c where L_a is the strictly lower triangular part of S'AA'Y +c R_z is the upper triangular part of S'ZZ'Y. + + if (updatd) then + if (iupdat .gt. m) then +c shift old part of WN1. + do 10 jy = 1, m - 1 + js = m + jy + call dcopy(m-jy,wn1(jy+1,jy+1),1,wn1(jy,jy),1) + call dcopy(m-jy,wn1(js+1,js+1),1,wn1(js,js),1) + call dcopy(m-1,wn1(m+2,jy+1),1,wn1(m+1,jy),1) + 10 continue + endif + +c put new rows in blocks (1,1), (2,1) and (2,2). + pbegin = 1 + pend = nsub + dbegin = nsub + 1 + dend = n + iy = col + is = m + col + ipntr = head + col - 1 + if (ipntr .gt. m) ipntr = ipntr - m + jpntr = head + do 20 jy = 1, col + js = m + jy + temp1 = zero + temp2 = zero + temp3 = zero +c compute element jy of row 'col' of Y'ZZ'Y + do 15 k = pbegin, pend + k1 = ind(k) + temp1 = temp1 + wy(k1,ipntr)*wy(k1,jpntr) + 15 continue +c compute elements jy of row 'col' of L_a and S'AA'S + do 16 k = dbegin, dend + k1 = ind(k) + temp2 = temp2 + ws(k1,ipntr)*ws(k1,jpntr) + temp3 = temp3 + ws(k1,ipntr)*wy(k1,jpntr) + 16 continue + wn1(iy,jy) = temp1 + wn1(is,js) = temp2 + wn1(is,jy) = temp3 + jpntr = mod(jpntr,m) + 1 + 20 continue + +c put new column in block (2,1). + jy = col + jpntr = head + col - 1 + if (jpntr .gt. m) jpntr = jpntr - m + ipntr = head + do 30 i = 1, col + is = m + i + temp3 = zero +c compute element i of column 'col' of R_z + do 25 k = pbegin, pend + k1 = ind(k) + temp3 = temp3 + ws(k1,ipntr)*wy(k1,jpntr) + 25 continue + ipntr = mod(ipntr,m) + 1 + wn1(is,jy) = temp3 + 30 continue + upcl = col - 1 + else + upcl = col + endif + +c modify the old parts in blocks (1,1) and (2,2) due to changes +c in the set of free variables. + ipntr = head + do 45 iy = 1, upcl + is = m + iy + jpntr = head + do 40 jy = 1, iy + js = m + jy + temp1 = zero + temp2 = zero + temp3 = zero + temp4 = zero + do 35 k = 1, nenter + k1 = indx2(k) + temp1 = temp1 + wy(k1,ipntr)*wy(k1,jpntr) + temp2 = temp2 + ws(k1,ipntr)*ws(k1,jpntr) + 35 continue + do 36 k = ileave, n + k1 = indx2(k) + temp3 = temp3 + wy(k1,ipntr)*wy(k1,jpntr) + temp4 = temp4 + ws(k1,ipntr)*ws(k1,jpntr) + 36 continue + wn1(iy,jy) = wn1(iy,jy) + temp1 - temp3 + wn1(is,js) = wn1(is,js) - temp2 + temp4 + jpntr = mod(jpntr,m) + 1 + 40 continue + ipntr = mod(ipntr,m) + 1 + 45 continue + +c modify the old parts in block (2,1). + ipntr = head + do 60 is = m + 1, m + upcl + jpntr = head + do 55 jy = 1, upcl + temp1 = zero + temp3 = zero + do 50 k = 1, nenter + k1 = indx2(k) + temp1 = temp1 + ws(k1,ipntr)*wy(k1,jpntr) + 50 continue + do 51 k = ileave, n + k1 = indx2(k) + temp3 = temp3 + ws(k1,ipntr)*wy(k1,jpntr) + 51 continue + if (is .le. jy + m) then + wn1(is,jy) = wn1(is,jy) + temp1 - temp3 + else + wn1(is,jy) = wn1(is,jy) - temp1 + temp3 + endif + jpntr = mod(jpntr,m) + 1 + 55 continue + ipntr = mod(ipntr,m) + 1 + 60 continue + +c Form the upper triangle of WN = [D+Y' ZZ'Y/theta -L_a'+R_z' ] +c [-L_a +R_z S'AA'S*theta] + + m2 = 2*m + do 70 iy = 1, col + is = col + iy + is1 = m + iy + do 65 jy = 1, iy + js = col + jy + js1 = m + jy + wn(jy,iy) = wn1(iy,jy)/theta + wn(js,is) = wn1(is1,js1)*theta + 65 continue + do 66 jy = 1, iy - 1 + wn(jy,is) = -wn1(is1,jy) + 66 continue + do 67 jy = iy, col + wn(jy,is) = wn1(is1,jy) + 67 continue + wn(iy,iy) = wn(iy,iy) + sy(iy,iy) + 70 continue + +c Form the upper triangle of WN= [ LL' L^-1(-L_a'+R_z')] +c [(-L_a +R_z)L'^-1 S'AA'S*theta ] + +c first Cholesky factor (1,1) block of wn to get LL' +c with L' stored in the upper triangle of wn. + call dpofa(wn,m2,col,info) + if (info .ne. 0) then + info = -1 + return + endif +c then form L^-1(-L_a'+R_z') in the (1,2) block. + col2 = 2*col + do 71 js = col+1 ,col2 + call dtrsl(wn,m2,col,wn(1,js),11,info) + 71 continue + +c Form S'AA'S*theta + (L^-1(-L_a'+R_z'))'L^-1(-L_a'+R_z') in the +c upper triangle of (2,2) block of wn. + + + do 72 is = col+1, col2 + do 74 js = is, col2 + wn(is,js) = wn(is,js) + ddot(col,wn(1,is),1,wn(1,js),1) + 74 continue + 72 continue + +c Cholesky factorization of (2,2) block of wn. + + call dpofa(wn(col+1,col+1),m2,col,info) + if (info .ne. 0) then + info = -2 + return + endif + + return + + end subroutine + +c======================= The end of formk ============================== + + subroutine formt(m, wt, sy, ss, col, theta, info) + + integer m, col, info + double precision theta, wt(m, m), sy(m, m), ss(m, m) + +c ************ +c +c Subroutine formt +c +c This subroutine forms the upper half of the pos. def. and symm. +c T = theta*SS + L*D^(-1)*L', stores T in the upper triangle +c of the array wt, and performs the Cholesky factorization of T +c to produce J*J', with J' stored in the upper triangle of wt. +c +c Subprograms called: +c +c Linpack ... dpofa. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i,j,k,k1 + double precision ddum + double precision zero + parameter (zero=0.0d0) + + +c Form the upper half of T = theta*SS + L*D^(-1)*L', +c store T in the upper triangle of the array wt. + + do 52 j = 1, col + wt(1,j) = theta*ss(1,j) + 52 continue + do 55 i = 2, col + do 54 j = i, col + k1 = min(i,j) - 1 + ddum = zero + do 53 k = 1, k1 + ddum = ddum + sy(i,k)*sy(j,k)/sy(k,k) + 53 continue + wt(i,j) = ddum + theta*ss(i,j) + 54 continue + 55 continue + + +c Cholesky factorize T to J*J' with +c J' stored in the upper triangle of wt. + + call dpofa(wt,m,col,info) + if (info .ne. 0) then + info = -3 + endif + + return + + end subroutine + +c======================= The end of formt ============================== + + subroutine freev(n, nfree, index, nenter, ileave, indx2, + + iwhere, wrk, updatd, cnstnd, iprint, iter) + + integer n, nfree, nenter, ileave, iprint, iter, + + index(n), indx2(n), iwhere(n) + logical wrk, updatd, cnstnd + +c ************ +c +c Subroutine freev +c +c This subroutine counts the entering and leaving variables when +c iter > 0, and finds the index set of free and active variables +c at the GCP. +c +c cnstnd is a logical variable indicating whether bounds are present +c +c index is an integer array of dimension n +c for i=1,...,nfree, index(i) are the indices of free variables +c for i=nfree+1,...,n, index(i) are the indices of bound variables +c On entry after the first iteration, index gives +c the free variables at the previous iteration. +c On exit it gives the free variables based on the determination +c in cauchy using the array iwhere. +c +c indx2 is an integer array of dimension n +c On entry indx2 is unspecified. +c On exit with iter>0, indx2 indicates which variables +c have changed status since the previous iteration. +c For i= 1,...,nenter, indx2(i) have changed from bound to free. +c For i= ileave+1,...,n, indx2(i) have changed from free to bound. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer iact,i,k + + nenter = 0 + ileave = n + 1 + if (iter .gt. 0 .and. cnstnd) then +c count the entering and leaving variables. + do 20 i = 1, nfree + k = index(i) + +c write(6,*) ' k = index(i) ', k +c write(6,*) ' index = ', i + + if (iwhere(k) .gt. 0) then + ileave = ileave - 1 + indx2(ileave) = k + if (iprint .ge. 100) write (6,*) + + 'Variable ',k,' leaves the set of free variables' + endif + 20 continue + do 22 i = 1 + nfree, n + k = index(i) + if (iwhere(k) .le. 0) then + nenter = nenter + 1 + indx2(nenter) = k + if (iprint .ge. 100) write (6,*) + + 'Variable ',k,' enters the set of free variables' + endif + 22 continue + if (iprint .ge. 99) write (6,*) + + n+1-ileave,' variables leave; ',nenter,' variables enter' + endif + wrk = (ileave .lt. n+1) .or. (nenter .gt. 0) .or. updatd + +c Find the index set of free and active variables at the GCP. + + nfree = 0 + iact = n + 1 + do 24 i = 1, n + if (iwhere(i) .le. 0) then + nfree = nfree + 1 + index(nfree) = i + else + iact = iact - 1 + index(iact) = i + endif + 24 continue + if (iprint .ge. 99) write (6,*) + + nfree,' variables are free at GCP ',iter + 1 + + return + + end subroutine + +c======================= The end of freev ============================== + + subroutine hpsolb(n, t, iorder, iheap) + integer iheap, n, iorder(n) + double precision t(n) + +c ************ +c +c Subroutine hpsolb +c +c This subroutine sorts out the least element of t, and puts the +c remaining elements of t in a heap. +c +c n is an integer variable. +c On entry n is the dimension of the arrays t and iorder. +c On exit n is unchanged. +c +c t is a double precision array of dimension n. +c On entry t stores the elements to be sorted, +c On exit t(n) stores the least elements of t, and t(1) to t(n-1) +c stores the remaining elements in the form of a heap. +c +c iorder is an integer array of dimension n. +c On entry iorder(i) is the index of t(i). +c On exit iorder(i) is still the index of t(i), but iorder may be +c permuted in accordance with t. +c +c iheap is an integer variable specifying the task. +c On entry iheap should be set as follows: +c iheap .eq. 0 if t(1) to t(n) is not in the form of a heap, +c iheap .ne. 0 if otherwise. +c On exit iheap is unchanged. +c +c +c References: +c Algorithm 232 of CACM (J. W. J. Williams): HEAPSORT. +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c ************ + + integer i,j,k,indxin,indxou + double precision ddum,out + + if (iheap .eq. 0) then + +c Rearrange the elements t(1) to t(n) to form a heap. + + do 20 k = 2, n + ddum = t(k) + indxin = iorder(k) + +c Add ddum to the heap. + i = k + 10 continue + if (i.gt.1) then + j = i/2 + if (ddum .lt. t(j)) then + t(i) = t(j) + iorder(i) = iorder(j) + i = j + goto 10 + endif + endif + t(i) = ddum + iorder(i) = indxin + 20 continue + endif + +c Assign to 'out' the value of t(1), the least member of the heap, +c and rearrange the remaining members to form a heap as +c elements 1 to n-1 of t. + + if (n .gt. 1) then + i = 1 + out = t(1) + indxou = iorder(1) + ddum = t(n) + indxin = iorder(n) + +c Restore the heap + 30 continue + j = i+i + if (j .le. n-1) then + if (t(j+1) .lt. t(j)) j = j+1 + if (t(j) .lt. ddum ) then + t(i) = t(j) + iorder(i) = iorder(j) + i = j + goto 30 + endif + endif + t(i) = ddum + iorder(i) = indxin + +c Put the least member in t(n). + + t(n) = out + iorder(n) = indxou + endif + + return + + end subroutine + +c====================== The end of hpsolb ============================== + + subroutine lnsrlb(n, l, u, nbd, x, f, fold, gd, gdold, g, d, r, t, + + z, stp, dnorm, dtd, xstep, stpmx, iter, ifun, + + iback, nfgv, info, task, boxed, cnstnd, csave, + + isave, dsave) + + character*60 task, csave + logical boxed, cnstnd + integer n, iter, ifun, iback, nfgv, info, + + nbd(n), isave(2) + double precision f, fold, gd, gdold, stp, dnorm, dtd, xstep, + + stpmx, x(n), l(n), u(n), g(n), d(n), r(n), t(n), + + z(n), dsave(13) +c ********** +c +c Subroutine lnsrlb +c +c This subroutine calls subroutine dcsrch from the Minpack2 library +c to perform the line search. Subroutine dscrch is safeguarded so +c that all trial points lie within the feasible region. +c +c Subprograms called: +c +c Minpack2 Library ... dcsrch. +c +c Linpack ... dtrsl, ddot. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ********** + + integer i +! double precision ddot,a1,a2 !Original + double precision a1,a2 !Fabian + double precision one,zero,big + parameter (one=1.0d0,zero=0.0d0,big=1.0d+10) + double precision ftol,gtol,xtol + parameter (ftol=1.0d-3,gtol=0.9d0,xtol=0.1d0) + !FF: Note that these tolerances are hardcoded! + + if (task(1:5) .eq. 'FG_LN') goto 556 + + dtd = ddot(n,d,1,d,1) + dnorm = sqrt(dtd) + +c Determine the maximum step length. + + stpmx = big + if (cnstnd) then + if (iter .eq. 0) then + stpmx = one + else + do 43 i = 1, n + a1 = d(i) + if (nbd(i) .ne. 0) then + if (a1 .lt. zero .and. nbd(i) .le. 2) then + a2 = l(i) - x(i) + if (a2 .ge. zero) then + stpmx = zero + else if (a1*stpmx .lt. a2) then + stpmx = a2/a1 + endif + else if (a1 .gt. zero .and. nbd(i) .ge. 2) then + a2 = u(i) - x(i) + if (a2 .le. zero) then + stpmx = zero + else if (a1*stpmx .gt. a2) then + stpmx = a2/a1 + endif + endif + endif + 43 continue + endif + endif + + if (iter .eq. 0 .and. .not. boxed) then + stp = min(one/dnorm, stpmx) + else + stp = one + endif + + call dcopy(n,x,1,t,1) + call dcopy(n,g,1,r,1) + + fold = f + ifun = 0 + iback = 0 + csave = 'START' + 556 continue + gd = ddot(n,g,1,d,1) + if (ifun .eq. 0) then + gdold=gd + if (gd .ge. zero) then +c the directional derivative >=0. +c Line search is impossible. + write(6,*)' ascent direction in projection gd = ', gd + info = -4 + return + endif + endif + + call dcsrch(f,gd,stp,ftol,gtol,xtol,zero,stpmx,csave,isave,dsave) + + xstep = stp*dnorm + if (csave(1:4) .ne. 'CONV' .and. csave(1:4) .ne. 'WARN') then + task = 'FG_LNSRCH' + ifun = ifun + 1 + nfgv = nfgv + 1 + iback = ifun - 1 + if (stp .eq. one) then + call dcopy(n,z,1,x,1) + else + do 41 i = 1, n + x(i) = stp*d(i) + t(i) + 41 continue + + endif + else + task = 'NEW_X' + endif + + + return + + end subroutine + +c======================= The end of lnsrlb ============================= + + subroutine matupd(n, m, ws, wy, sy, ss, d, r, itail, + + iupdat, col, head, theta, rr, dr, stp, dtd) + + integer n, m, itail, iupdat, col, head + double precision theta, rr, dr, stp, dtd, d(n), r(n), + + ws(n, m), wy(n, m), sy(m, m), ss(m, m) + +c ************ +c +c Subroutine matupd +c +c This subroutine updates matrices WS and WY, and forms the +c middle matrix in B. +c +c Subprograms called: +c +c Linpack ... dcopy, ddot. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer j,pointr +! double precision ddot !Original + !Fabian + double precision one + parameter (one=1.0d0) + +c Set pointers for matrices WS and WY. + + if (iupdat .le. m) then + col = iupdat + itail = mod(head+iupdat-2,m) + 1 + else + itail = mod(itail,m) + 1 + head = mod(head,m) + 1 + endif + +c Update matrices WS and WY. + + call dcopy(n,d,1,ws(1,itail),1) + call dcopy(n,r,1,wy(1,itail),1) + +c Set theta=yy/ys. + + theta = rr/dr +! write(6,*) 'FF:theta=', theta + + +c Form the middle matrix in B. + +c update the upper triangle of SS, +c and the lower triangle of SY: + if (iupdat .gt. m) then +c move old information + do 50 j = 1, col - 1 + call dcopy(j,ss(2,j+1),1,ss(1,j),1) + call dcopy(col-j,sy(j+1,j+1),1,sy(j,j),1) + 50 continue + endif +c add new information: the last row of SY +c and the last column of SS: + pointr = head + do 51 j = 1, col - 1 + sy(col,j) = ddot(n,d,1,wy(1,pointr),1) + ss(j,col) = ddot(n,ws(1,pointr),1,d,1) + pointr = mod(pointr,m) + 1 + 51 continue + if (stp .eq. one) then + ss(col,col) = dtd + else + ss(col,col) = stp*stp*dtd + endif + sy(col,col) = dr + + return + + end subroutine + +c======================= The end of matupd ============================= + + subroutine prn1lb(n, m, l, u, x, iprint, itfile, epsmch) + + integer n, m, iprint, itfile + double precision epsmch, x(n), l(n), u(n) + +c ************ +c +c Subroutine prn1lb +c +c This subroutine prints the input data, initial point, upper and +c lower bounds of each variable, machine precision, as well as +c the headings of the output. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i + + if (iprint .ge. 0) then + write (6,7001) epsmch + write (6,*) 'N = ',n,' M = ',m + if (iprint .ge. 1) then + write (itfile,2001) epsmch + write (itfile,*)'N = ',n,' M = ',m + write (itfile,9001) + if (iprint .gt. 100) then + write (6,1004) 'L =',(l(i),i = 1,n) + write (6,1004) 'X0 =',(x(i),i = 1,n) + write (6,1004) 'U =',(u(i),i = 1,n) + endif + endif + endif + + 1004 format (/,a4, 1p, 6(1x,d11.4),/,(4x,1p,6(1x,d11.4))) + 2001 format ('RUNNING THE L-BFGS-B CODE',/,/, + + 'it = iteration number',/, + + 'nf = number of function evaluations',/, + + 'nseg = number of segments explored during the Cauchy search',/, + + 'nact = number of active bounds at the generalized Cauchy point' + + ,/, + + 'sub = manner in which the subspace minimization terminated:' + + ,/,' con = converged, bnd = a bound was reached',/, + + 'itls = number of iterations performed in the line search',/, + + 'stepl = step length used',/, + + 'tstep = norm of the displacement (total step)',/, + + 'projg = norm of the projected gradient',/, + + 'f = function value',/,/, + + ' * * *',/,/, + + 'Machine precision =',1p,d10.3) + 7001 format ('RUNNING THE L-BFGS-B CODE',/,/, + + ' * * *',/,/, + + 'Machine precision =',1p,d10.3) + 9001 format (/,3x,'it',3x,'nf',2x,'nseg',2x,'nact',2x,'sub',2x,'itls', + + 2x,'stepl',4x,'tstep',5x,'projg',8x,'f') + + return + + end subroutine + +c======================= The end of prn1lb ============================= + + subroutine prn2lb(n, x, f, g, iprint, itfile, iter, nfgv, nact, + + sbgnrm, nseg, word, iword, iback, stp, xstep) + + character*3 word + integer n, iprint, itfile, iter, nfgv, nact, nseg, + + iword, iback + double precision f, sbgnrm, stp, xstep, x(n), g(n) + +c ************ +c +c Subroutine prn2lb +c +c This subroutine prints out new information after a successful +c line search. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i,imod + +c 'word' records the status of subspace solutions. + if (iword .eq. 0) then +c the subspace minimization converged. + word = 'con' + else if (iword .eq. 1) then +c the subspace minimization stopped at a bound. + word = 'bnd' + else if (iword .eq. 5) then +c the truncated Newton step has been used. + word = 'TNT' + else + word = '---' + endif + if (iprint .ge. 99) then + write (6,*) 'LINE SEARCH',iback,' times; norm of step = ',xstep + write (6,2001) iter,f,sbgnrm + if (iprint .gt. 100) then + write (6,1004) 'X =',(x(i), i = 1, n) + write (6,1004) 'G =',(g(i), i = 1, n) + endif + else if (iprint .gt. 0) then + imod = mod(iter,iprint) + if (imod .eq. 0) write (6,2001) iter,f,sbgnrm + endif + if (iprint .ge. 1) write (itfile,3001) + + iter,nfgv,nseg,nact,word,iback,stp,xstep,sbgnrm,f + + 1004 format (/,a4, 1p, 6(1x,d11.4),/,(4x,1p,6(1x,d11.4))) + 2001 format + + (/,'At iterate',i5,4x,'f= ',1p,d12.5,4x,'|proj g|= ',1p,d12.5) + 3001 format(2(1x,i4),2(1x,i5),2x,a3,1x,i4,1p,2(2x,d8.1),1p,2(1x,d10.3)) + + return + + end subroutine + +c======================= The end of prn2lb ============================= + + subroutine prn3lb(n, x, f, task, iprint, info, itfile, + + iter, nfgv, nintol, nskip, nact, sbgnrm, + + time, nseg, word, iback, stp, xstep, k, + + cachyt, sbtime, lnscht) + + character*60 task + character*3 word + integer n, iprint, info, itfile, iter, nfgv, nintol, + + nskip, nact, nseg, iback, k + double precision f, sbgnrm, time, stp, xstep, cachyt, sbtime, + + lnscht, x(n) + +c ************ +c +c Subroutine prn3lb +c +c This subroutine prints out information when either a built-in +c convergence test is satisfied or when an error message is +c generated. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i + + if (task(1:5) .eq. 'ERROR') goto 999 + + if (iprint .ge. 0) then + write (6,3003) + write (6,3004) + write(6,3005) n,iter,nfgv,nintol,nskip,nact,sbgnrm,f + if (iprint .ge. 100) then + write (6,1004) 'X =',(x(i),i = 1,n) + endif + if (iprint .ge. 1) write (6,*) ' F =',f + endif + 999 continue + if (iprint .ge. 0) then + write (6,3009) task + if (info .ne. 0) then + if (info .eq. -1) write (6,9011) + if (info .eq. -2) write (6,9012) + if (info .eq. -3) write (6,9013) + if (info .eq. -4) write (6,9014) + if (info .eq. -5) write (6,9015) + if (info .eq. -6) write (6,*)' Input nbd(',k,') is invalid.' + if (info .eq. -7) + + write (6,*)' l(',k,') > u(',k,'). No feasible solution.' + if (info .eq. -8) write (6,9018) + if (info .eq. -9) write (6,9019) + endif + if (iprint .ge. 1) write (6,3007) cachyt,sbtime,lnscht + write (6,3008) time + if (iprint .ge. 1) then + if (info .eq. -4 .or. info .eq. -9) then + write (itfile,3002) + + iter,nfgv,nseg,nact,word,iback,stp,xstep + endif + write (itfile,3009) task + if (info .ne. 0) then + if (info .eq. -1) write (itfile,9011) + if (info .eq. -2) write (itfile,9012) + if (info .eq. -3) write (itfile,9013) + if (info .eq. -4) write (itfile,9014) + if (info .eq. -5) write (itfile,9015) + if (info .eq. -8) write (itfile,9018) + if (info .eq. -9) write (itfile,9019) + endif + write (itfile,3008) time + endif + endif + + 1004 format (/,a4, 1p, 6(1x,d11.4),/,(4x,1p,6(1x,d11.4))) + 3002 format(2(1x,i4),2(1x,i5),2x,a3,1x,i4,1p,2(2x,d8.1),6x,'-',10x,'-') + 3003 format (/, + + ' * * *',/,/, + + 'Tit = total number of iterations',/, + + 'Tnf = total number of function evaluations',/, + + 'Tnint = total number of segments explored during', + + ' Cauchy searches',/, + + 'Skip = number of BFGS updates skipped',/, + + 'Nact = number of active bounds at final generalized', + + ' Cauchy point',/, + + 'Projg = norm of the final projected gradient',/, + + 'F = final function value',/,/, + + ' * * *') + 3004 format (/,3x,'N',4x,'Tit',5x,'Tnf',2x,'Tnint',2x, + + 'Skip',2x,'Nact',5x,'Projg',8x,'F') + 3005 format (i5,2(1x,i6),(1x,i6),(2x,i4),(1x,i5),1p,2(2x,d10.3)) + 3007 format (/,' Cauchy time',1p,e10.3,' seconds.',/ + + ' Subspace minimization time',1p,e10.3,' seconds.',/ + + ' Line search time',1p,e10.3,' seconds.') + 3008 format (/,' Total User time',1p,e10.3,' seconds.',/) + 3009 format (/,a60) + 9011 format (/, + +' Matrix in 1st Cholesky factorization in formk is not Pos. Def.') + 9012 format (/, + +' Matrix in 2st Cholesky factorization in formk is not Pos. Def.') + 9013 format (/, + +' Matrix in the Cholesky factorization in formt is not Pos. Def.') + 9014 format (/, + +' Derivative >= 0, backtracking line search impossible.',/, + +' Previous x, f and g restored.',/, + +' Possible causes: 1 error in function or gradient evaluation;',/, + +' 2 rounding errors dominate computation.') + 9015 format (/, + +' Warning: more than 10 function and gradient',/, + +' evaluations in the last line search. Termination',/, + +' may possibly be caused by a bad search direction.') + 9018 format (/,' The triangular system is singular.') + 9019 format (/, + +' Line search cannot locate an adequate point after 20 function',/ + +,' and gradient evaluations. Previous x, f and g restored.',/, + +' Possible causes: 1 error in function or gradient evaluation;',/, + +' 2 rounding error dominate computation.') + + return + + end subroutine + +c======================= The end of prn3lb ============================= + + subroutine projgr(n, l, u, nbd, x, g, sbgnrm) + + integer n, nbd(n) + double precision sbgnrm, x(n), l(n), u(n), g(n) + +c ************ +c +c Subroutine projgr +c +c This subroutine computes the infinity norm of the projected +c gradient. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i + double precision gi + double precision one,zero + parameter (one=1.0d0,zero=0.0d0) + + sbgnrm = zero + do 15 i = 1, n + gi = g(i) + if (nbd(i) .ne. 0) then + if (gi .lt. zero) then + if (nbd(i) .ge. 2) gi = max((x(i)-u(i)),gi) + else + if (nbd(i) .le. 2) gi = min((x(i)-l(i)),gi) + endif + endif + sbgnrm = max(sbgnrm,abs(gi)) + 15 continue + + return + + end subroutine + +c======================= The end of projgr ============================= + + subroutine subsm ( n, m, nsub, ind, l, u, nbd, x, d, xp, ws, wy, + + theta, xx, gg, + + col, head, iword, wv, wn, iprint, info ) + implicit none + integer n, m, nsub, col, head, iword, iprint, info, + + ind(nsub), nbd(n) + double precision theta, + + l(n), u(n), x(n), d(n), xp(n), xx(n), gg(n), + + ws(n, m), wy(n, m), + + wv(2*m), wn(2*m, 2*m) + +c ********************************************************************** +c +c This routine contains the major changes in the updated version. +c The changes are described in the accompanying paper +c +c Jose Luis Morales, Jorge Nocedal +c "Remark On Algorithm 788: L-BFGS-B: Fortran Subroutines for Large-Scale +c Bound Constrained Optimization". Decemmber 27, 2010. +c +c J.L. Morales Departamento de Matematicas, +c Instituto Tecnologico Autonomo de Mexico +c Mexico D.F. +c +c J, Nocedal Department of Electrical Engineering and +c Computer Science. +c Northwestern University. Evanston, IL. USA +c +c January 17, 2011 +c +c ********************************************************************** +c +c +c Subroutine subsm +c +c Given xcp, l, u, r, an index set that specifies +c the active set at xcp, and an l-BFGS matrix B +c (in terms of WY, WS, SY, WT, head, col, and theta), +c this subroutine computes an approximate solution +c of the subspace problem +c +c (P) min Q(x) = r'(x-xcp) + 1/2 (x-xcp)' B (x-xcp) +c +c subject to l<=x<=u +c x_i=xcp_i for all i in A(xcp) +c +c along the subspace unconstrained Newton direction +c +c d = -(Z'BZ)^(-1) r. +c +c The formula for the Newton direction, given the L-BFGS matrix +c and the Sherman-Morrison formula, is +c +c d = (1/theta)r + (1/theta*2) Z'WK^(-1)W'Z r. +c +c where +c K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c +c Note that this procedure for computing d differs +c from that described in [1]. One can show that the matrix K is +c equal to the matrix M^[-1]N in that paper. +c +c n is an integer variable. +c On entry n is the dimension of the problem. +c On exit n is unchanged. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric corrections +c used to define the limited memory matrix. +c On exit m is unchanged. +c +c nsub is an integer variable. +c On entry nsub is the number of free variables. +c On exit nsub is unchanged. +c +c ind is an integer array of dimension nsub. +c On entry ind specifies the coordinate indices of free variables. +c On exit ind is unchanged. +c +c l is a double precision array of dimension n. +c On entry l is the lower bound of x. +c On exit l is unchanged. +c +c u is a double precision array of dimension n. +c On entry u is the upper bound of x. +c On exit u is unchanged. +c +c nbd is a integer array of dimension n. +c On entry nbd represents the type of bounds imposed on the +c variables, and must be specified as follows: +c nbd(i)=0 if x(i) is unbounded, +c 1 if x(i) has only a lower bound, +c 2 if x(i) has both lower and upper bounds, and +c 3 if x(i) has only an upper bound. +c On exit nbd is unchanged. +c +c x is a double precision array of dimension n. +c On entry x specifies the Cauchy point xcp. +c On exit x(i) is the minimizer of Q over the subspace of +c free variables. +c +c d is a double precision array of dimension n. +c On entry d is the reduced gradient of Q at xcp. +c On exit d is the Newton direction of Q. +c +c xp is a double precision array of dimension n. +c used to safeguard the projected Newton direction +c +c xx is a double precision array of dimension n +c On entry it holds the current iterate +c On output it is unchanged + +c gg is a double precision array of dimension n +c On entry it holds the gradient at the current iterate +c On output it is unchanged +c +c ws and wy are double precision arrays; +c theta is a double precision variable; +c col is an integer variable; +c head is an integer variable. +c On entry they store the information defining the +c limited memory BFGS matrix: +c ws(n,m) stores S, a set of s-vectors; +c wy(n,m) stores Y, a set of y-vectors; +c theta is the scaling factor specifying B_0 = theta I; +c col is the number of variable metric corrections stored; +c head is the location of the 1st s- (or y-) vector in S (or Y). +c On exit they are unchanged. +c +c iword is an integer variable. +c On entry iword is unspecified. +c On exit iword specifies the status of the subspace solution. +c iword = 0 if the solution is in the box, +c 1 if some bound is encountered. +c +c wv is a double precision working array of dimension 2m. +c +c wn is a double precision array of dimension 2m x 2m. +c On entry the upper triangle of wn stores the LEL^T factorization +c of the indefinite matrix +c +c K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c where E = [-I 0] +c [ 0 I] +c On exit wn is unchanged. +c +c iprint is an INTEGER variable that must be set by the user. +c It controls the frequency and type of output generated: +c iprint<0 no output is generated; +c iprint=0 print only one line at the last iteration; +c 0100 print details of every iteration including x and g; +c When iprint > 0, the file iterate.dat will be created to +c summarize the iteration. +c +c info is an integer variable. +c On entry info is unspecified. +c On exit info = 0 for normal return, +c = nonzero for abnormal return +c when the matrix K is ill-conditioned. +c +c Subprograms called: +c +c Linpack dtrsl. +c +c +c References: +c +c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited +c memory algorithm for bound constrained optimization'', +c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. +c +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer pointr,m2,col2,ibd,jy,js,i,j,k + double precision alpha, xk, dk, temp1, temp2 + double precision one,zero + parameter (one=1.0d0,zero=0.0d0) +c + double precision dd_p + + if (nsub .le. 0) return + if (iprint .ge. 99) write (6,1001) + +c Compute wv = W'Zd. + + pointr = head + do 20 i = 1, col + temp1 = zero + temp2 = zero + do 10 j = 1, nsub + k = ind(j) + temp1 = temp1 + wy(k,pointr)*d(j) + temp2 = temp2 + ws(k,pointr)*d(j) + 10 continue + wv(i) = temp1 + wv(col + i) = theta*temp2 + pointr = mod(pointr,m) + 1 + 20 continue + +c Compute wv:=K^(-1)wv. + + m2 = 2*m + col2 = 2*col + call dtrsl(wn,m2,col2,wv,11,info) + if (info .ne. 0) return + do 25 i = 1, col + wv(i) = -wv(i) + 25 continue + call dtrsl(wn,m2,col2,wv,01,info) + if (info .ne. 0) return + +c Compute d = (1/theta)d + (1/theta**2)Z'W wv. + + pointr = head + do 40 jy = 1, col + js = col + jy + do 30 i = 1, nsub + k = ind(i) + d(i) = d(i) + wy(k,pointr)*wv(jy)/theta + + + ws(k,pointr)*wv(js) + 30 continue + pointr = mod(pointr,m) + 1 + 40 continue + + call dscal( nsub, one/theta, d, 1 ) +c +c----------------------------------------------------------------- +c Let us try the projection, d is the Newton direction + + iword = 0 + + call dcopy ( n, x, 1, xp, 1 ) +c + do 50 i=1, nsub + k = ind(i) + dk = d(i) + xk = x(k) + if ( nbd(k) .ne. 0 ) then +c + if ( nbd(k).eq.1 ) then ! lower bounds only + x(k) = max( l(k), xk + dk ) + if ( x(k).eq.l(k) ) iword = 1 + else +c + if ( nbd(k).eq.2 ) then ! upper and lower bounds + xk = max( l(k), xk + dk ) + x(k) = min( u(k), xk ) + if ( x(k).eq.l(k) .or. x(k).eq.u(k) ) iword = 1 + else +c + if ( nbd(k).eq.3 ) then ! upper bounds only + x(k) = min( u(k), xk + dk ) + if ( x(k).eq.u(k) ) iword = 1 + end if + end if + end if +c + else ! free variables + x(k) = xk + dk + end if + 50 continue +c + if ( iword.eq.0 ) then + go to 911 + end if +c +c check sign of the directional derivative +c + dd_p = zero + do 55 i=1, n + dd_p = dd_p + (x(i) - xx(i))*gg(i) + 55 continue + if ( dd_p .gt.zero ) then + call dcopy( n, xp, 1, x, 1 ) + write(6,*) ' Positive dir derivative in projection ' + write(6,*) ' Using the backtracking step ' + else + go to 911 + endif +c +c----------------------------------------------------------------- +c + alpha = one + temp1 = alpha + ibd = 0 + do 60 i = 1, nsub + k = ind(i) + dk = d(i) + if (nbd(k) .ne. 0) then + if (dk .lt. zero .and. nbd(k) .le. 2) then + temp2 = l(k) - x(k) + if (temp2 .ge. zero) then + temp1 = zero + else if (dk*alpha .lt. temp2) then + temp1 = temp2/dk + endif + else if (dk .gt. zero .and. nbd(k) .ge. 2) then + temp2 = u(k) - x(k) + if (temp2 .le. zero) then + temp1 = zero + else if (dk*alpha .gt. temp2) then + temp1 = temp2/dk + endif + endif + if (temp1 .lt. alpha) then + alpha = temp1 + ibd = i + endif + endif + 60 continue + + if (alpha .lt. one) then + dk = d(ibd) + k = ind(ibd) + if (dk .gt. zero) then + x(k) = u(k) + d(ibd) = zero + else if (dk .lt. zero) then + x(k) = l(k) + d(ibd) = zero + endif + endif + do 70 i = 1, nsub + k = ind(i) + x(k) = x(k) + alpha*d(i) + 70 continue +cccccc + 911 continue + + if (iprint .ge. 99) write (6,1004) + + 1001 format (/,'----------------SUBSM entered-----------------',/) + 1004 format (/,'----------------exit SUBSM --------------------',/) + + return + + end subroutine +c====================== The end of subsm =============================== + + subroutine dcsrch(f,g,stp,ftol,gtol,xtol,stpmin,stpmax, + + task,isave,dsave) + character*(*) task + integer isave(2) + double precision f,g,stp,ftol,gtol,xtol,stpmin,stpmax + double precision dsave(13) +c ********** +c +c Subroutine dcsrch +c +c This subroutine finds a step that satisfies a sufficient +c decrease condition and a curvature condition. +c +c Each call of the subroutine updates an interval with +c endpoints stx and sty. The interval is initially chosen +c so that it contains a minimizer of the modified function +c +c psi(stp) = f(stp) - f(0) - ftol*stp*f'(0). +c +c If psi(stp) <= 0 and f'(stp) >= 0 for some step, then the +c interval is chosen so that it contains a minimizer of f. +c +c The algorithm is designed to find a step that satisfies +c the sufficient decrease condition +c +c f(stp) <= f(0) + ftol*stp*f'(0), +c +c and the curvature condition +c +c abs(f'(stp)) <= gtol*abs(f'(0)). +c +c If ftol is less than gtol and if, for example, the function +c is bounded below, then there is always a step which satisfies +c both conditions. +c +c If no step can be found that satisfies both conditions, then +c the algorithm stops with a warning. In this case stp only +c satisfies the sufficient decrease condition. +c +c A typical invocation of dcsrch has the following outline: +c +c task = 'START' +c 10 continue +c call dcsrch( ... ) +c if (task .eq. 'FG') then +c Evaluate the function and the gradient at stp +c goto 10 +c end if +c +c NOTE: The user must no alter work arrays between calls. +c +c The subroutine statement is +c +c subroutine dcsrch(f,g,stp,ftol,gtol,xtol,stpmin,stpmax, +c task,isave,dsave) +c where +c +c f is a double precision variable. +c On initial entry f is the value of the function at 0. +c On subsequent entries f is the value of the +c function at stp. +c On exit f is the value of the function at stp. +c +c g is a double precision variable. +c On initial entry g is the derivative of the function at 0. +c On subsequent entries g is the derivative of the +c function at stp. +c On exit g is the derivative of the function at stp. +c +c stp is a double precision variable. +c On entry stp is the current estimate of a satisfactory +c step. On initial entry, a positive initial estimate +c must be provided. +c On exit stp is the current estimate of a satisfactory step +c if task = 'FG'. If task = 'CONV' then stp satisfies +c the sufficient decrease and curvature condition. +c +c ftol is a double precision variable. +c On entry ftol specifies a nonnegative tolerance for the +c sufficient decrease condition. +c On exit ftol is unchanged. +c +c gtol is a double precision variable. +c On entry gtol specifies a nonnegative tolerance for the +c curvature condition. +c On exit gtol is unchanged. +c +c xtol is a double precision variable. +c On entry xtol specifies a nonnegative relative tolerance +c for an acceptable step. The subroutine exits with a +c warning if the relative difference between sty and stx +c is less than xtol. +c On exit xtol is unchanged. +c +c stpmin is a double precision variable. +c On entry stpmin is a nonnegative lower bound for the step. +c On exit stpmin is unchanged. +c +c stpmax is a double precision variable. +c On entry stpmax is a nonnegative upper bound for the step. +c On exit stpmax is unchanged. +c +c task is a character variable of length at least 60. +c On initial entry task must be set to 'START'. +c On exit task indicates the required action: +c +c If task(1:2) = 'FG' then evaluate the function and +c derivative at stp and call dcsrch again. +c +c If task(1:4) = 'CONV' then the search is successful. +c +c If task(1:4) = 'WARN' then the subroutine is not able +c to satisfy the convergence conditions. The exit value of +c stp contains the best point found during the search. +c +c If task(1:5) = 'ERROR' then there is an error in the +c input arguments. +c +c On exit with convergence, a warning or an error, the +c variable task contains additional information. +c +c isave is an integer work array of dimension 2. +c +c dsave is a double precision work array of dimension 13. +c +c Subprograms called +c +c MINPACK-2 ... dcstep +c +c MINPACK-1 Project. June 1983. +c Argonne National Laboratory. +c Jorge J. More' and David J. Thuente. +c +c MINPACK-2 Project. October 1993. +c Argonne National Laboratory and University of Minnesota. +c Brett M. Averick, Richard G. Carter, and Jorge J. More'. +c +c ********** + double precision zero,p5,p66 + parameter(zero=0.0d0,p5=0.5d0,p66=0.66d0) + double precision xtrapl,xtrapu + parameter(xtrapl=1.1d0,xtrapu=4.0d0) + + logical brackt + integer stage + double precision finit,ftest,fm,fx,fxm,fy,fym,ginit,gtest, + + gm,gx,gxm,gy,gym,stx,sty,stmin,stmax,width,width1 + +c Initialization block. + + if (task(1:5) .eq. 'START') then + +c Check the input arguments for errors. + + if (stp .lt. stpmin) task = 'ERROR: STP .LT. STPMIN' + if (stp .gt. stpmax) task = 'ERROR: STP .GT. STPMAX' + if (g .ge. zero) task = 'ERROR: INITIAL G .GE. ZERO' + if (ftol .lt. zero) task = 'ERROR: FTOL .LT. ZERO' + if (gtol .lt. zero) task = 'ERROR: GTOL .LT. ZERO' + if (xtol .lt. zero) task = 'ERROR: XTOL .LT. ZERO' + if (stpmin .lt. zero) task = 'ERROR: STPMIN .LT. ZERO' + if (stpmax .lt. stpmin) task = 'ERROR: STPMAX .LT. STPMIN' + +c Exit if there are errors on input. + + if (task(1:5) .eq. 'ERROR') return + +c Initialize local variables. + + brackt = .false. + stage = 1 + finit = f + ginit = g + gtest = ftol*ginit + width = stpmax - stpmin + width1 = width/p5 + +c The variables stx, fx, gx contain the values of the step, +c function, and derivative at the best step. +c The variables sty, fy, gy contain the value of the step, +c function, and derivative at sty. +c The variables stp, f, g contain the values of the step, +c function, and derivative at stp. + + stx = zero + fx = finit + gx = ginit + sty = zero + fy = finit + gy = ginit + stmin = zero + stmax = stp + xtrapu*stp + task = 'FG' + + goto 1000 + + else + +c Restore local variables. + + if (isave(1) .eq. 1) then + brackt = .true. + else + brackt = .false. + endif + stage = isave(2) + ginit = dsave(1) + gtest = dsave(2) + gx = dsave(3) + gy = dsave(4) + finit = dsave(5) + fx = dsave(6) + fy = dsave(7) + stx = dsave(8) + sty = dsave(9) + stmin = dsave(10) + stmax = dsave(11) + width = dsave(12) + width1 = dsave(13) + + endif + +c If psi(stp) <= 0 and f'(stp) >= 0 for some step, then the +c algorithm enters the second stage. + + ftest = finit + stp*gtest + if (stage .eq. 1 .and. f .le. ftest .and. g .ge. zero) + + stage = 2 + +c Test for warnings. + + if (brackt .and. (stp .le. stmin .or. stp .ge. stmax)) + + task = 'WARNING: ROUNDING ERRORS PREVENT PROGRESS' + if (brackt .and. stmax - stmin .le. xtol*stmax) + + task = 'WARNING: XTOL TEST SATISFIED' + if (stp .eq. stpmax .and. f .le. ftest .and. g .le. gtest) + + task = 'WARNING: STP = STPMAX' + if (stp .eq. stpmin .and. (f .gt. ftest .or. g .ge. gtest)) + + task = 'WARNING: STP = STPMIN' + +c Test for convergence. + + if (f .le. ftest .and. abs(g) .le. gtol*(-ginit)) + + task = 'CONVERGENCE' + +c Test for termination. + + if (task(1:4) .eq. 'WARN' .or. task(1:4) .eq. 'CONV') goto 1000 + +c A modified function is used to predict the step during the +c first stage if a lower function value has been obtained but +c the decrease is not sufficient. + + if (stage .eq. 1 .and. f .le. fx .and. f .gt. ftest) then + +c Define the modified function and derivative values. + + fm = f - stp*gtest + fxm = fx - stx*gtest + fym = fy - sty*gtest + gm = g - gtest + gxm = gx - gtest + gym = gy - gtest + +c Call dcstep to update stx, sty, and to compute the new step. + + call dcstep(stx,fxm,gxm,sty,fym,gym,stp,fm,gm, + + brackt,stmin,stmax) + +c Reset the function and derivative values for f. + + fx = fxm + stx*gtest + fy = fym + sty*gtest + gx = gxm + gtest + gy = gym + gtest + + else + +c Call dcstep to update stx, sty, and to compute the new step. + + call dcstep(stx,fx,gx,sty,fy,gy,stp,f,g, + + brackt,stmin,stmax) + + endif + +c Decide if a bisection step is needed. + + if (brackt) then + if (abs(sty-stx) .ge. p66*width1) stp = stx + p5*(sty - stx) + width1 = width + width = abs(sty-stx) + endif + +c Set the minimum and maximum steps allowed for stp. + + if (brackt) then + stmin = min(stx,sty) + stmax = max(stx,sty) + else + stmin = stp + xtrapl*(stp - stx) + stmax = stp + xtrapu*(stp - stx) + endif + +c Force the step to be within the bounds stpmax and stpmin. + + stp = max(stp,stpmin) + stp = min(stp,stpmax) + +c If further progress is not possible, let stp be the best +c point obtained during the search. + + if (brackt .and. (stp .le. stmin .or. stp .ge. stmax) + + .or. (brackt .and. stmax-stmin .le. xtol*stmax)) stp = stx + +c Obtain another function and derivative. + + task = 'FG' + + 1000 continue + +c Save local variables. + + if (brackt) then + isave(1) = 1 + else + isave(1) = 0 + endif + isave(2) = stage + dsave(1) = ginit + dsave(2) = gtest + dsave(3) = gx + dsave(4) = gy + dsave(5) = finit + dsave(6) = fx + dsave(7) = fy + dsave(8) = stx + dsave(9) = sty + dsave(10) = stmin + dsave(11) = stmax + dsave(12) = width + dsave(13) = width1 + + return + end subroutine + +c====================== The end of dcsrch ============================== + + subroutine dcstep(stx,fx,dx,sty,fy,dy,stp,fp,dp,brackt, + + stpmin,stpmax) + logical brackt + double precision stx,fx,dx,sty,fy,dy,stp,fp,dp,stpmin,stpmax +c ********** +c +c Subroutine dcstep +c +c This subroutine computes a safeguarded step for a search +c procedure and updates an interval that contains a step that +c satisfies a sufficient decrease and a curvature condition. +c +c The parameter stx contains the step with the least function +c value. If brackt is set to .true. then a minimizer has +c been bracketed in an interval with endpoints stx and sty. +c The parameter stp contains the current step. +c The subroutine assumes that if brackt is set to .true. then +c +c min(stx,sty) < stp < max(stx,sty), +c +c and that the derivative at stx is negative in the direction +c of the step. +c +c The subroutine statement is +c +c subroutine dcstep(stx,fx,dx,sty,fy,dy,stp,fp,dp,brackt, +c stpmin,stpmax) +c +c where +c +c stx is a double precision variable. +c On entry stx is the best step obtained so far and is an +c endpoint of the interval that contains the minimizer. +c On exit stx is the updated best step. +c +c fx is a double precision variable. +c On entry fx is the function at stx. +c On exit fx is the function at stx. +c +c dx is a double precision variable. +c On entry dx is the derivative of the function at +c stx. The derivative must be negative in the direction of +c the step, that is, dx and stp - stx must have opposite +c signs. +c On exit dx is the derivative of the function at stx. +c +c sty is a double precision variable. +c On entry sty is the second endpoint of the interval that +c contains the minimizer. +c On exit sty is the updated endpoint of the interval that +c contains the minimizer. +c +c fy is a double precision variable. +c On entry fy is the function at sty. +c On exit fy is the function at sty. +c +c dy is a double precision variable. +c On entry dy is the derivative of the function at sty. +c On exit dy is the derivative of the function at the exit sty. +c +c stp is a double precision variable. +c On entry stp is the current step. If brackt is set to .true. +c then on input stp must be between stx and sty. +c On exit stp is a new trial step. +c +c fp is a double precision variable. +c On entry fp is the function at stp +c On exit fp is unchanged. +c +c dp is a double precision variable. +c On entry dp is the the derivative of the function at stp. +c On exit dp is unchanged. +c +c brackt is an logical variable. +c On entry brackt specifies if a minimizer has been bracketed. +c Initially brackt must be set to .false. +c On exit brackt specifies if a minimizer has been bracketed. +c When a minimizer is bracketed brackt is set to .true. +c +c stpmin is a double precision variable. +c On entry stpmin is a lower bound for the step. +c On exit stpmin is unchanged. +c +c stpmax is a double precision variable. +c On entry stpmax is an upper bound for the step. +c On exit stpmax is unchanged. +c +c MINPACK-1 Project. June 1983 +c Argonne National Laboratory. +c Jorge J. More' and David J. Thuente. +c +c MINPACK-2 Project. October 1993. +c Argonne National Laboratory and University of Minnesota. +c Brett M. Averick and Jorge J. More'. +c +c ********** + double precision zero,p66,two,three + parameter(zero=0.0d0,p66=0.66d0,two=2.0d0,three=3.0d0) + + double precision gamma,p,q,r,s,sgnd,stpc,stpf,stpq,theta + + sgnd = dp*(dx/abs(dx)) + +c First case: A higher function value. The minimum is bracketed. +c If the cubic step is closer to stx than the quadratic step, the +c cubic step is taken, otherwise the average of the cubic and +c quadratic steps is taken. + + if (fp .gt. fx) then + theta = three*(fx - fp)/(stp - stx) + dx + dp + s = max(abs(theta),abs(dx),abs(dp)) + gamma = s*sqrt((theta/s)**2 - (dx/s)*(dp/s)) + if (stp .lt. stx) gamma = -gamma + p = (gamma - dx) + theta + q = ((gamma - dx) + gamma) + dp + r = p/q + stpc = stx + r*(stp - stx) + stpq = stx + ((dx/((fx - fp)/(stp - stx) + dx))/two)* + + (stp - stx) + if (abs(stpc-stx) .lt. abs(stpq-stx)) then + stpf = stpc + else + stpf = stpc + (stpq - stpc)/two + endif + brackt = .true. + +c Second case: A lower function value and derivatives of opposite +c sign. The minimum is bracketed. If the cubic step is farther from +c stp than the secant step, the cubic step is taken, otherwise the +c secant step is taken. + + else if (sgnd .lt. zero) then + theta = three*(fx - fp)/(stp - stx) + dx + dp + s = max(abs(theta),abs(dx),abs(dp)) + gamma = s*sqrt((theta/s)**2 - (dx/s)*(dp/s)) + if (stp .gt. stx) gamma = -gamma + p = (gamma - dp) + theta + q = ((gamma - dp) + gamma) + dx + r = p/q + stpc = stp + r*(stx - stp) + stpq = stp + (dp/(dp - dx))*(stx - stp) + if (abs(stpc-stp) .gt. abs(stpq-stp)) then + stpf = stpc + else + stpf = stpq + endif + brackt = .true. + +c Third case: A lower function value, derivatives of the same sign, +c and the magnitude of the derivative decreases. + + else if (abs(dp) .lt. abs(dx)) then + +c The cubic step is computed only if the cubic tends to infinity +c in the direction of the step or if the minimum of the cubic +c is beyond stp. Otherwise the cubic step is defined to be the +c secant step. + + theta = three*(fx - fp)/(stp - stx) + dx + dp + s = max(abs(theta),abs(dx),abs(dp)) + +c The case gamma = 0 only arises if the cubic does not tend +c to infinity in the direction of the step. + + gamma = s*sqrt(max(zero,(theta/s)**2-(dx/s)*(dp/s))) + if (stp .gt. stx) gamma = -gamma + p = (gamma - dp) + theta + q = (gamma + (dx - dp)) + gamma + r = p/q + if (r .lt. zero .and. gamma .ne. zero) then + stpc = stp + r*(stx - stp) + else if (stp .gt. stx) then + stpc = stpmax + else + stpc = stpmin + endif + stpq = stp + (dp/(dp - dx))*(stx - stp) + + if (brackt) then + +c A minimizer has been bracketed. If the cubic step is +c closer to stp than the secant step, the cubic step is +c taken, otherwise the secant step is taken. + + if (abs(stpc-stp) .lt. abs(stpq-stp)) then + stpf = stpc + else + stpf = stpq + endif + if (stp .gt. stx) then + stpf = min(stp+p66*(sty-stp),stpf) + else + stpf = max(stp+p66*(sty-stp),stpf) + endif + else + +c A minimizer has not been bracketed. If the cubic step is +c farther from stp than the secant step, the cubic step is +c taken, otherwise the secant step is taken. + + if (abs(stpc-stp) .gt. abs(stpq-stp)) then + stpf = stpc + else + stpf = stpq + endif + stpf = min(stpmax,stpf) + stpf = max(stpmin,stpf) + endif + +c Fourth case: A lower function value, derivatives of the same sign, +c and the magnitude of the derivative does not decrease. If the +c minimum is not bracketed, the step is either stpmin or stpmax, +c otherwise the cubic step is taken. + + else + if (brackt) then + theta = three*(fp - fy)/(sty - stp) + dy + dp + s = max(abs(theta),abs(dy),abs(dp)) + gamma = s*sqrt((theta/s)**2 - (dy/s)*(dp/s)) + if (stp .gt. sty) gamma = -gamma + p = (gamma - dp) + theta + q = ((gamma - dp) + gamma) + dy + r = p/q + stpc = stp + r*(sty - stp) + stpf = stpc + else if (stp .gt. stx) then + stpf = stpmax + else + stpf = stpmin + endif + endif + +c Update the interval which contains a minimizer. + + if (fp .gt. fx) then + sty = stp + fy = fp + dy = dp + else + if (sgnd .lt. zero) then + sty = stx + fy = fx + dy = dx + endif + stx = stp + fx = fp + dx = dp + endif + +c Compute the new step. + + stp = stpf + + return + end subroutine + + +!###################################################################################################### + +! THE FOLLOWING CODE IS A COPY OF THE HELPER ROUTINES FOR THE LBFGS-B Algorithm from Nocedal et al. + +!###################################################################################################### + +c +c L-BFGS-B is released under the “New BSD License” (aka “Modified BSD License” +c or “3-clause license”) +c Please read attached file License.txt +c + + double precision function dnrm2(n,x,incx) + integer n,incx + double precision x(n) +c ********** +c +c Function dnrm2 +c +c Given a vector x of length n, this function calculates the +c Euclidean norm of x with stride incx. +c +c The function statement is +c +c double precision function dnrm2(n,x,incx) +c +c where +c +c n is a positive integer input variable. +c +c x is an input array of length n. +c +c incx is a positive integer variable that specifies the +c stride of the vector. +c +c Subprograms called +c +c FORTRAN-supplied ... abs, max, sqrt +c +c MINPACK-2 Project. February 1991. +c Argonne National Laboratory. +c Brett M. Averick. +c +c ********** + integer i + double precision scale + + dnrm2 = 0.0d0 + scale = 0.0d0 + + do 10 i = 1, n, incx + scale = max(scale, abs(x(i))) + 10 continue + + if (scale .eq. 0.0d0) return + + do 20 i = 1, n, incx + dnrm2 = dnrm2 + (x(i)/scale)**2 + 20 continue + + dnrm2 = scale*sqrt(dnrm2) + + + return + + end function + +c====================== The end of dnrm2 =============================== + + subroutine daxpy(n,da,dx,incx,dy,incy) +c +c constant times a vector plus a vector. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c + double precision dx(*),dy(*),da + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if (da .eq. 0.0d0) return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dy(iy) = dy(iy) + da*dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,4) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dy(i) = dy(i) + da*dx(i) + 30 continue + if( n .lt. 4 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,4 + dy(i) = dy(i) + da*dx(i) + dy(i + 1) = dy(i + 1) + da*dx(i + 1) + dy(i + 2) = dy(i + 2) + da*dx(i + 2) + dy(i + 3) = dy(i + 3) + da*dx(i + 3) + 50 continue + return + end subroutine + +c====================== The end of daxpy =============================== + + subroutine dcopy(n,dx,incx,dy,incy) +c +c copies a vector, x, to a vector, y. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c + double precision dx(*),dy(*) + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dy(iy) = dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,7) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dy(i) = dx(i) + 30 continue + if( n .lt. 7 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,7 + dy(i) = dx(i) + dy(i + 1) = dx(i + 1) + dy(i + 2) = dx(i + 2) + dy(i + 3) = dx(i + 3) + dy(i + 4) = dx(i + 4) + dy(i + 5) = dx(i + 5) + dy(i + 6) = dx(i + 6) + 50 continue + return + end subroutine + +c====================== The end of dcopy =============================== + + double precision function ddot(n,dx,incx,dy,incy) +c +c forms the dot product of two vectors. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c + double precision dx(*),dy(*),dtemp + integer i,incx,incy,ix,iy,m,mp1,n +c + ddot = 0.0d0 + dtemp = 0.0d0 + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dtemp = dtemp + dx(ix)*dy(iy) + ix = ix + incx + iy = iy + incy + 10 continue + ddot = dtemp + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,5) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dtemp = dtemp + dx(i)*dy(i) + 30 continue + if( n .lt. 5 ) go to 60 + 40 mp1 = m + 1 + do 50 i = mp1,n,5 + dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + + * dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) + 50 continue + 60 ddot = dtemp + return + end function + +c====================== The end of ddot ================================ + + subroutine dscal(n,da,dx,incx) +c +c scales a vector by a constant. +c uses unrolled loops for increment equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 3/93 to return if incx .le. 0. +c + double precision da,dx(*) + integer i,incx,m,mp1,n,nincx +c + if( n.le.0 .or. incx.le.0 )return + if(incx.eq.1)go to 20 +c +c code for increment not equal to 1 +c + nincx = n*incx + do 10 i = 1,nincx,incx + dx(i) = da*dx(i) + 10 continue + return +c +c code for increment equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,5) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dx(i) = da*dx(i) + 30 continue + if( n .lt. 5 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,5 + dx(i) = da*dx(i) + dx(i + 1) = da*dx(i + 1) + dx(i + 2) = da*dx(i + 2) + dx(i + 3) = da*dx(i + 3) + dx(i + 4) = da*dx(i + 4) + 50 continue + return + end subroutine + +c====================== The end of dscal =============================== + +c +c L-BFGS-B is released under the “New BSD License” (aka “Modified BSD License” +c or “3-clause license”) +c Please read attached file License.txt +c + subroutine dpofa(a,lda,n,info) + integer lda,n,info + double precision a(lda,*) +c +c dpofa factors a double precision symmetric positive definite +c matrix. +c +c dpofa is usually called by dpoco, but it can be called +c directly with a saving in time if rcond is not needed. +c (time for dpoco) = (1 + 18/n)*(time for dpofa) . +c +c on entry +c +c a double precision(lda, n) +c the symmetric matrix to be factored. only the +c diagonal and upper triangle are used. +c +c lda integer +c the leading dimension of the array a . +c +c n integer +c the order of the matrix a . +c +c on return +c +c a an upper triangular matrix r so that a = trans(r)*r +c where trans(r) is the transpose. +c the strict lower triangle is unaltered. +c if info .ne. 0 , the factorization is not complete. +c +c info integer +c = 0 for normal return. +c = k signals an error condition. the leading minor +c of order k is not positive definite. +c +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c +c subroutines and functions +c +c blas ddot +c fortran sqrt +c +c internal variables +c +! double precision ddot,t !Original + double precision t !Fabian + double precision s + integer j,jm1,k +c begin block with ...exits to 40 +c +c + do 30 j = 1, n + info = j + s = 0.0d0 + jm1 = j - 1 + if (jm1 .lt. 1) go to 20 + do 10 k = 1, jm1 + t = a(k,j) - ddot(k-1,a(1,k),1,a(1,j),1) + t = t/a(k,k) + a(k,j) = t + s = s + t*t + 10 continue + 20 continue + s = a(j,j) - s +c ......exit + if (s .le. 0.0d0) go to 40 + a(j,j) = sqrt(s) + 30 continue + info = 0 + 40 continue + return + end subroutine + +c====================== The end of dpofa =============================== + + subroutine dtrsl(t,ldt,n,b,job,info) + integer ldt,n,job,info + double precision t(ldt,*),b(*) +c +c +c dtrsl solves systems of the form +c +c t * x = b +c or +c trans(t) * x = b +c +c where t is a triangular matrix of order n. here trans(t) +c denotes the transpose of the matrix t. +c +c on entry +c +c t double precision(ldt,n) +c t contains the matrix of the system. the zero +c elements of the matrix are not referenced, and +c the corresponding elements of the array can be +c used to store other information. +c +c ldt integer +c ldt is the leading dimension of the array t. +c +c n integer +c n is the order of the system. +c +c b double precision(n). +c b contains the right hand side of the system. +c +c job integer +c job specifies what kind of system is to be solved. +c if job is +c +c 00 solve t*x=b, t lower triangular, +c 01 solve t*x=b, t upper triangular, +c 10 solve trans(t)*x=b, t lower triangular, +c 11 solve trans(t)*x=b, t upper triangular. +c +c on return +c +c b b contains the solution, if info .eq. 0. +c otherwise b is unaltered. +c +c info integer +c info contains zero if the system is nonsingular. +c otherwise info contains the index of +c the first zero diagonal element of t. +c +c linpack. this version dated 08/14/78 . +c g. w. stewart, university of maryland, argonne national lab. +c +c subroutines and functions +c +c blas daxpy,ddot +c fortran mod +c +c internal variables +c +! double precision ddot,temp !Original + double precision temp !Fabian + integer case,j,jj +c +c begin block permitting ...exits to 150 +c +c check for zero diagonal elements. +c + do 10 info = 1, n +c ......exit + if (t(info,info) .eq. 0.0d0) go to 150 + 10 continue + info = 0 +c +c determine the task and go to it. +c + case = 1 + if (mod(job,10) .ne. 0) case = 2 + if (mod(job,100)/10 .ne. 0) case = case + 2 + go to (20,50,80,110), case +c +c solve t*x=b for t lower triangular +c + 20 continue + b(1) = b(1)/t(1,1) + if (n .lt. 2) go to 40 + do 30 j = 2, n + temp = -b(j-1) + call daxpy(n-j+1,temp,t(j,j-1),1,b(j),1) + b(j) = b(j)/t(j,j) + 30 continue + 40 continue + go to 140 +c +c solve t*x=b for t upper triangular. +c + 50 continue + b(n) = b(n)/t(n,n) + if (n .lt. 2) go to 70 + do 60 jj = 2, n + j = n - jj + 1 + temp = -b(j+1) + call daxpy(j,temp,t(1,j+1),1,b(1),1) + b(j) = b(j)/t(j,j) + 60 continue + 70 continue + go to 140 +c +c solve trans(t)*x=b for t lower triangular. +c + 80 continue + b(n) = b(n)/t(n,n) + if (n .lt. 2) go to 100 + do 90 jj = 2, n + j = n - jj + 1 + b(j) = b(j) - ddot(jj-1,t(j+1,j),1,b(j+1),1) + b(j) = b(j)/t(j,j) + 90 continue + 100 continue + go to 140 +c +c solve trans(t)*x=b for t upper triangular. +c + 110 continue + b(1) = b(1)/t(1,1) + if (n .lt. 2) go to 130 + do 120 j = 2, n + b(j) = b(j) - ddot(j-1,t(1,j),1,b(1),1) + b(j) = b(j)/t(j,j) + 120 continue + 130 continue + 140 continue + 150 continue + return + end subroutine + +c====================== The end of dtrsl =============================== + + +c +c L-BFGS-B is released under the “New BSD License” (aka “Modified BSD License” +c or “3-clause license”) +c Please read attached file License.txt +c + subroutine timer(ttime) + double precision ttime +c + real temp +c +c This routine computes cpu time in double precision; it makes use of +c the intrinsic f90 cpu_time therefore a conversion type is +c needed. +c +c J.L Morales Departamento de Matematicas, +c Instituto Tecnologico Autonomo de Mexico +c Mexico D.F. +c +c J.L Nocedal Department of Electrical Engineering and +c Computer Science. +c Northwestern University. Evanston, IL. USA +c +c January 21, 2011 +c + temp = sngl(ttime) + call cpu_time(temp) + ttime = dble(temp) + + return + + end subroutine + + end module lbfgsb_mod diff --git a/src/marq.f b/src/marq.f new file mode 100644 index 0000000..2174567 --- /dev/null +++ b/src/marq.f @@ -0,0 +1,558 @@ + module marq_mod + implicit none + logical, parameter :: dbg = .false. + + !Fabian: Declare visibility of subroutines in this module for other modules + private + public :: mrqmin + + contains + + +!> Routine for non linear least-squares fitting by the Marquardt-Levenberg method. +!! The current implementation is based on Numerical Recipies pp. 526ff. +!! This subroutine is only called by the parent subroutine fit and and itself only calls funcs as a subroutine, which is the interface to the user-specific model routines. +!! +!! @author Fabian Fritsch +!! @version 0.2 +!! @date 15.03.2022 +!! +!! @todo Implement different versions of the Marquardt-Levenberg method, e.g. MINPACK. + + subroutine mrqmin(par,npar,ma,mfit,rms,micit,set) + use dim_parameter, only: log_convergence + implicit none +! Input variables (not changed within this subroutine). + integer npar !< number of parameters + integer mfit !< number of active parameters + integer ma(npar) !< array that contains info if a parameter is active or not + integer micit !< number of microiterations / optimization cycles for the Marquardt Levenberg algorithm + integer set !number of current set +! Input/output variables (changed/updated within this subroutine) + double precision par(npar) !< parameter vector (on input: guess for parameters, on output: optimized parameters) +! Output variables + + double precision rms !< root mean square error for the optimized parameter set + +! Internal variables (used at most by subordinated subroutines) +!> @param alpha weighted approximation to the Hesse matrix (wt**2 * J^T * J) +!> @param covar damped alpha, ie. (wt**2 * J^T * J + alamda * 1) + double precision alpha(mfit,mfit) !< weighted approximation to the Hesse matrix (wt**2 * J^T * J) / curvature matrix + double precision covar(mfit,mfit) !< damped alpha, ie. (wt**2 * J^T * J + alamda * diag(J^T * J)) + double precision da(mfit) !< J^T * (difference between y and fitted y) + double precision beta(mfit) !< @param[in] beta J^T * (difference between y and fitted y) + + logical skip !< logical: true, if a parameter set must be skipped + + double precision chisq !< chi-squared error (current parameter set) + double precision ochisq !< chi-squared error (previous best parameter set) + double precision alamda !< Marquardt-Levenberg parameter + + double precision atry(npar) !< work array for temporal storage of the changed parameter vector + double precision asave(npar) !< work array for temporal storage of the changed parameter vector + + double precision trust !< trust region parameter + double precision ilamda !< initial value for the Marquardt Levenberg parameter alamda + + logical quit + +! Internal variables + + integer i,j,lauf !< iteration variables + double precision incr_alamda !< increase factor of alamda + double precision decr_alamda !< decrease facotr of alamda + + character(len=80) file_name,fmt + integer id_plot + integer counter + integer rejected + +! Lapack variables (for details,see lapack documentation for the called subroutine) + + integer info + double precision work(mfit) + integer*8 lwork !important that its 64bit! + integer*8 ipiv(mfit) + +!> Open logging files + if (log_convergence) then + write (file_name,"('.conv_marq_set',i0,'.dat')") set + id_plot=6666+set + open(id_plot,file=trim(file_name),action='write') + write (id_plot,69) + 69 format ('#Levenberg-Marquardt',/, + + '#it = iteration number',/, + + '#nf = number of function evaluations',/, + + '#stepl = step length used',/, + + '#tstep = norm of the displacement (total step)',/, + + '#projg = norm of the projected gradient',/, + + '#f = function value') + write (id_plot,123) + 123 format ('#',3x,'it',3x,'nf',3x,'stepl',4x,'pstep',5x, + $ 'projg',8x,'f') + endif +!> Initialize skip, Marquardt parameter, error variables and parameter work arrays + + skip=.false. + ilamda=0.1d0 !Initial Marquardt parameter + alamda=ilamda !Current Marquardt parameter + rms=1.d6 + atry(1:npar)=par(1:npar) + asave(1:npar)=par(1:npar) + + !Fabian: Adjusted values (TO-DO: Make this Input-Cards) + trust=2.0d+1 + incr_alamda=1.5d0 + decr_alamda=1.d0/1.5d0 + + counter=0 + rejected=0 + alpha=0.d0 + beta=0.d0 + chisq=0.d0 + +!> Calculate RMS error for the given start parameters + + call mrqcof(par,npar,ma,mfit, + $ alpha,beta,chisq,skip) + ochisq=chisq + + !Check initial Hessian for (trivial) rank-deficiency + !This check reveals for which parameter no data is available, i.e no optimization will occur although the parameter is active + !Note: In general, rank deficiency might lead to ambiguous results when solving the normal equations. Here this will not occur due to the regularization in the LM-Algorithm + if (dbg) then + do i=1,mfit + if(all(abs(alpha(i,:)).lt.1E-16)) then + write(6,*) + $ 'Warning: Rank deficiency of J^T*J for active param',i + endif + enddo + endif + +!> Termination if micit=0, i.e. only genetic algorithm and no LM optimization + if (micit.eq.0) then + rms=dsqrt(chisq) + if (log_convergence) close(id_plot) + return + endif + +!> Write warning and return if error for initial parameters is large + if (skip) then + write(6,*) 'WARNING: initial parameter set skipped' +! call flush +! flush(6) + rms=1.e6 + if (log_convergence) close(id_plot) + return + endif + +!------------------------------------------------------------------------- + +!> Start optimization of parameters using the Marquardt-Levenberg algorihm + + do lauf=1,micit + +!-------------------------------------------------------------------------o + + !> Scale approximated Hessian (alpha = wt**2 * J^T * J) if necessary + call mrqrescale(mfit,alpha) + + !------------------------------------------------------------------------- + + !> Calculate covariance matrix and "gradient": wt**2 * J^T * J + alamda * diag(J^T * J) == alpha + alamda * diag(J^T * J) + + !Copy alpha to covar and beta to da + covar(1:mfit,1:mfit)=alpha(1:mfit,1:mfit) + da(1:mfit)=beta(1:mfit) + !Adjust diagonal elements of covar by alamda + do i=1,mfit + covar(i,i)=covar(i,i)*(1.d0 + alamda) + if (dabs(covar(i,i)).lt.1.d-12) then + covar(i,i)=1.d-8 + endif + enddo + + !------------------------------------------------------------------------- + + !> Solve set of equations, i.e. covar * vec = da + + !Lapack version (on output: da contains solution the equation, called shift vector) + ipiv=0 + lwork = max(1,mfit) + call dsysv('U',mfit,1,covar,mfit,ipiv,da,mfit, !qr decomposition + $ work,lwork,info) +! call dposv('U',mfit,1,covar,mfit,da,mfit, !cholesky decomposition +! $ info) + !------------------------------------------------------------------------- + + !> Calculate trust region of the shift vector, if necessary rescale the entire shift vector + + call mrqtrustregion(trust,npar,ma,par,mfit,da) + + !------------------------------------------------------------------------- + + !> Check if the new (rescaled) parameters are better then the previous best (micro)iteration + + !Calculate the new parameters and write them on atry + j=0 + do i=1,npar +!Nicole: added flexible value of ma + if (ma(i).ge.1) then +! if (abs(ma(i)).eq.1) then + j=j+1 + atry(i)=par(i)+da(j) + endif + enddo + + !Calculate RMS with the new parameters atry + call mrqcof(atry,npar,ma,mfit, + $ covar,da,chisq,skip) + + ! Write warning, if mrqcof (more precisely funcs within mrqcof) yields the skip message + if (skip) then + write(6,*) 'WARNING: parameter set skipped' +! call flush +! flush(6) + rms=1.e6 + if (log_convergence) close(id_plot) + return + endif + + !Compare the new RMS with the RMS of the previous best parameters, if yes: save the parameters + if(chisq.lt.ochisq) then + counter=counter+1 !number of accepted steps + asave(1:npar)=atry(1:npar) + !Write logging information + if(log_convergence) then + write(id_plot,124) counter,lauf,1.d0,sum((atry-par)**2), + $ sum(da**2),chisq + 124 format(1x,2(1x,i4),1p,2(2x,e8.1),1p,2(1x,e10.3)) + endif + endif + + !------------------------------------------------------------------------- + + !Perform convergence / error checks + quit=.false. + call mrqconvergence(lauf,micit,npar,par,mfit,da,asave, + $ chisq,ochisq,rms,rejected,quit) + if(quit) then + if (log_convergence) close(id_plot) + return + endif + + !------------------------------------------------------------------------- + + !Increase counter of consecutive rejected steps by one + rejected=rejected+1 + + !Adjust the marquardt parameter (alamda) for the next iteration + !If chisq has been reduced: Update alpha, beta, par and ochisq + if (chisq.lt.ochisq) then + rejected=0 !reset counter of consecutive rejected step + alamda=alamda*decr_alamda + if(alamda.lt.1E-8) alamda=1E-8 + alpha(1:mfit,1:mfit)=covar(1:mfit,1:mfit) + beta(1:mfit)=da(1:mfit) + par(1:npar)=atry(1:npar) + ochisq=chisq + else + alamda=alamda*incr_alamda + !If after a certain number of iterations in which the rms is not reduced or convergence occurs, + !alamda takes a certain value, then take the result of this iteration as a new input guess ! + if (alamda.gt.1.d5) then + write(6,*) 'Warning: Large alamda, try new parameters' + alamda=ilamda + par(1:npar)=atry(1:npar) + ochisq=chisq + endif + endif + + enddo + + if(log_convergence) close(id_plot) + + end subroutine + + +c############################################################### + +!> Routine for calculating the residuals, gradients, approximated Hessian for the Marquardt-Levenberg-Algorithm + + subroutine mrqcof(par,npar,ma,mfit, + $ alpha,beta,chisq,skip) + + use dim_parameter, only: ntot,qn,numdatpt,nstat,hybrid + + use data_module, only: x1_m,x2_m,y_m,wt_m,ny_m + use funcs_mod,only: funcs + implicit none + +! Input variables (not changed within this subroutine). +! double precision q(*),x1(*),x2(*),y(*),ny(*),wt(*) !< coordinates,data and weights + integer npar !< number of parameters + double precision par(npar) !< parameter vector (on input: guess for parameters, on output: optimized parameters) + integer mfit !< number of active parameters + integer ma(npar) !< array that contains info if a parameter is active or not + +! Output variables + double precision alpha(mfit,mfit) !< weighted approximation to the Hesse matrix (wt**2 * J^T * J) / curvature matrix + double precision beta(mfit) !< weighted J^T * (difference between y and fitted y) + double precision chisq !< chisq error + logical skip !< logical: true, if a parameter set must be skipped + +! Internal variables (used at most by subordinated subroutines) + double precision ymod(ntot) !< fitted datapoints (for one geometry) + double precision dy(ntot) !< difference between ab-initio and fitted datapoints + double precision dyda(ntot,npar) !gradient of datapoints (for one geometry) with respect to the parameters + +! Internal variables + integer i,j,k,l,m,n !< iteration variables + integer nloop + +!------------------------------------------------------------------------- + +!> Initialize skip, alpha, beta and chisq + + skip=.false. + alpha(1:mfit,1:mfit)=0.d0 + beta(1:mfit)=0.d0 + chisq=0.d0 + + nloop=ntot + if(.not.hybrid) nloop=nstat + + do i=1,numdatpt + + call funcs(i,par,ymod,dyda,npar,ma,skip) + if (skip) return + + !Idea: Since the quantities dyda,dy and wt_m are rather small, one might consider scaling them + !Idea: and then rescale the final quantities alpha,beta,chisq accordingly + !Idea: Scale dyda,dy and wt_m by 1D+5; final rescale of alpha,beta and chisq by 1D-10 + + do n=1,nloop + dy(n)=y_m(n,i)-ymod(n) + j=0 + do l=1,npar + ! Nicole: values of ma (active parameter) changed + if (ma(l).ge.1) then + j=j+1 + k=0 + do m=1,l +! Nicole: values of ma (active parameter) changed + if (ma(m).ge.1) then + k=k+1 + !(wt*J)^T*(wt*J) + alpha(j,k)=alpha(j,k)+ + $ (dyda(n,l)*dyda(n,m))*(wt_m(n,i)*wt_m(n,i)) + endif + enddo + !(wt*J)^T*(wt*delta_y) + beta(j)=beta(j)+ + $ (dy(n)*dyda(n,l))*(wt_m(n,i)*wt_m(n,i)) + endif + enddo + !(wt*delta_y)*(wt*delta_y) + chisq=chisq+ + $ (dy(n)*dy(n))*(wt_m(n,i)*wt_m(n,i)) + enddo + + enddo + +!------------------------------------------------------------------------- + + !Fill in missing parts of the symmetric matrix alpha + do i=2,mfit + do j=1,i-1 + alpha(j,i)=alpha(i,j) + enddo + enddo + + end subroutine + +c############################################################### + +!> Scale approximated Hessian (alpha = wt**2 * J^T * J) if necessary + subroutine mrqrescale(mfit,alpha) + + implicit none + +!> Input variables + integer mfit + +!> Input/output variables + double precision alpha(mfit,mfit) + +!> Internal variables + double precision dum !Maik changed to double from int + integer i,j + +!> Find largest value of the approximated Hessian alpha + dum=0.d0 + do i=1,mfit + do j=1,mfit + if (abs(alpha(i,j)).gt.dum) dum=abs(alpha(i,j)) !find largest value of the approximated Hessian + enddo + enddo + +!> Rescale approximated Hessian if largest value is greater then a threshold (hardcoded) + if (dum.gt.1.d30) then + dum=1.d3/dum + write(6,'(''Warning: Hessian scaled by'',d12.3)') dum + write(6,*) + do i=1,mfit + do j=1,mfit + alpha(i,j)=alpha(i,j)*dum + enddo + enddo + endif + + end subroutine + +c############################################################### + + subroutine mrqtrustregion(trust,npar,ma,par,mfit,da) + + implicit none + +!> Input variables + double precision trust + integer npar + integer ma(npar) + double precision par(npar) + integer mfit + +!> Input/output variables + double precision da(mfit) + +!> Internal variables + integer i,j + double precision dum + + !Init + dum=0.d0 + j=0 + + !Find the largest relative (magnitude of gradient / magnitude of parameter = da / par ) shift of a parameter + !Explanation: For parameters of high scale, their gradients are also of high scale even if the relative change is small + do i=1,npar +! Nicole: values of ma (active parameter) changed + if (ma(i).ge.1) then + j=j+1 + if (abs(par(i)).gt.1.d-4) then + if (abs(da(j)/par(i)).gt.dum) then + dum=abs(da(j)/par(i)) + endif + endif + endif + enddo + !If maximum relative shift exceeds a threshold, scale shift vector + if (dum.gt.trust) then + dum=trust/dum + j=0 + do i=1,npar +! Nicole: values of ma (active parameter) changed + if (ma(i).ge.1) then + j=j+1 + da(j)=da(j)*dum + endif + enddo + endif + + end subroutine + +c############################################################### + +!> Perform convergence and error checks + subroutine mrqconvergence(lauf,micit,npar,par,mfit,da,asave, + $ chisq,ochisq,rms,rejected,quit) + + implicit none + +!> Input variables + integer lauf + integer micit + integer npar + integer mfit + double precision da(mfit) + double precision asave(npar) + double precision chisq + double precision ochisq + integer rejected !number of consecutive rejected steps + + +!> Input/Output variables + double precision par(npar) + double precision rms + +!> Output variable + logical quit + +!> Internal variables + integer i + double precision dum + double precision check + + + quit=.false. + + !Negative termination, if rms is too large, quit this iteration + if (chisq.gt.1.d3) then + write(6,*) 'chi^2 unreasonable!', chisq, lauf + rms=dsqrt(ochisq) + par(1:npar)=asave(1:npar) + quit=.true. + return + endif + +! Negative-neutral termination, if maximum number of consecutive not accepted microiterations reached + if (rejected.ge.25) then + write(6,*) 'Warning: 25 consecutive non accepted steps!' + if (chisq.lt.ochisq) rms=dsqrt(chisq) + if (chisq.ge.ochisq) rms=dsqrt(ochisq) + par(1:npar)=asave(1:npar) + quit=.true. + return + endif + +! Neutral termination, if number of maximum microiterations reached, quit the LM algorithm + if (lauf.eq.micit) then + if (chisq.lt.ochisq) rms=dsqrt(chisq) + if (chisq.ge.ochisq) rms=dsqrt(ochisq) + par(1:npar)=asave(1:npar) + write(6,'(''Warning: iterations exceeded: '',I0)') lauf + quit=.true. + return + endif + +! Neutral-positive termination, if parameter changes are small + check=0.d0 + do i=1,mfit + check=check+da(i)**2 + enddo + check=dsqrt(check) !root mean square of gradient + if (check.lt.1.d-15) then + write(6,*) 'change of parameters converged', check, lauf + rms=dsqrt(chisq) + par(1:npar)=asave(1:npar) + quit=.true. + return + endif + + !Positive termination, if difference between the previous lowest/optimal chisq (that is ochisq) & the current chisq is small + dum=max(chisq,ochisq)/min(chisq,ochisq) - 1.d0 + if ((dum.lt.1.d-5).and.(lauf.gt.1)) then !change of chi^2 < 0.01% + write(6,*) 'change of chi^2 converged', dum, lauf +! call flush !Fabian 15.03.2022: Not sure, why this is called +! flush(6) + rms=dsqrt(chisq) + par(1:npar)=asave(1:npar) + quit=.true. + return + endif + + + end subroutine + + end module marq_mod diff --git a/src/mpi_fit_MeX.f b/src/mpi_fit_MeX.f new file mode 100644 index 0000000..16433cc --- /dev/null +++ b/src/mpi_fit_MeX.f @@ -0,0 +1,203 @@ +#ifdef mpi_version + subroutine mpi_rest_control(micit,npar) + use mpi + implicit none +! global permanent data (only transferred once) + integer npar + integer mfit + integer micit + integer ma(npar) + integer ierror + integer i + integer mode + logical runner + integer status(MPI_STATUS_SIZE) + +! do loop around this, checking for next fit or finish + call bcastact(ma,npar) + call MPI_Bcast(mfit, 1, MPI_INT, 0, MPI_COMM_WORLD,ierror) + + runner=.true. + do while(runner) + + call MPI_Recv(mode, 1, MPI_INTEGER, 0, 69, MPI_COMM_WORLD, + $ status,ierror) + + if(mode.ne.0) then + call mpi_fit_single_set(npar,mfit,micit,ma,mode) + else + runner=.false. + endif + end do + call MPI_Barrier(MPI_COMM_WORLD, ierror) + end + + !----------------------------------------------- + +c this does a single crunch of data + subroutine mpi_fit_single_set(npar,mfit,micit,ma,nset) + use mpi + use dim_parameter, only: lbfgs + use marq_mod,only: mrqmin + use lbfgsb_mod,only: lbfgs_driver + implicit none + integer npar,mfit,micit,ierror,ma(*) + integer status(MPI_STATUS_SIZE), nset, my_rank + double precision par(npar), rms, startzeit, endzeit + + startzeit = MPI_Wtime() + +! receive data via blocking receive + call MPI_Recv(par, npar, MPI_DOUBLE_PRECISION, 0, 13, + $ MPI_COMM_WORLD, status, ierror) + call MPI_Recv(rms, 1, MPI_DOUBLE_PRECISION, 0, 14, + $ MPI_COMM_WORLD, status, ierror) + + if(lbfgs) then + call lbfgs_driver(par,npar,ma,mfit, + & rms,micit,nset) + else + call mrqmin(par,npar,ma,mfit, + & rms,micit,nset) + endif + + call MPI_Comm_rank(MPI_COMM_WORLD, my_rank, ierror) + +! send back data via blocking send + call MPI_Send(par, npar, MPI_DOUBLE_PRECISION, 0, 23, + $ MPI_COMM_WORLD, ierror) + call MPI_Send(rms, 1, MPI_DOUBLE_PRECISION, 0, 24, MPI_COMM_WORLD, + $ ierror) + + + endzeit = MPI_Wtime() + + write(6,*) 'Thread', my_rank ,'Zeit:', endzeit-startzeit + +!> Write output for the spezific set of parameters + write(6,99) nset, rms, rms*219474.69d0 + 99 format('Set:',i5,5x,'RMS:',g16.6,3x,'(',f16.6,' cm-1)') + + end + + !----------------------------------------------- + + subroutine bcastact(act,len) + use mpi + implicit none + integer len + integer act(len) + integer ierror + + call MPI_Bcast(act, len, MPI_INT, 0, MPI_COMM_WORLD,ierror) + + end + + !----------------------------------------------- + + subroutine workshare(numthreads, par, rms, npar, nset) + use mpi + implicit none + integer numthreads,ierror,nset,npar + double precision, asynchronous :: par(npar,nset),rms(nset) + logical working(numthreads-1) + logical sent,received_rms,received_par,received + integer request_par(8,numthreads-1) + integer request_rms(8,numthreads-1) + integer ping(8) + integer nextworker + integer i,j,k + integer worksignal + integer status(MPI_STATUS_SIZE) + integer (kind=MPI_ADDRESS_KIND) :: iadummy + +! init working array + do i = 1,numthreads + working(i) = .false. + enddo + + do i = 1,nset + +! do a round of sending + sent=.false. + do while(.not.sent) + + do j = 1,numthreads-1 + if(.not.working(j)) then + working(j)=.true. + nextworker = j + sent=.true. + exit + endif + enddo + + if(sent) then + call MPI_Issend(i, 1, MPI_INTEGER, + $ nextworker, 69, MPI_COMM_WORLD, ping(1), ierror) + call MPI_Issend(par(1,i), npar, MPI_DOUBLE_PRECISION, + $ nextworker, 13, MPI_COMM_WORLD, request_par(1 + $ ,nextworker), ierror) + call MPI_Issend(rms(i), 1, MPI_DOUBLE_PRECISION, + $ nextworker, 14, MPI_COMM_WORLD, request_rms(1 + $ ,nextworker), ierror) + +! wait for Issend to finish (Hannes initial position for these statements --> runs parallel) + call MPI_Wait(ping(1), status, ierror) + call MPI_Wait(request_par(1,nextworker), status, ierror) + call MPI_Wait(request_rms(1,nextworker), status, ierror) + + call MPI_Irecv(par(1,i), npar, MPI_DOUBLE_PRECISION, + $ nextworker, 23, MPI_COMM_WORLD, request_par(1 + $ ,nextworker) , ierror) + + call MPI_Irecv(rms(i), 1, MPI_DOUBLE_PRECISION, + $ nextworker, 24, MPI_COMM_WORLD, request_rms(1 + $ ,nextworker), ierror) + + endif + +! check finished workers + do j = 1,numthreads-1 + if(working(j)) then + received_rms=.false. + received_par=.false. + call MPI_Test(request_par(1,j), received_rms, + $ status, ierror) + call MPI_Test(request_rms(1,j), received_par, + $ status, ierror) + if(received_par.and.received_rms) then + working(j) = .false. + endif + endif + enddo + + enddo + + enddo + + received = .false. + do while(.not.received) + do j = 1,numthreads-1 + if(working(j)) then + received_rms=.false. + received_par=.false. + call MPI_Test(request_par(1,j), received_rms, + $ MPI_STATUS_IGNORE, ierror) + call MPI_Test(request_rms(1,j), received_par, + $ MPI_STATUS_IGNORE, ierror) + if(received_par.and.received_rms) then + working(j) = .false. + endif + endif + enddo + received=.true. + do j = 1,numthreads-1 + if(working(j)) then + received = .false. + exit + endif + enddo + enddo + + end +#endif diff --git a/src/parser/errcat.incl b/src/parser/errcat.incl new file mode 100644 index 0000000..feae198 --- /dev/null +++ b/src/parser/errcat.incl @@ -0,0 +1,32 @@ +**** ERROR CATALOGUE -- this defines what kind of errors parse.f throws + + +! 1 32 64 +! v v v +! '................................................................' + errcat( 1)='ILLOGICALLY SMALL VALUE' + errcat( 2)='VALUE EXCEEDS SET MAXIMUM' + errcat( 3)='GIVEN DATA STRUCTURE SIZE INCONSISTENT WITH' + > // ' PREVIOUS DECLARATION' + errcat( 4)='VALUE GREATER THAN SET MAXIMUM' + errcat( 5)='VALUE LESS THAN SET MINIMUM' + errcat( 6)='IMPLIED DATA POINT NUMBER INCONSISTENT WITH NPAT' + errcat( 7)='PERCENTAGE NOT WITHIN MEANINGFUL RANGE (0.0-100.0)' + errcat( 8)='MISSING KEY CLASHES WITH PREVIOUS DECLARATION' + errcat( 9)='MAXIMUM IDENTICAL TO MINIMUM' + errcat(10)='DEPRECATED COMMAND: FEATURE HAS BEEN REMOVED, ' + > // 'SEE PARSER.' + errcat(11)='TOO MANY ARGUMENTS' +! errcat(12)= +! errcat(13)= +! errcat(14)= +! errcat(15)= +! errcat(16)= +! errcat(17)= +! errcat(18)= +! errcat(19)= +! errcat(20)= +! errcat(21)= +! errcat(22)= +! errcat(23)= +! errcat(24)= diff --git a/src/parser/io_parameters.f b/src/parser/io_parameters.f new file mode 100644 index 0000000..57e95f8 --- /dev/null +++ b/src/parser/io_parameters.f @@ -0,0 +1,55 @@ + module io_parameters + implicit none +! ****************************************************************************** +! **** I/O-Parameters +! *** +! *** dnlen: maximum char length of data file path +! *** maxlines: maximum input file length +! *** llen: character maximum per line +! *** maxdat: maximum number of input data values of one kind +! *** (e.g. integer values) excluding DATA: block +! *** clen: max. character length of string data +! *** klen: maximum length of key or typestring +! *** maxkeys: max. number of keys +! *** maxerrors: max. number of pre-defined error messages. + + integer, parameter :: dnlen = 8192 + integer, parameter :: maxlines = 3000000,llen = 750 + integer, parameter :: klen=20,maxkeys=200 + integer, parameter :: maxdat=2000,clen=1024 + integer, parameter :: maxerrors=100 +! Declarations for general Keylist and error massages + integer :: keynum !< keynum number of general keys + integer :: datpos(3,maxdat) !< datpos Pointer to type, data adress and length for each general key + character(len=klen) :: keylist(2,maxkeys) !< list of general program keys for programm control and parameter initialisation defined in keylist.incl + character(len=64) :: errcat(maxerrors) !< list of generic error Messages defined in errcat.incl + +! parameter key declaration + integer, parameter :: maxpar_keys=400 ! maxlines,dnlen) + use strings_mod,only:write_oneline,int2string + implicit none + +! Read input file located at DATNAM, skipping comments and blank lines. + integer dnlen,llen,maxlines + integer linenum + character(len=dnlen) datnam + character(len=llen) infile(maxlines) + + character(len=llen) line + + !character*16 int2string + + integer j + + !Fabian + character(len=llen) fmt,fmt2 + integer,parameter :: std_out = 6 + integer,parameter :: funit = 10 + write(fmt,'(A)') 'Reading file ''' // trim(datnam) // ''' ...' + call write_oneline(fmt,std_out) + + open(unit=funit,file=datnam) + linenum=0 + do j=1,maxlines + !read(funit,fmt='(A)',end=20) line ! works only for ifort, not for gfortran or mpif90 + write(fmt2,'("(A",I3,")")') llen !Fabian + read(funit,fmt=fmt2,end=20) line !Fabian + if (line(1:3).eq.'---') then + write(fmt,'(A)') 'EOF-mark "---" found at line' + > // trim(int2string(j)) + call write_oneline(fmt,std_out) + exit + endif + call internalize_line(linenum,infile,line,llen,maxlines) + enddo + 20 close(funit) + + if (j.ge.maxlines) then + write(6,'(A)') 'ERROR: FILE LENGTH EXCEEDING MAXLINES.' + stop 1 + endif + + write(fmt,'(A)') 'File read successfully (' + > // trim(int2string(linenum)) // ' lines).' + call write_oneline(fmt,std_out) + + end subroutine internalize_datfile + +!------------------------------------------------------------------- + + subroutine internalize_line(linenum,infile,line,llen,maxlines) + use strings_mod,only: strip_string,upcase + implicit none +! Parse a single line of input. Ignore comments ("!..") and blank +! lines, and turn all input to uppercase. +! +! infile: data file's internalized form +! line: single verbatim line read from physical file +! linenum: current number of non-commentlines read +! increased by 1 if read line is not a comment +! llen: maximum character length of a single line +! maxlines: maximum number of lines in infile + + integer llen,maxlines + integer linenum + character(len=llen) infile(maxlines) + character(len=llen) line + + character(len=llen) strip + integer line_pos,text_end + + integer j + + line_pos=linenum+1 + +! ignore empty lines + if (len_trim(line).eq.0) then + return + endif + +! strip needless whitespace + call strip_string(line,strip,llen) + +! determine EOL +! ignore comments + text_end=0 + do j=1,len_trim(strip) + if (strip(j:j).eq.'!') then + exit + endif + text_end=text_end+1 + enddo + + if (text_end.eq.llen) then + write(6,'(A,I6)') 'WARNING: POTENTIALLY TRUNCATED LINE:' + write(6,'(A)') '"' // strip(1:60) // '"...' + endif + +! skip if line is a comment + if (text_end.eq.0) then + return + endif + + infile(line_pos)=' ' + +! turn string to uppercase and write to infile, ignoring comments + call upcase(strip,infile(line_pos),text_end) + +! increment line number + linenum=linenum+1 + + end subroutine internalize_line + + end module diff --git a/src/parser/lib/keyread.f b/src/parser/lib/keyread.f new file mode 100644 index 0000000..47c8a17 --- /dev/null +++ b/src/parser/lib/keyread.f @@ -0,0 +1,274 @@ + module keyread_mod + contains + + subroutine keyread(keylist,infile,keynum,idat,ddat,cdat,datpos, + > klen,llen,clen,linenum,maxdat) + use long_keyread_mod,only:long_intkey,long_realkey,long_strkey + use strings_mod,only:int2string,dble2string + implicit none +! Read all keys from KEYLIST from INFILE and write their associated +! data to the corresponding data block. Memory management is +! handled by DATPOS. +! +! keylist: Registry of keys containing the name of the key +! and it's type information. +! keylist(N,1): keyname. It should be in all-caps. +! keylist(N,2): type string of the form "X#" +! +! Note: Key 1 (keylist(1,1)) has the special property that all +! lines of the input file after it's first occurence will be +! ignored. This allows for long input files holding non-key +! information. +! +! typestring syntax: +! X should be I (Integer), +I (Int >= 0), D (double precision), +! C (character string), +D (real >= 0.0d0) +! or E (checks whether key exists). +! X! (e.g. +I!, D!,..) makes a key non-optional. +! E!, while absurd, is a valid option. +! # should be either N (meaning variable length) or an integer >0. +! it encodes the expected number of read values +! +! note: the E-type has no associated *dat-array, instead +! datpos(2,N) is either -1 or it's last occurence in infile, +! depending on whether the key was found. Furthermore, +! E-type keys accept no arguments. +! +! *dat: data arrays for respective items +! klen: length of key/typestring +! llen: line length of infile +! clen: length of read strings +! keynum: number of keys +! linenum: number of lines the file has +! maxdat: maximum number of total input values read +! infile: input file +! datpos: integer array assigning read values to the keys +! datpos(1,N): internalized type (0: I, 1: +I, 2: D, 3: +D, +! 4: C, 5: E) +! datpos(2,N): starting pos. in respective data array +! datpos(3,N): length of data block +! + +!? WARNING: *dat() MAY BE WRITTEN BEYOND THEIR LENGTH FOR BAD DIMENSIONS. +!? CATCH THIS! + + integer klen, llen, clen + integer keynum, linenum, maxdat + character(len=klen) keylist(2,keynum) + character(len=llen) infile(linenum) + integer datpos(3,maxdat) + + integer idat(maxdat) + double precision ddat(maxdat) + character(len=clen) cdat(maxdat) + character(len=klen) key + character(len=64) errmsg + + integer intype,inlen,readlen + integer cstart,istart,dstart + integer key_end + integer datnum,inpos,datlen + integer file_stop + logical optional2 + + integer j,k + + cstart=1 + istart=1 + dstart=1 + datnum=0 + + file_stop=linenum + key=keylist(1,1) + key_end=len_trim(key) + if (key_end.ne.0) then + do k=1,linenum + if (infile(k)(1:key_end).eq.trim(key)) then + file_stop=k + exit + endif + enddo + endif + + do j=1,keynum + key=keylist(1,j) + +! get information needed to read key + call get_key_kind(keylist(:,j),intype,optional2,inlen,klen) + datpos(1,j)=intype + key_end=len_trim(key) + +! find last invocation of key (if present) + inpos=0 + do k=1,file_stop + if (infile(k)(1:key_end).eq.trim(key)) then + inpos=k + endif + enddo + + if (inpos.eq.0) then + if (.not.optional2) then + errmsg='MISSING, NON-OPTIONAL KEY' + call signal_key_error(key,errmsg,klen) + endif + datpos(2,j)=-1 + datpos(3,j)=0 + cycle + endif + +! read from last occurence of key + readlen=0 + if (intype.le.1) then + datlen=maxdat-istart+1 + call long_intkey(infile,inpos,key_end, + > idat,istart,readlen,llen,maxdat,linenum) + else if (intype.le.3) then + datlen=maxdat-dstart+1 + call long_realkey(infile,inpos,key_end, + > ddat,dstart,readlen,llen,maxdat,linenum) + else if (intype.eq.4) then + call long_strkey(infile,inpos,key_end, + > cdat,cstart,readlen,llen,maxdat,linenum,clen) + else if (intype.eq.5) then +! since datpos already encodes whether the key was found, +! there is no need to save anything + readlen=0 + else + write(6,*) 'ERROR: ENCOUNTERED FAULTY TYPE SPEC.' + stop 1 + endif + +! check validity of input length + if (inlen.eq.-1) then + inlen=readlen + else if (inlen.ne.readlen) then + errmsg='WRONG NUMBER OF ARGUMENTS' + call signal_key_error(key,errmsg,klen) + endif + +! check sign of +X types + if (intype.eq.1) then + do k=1,inlen + if (idat(istart-1+k).lt.0) then + errmsg='UNEXPECTED NEGATIVE INTEGER: ' + > // trim(int2string(idat(istart-1+k))) + call signal_key_error(key,errmsg,klen) + endif + enddo + else if (intype.eq.3) then + do k=1,inlen + if (ddat(dstart-1+k).lt.0.0d0) then + errmsg='UNEXPECTED NEGATIVE REAL: ' + > // trim(dble2string(ddat(dstart-1+k))) + call signal_key_error(key,errmsg,klen) + endif + enddo + endif + + if (intype.le.1) then + datpos(2,j)=istart + istart=istart+inlen + else if (intype.le.3) then + datpos(2,j)=dstart + dstart=dstart+inlen + else if (intype.eq.4) then + datpos(2,j)=cstart + dstart=cstart+inlen + else if (intype.eq.5) then +! remember where you last found the key in infile + datpos(2,j)=inpos + endif + + datpos(3,j)=inlen + + enddo + end subroutine keyread + + + subroutine get_key_kind(kentry,dattype,optional2,datlen,klen) + use strings_mod,only:trimnum,nth_word + implicit none +! Read typestring from a keylist entry KENTRY and extract the +! specific type and expected length of KEYs input. +! +! dattype: type of the data, encoded as int +! optional: true if key does not need to be present +! datlen: number of values expected +! klen: length of keys + + include 'typedef.incl' + + integer klen + integer dattype,datlen + character(len=klen) kentry(2) + logical optional2 + + character(len=klen) typestr,key,tmp,numstr + character(len=64) errmsg + integer strpos,typelen + + integer j + + key=kentry(1) + typestr=kentry(2) + strpos=0 + dattype=-1 +! check type declaration against defined types in typedef.incl + do j=1,typenum + typelen=len_trim(types(j)) + if (typestr(1:typelen).eq.trim(types(j))) then + dattype=j-1 + strpos=typelen+1 + exit + endif + enddo + + if (dattype.eq.-1) then + errmsg='INVALID TYPE SPEC: '//'"'//typestr(1:maxtypelen)//'"' + call signal_key_error(key,errmsg,klen) + endif + +! Any type followed by ! makes the card non-optional, crashing the +! program if it is missing. + optional2=(typestr(strpos:strpos).ne.'!') + if (.not.optional2) then + strpos=strpos+1 + endif + + if (dattype.eq.5) then +! since only the key's presence is checked, there is no need to +! read beyond the key + datlen=0 + else if (typestr(strpos:strpos).eq.'N') then + datlen=-1 + else + call trimnum(typestr,tmp,klen) + call nth_word(tmp,numstr,1,klen) +! crash gracefully if the expected number of values is neither +! int nor "N" (hackey version, but i can't think of a cleaner one) + do j=1,1 + read(numstr,*,err=600,end=600) datlen + cycle + 600 errmsg='CORRUPTED NUMBER OF VALUES: ' + > //'"'//trim(typestr)//'"' + call signal_key_error(key,errmsg,klen) + enddo + if (datlen.le.0) then + errmsg='INVALID TYPE SPEC: '//'"'//trim(typestr)//'"' + call signal_key_error(key,errmsg,klen) + endif + endif + + end subroutine get_key_kind + + + subroutine signal_key_error(key,msg,klen) + implicit none + integer klen + character(len=klen) key + character(len=*) msg + write(6,'(A)') 'ERROR: ' // trim(key) // ' ' // trim(msg) + stop 1 + end subroutine signal_key_error + + end module diff --git a/src/parser/lib/long_keyread.f b/src/parser/lib/long_keyread.f new file mode 100644 index 0000000..afab713 --- /dev/null +++ b/src/parser/lib/long_keyread.f @@ -0,0 +1,601 @@ + module long_keyread_mod + contains + +! NOTE: all routines other than long_intkey and long_intline are +! copy-pasted versions of different types. +! replacements: +! idat -> *dat +! ipos -> *pos +! istart -> *start +! LONG_INT -> LONG_* + +!--------------------------------------------------------------------------- + + subroutine long_intkey(infile,inpos,key_end,idat,istart, + > readlen,linelen,maxdat,maxlines) + implicit none +! Read an arbitrary number of integers for a single key from infile +! and write to idat. +! +! Data in infile is expected to have the general format +! +! KEY: ... ... ... ... & +! .... ... ... ... ... & +! .... ... ... ... ... +! +! Lines can be continued using the continuation marker arbitrarily +! often. A continuation marker at the last line causes the program +! to read undefined data following below. If that data is not a +! valid line of integers, the program breaks appropiately. +! +! idat: vector to write read data on +! istart: current position in vector idat (first empty entry) +! maxdat: length of idat +! readlen: the number of read integers for current key +! +! infile: string vector containing the read input file linewise +! key_end: length of key, expected at the first line read +! inpos: current position in infile +! linelen: max. character length of a single line +! maxlines: length of infile +! +! broken: if true, assume read data to be corrupt +! continued: if true, the next input line should continue +! the current data block. + + + integer maxlines,linelen,maxdat + integer key_end + integer istart,inpos,readlen + integer idat(maxdat) + character(len=linelen) infile(maxlines) + logical continued, broken + + + integer line_start,ipos + character(len=linelen) key + + integer n + + ipos=istart + readlen=0 + + key=' ' + key=infile(inpos)(1:key_end) + +! skip key on first line + line_start=key_end+1 + + call long_intline(infile(inpos),linelen,line_start, + > idat,ipos,maxdat,readlen, + > continued,broken) + + line_start=1 + do n=inpos+1,maxlines + if (broken) then + continued=.false. + exit + endif + if (.not.continued) then + exit + endif + call long_intline(infile(n),linelen,line_start, + > idat,ipos,maxdat,readlen, + > continued,broken) + enddo + + if (continued) then + write(6,'(A)') 'ERROR: LONG_INTKEY: ' + > // trim(key) //' CONTINUATION PAST EOF' + write(6,'(A,I5.5)') 'LINE #',n + endif + if (broken) then + write(6,'(A)') 'ERROR: LONG_INTKEY: ' + > // trim(key) //' BROKEN INPUT.' + write(6,'(A,I5.5)') 'LINE #',n + write(6,'(A,I5.5,A)') 'AFTER ', n-inpos-1, ' CONTINUATIONS' + stop 1 + endif + + + end subroutine long_intkey + +!--------------------------------------------------------------------------- + + subroutine long_intline(inline,linelen,line_start, + > idat,ipos,maxdat,readlen, + > continued,broken) + use strings_mod,only: count_words,nth_word + implicit none +! Read a single line of string input INLINE encoding integers. +! +! idat: vector to write read data on +! ipos: current position in vector idat (first empty entry) +! maxdat: length of idat +! inline: string containing line from read input file +! linelen: max. character length of a single line +! broken: if true, assume read data to be corrupt +! continued: if true, the next input line should continue +! the current data block. +! readlen: increment counting the number of read ints +! ASSUMED TO BE INITIALIZED. + + integer linelen,maxdat + integer line_start,ipos + integer idat(maxdat) + integer readlen +! character(len=linelen) inline + character(len=linelen) inline + logical continued, broken + + integer line_end, wordcount + character(len=linelen) workline, word + + integer n + + line_end=len_trim(inline) + broken=.false. + +! check whether line will be continued + if (inline(line_end:line_end).eq.'&') then + continued=.true. + line_end=line_end-1 + else + continued=.false. + endif + +! create working copy of line + workline=' ' + workline=inline(line_start:line_end) + +! check the number of wordcount on line + call count_words(workline,wordcount,linelen) + +! if the number of entries exceeds the length of idat, break + if ((wordcount+ipos-1).gt.maxdat) then + write(6,'(A)') 'ERROR: LONG_INTLINE: PARSER OUT OF MEMORY ' + > // 'ON READ' + write(6,'(A)') 'CURRENT LINE:' + write(6,'(A)') trim(inline) + broken=.true. + return + endif + + do n=1,wordcount + call nth_word(workline,word,n,linelen) + read(word,fmt=*,err=600,end=600) idat(ipos) + readlen=readlen+1 + ipos=ipos+1 + cycle +! avoid segfault in parser at all costs, throw error instead + 600 write(6,'(A,I4.4)') 'ERROR: LONG_INTLINE: ' + > // 'A FATAL ERROR OCCURED ON ENTRY #', + > n + write(6,'(A)') 'CURRENT LINE:' + write(6,'(A)') trim(inline) + broken=.true. + return + enddo + + end subroutine long_intline + +!--------------------------------------------------------------------------- + + subroutine long_realkey(infile,inpos,key_end,ddat,dstart, + > readlen,linelen,maxdat,maxlines) + implicit none +! Read an arbitrary number of double precisions for a single key from infile +! and write to ddat. +! +! Data in infile is expected to have the general format +! +! KEY: ... ... ... ... & +! .... ... ... ... ... & +! .... ... ... ... ... +! +! Lines can be continued using the continuation marker arbitrarily +! often. A continuation marker at the last line causes the program +! to read undefined data following below. If that data is not a +! valid line of integers, the program breaks appropiately. +! +! ddat: vector to write read data on +! dstart: current position in vector ddat (first empty entry) +! maxdat: length of ddat +! readlen: the number of read integers for current key +! +! infile: string vector containing the read input file linewise +! key_end: length of key, expected at the first line read +! inpos: current position in infile +! linelen: max. character length of a single line +! maxlines: length of infile +! +! broken: if true, assume read data to be corrupt +! continued: if true, the next input line should continue +! the current data block. + + + integer maxlines,linelen,maxdat + integer key_end + integer dstart,inpos,readlen + double precision ddat(maxdat) + character(len=linelen) infile(maxlines) + logical continued, broken + + + integer line_start,dpos + character(len=linelen) key + + integer n + + dpos=dstart + readlen=0 + + key=' ' + key=infile(inpos)(1:key_end) + +! skip key on first line + line_start=key_end+1 + + call long_realline(infile(inpos),linelen,line_start, + > ddat,dpos,maxdat,readlen, + > continued,broken) + + line_start=1 + do n=inpos+1,maxlines + if (broken) then + continued=.false. + exit + endif + if (.not.continued) then + exit + endif + call long_realline(infile(n),linelen,line_start, + > ddat,dpos,maxdat,readlen, + > continued,broken) + enddo + + if (continued) then + write(6,'(A)') 'ERROR: LONG_REALKEY: ' + > // trim(key) //' CONTINUATION PAST EOF' + write(6,'(A,I5.5)') 'LINE #',n + endif + if (broken) then + write(6,'(A)') 'ERROR: LONG_REALKEY: ' + > // trim(key) //' BROKEN INPUT.' + write(6,'(A,I5.5)') 'LINE #',n + write(6,'(A,I5.5,A)') 'AFTER ', n-inpos-1, ' CONTINUATIONS' + stop 1 + endif + + + end subroutine long_realkey + +!--------------------------------------------------------------------------- + + subroutine long_realline(inline,linelen,line_start, + > ddat,dpos,maxdat,readlen, + > continued,broken) + use strings_mod,only: count_words,nth_word + implicit none +! Read a single line of string input INLINE encoding double precisions. +! +! ddat: vector to write read data on +! dpos: current position in vector ddat (first empty entry) +! maxdat: length of ddat +! inline: string containing line from read input file +! linelen: max. character length of a single line +! broken: if true, assume read data to be corrupt +! continued: if true, the next input line should continue +! the current data block. +! readlen: increment counting the number of read ints +! ASSUMED TO BE INITIALIZED. + + + integer linelen,maxdat + integer line_start,dpos + integer readlen + double precision ddat(maxdat) + character(len=linelen) inline + logical continued, broken + + integer line_end, wordcount + character(len=linelen) workline, word + + integer n + + line_end=len_trim(inline) + broken=.false. + +! check whether line will be continued + if (inline(line_end:line_end).eq.'&') then + continued=.true. + line_end=line_end-1 + else + continued=.false. + endif + +! create working copy of line + workline=' ' + workline=inline(line_start:line_end) + +! check the number of wordcount on line + call count_words(workline,wordcount,linelen) + +! if the number of entries exceeds the length of ddat, break + if ((wordcount+dpos-1).gt.maxdat) then + write(6,'(A)') 'ERROR: LONG_REALLINE: PARSER OUT OF MEMORY ' + > // 'ON READ' + write(6,'(A)') 'CURRENT LINE:' + write(6,'(A)') trim(inline) + write(6,*) 'wordcount',wordcount + write(6,*) 'dpos',dpos + write(6,*) 'maxdat',maxdat + write(6,*) 'ddat',ddat(1:maxdat) + broken=.true. + return + endif + + do n=1,wordcount + call nth_word(workline,word,n,linelen) + read(word,fmt=*,err=600,end=600) ddat(dpos) + readlen=readlen+1 + dpos=dpos+1 + cycle +! avoid segfault in parser at all costs, throw error instead + 600 write(6,'(A,I4.4)') 'ERROR: LONG_REALLINE: ' + > // 'A FATAL ERROR OCCURED ON ENTRY #', + > n + write(6,'(A)') 'CURRENT LINE:' + write(6,'(A)') trim(inline) + broken=.true. + return + enddo + + end subroutine long_realline + +!--------------------------------------------------------------------------- + + subroutine long_strkey(infile,inpos,key_end,cdat,cstart, + > readlen,linelen,datlen,maxlines,clen) + implicit none +! Read an arbitrary number of strings for a single key from infile +! and write to idat. +! +! Data in infile is expected to have the general format +! +! KEY: ... ... ... ... & +! .... ... ... ... ... & +! .... ... ... ... ... +! +! Lines can be continued using the continuation marker arbitrarily +! often. A continuation marker at the last line causes the program +! to read undefined data following below. If that data is not a +! valid line of strings, the program breaks appropiately. +! +! cdat: vector to write read data on +! cstart: current position in vector idat (first empty entry) +! datlen: length of idat +! readlen: the number of read integers for current key +! +! infile: string vector containing the read input file linewise +! key_end: length of key, expected at the first line read +! inpos: current position in infile +! linelen: max. character length of a single line +! maxlines: length of infile +! clen: maximum length of a given string +! +! broken: if true, assume read data to be corrupt +! continued: if true, the next input line should continue +! the current data block. +! append: if true, continue appending to an existing string. + + + integer maxlines,linelen,datlen,clen + integer key_end + integer cstart,inpos,readlen + character(len=linelen) infile(maxlines) + character(len=clen) cdat(datlen) + + + integer line_start,cpos + integer strpos + character(len=linelen) key + logical continued, broken + + integer n + + cpos=cstart + readlen=0 + + key=' ' + key=infile(inpos)(1:key_end) + +! skip key on first line + line_start=key_end+1 + + strpos=0 + + call long_strline(infile(inpos),linelen,line_start, + > cdat,cpos,datlen,readlen,clen, + > continued,broken,strpos) + + line_start=1 + do n=inpos+1,maxlines + if (broken) then + continued=.false. + exit + endif + if (.not.continued) then + exit + endif + call long_strline(infile(n),linelen,line_start, + > cdat,cpos,datlen,readlen,clen, + > continued,broken,strpos) + enddo + + if (continued) then + write(6,'(A)') 'ERROR: LONG_STRKEY: ' + > // trim(key) //' CONTINUATION PAST EOF' + write(6,'(A,I5.5)') 'LINE #',n + endif + if (broken) then + write(6,'(A)') 'ERROR: LONG_STRKEY: ' + > // trim(key) //' BROKEN INPUT.' + write(6,'(A,I5.5)') 'LINE #',n + write(6,'(A,I5.5,A)') 'AFTER ', n-inpos-1, ' CONTINUATIONS' + stop 1 + endif + + + end subroutine long_strkey + + +!--------------------------------------------------------------------------- + + subroutine long_strline(inline,linelen,line_start, + > cdat,cpos,datlen,readlen,clen, + > continued,broken,strpos) + use strings_mod,only:iswhitespace, downcase + implicit none +! Read a single line of string input INLINE encoding integers. +! +! cdat: vector to write read data on +! cpos: current position in vector cdat (first empty/incomplete entry) +! datlen: length of idat +! inline: string containing line from read input file +! linelen: max. character length of a single line +! broken: if true, assume read data to be corrupt +! continued: if true, the next input line should continue +! the current data block. +! readlen: increment counting the number of read strings +! ASSUMED TO BE INITIALIZED. +! strpos: if 0, create new string. Otherwise, append to string of assumed +! length strpos. + + integer :: linelen,datlen,clen + integer :: line_start,cpos,strpos + integer :: readlen + character(len=linelen) :: inline + character(len=clen) :: cdat(datlen) + logical :: continued, broken + + character,parameter :: esc = ACHAR(92) ! "\" + + integer :: line_end + character(len=linelen) :: workline + character(len=1) :: char, tmp_char + + logical :: cont_string, escaped + + integer :: j + +! logical :: iswhitespace + + broken=.false. + continued=.false. + cont_string=.false. + escaped=.false. + +! create working copy of line + workline=' ' + workline=inline(line_start:len_trim(inline)) + line_end=len_trim(workline) + +! If needed, initialize working position in cdat + if (strpos.eq.0) then + cdat(cpos)=' ' + endif + +! iterate over characters in line + do j=1,line_end + char=workline(j:j) + if (escaped) then +! Insert escaped character and proceed. + escaped=.false. +! Special escape sequences + if (char.eq.'.') then +! \. = ! + char='!' + endif + else if (char.eq.esc) then +! Consider next character escaped, skip char. + escaped=.true. + cycle + else if (char.eq.'&') then + continued=.true. + if (j.eq.line_end) then + exit + endif +! Deal with unusual continuations, look at char after "&" + char=workline(j+1:j+1) + if (char.eq.'&') then +! "&&" allows multi-line strings + cont_string=.true. + if (j+1.eq.line_end) then + exit + endif + endif + write(6,'(A)') 'WARNING: LONG_STRLINE: IGNORED' + > // ' JUNK CHARACTER(S) FOLLOWING' + > // ' CONTINUATION CHARACTER.' + exit + else if (iswhitespace(char)) then +! Whitespace separates strings; skip char. + if (strpos.gt.0) then +! Begin a new string unless the current one is empty. + strpos=0 + cpos=cpos+1 + cdat(cpos)=' ' + endif + cycle + else +! assume char to be meant as a downcase char + call downcase(char,tmp_char,1) + char=tmp_char + endif + +! Incorporate new char into string + strpos=strpos+1 + +! Break if a boundary exception occurs + if (cpos.gt.datlen) then + write(6,'(A)') 'ERROR: LONG_STRLINE: PARSER OUT OF MEMORY' + > // ' ON READ' + write(6,'(A)') 'CURRENT LINE:' + write(6,'(A)') trim(inline) + broken=.true. + return + else if (strpos.gt.clen) then + write(6,'(A)') 'ERROR: LONG_STRLINE: PARSER OUT OF MEMORY' + > // ' ON READ: STRING ARGUMENT EXCEEDS CLEN' + write(6,'(A)') 'CURRENT LINE:' + write(6,'(A)') trim(inline) + broken=.true. + return + endif + +! insert character + cdat(cpos)(strpos:strpos)=char + if (strpos.eq.1) then + readlen=readlen+1 + endif + enddo + +! Fix incomplete escape sequences and deal with continuation + if (escaped) then + write(6,'(A)') 'WARNING: LONG_STRLINE: ENCOUNTERED ESCAPE' + > // ' CHARACTER AT EOL. IGNORED.' + endif + +! Unless the line ended with "&&", consider the current, non-empty +! string complete. + if ((cont_string).or.(strpos.eq.0)) then + return + else + cpos=cpos+1 + strpos=0 + endif + + end subroutine long_strline + + end module diff --git a/src/parser/lib/strings.f b/src/parser/lib/strings.f new file mode 100644 index 0000000..da09710 --- /dev/null +++ b/src/parser/lib/strings.f @@ -0,0 +1,505 @@ + module strings_mod + implicit none + contains + +!---------------------------------------------------------------------------- + subroutine capital(in,str,lauf,mmax,sl) + integer mmax,lauf,i,j,sl + character in(mmax)*(*), str*(*) + + if (str.eq.'') return + + j=0 + do i=1,sl + if (str(i:i).ne.' ') then + j=i-1 + goto 10 + endif + enddo + 10 do i=1,sl-j + str(i:i)=str(i+j:i+j) + enddo + do i=sl-j+1,sl + str(i:i)=' ' + enddo + + if (str(1:1).eq.'!') return + + lauf=lauf+1 + do i=1,sl + in(lauf)(i:i)=str(i:i) + if (str(i:i).eq.'a') in(lauf)(i:i)='A' + if (str(i:i).eq.'b') in(lauf)(i:i)='B' + if (str(i:i).eq.'c') in(lauf)(i:i)='C' + if (str(i:i).eq.'d') in(lauf)(i:i)='D' + if (str(i:i).eq.'e') in(lauf)(i:i)='E' + if (str(i:i).eq.'f') in(lauf)(i:i)='F' + if (str(i:i).eq.'g') in(lauf)(i:i)='G' + if (str(i:i).eq.'h') in(lauf)(i:i)='H' + if (str(i:i).eq.'i') in(lauf)(i:i)='I' + if (str(i:i).eq.'j') in(lauf)(i:i)='J' + if (str(i:i).eq.'k') in(lauf)(i:i)='K' + if (str(i:i).eq.'l') in(lauf)(i:i)='L' + if (str(i:i).eq.'m') in(lauf)(i:i)='M' + if (str(i:i).eq.'n') in(lauf)(i:i)='N' + if (str(i:i).eq.'o') in(lauf)(i:i)='O' + if (str(i:i).eq.'p') in(lauf)(i:i)='P' + if (str(i:i).eq.'q') in(lauf)(i:i)='Q' + if (str(i:i).eq.'r') in(lauf)(i:i)='R' + if (str(i:i).eq.'s') in(lauf)(i:i)='S' + if (str(i:i).eq.'t') in(lauf)(i:i)='T' + if (str(i:i).eq.'u') in(lauf)(i:i)='U' + if (str(i:i).eq.'v') in(lauf)(i:i)='V' + if (str(i:i).eq.'w') in(lauf)(i:i)='W' + if (str(i:i).eq.'x') in(lauf)(i:i)='X' + if (str(i:i).eq.'y') in(lauf)(i:i)='Y' + if (str(i:i).eq.'z') in(lauf)(i:i)='Z' +C..... Addition of the first if-loop + if (i-3.gt.0) then + if (in(lauf)(i-3:i).eq.'CHK:') then + in(lauf)(i+1:sl)=str(i+1:sl) + return + endif + endif +! if (i+3.le.sl) then +! if (in(lauf)(i:i+3).eq.'CHK:') then +! in(lauf)(i+1:sl)=str(i+1:sl) +! return +! endif +! endif + enddo + + end subroutine capital + +!----------------------------------------------------------------------- + subroutine lcap(str,n) + integer i, n + character str*(*), dum*750 + + dum='' + do i=1,n + dum(i:i)=str(i:i) + if (str(i:i).eq.'a') dum(i:i)='A' + if (str(i:i).eq.'b') dum(i:i)='B' + if (str(i:i).eq.'c') dum(i:i)='C' + if (str(i:i).eq.'d') dum(i:i)='D' + if (str(i:i).eq.'e') dum(i:i)='E' + if (str(i:i).eq.'f') dum(i:i)='F' + if (str(i:i).eq.'g') dum(i:i)='G' + if (str(i:i).eq.'h') dum(i:i)='H' + if (str(i:i).eq.'i') dum(i:i)='I' + if (str(i:i).eq.'j') dum(i:i)='J' + if (str(i:i).eq.'k') dum(i:i)='K' + if (str(i:i).eq.'l') dum(i:i)='L' + if (str(i:i).eq.'m') dum(i:i)='M' + if (str(i:i).eq.'n') dum(i:i)='N' + if (str(i:i).eq.'o') dum(i:i)='O' + if (str(i:i).eq.'p') dum(i:i)='P' + if (str(i:i).eq.'q') dum(i:i)='Q' + if (str(i:i).eq.'r') dum(i:i)='R' + if (str(i:i).eq.'s') dum(i:i)='S' + if (str(i:i).eq.'t') dum(i:i)='T' + if (str(i:i).eq.'u') dum(i:i)='U' + if (str(i:i).eq.'v') dum(i:i)='V' + if (str(i:i).eq.'w') dum(i:i)='W' + if (str(i:i).eq.'x') dum(i:i)='X' + if (str(i:i).eq.'y') dum(i:i)='Y' + if (str(i:i).eq.'z') dum(i:i)='Z' + enddo + str(1:n)=dum(1:n) + + end subroutine lcap + +!-------------------------------------------------------------------------- +! function to test how many entries are on one line: + function clen(str,sl) + integer clen, i, j, sl + character str*(sl) + + clen=0 + j=0 + do i=sl,1,-1 + if ((str(i:i).ne.' ').and.(j.eq.0)) then + clen=clen+1 + j=1 + endif + if (str(i:i).eq.' ') j=0 + enddo + + end function clen + +!-------------------------------------------------------------------------- + + logical function isnumeral(char) +! Check whether character CHAR is a numeral. + + character char + + character numerals(10) + parameter (numerals = ['0','1','2','3','4','5','6','7','8','9']) + + isnumeral=any(numerals.eq.char) + + end function isnumeral + +!-------------------------------------------------------------------------- + + logical function iswhitespace(char) +! Check whether CHAR is tab or spc character + + character char + + character whitespace(2) + parameter (whitespace = [' ', ' ']) + + iswhitespace=any(whitespace.eq.char) + + end function iswhitespace + +!-------------------------------------------------------------------------- + + subroutine trimnum(string,outstr,str_len) +! Extract numbers in STRING as a space separated list in OUTSTR. + integer str_len + character(len=str_len) string + character(len=str_len) outstr + + integer length + logical foundnum + + integer k + +! logical isnumeral + + length=len_trim(string) + foundnum=.false. + + outstr=' ' + + do k=1,length + if (isnumeral(string(k:k))) then + if (foundnum) then + outstr = trim(outstr) // string(k:k) + else if (len_trim(outstr).ne.0) then + outstr = trim(outstr) // ' ' // string(k:k) + foundnum=.true. + else + outstr = trim(outstr) // string(k:k) + foundnum=.true. + endif + else + foundnum=.false. + endif + enddo + + end subroutine trimnum + +!-------------------------------------------------------------------------- + + subroutine strip_string(string,stripped,str_len) +! Strip lefthand whitespace of STRING as well as excessive +! whitespace and save to STRIPPED. +! Example: +! " the quick brown fox" -> "the quick brown fox" + + integer str_len + character(len=str_len) string,stripped + + character char + logical spaced + +! logical iswhitespace + + integer k, trimpos + + stripped=' ' + trimpos=1 + +! spaced indicates whether if a space is found it is the first +! (separating the word from the next) or redundant + spaced=.true. + + do k=1,len_trim(string) + char=string(k:k) + if (.not.iswhitespace(char)) then + spaced=.false. + else if (.not.spaced) then +! replace TAB characters if present + char=' ' + spaced=.true. + else +! ignore redundant spaces + cycle + endif + stripped(trimpos:trimpos)=char + trimpos=trimpos+1 + enddo + + + end subroutine strip_string + +!-------------------------------------------------------------------------- + + subroutine nth_word(string,word,n,str_len) +! If STRING is a space separated list of words, return the Nth word. + + integer str_len + character(len=str_len) string,word + integer n + + character(len=str_len) strip + integer wc + +! logical iswhitespace + + integer k,j + + call strip_string(string,strip,str_len) + + word=' ' + wc=1 + +! find the word + do k=1,len_trim(strip) + if (wc.eq.n) exit + if (iswhitespace(strip(k:k))) then + wc=wc+1 + endif + enddo + do j=k,len_trim(strip) + if (iswhitespace(strip(j:j))) exit + word = trim(word) // strip(j:j) + enddo + + end subroutine nth_word + +!-------------------------------------------------------------------------- + + subroutine count_words(string,wordcount,str_len) +! If STRING is a space separated list of words, return the Nth word. + + integer str_len + character(len=str_len) string + integer wordcount + + character(len=str_len) strip + integer wc + +! logical iswhitespace + + integer k + + call strip_string(string,strip,str_len) + + if (len_trim(strip).gt.0) then + wc=1 + else + wordcount=0 + return + endif + +! find the word + do k=1,len_trim(strip) + if (iswhitespace(strip(k:k))) then + wc=wc+1 + endif + enddo + wordcount=wc + + end subroutine count_words + +!-------------------------------------------------------------------------- + + subroutine upcase(string,upstring,str_len) +! Transform arbitrary string to uppercase and save to upstring + + integer str_len + character(len=str_len) string,upstring + + integer j + + upstring=' ' + + do j=1,len_trim(string) + select case (string(j:j)) + case ('a') + upstring(j:j)= 'A' + case ('b') + upstring(j:j)= 'B' + case ('c') + upstring(j:j)= 'C' + case ('d') + upstring(j:j)= 'D' + case ('e') + upstring(j:j)= 'E' + case ('f') + upstring(j:j)= 'F' + case ('g') + upstring(j:j)= 'G' + case ('h') + upstring(j:j)= 'H' + case ('i') + upstring(j:j)= 'I' + case ('j') + upstring(j:j)= 'J' + case ('k') + upstring(j:j)= 'K' + case ('l') + upstring(j:j)= 'L' + case ('m') + upstring(j:j)= 'M' + case ('n') + upstring(j:j)= 'N' + case ('o') + upstring(j:j)= 'O' + case ('p') + upstring(j:j)= 'P' + case ('q') + upstring(j:j)= 'Q' + case ('r') + upstring(j:j)= 'R' + case ('s') + upstring(j:j)= 'S' + case ('t') + upstring(j:j)= 'T' + case ('u') + upstring(j:j)= 'U' + case ('v') + upstring(j:j)= 'V' + case ('w') + upstring(j:j)= 'W' + case ('x') + upstring(j:j)= 'X' + case ('y') + upstring(j:j)= 'Y' + case ('z') + upstring(j:j)= 'Z' + case default + upstring(j:j)=string(j:j) + end select + enddo + + end subroutine upcase + +!-------------------------------------------------------------------------- + + subroutine downcase(string,downstring,str_len) +! Transform arbitrary string to downcase and save to downstring + + integer str_len + character(len=str_len) string,downstring + + integer j + + downstring=' ' + + do j=1,len_trim(string) + select case (string(j:j)) + case ('A') + downstring(j:j)= 'a' + case ('B') + downstring(j:j)= 'b' + case ('C') + downstring(j:j)= 'c' + case ('D') + downstring(j:j)= 'd' + case ('E') + downstring(j:j)= 'e' + case ('F') + downstring(j:j)= 'f' + case ('G') + downstring(j:j)= 'g' + case ('H') + downstring(j:j)= 'h' + case ('I') + downstring(j:j)= 'i' + case ('J') + downstring(j:j)= 'j' + case ('K') + downstring(j:j)= 'k' + case ('L') + downstring(j:j)= 'l' + case ('M') + downstring(j:j)= 'm' + case ('N') + downstring(j:j)= 'n' + case ('O') + downstring(j:j)= 'o' + case ('P') + downstring(j:j)= 'p' + case ('Q') + downstring(j:j)= 'q' + case ('R') + downstring(j:j)= 'r' + case ('S') + downstring(j:j)= 's' + case ('T') + downstring(j:j)= 't' + case ('U') + downstring(j:j)= 'u' + case ('V') + downstring(j:j)= 'v' + case ('W') + downstring(j:j)= 'w' + case ('X') + downstring(j:j)= 'x' + case ('Y') + downstring(j:j)= 'y' + case ('Z') + downstring(j:j)= 'z' + case default + downstring(j:j)=string(j:j) + end select + enddo + + end subroutine downcase + +!-------------------------------------------------------------------------- + pure function int2string(int) result(string) + character(len=:), allocatable :: string + integer, intent(in) :: int + character(len=100) :: str + write(str,'(i0)') int + string = trim(adjustl(str)) + end function int2string +!-------------------------------------------------------------------------- + pure function dble2string(dble) result(string) + character(len=:), allocatable :: string + double precision, intent(in) :: dble + character(len=100) :: str + write(str,'(ES16.9)') dble + string = trim(adjustl(str)) + end function dble2string +!-------------------------------------------------------------------------- + pure function shortdble2string(dble) result(string) + character(len=:), allocatable :: string + double precision, intent(in) :: dble + character(len=100) :: str + write(str,'(ES11.2)') dble + string = trim(adjustl(str)) + end function shortdble2string +!---------------------------------------------------------------------------------- + subroutine write_oneline(string,id_print) +#ifdef mpi_version + use mpi +#endif + integer,intent(in) :: id_print + character(len=*) string + +#ifdef mpi_version + integer my_rank,ierror + call MPI_Comm_rank(MPI_COMM_WORLD, my_rank, ierror) +#endif + +#ifdef mpi_version + if (my_rank.eq.0) then +#endif + write(id_print,'(A)') adjustl(trim(string)) + +#ifdef mpi_version + endif +#endif + + end subroutine write_oneline + + end module diff --git a/src/parser/lib/typedef.incl b/src/parser/lib/typedef.incl new file mode 100644 index 0000000..8a27579 --- /dev/null +++ b/src/parser/lib/typedef.incl @@ -0,0 +1,6 @@ + + integer typenum,maxtypelen + parameter (typenum=6,maxtypelen=2) + character(len=maxtypelen) types(typenum) +! parameter (types=['I', '+I', 'D', '+D', 'C', 'E']) + parameter (types=['I ', '+I', 'D ', '+D', 'C ', 'E ']) !Fabian diff --git a/src/parser/long_write.f b/src/parser/long_write.f new file mode 100644 index 0000000..c005591 --- /dev/null +++ b/src/parser/long_write.f @@ -0,0 +1,103 @@ +************************************************************************ +*** long_write +*** writing genetic's long input format +*** +************************************************************************ + module long_write + implicit none + contains + + subroutine write_longint(f_unit,params,plen,intfmt,maxvals) + implicit none +! Routine writing long integer output of the form +! x1 x2 x3 .... xN & +! ... & +! +! f_unit: UNIT to be written on, directly passed to write +! params: integer vector to be written out +! plen: number of elements to be printed +! maxvals: (maximum) number of values per line +! intfmt: format of a single interger, e.g. '(I6)' + + integer f_unit + integer params(*) + integer plen,maxvals + character*16 intfmt + + integer pcount + + integer j,k + + pcount=0 ! count parameters written so far + +! write all values that fill entire lines. + do k=1,(plen/maxvals) + do j=1,maxvals + write(unit=f_unit,fmt=intfmt,advance='NO') params(pcount+j) + enddo + pcount=pcount+maxvals + if (pcount.lt.plen) then + write(unit=f_unit,fmt='(A)') ' &' + endif + enddo + + pcount=pcount+1 + +! write remaining few + do k=pcount,plen + write(unit=f_unit,fmt=intfmt,advance='NO') params(k) + enddo + + write(f_unit,'(A)') '' + + end subroutine + +!---------------------------------------------------------------------------- + + subroutine write_longreal(f_unit,params,plen,dfmt,maxvals) + implicit none +! Routine writing long real(*8) output of the form +! x1 x2 x3 .... xN & +! ... & +! +! f_unit: UNIT to be written on, directly passed to write +! params: integer vector to be written out +! plen: number of elements to be printed +! maxvals: (maximum) number of values per line +! dfmt: format of a single real, e.g. '(ES23.15)' + + real*8 params(*) + integer f_unit + integer plen,maxvals + character*16 dfmt + + integer pcount + + integer j,k + + pcount=0 ! count parameters written so far + +! write all values that fill entire lines. + do k=1,(plen/maxvals) + do j=1,maxvals + write(unit=f_unit,fmt=dfmt,advance='NO') params(pcount+j) + enddo + pcount=pcount+maxvals + if (pcount.lt.plen) then + write(unit=f_unit,fmt='(A)') ' &' + endif + enddo + + pcount=pcount+1 + +! write remaining few + do k=pcount,plen + write(unit=f_unit,fmt=dfmt,advance='NO') params(k) + enddo + + write(f_unit,'(A)') '' + + end subroutine + + + end module diff --git a/src/parser/parameterkeys.f b/src/parser/parameterkeys.f new file mode 100644 index 0000000..809cda4 --- /dev/null +++ b/src/parser/parameterkeys.f @@ -0,0 +1,248 @@ + module parameterkeys + use io_parameters, only: llen,klen, + > key,maxpar_keys,parkeynum,parkeylen,ec_read,ec_dim + use dim_parameter,only: pst,max_par + use keys_mod, only: init_keys + implicit none + + + contains +! < Subroutine reading the user defined Parameter keys from keys.incl +! (infile,linenum,p,p_act,p_spread,npar,gspread,facspread) + use strings_mod,only:write_oneline + use long_keyread_mod,only:long_intkey,long_realkey,long_strkey +! dir$ optimize:1 +! IN: variables + integer linenum !< number of lines in internalized input file (infile) + character(len=llen) :: infile(linenum) !< internalized input file + double precision gspread !< general parameterspread used to initialize p_spread + double precision facspread !< multiplicative factor for spreads + +! OUT: read parameters and their lenght,spread and active state + integer npar !< lenght oo parameter vector + double precision, allocatable :: p(:) !< vector for the values of read parameters + double precision, allocatable :: p_spread(:) !< vector for the spread values for each parameter + integer, allocatable :: p_act(:) !< vector containing 0 or 1 defining if corresponding parameters are activ in Fit ! Nicole: added flexible value for nonlinear terms + +! Private: variables + integer i,j !< running indicies + integer ktype,key_end !< dummys for keytype and keylength + integer pcount !< dummy for number of read values + logical dbg !< logical for debugging state + +! Fabian + character(len=llen) fmt + integer,parameter :: std_out = 6 + + dbg =.false. + + !Fabian: No need that these are within keys.incl since these are generic statements + parkeynum=0 + parkeylen=0 + key = ' ' + + !Fabian: Include user specific keys + call init_keys +! include 'keys.incl' + + !Fabian: No need that this is within keys.incl since it is generic + do j=1,maxpar_keys + if (key(1,j)(1:1).eq.' ') then + parkeynum=j-1 + write(fmt,'("Number of accepted parameter keys: ",I3)') + > parkeynum + call write_oneline(fmt,std_out) + exit + endif + enddo + + do i=1,4 + do j=1,maxpar_keys + if(parkeylen.lt.len_trim(key(i,j))) then + parkeylen = len_trim(key(i,j)) + endif + enddo + enddo + if(parkeylen.ge.klen) then + write(fmt,*) + > 'WARNING: Lenght of Parameterkey >= Maximum Keylenght' + call write_oneline(fmt,std_out) + endif + + + +! reading cards for the number of parameters' + npar =0 + ktype = 1 !reading number of parameters per key + do i=1,linenum + do j=1, parkeynum + +! get string length of key + key_end=len_trim(key(ktype,j)) + +! check if key is present and read values if present + if (infile(i)(1:key_end).eq.key(ktype,j)) then + if(dbg) write(6,*) key(ktype,j),' read' + read (infile(i)(key_end+1:llen),*) pst(2,j) + endif + enddo + enddo + +!.. compute total number of parameters: + do i=1, parkeynum + npar=npar + pst(2,i) + enddo + if(npar.gt.max_par) call signal_maxparameter_error(npar,max_par) + if(npar.le.0) call signal_noparameters_error(npar) + + write(fmt,'("Number of Expected Parameters: ",I9)') npar + call write_oneline(fmt,std_out) + +!.. determine start and end points of parameter blocks: + pst(1,1)=1 ! 1 = start of block + do i=2,parkeynum + pst(1,i)= pst(1,i-1)+pst(2,i-1) + if(dbg) write(6,'("pst(1:2,i): ",2i9)') pst(1:2,i) + enddo + + +! allocate parameter arrays + allocate(p(npar),p_act(npar),p_spread(npar)) +! initialize parameter arrays + p=0.d0 +! DW: UNDOCUMENTED BEHAVIOR: What does act=2 do??? + p_act=10 + p_spread=gspread + +! read parameter values + ktype = 2 !reading value of parameters per key + do i=1,linenum + do j=1, parkeynum + +! get string length of key + key_end=len_trim(key(ktype,j)) + +! check if key is present and read values if present + if (infile(i)(1:key_end).eq.key(ktype,j)) then + if(dbg) write(6,*) key(ktype,j),' read' + call long_realkey(infile,i,key_end, + > p,pst(1,j),pcount,llen,npar,linenum) + +! check if number of parameters consistent + if(pcount.ne.pst(2,j)) then + call signal_parameter_error + > (key(ktype,j),pcount,pst(2,j)) + endif + + endif + + enddo + enddo + + +! read if parameters are activ + ktype = 3 !reading activity of parameter per key + do i=1,linenum + do j=1, parkeynum + +! get string length of key + key_end=len_trim(key(ktype,j)) + +! check if key is present and read values if present + if (infile(i)(1:key_end).eq.key(ktype,j)) then + if(dbg) write(6,*) key(ktype,j),' read' + call long_intkey(infile,i,key_end, + > p_act,pst(1,j),pcount,llen,npar,linenum) +! check if number of parameters consistent + if(pcount.ne.pst(2,j)) then + call signal_parameter_error + > (key(ktype,j),pcount,pst(2,j)) + endif + + endif + + enddo + enddo + +! check if all values for p_act are in valid range + do i=1,npar +! Nicole: added flexible p_act values +! in my case now up tp 6 + if((abs(p_act(i)).gt.6)) then + write(fmt,*) 'Invalid value for p_act: ', p_act(i), i + call write_oneline(fmt,std_out) + endif + enddo + +! read spread for parameters + ktype = 4 !reading spread of parameters per key + do i=1,linenum + do j=1, parkeynum + +! get string length of key + key_end=len_trim(key(ktype,j)) + +! check if key is present and read values if present + if (infile(i)(1:key_end).eq.key(ktype,j)) then + if(dbg) write(6,*) key(ktype,j),' read' + call long_realkey(infile,i,key_end, + > p_spread,pst(1,j),pcount,llen,npar,linenum) + +! check if number of parameters consistent + if(pcount.ne.pst(2,j)) then + call signal_parameter_error + > (key(ktype,j),pcount,pst(2,j)) + endif + + endif + + enddo + enddo + + !Multiply p_spread by facspread + !(default facspread=1, unless it is explicitly declared) + p_spread=p_spread*facspread + + end subroutine +!---------------------------------------------------------------------------------------------------- +! // trim(int2string(val)) // ' Parameters, but expected: ' + > // trim(int2string(expval)) + stop ec_read + end subroutine + +!---------------------------------------------------------------------------------------------------- +! // trim(int2string(val)) // ' Parameters, but maximum: ' + > // trim(int2string(maxval)) + stop ec_dim + end subroutine + +!---------------------------------------------------------------------------------------------------- +! // trim(int2string(val)) + stop ec_dim + end subroutine + + + end module diff --git a/src/parser/parse_errors.f b/src/parser/parse_errors.f new file mode 100644 index 0000000..45e3243 --- /dev/null +++ b/src/parser/parse_errors.f @@ -0,0 +1,117 @@ + module parse_errors + use io_parameters, only: + > keylist, errcat, ec_dim, ec_log, ec_read, ec_error + implicit none + + contains + +!-------------------------------------------------------------------------------- + + subroutine signal_p_error(key_id,msg) +! Signal generic error with user-defined message MSG. + integer key_id + character(len=*) msg + + write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id)) + > // ' ' // trim(msg) + stop ec_error + + end subroutine + +!-------------------------------------------------------------------------------- + + subroutine signal_dim_error(key_id,msg_code,value,expval) + use strings_mod,only:int2string +! Signals errors where one specific dimensioning value is ill-set. +! If the optional parameter EXPVAL is given, return it as expected +! dimensioning value. + integer key_id, value + integer, optional :: expval + integer msg_code + write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id)) + > // ' ' // trim(errcat(msg_code)) + write(6,'(A)') 'OFFENDING VALUE: ' // trim(int2string(value)) + if (present(expval)) then + write(6,'(A)') 'EXPECTED: ' // trim(int2string(expval)) + endif + stop ec_dim + + end subroutine + +!-------------------------------------------------------------------------------- + + subroutine signal_log_error(key_id,msg_code,alt_key) +! Signals errors where contradictory settings are provided which +! the program cannot resolve. If the optional parameter ALT_KEY +! is given, name the explicit key current settings clash with. + integer key_id + integer, optional :: alt_key + integer msg_code + + write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id)) + > // ' ' // trim(errcat(msg_code)) + if (present(alt_key)) then + write(6,'(A)') 'OFFENDING KEY: ' // trim(keylist(1,alt_key)) + endif + + stop ec_log + + end subroutine + +!-------------------------------------------------------------------------------- + + subroutine signal_val_error(key_id,msg_code,value,expval) + use strings_mod,only:int2string +! Signals errors where a given value makes no sense in it's given context. +! If the optional parameter EXPVAL is given, return it as expected +! dimensioning value. + integer key_id, value + integer, optional :: expval + integer msg_code + write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id)) + > // ' ' // trim(errcat(msg_code)) + write(6,'(A)') 'OFFENDING VALUE: ' // trim(int2string(value)) + if (present(expval)) then + write(6,'(A)') 'EXPECTED: ' // trim(int2string(expval)) + endif + stop ec_read + + end subroutine + +!-------------------------------------------------------------------------------- + + subroutine signal_dval_error(key_id,msg_code,value,expval) + use strings_mod,only: shortdble2string +! Signals errors where a given value makes no sense in it's given context. +! If the optional parameter EXPVAL is given, return it as expected +! dimensioning value. + integer key_id + double precision value + double precision, optional :: expval + integer msg_code + write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id)) + > // ' ' // trim(errcat(msg_code)) + write(6,'(A)') 'OFFENDING VALUE: ' + > // trim(shortdble2string(value)) + if (present(expval)) then + write(6,'(A)') 'EXPECTED: ' // trim(shortdble2string(expval)) + endif + stop ec_read + + end subroutine + + +!-------------------------------------------------------------------------------- + + subroutine signal_meta_error(key_id,msg_code) +! Signals errors where a key (or key combinations) is/are not +! supported or maintained for reasons outside of the program's +! scope (e.g.: deprecation). + integer key_id,msg_code + + write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id)) + > // ' ' // trim(errcat(msg_code)) + stop ec_read + + end subroutine + end module diff --git a/src/parser/parser.f b/src/parser/parser.f new file mode 100644 index 0000000..6ffeeb3 --- /dev/null +++ b/src/parser/parser.f @@ -0,0 +1,875 @@ + +! >Module Containing Subroutines relevant for reading cards and information from an inputfile + + module parser + use io_parameters + use dim_parameter + use parse_errors + use parameterkeys, only: parameterkey_read + use long_write + implicit none + contains +!-------------------------------------------------------------------------------------------------------------------------------------- +! >Reads Cards and Data from Inputfile +! !@param datname name of input file that is readed +! !@param infile internalized input file +! !@param linenum linenumber of internalized input file +! !@param idat + subroutine les(x,y,wt,p,p_act,p_spread,npar, + > seed,gtype,nset,maxit,micit,nsel,mut,difper,freeze) + use strings_mod,only:write_oneline + use fileread_mod,only:get_datfile,internalize_datfile + use keyread_mod,only:keyread +! implicit none +! Include Files for needed dimension parameters + +! Declare OUT Variables +! Data variables + double precision, allocatable :: x(:,:) , y(:,:), wt(:,:) +! Fiting Model Parameters + double precision, allocatable :: p(:) !< vector(npar) for the values of read parameters + integer, allocatable :: p_act(:) !< vector(npar) containing 0 or 1 defining if corresponding parameters are activ in Fit + double precision, allocatable :: p_spread(:) !< vector(npar) for the spread values for each parameter + integer npar !< read length of parameter arrays +! Fit control Parameters + integer seed !< Seed for RNG + integer nset !< number of diffrent parameter sets + logical freeze !< determines if parameters are active + double precision mut, difper !< percentage of selected Parents, number of mutations in parents, minimum diffrence between selected parents + double precision psel !< percantage of selected parents + integer nsel !< number of selected parents , generated from psel and nset by rounding to nearest integer + integer gtype !< type of RNG used + integer maxit, micit ! (datname,infile,linenum,llen,maxlines,dnlen) + dbgdatname='.internal_input' +#ifndef mpi_version + write(6,'(A)') 'Writing internalized version of input to ''' + > // trim(dbgdatname) // '''..' + open(unit=id_internal,file=trim(dbgdatname)) + do j=1,linenum + write(id_internal,'(A)') trim(infile(j)) + enddo + close(id_internal) +#endif + write(fmt,'("Parsing Keys..")') + call write_oneline(fmt,std_out) + + call keyread(keylist,infile,keynum,idat,ddat,cdat,datpos, + > klen,llen,clen,linenum,maxdat) + +!############################################################ +! Read Individual keys for Program Control +!############################################################ + +!************************************************************************ +! DATA: +!************************************************************************ +! This card separates the data to be fitted from the rest of the +! file. +!************************************************************************ + key_id=1 +! Find where in the input file the DATA:-block begins and +! exclude the line of the card itself + dat_start=datIdx(2,key_id) + +!************************************************************************ +! SEED: +!************************************************************************ +! Random seed for the RNG. +!************************************************************************ + key_id=2 + seed=8236475 + + if (is_present(key_id)) then + seed=idat(datIdx(1,key_id)) + else + write(fmt,76) seed + call write_oneline(fmt,std_out) + endif + 76 format('No random seed specified; seed set to',i12) + + if (abs(seed).lt.10**5) then + call signal_val_error(key_id,5,seed) + endif + + write(fmt,'("Random seed set to: ",I12)') seed + call write_oneline(fmt,std_out) + + seed=-iabs(seed) + +!************************************************************************ +! NSET: +!************************************************************************ +! Number of diffrent Parameter sets. +!************************************************************************ + key_id=3 + nset=1 + if (is_present(key_id)) then + nset=idat(datIdx(1,key_id)) + if (nset.le.0) + > call signal_val_error(key_id,5,nset) + else + write(fmt,77) nset + call write_oneline(fmt,std_out) + endif + 77 format('No number of Parametersets specified; nset set to',i9) + + write(fmt,'("Number of Parametersets set to: ",I9)') nset + call write_oneline(fmt,std_out) + +!************************************************************************ +! FREEZE: +!************************************************************************ +! Determines if All parameters are nonactive if present. +!************************************************************************ + key_id=4 + freeze=is_present(key_id) + +!************************************************************************ +! NSTAT: +!************************************************************************ +! Number of Energievalues in y for each Point +!************************************************************************ + key_id=5 + nstat = idat(datIdx(1,key_id)) + + write(fmt,'("Number of Energie values set to: ",I9 )') nstat + call write_oneline(fmt,std_out) + +!************************************************************************ +! NCI: +!************************************************************************ +! Number of CI vectors in y for each Geometry +!************************************************************************ + key_id=6 + nci = 0 + if(is_present(key_id)) then + nci =idat(datIdx(1,key_id)) + endif + write(fmt,'("Number of CI vectors set to: ",I9 )') nci + call write_oneline(fmt,std_out) + +!************************************************************************ +! NDIAB: +!************************************************************************ +! Size of diabatic space = lenght of ci vectors +!************************************************************************ + key_id=7 + ndiab=nstat + if(is_present(key_id)) then + ndiab = idat(datIdx(1,key_id)) + endif + + write(fmt,'("Setting ndiab to:",I9)') ndiab + call write_oneline(fmt,std_out) + +!************************************************************************ + + min_ntot= nstat + (nci*ndiab) + if(min_ntot.gt.max_ntot) then + write(6,*)'ERROR: ntot exceeds set Maximum: ',min_ntot,max_ntot + stop + endif + +!************************************************************************ +! HYBRID: +!************************************************************************ +! If present then CI vectors are used in Fit +!************************************************************************ + key_id=8 + hybrid=is_present(key_id) + if(hybrid.and.(nci.le.0)) then + write(6,*) 'Cant do Hybrid Fit without ci vectors, nci: ',nci + stop ec_log + endif + +!************************************************************************ +! SEL: +!************************************************************************ +! Percentage of selected Parameter sets as Parents +!************************************************************************ + key_id=9 + psel=0.15d0 + + if(is_present(key_id)) then + psel = ddat(datIdx(1,key_id)) + if (psel.gt.1.d0) call signal_dval_error(key_id,7,psel*100) + endif + nsel=max(int(psel*nset),1) + + write(fmt,79) psel*100, nsel + call write_oneline(fmt,std_out) + + 79 format(f5.1,'%(#',i5,')of Parameters will be selected as parents') + +!************************************************************************ +! MUT: +!************************************************************************ +! Percentage of how many mutations happen in parameters +!************************************************************************ + key_id=10 + mut=0.d0 + if(is_present(key_id)) then + mut = ddat(datIdx(1,key_id)) + if (mut.gt.1.d0) call signal_dval_error(key_id,7,mut*100.d0) + endif + + write(fmt,80) mut + call write_oneline(fmt,std_out) + + 80 format('MUTATION set to: ',g9.1) + +!************************************************************************ +! DIFPER: +!************************************************************************ +! minimum Percentage of diffrence between selected parents +!************************************************************************ + key_id=11 + difper=0.05d0 + if(is_present(key_id)) then + difper = ddat(datIdx(1,key_id)) + if (difper.gt.1.d0) then + call signal_dval_error(key_id,7,difper*100.d0) + endif + endif + + write(fmt,81) difper + call write_oneline(fmt,std_out) + + 81 format('DIFPER set to: ',g9.1) + +!************************************************************************ +! GTYPE: +!************************************************************************ +! Type of used RNG +!************************************************************************ + key_id=12 + gtype=2 + if(is_present(key_id)) then + gtype = idat(datIdx(1,key_id)) + endif + + write(fmt,'("GTYPE set to: ",i9)') gtype + call write_oneline(fmt,std_out) + +!************************************************************************ +! MAXIT: +!************************************************************************ +! number of maximum makro Iterations +!************************************************************************ + key_id=13 + maxit=5 + if(is_present(key_id)) then + maxit=idat(datIdx(1,key_id)) + endif + + write(fmt,'("max. number of makro iterations set to: ",i9)') maxit + call write_oneline(fmt,std_out) + +!************************************************************************ +! MICIT: +!************************************************************************ +! number of maximum micro Iterations +!************************************************************************ + key_id=14 + micit=1000 + if(is_present(key_id)) then + micit=idat(datIdx(1,key_id)) + endif + + write(fmt,'("max. number of micro iterations set to: ",i9)') micit + call write_oneline(fmt,std_out) + +!************************************************************************ +! GSPREAD: +!************************************************************************ +! read general Spread for Parameter keys +!************************************************************************ + key_id=15 + gspread=1.d0 + if(is_present(key_id)) then + gspread = ddat(datIdx(1,key_id)) + endif + + write(fmt,'("General Parameterspread set to: ",f5.2)') gspread + call write_oneline(fmt,std_out) + +!************************************************************************ +! SETS: +!************************************************************************ +! Number of seperatly grouped geometries. +! With more than one argument, total sets = sum of all entries. +!************************************************************************ + key_id=16 + sets=-1 + sets=idat(datIdx(1,key_id)) + do j=2,datlen(key_id) + sets=sets+idat(datIdx(j,key_id)) + enddo + + if(sets.eq.0) call signal_val_error(key_id,5,sets,1) + + write(fmt,'("Number of Data Sets set to: ",i9)') sets + call write_oneline(fmt,std_out) + +!************************************************************************ +! INPUTS: +!************************************************************************ +! Dimension of input values. +! INPUTS: D [d] +! If given the optional second argument d, read d call signal_dim_error(key_id,3,datlen(key_id),nstat) + do j=1,nstat + wt_en(j)=ddat(datIdx(j,key_id)) + enddo + endif + +!************************************************************************ +! WTCI: +!************************************************************************ +! parameter used for weighting CI vectors independent +!************************************************************************ + key_id=20 + allocate(wt_ci(nci)) + wt_ci=1.d0 + + if(is_present(key_id)) then + if(datlen(key_id).ne.nstat) + > call signal_dim_error(key_id,3,datlen(key_id),nci) + do j=1,nci + wt_ci(j)=ddat(datIdx(j,key_id)) + enddo + endif + +!************************************************************************ +! RMSTHR: +!************************************************************************ +! Threshhold for RMSE calculation for cutting above the given threshold +! one or nstat real expected for each energie one threshold or one for all +!************************************************************************ + key_id=23 + allocate(rms_thr(nstat)) + rms_thr = 0.d0 + + if(is_present(key_id)) then + if(datlen(key_id).eq.nstat) then + do j=1,nstat + rms_thr(j)=ddat(datIdx(j,key_id)) + enddo +! write(6,'("Setting RMS Threshold for individual States to: ", +! >g12.4)') rms_thr(1:nstat) ! works only for ifort, not for gfortran or mpif90 + + write(fmt2,'("(A,",I2,"g12.4)")') nstat + write(fmt,fmt2) + $ "Set RMS Threshold for individual states to:", + $ rms_thr(1:nstat) + call write_oneline(fmt,std_out) + + else if (datlen(key_id).eq.1) then + rms_thr = ddat(datIdx(1,key_id)) +! write(6,'("Setting RMS Threshold for all States to: ", +! >g12.4)') rms_thr ! works only for ifort, not for gfortran or mpif90 + write(fmt2,'("(A,",I2,"g12.4)")') nstat + write(fmt,fmt2) + $ "Set RMS Threshold for individual states to:", + $ rms_thr(1:nstat) + call write_oneline(fmt,std_out) + + else + call signal_dim_error(key_id,3,datlen(key_id),nstat) + endif + endif + + +!************************************************************************ +! NPOINTS: +!************************************************************************ +! Number of geometries for each set +!************************************************************************ + key_id=21 + allocate(ndata(sets)) + ndata=0 + + if (is_present(key_id)) then + if (datlen(key_id).ne.sets) then + call signal_dim_error(key_id,3,datlen(key_id),sets) + endif + do j=1,sets + ndata(j)=idat(datIdx(j,key_id)) + enddo + numdatpt=sum(ndata(1:sets)) + else + write(*,*)'WARNING: NO NPOINTS CARD GIVEN' + endif + +!************************************************************************ +! NTOT: +!************************************************************************ +! Total number of output values. +!************************************************************************ + key_id=22 + ntot=min_ntot + if (is_present(key_id)) then + ntot=idat(datIdx(1,key_id)) + if(ntot.lt.min_ntot) then + write(6,*)'ERROR: ntot less than set Minimum: ', + > ntot,min_ntot + stop + elseif(ntot.gt.max_ntot) then + write(6,*)'ERROR: ntot exceeds set Maximum: ',ntot,max_ntot + stop + endif + endif + + +!************************************************************************ +! ANAGRAD: +!************************************************************************ +! if present analytical gradients are used for eigenvalues and vectors +!************************************************************************ + key_id=24 + anagrad=is_present(key_id) + if(anagrad) then + write(fmt,'(A)') 'Using Analytical gradients.' + call write_oneline(fmt,std_out) + endif + +!************************************************************************ +! LBFGS: +!************************************************************************ +! if present the LBFGS-B algorithm of Nocedal and Wright is used +! instead of the default Levenberg-Marquard algorithm +!************************************************************************ + key_id=25 + lbfgs=is_present(key_id) + if(lbfgs) then + write(fmt,'(A)') 'Using LBFGS-B algorithm for fit' + call write_oneline(fmt,std_out) + endif + + key_id=26 + lbfgs_corr=10 !Standard value + if (lbfgs) then + if(is_present(key_id)) then + lbfgs_corr=idat(datIdx(1,key_id)) + endif + if(lbfgs_corr.eq.0) + $ call signal_val_error(key_id,5,lbfgs_corr,1) + write(fmt,'("Number of LBFGS corrections set to: ",i9)') + $ lbfgs_corr + call write_oneline(fmt,std_out) + endif + +!************************************************************************ +! FACSPREAD: +!************************************************************************ +! read multiplicative factor for spreads of all parameters +!************************************************************************ + key_id=27 + facspread=1.d0 + if(is_present(key_id)) then + facspread = ddat(datIdx(1,key_id)) + if(facspread.le.0.d0) then + write(6,*) 'ERROR: facspread <= 0' + stop + endif + endif + + write(fmt,'("Multiplicative factor for parameter spread: ",f5.2)') + $ facspread + call write_oneline(fmt,std_out) + +!************************************************************************ +! LOGCONVERGENCE: +!************************************************************************ +! If present logging files for convergence are printed +!************************************************************************ + key_id=28 + log_convergence=is_present(key_id) + +!************************************************************************ +! COORD: +!************************************************************************ +! For each set, specify a coord number N, where +! N=0 (default) computes a walk coordinate on q mapped to [0:1] +! N>0 plot against q(N) +! +!************************************************************************ + key_id=29 + allocate(plot_coord(sets)) + plot_coord=0 + if (is_present(key_id)) then + if (datlen(key_id).ne.sets) then + call signal_dim_error(key_id,3,datlen(key_id),sets) + endif + do j=1,sets + plot_coord(j)=idat(datIdx(j,key_id)) + enddo + fmt='COORD: Scan file(s) will use the following coordinates:' + call write_oneline(fmt,std_out) + fmt='(I3)' + call write_longint(std_out,plot_coord,datlen(key_id), + > fmt,16) + endif + +!************************************************************************ +! PARMETER KEYS: +!************************************************************************ +! read the parameter keys defined in keys.incl +!************************************************************************ + + call parameterkey_read + > (infile,linenum,p,p_act,p_spread,npar,gspread,facspread) + + if (all(p_act.eq.0)) then + write(std_out,'(A)') 'WARNING: No active parameters. ' + > // 'Setting FREEZE:' + freeze=.true. + endif + + +!************************************************************************ +! DATA: +!************************************************************************ +! reading x an y values in the datablock after DATA: card +!************************************************************************ + legacy_wt=.true. !< @TODO consider implementing card for ANN weighting format + call read_data(infile,x,y,wt, + > legacy_wt,dat_start,linenum,ntot,qn, + > qn_read,numdatpt) + + + deallocate(infile) + end subroutine + +!************************************************************************ + subroutine read_data(in,x,y,wt, + > legacy_wt,st,lauf,y_dim,x_dim, + > x_read,ndatapoints) +! Routine reading DATA-block. +! If ndatapoints is nonzero, only the first ndatapoints pattern pairs are read. +! +! in: input file as string vector +! in(n) nth line of input file +! lauf: number of lines in input file +! st: starting position of DATA-block +! +!.....Splitting variables +! ndatapoints: number of given pattern pairs +! nref: number of reference patterns +!.....Data arrays containing the read out and in values +! wterr: weight factors for each element of the error vector e +! x: input patterns +! y: desired output patterns +! x/y(i,N): value of ith in-/output neuron for pattern N +! x_dim: physical dimension of x(:,N) +! x_read: number of read coordinates (rest is 0) +! +! expected format (for one pattern pair): +!.. y1 x1 x2 x3 ... xM +!.. y2 x1 x2 x3 ... xM +!.. .. .. .. .. ... .. +!.. yN x1 x2 x3 ... xM +!.. +!.. WT: w1 w2 ... wN +! +!... wt-legacy mode format: +!.. y1 x1 x2 x3 ... xM +!.. WT: w1 +!.. y2 x1 x2 x3 ... xM +!.. WT: w2 +!.. .. .. .. .. ... .. +!.. yN x1 x2 x3 ... xM +!.. WT: wN +! +! where N=inp_out and M=inp_in + + double precision, allocatable :: x(:,:),y(:,:) + double precision, allocatable :: wt(:,:) +! actual relevant Dimensions + integer ndatapoints,st,lauf,y_dim,x_dim + integer x_read + character(len=llen) in(lauf) + logical legacy_wt + integer pat_count,line + + integer k + +! allocate arrays + allocate(x(x_dim,ndatapoints),y(y_dim,ndatapoints), + > wt(y_dim,ndatapoints)) + + + pat_count=0 + line=st !count lines + + do while (line.le.lauf) + if (in(line)(1:3).eq.'WT:') then + + if (legacy_wt .or. (pat_count.eq.0)) then + write(6,419) 1 + write(6,'(A)') '(preceding WT-block)' + stop ec_read + endif + + read(in(line)(4:llen),*,err=511,end=508) + > wt(1:y_dim,pat_count) + + line=line+1 + + if (pat_count.eq.ndatapoints) exit + + cycle + 508 write(6,419) pat_count + write(6,'(A)') '(broken WT: input)' + stop ec_read + 511 write(6,418) pat_count + write(6,'(A)') 'LINE DUMP:' + write(6,'(A)') trim(in(line)(4:llen)) + stop ec_read + else +! stop reading if desired number of patterns is read + if ((ndatapoints.gt.0).and.(pat_count.eq.ndatapoints)) exit + +! new input set begins + pat_count=pat_count+1 + wt(1:y_dim,pat_count)=1.0D0 + x(:,pat_count)=0.d0 + read(in(line)(1:llen),*,err=513,end=510) y(1,pat_count), + > x(1:x_read,pat_count) + line=line+1 +! wt-legacy-mode: read single weight + if (legacy_wt .and. (in(line)(1:3).eq.'WT:')) then + read(in(line)(4:llen),*,err=515,end=514) + > wt(1:1,pat_count) + line=line+1 + endif + + do k=2,y_dim +! read y(k,pat_count) and copy x-vector for comparison + read(in(line)(1:llen),*,err=512,end=509) + > y(k,pat_count) + + if (line.lt.lauf) then + line=line+1 + if (legacy_wt .and. (in(line)(1:3).eq.'WT:')) then + read(in(line)(4:llen),*,err=515,end=514) + > wt(k:k,pat_count) + line=line+1 + endif + cycle + else if (k.eq.y_dim) then + exit + endif + 509 write(6,419) pat_count + write(6,'(A)') '(reached EOF before completion)' + stop ec_read + 512 write(6,421) pat_count, line + write(6,'(A)') 'LINE DUMP:' + write(6,'(A)') trim(in(line)(1:llen)) + stop ec_read + enddo + + cycle + 510 write(6,419) pat_count + stop ec_read + 513 write(6,421) pat_count, line + write(6,'(A)') 'LINE DUMP:' + write(6,'(A)') trim(in(line)(1:llen)) + stop ec_read + 514 write(6,419) pat_count + write(6,'(A)') '(broken WT: input)' + stop ec_read + 515 write(6,418) pat_count + write(6,'(A)') 'LINE DUMP:' + write(6,'(A)') trim(in(line)(4:llen)) + stop ec_read + endif + enddo +! pat_count is now actual number of patterns + + if (pat_count.le.0) then + write(6,419) 1 + stop ec_read + else if (ndatapoints.ne.pat_count) then + write(6,420) ndatapoints,pat_count + stop ec_read + endif + + +! 417 format('ERROR: CORRUPTED WEIGHT INPUT (SET #',I9,')') + 418 format('ERROR: NUMDATPT EXCEEDING MAX_NUMDATPT(',I9,' vs.',I9,')') + 419 format('ERROR: INCOMPLETE OR MISSING DATA SET. SET #',I9) + 420 format('ERROR: NUMBER OF DATA POINTS INCONSISTENT + > WITH NDATAPOINTS', + > '(',I9,' vs.',I9,')') + 421 format('ERROR: CORRUPTED DATA POINT INPUT (SET #',I9,', LINE,', + > I9,')') + + end subroutine + +!-------------------------------------------------------------------------------- +! Here follow convenience functions defined for this modul only. + + integer function datIdx(j,key_id) +! Locate Jth value of KEY_IDth data block on *dat vector(s). + + integer j,key_id + + datIdx=IdxShift(j,datpos(2,key_id)) + end function + +!-------------------------------------------------------------------------- + + integer function IdxShift(j,start) +! Map linear index of a logical vector which is embedded in a memory +! vector and begins at START. + + integer j,start + + IdxShift=start-1+j + + end function + +!-------------------------------------------------------------------------------- + + logical function is_present(key_id,quiet) + use strings_mod,only:write_oneline + implicit none +! Checks whether optional key has been given in input file. +! If optional argument QUIET is true, do not print a message +! if the key wasn't found. + + integer key_id + logical quiet + optional quiet + + character(len=llen) fmt + integer,parameter :: std_out = 6 + + is_present=(datpos(2,key_id).ne.-1) + + if (present(quiet)) then + if (quiet) then + return + endif + else if (.not.is_present) then + write(fmt,'(A)') 'No '//trim(keylist(1,key_id))//' card found.' + call write_oneline(fmt,std_out) + endif + + end function + +!---------------------------------------------------------------------------------- + integer function datlen(key_id) + implicit none + integer key_id + datlen=datpos(3,key_id) + end function + + end module diff --git a/src/ptr_structure.f b/src/ptr_structure.f new file mode 100644 index 0000000..8bc41ae --- /dev/null +++ b/src/ptr_structure.f @@ -0,0 +1,71 @@ + module ptr_structure + use dim_parameter,only: pst,numdatpt,ndiab,qn + implicit none + public + + type, public :: value_loc_ptr + !number of non-zero-elements + integer :: nnz=0 + !row position of non-zero values + integer, allocatable :: rowPtr(:) + !column position of non-zero values + integer, allocatable :: colPtr(:) + !holds non-zero values + double precision, allocatable :: values(:,:) + end type value_loc_ptr + + contains + + + subroutine init_ptr(ptr,occupation) + + type(value_loc_ptr) :: ptr + logical, intent(in) :: occupation(ndiab,ndiab) + + integer :: i,j,k + integer :: m,n,nnz + + ! Get occupation size for first and second index + m = size(occupation,1) + n = size(occupation,2) + + !Count number of non-zero occupation elements + nnz = count(occupation .eqv. .true.) + ptr%nnz = nnz + + !Allocate data for pointer arrays and value array + allocate(ptr%rowPtr(nnz),ptr%colPtr(nnz),ptr%values(nnz,numdatpt)) + + !Get all non-zero elements of occupation + !Write values on values, write positions on rowPtr and colPtr + k=1 + !Loop over rows + do i=1,m + !Loop over columns + do j=1,n + !Get non-zero elements and write their values on values & write their positions on rowPtr and colPtr + if(occupation(i,j)) then + ptr%rowPtr(k)=i + ptr%colPtr(k)=j + !Increase counter + k=k+1 + endif + enddo + enddo + + end subroutine init_ptr + + subroutine init_values(ptr,matrix,pt) + + type(value_loc_ptr) :: ptr + double precision matrix(ndiab,ndiab) + integer pt + integer l + + do l=1,ptr%nnz + ptr%values(l,pt)=matrix(ptr%rowPtr(l),ptr%colPtr(l)) + enddo + + end subroutine init_values + + end module ptr_structure diff --git a/src/random.f b/src/random.f new file mode 100644 index 0000000..32fdda6 --- /dev/null +++ b/src/random.f @@ -0,0 +1,362 @@ +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c interface for genetic to call random generator + +c seed = initialization seed: large integer +c ierr=6 : output for error [only for Marius Lewerenz random number generator) +c gtype = choose which random number generator is invoked + +c gtype = 1 is the DEFAULT behavior if the GTYPE card is not set within the input file + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + function rn(seed,gtype,cont) + implicit none + + !INPUT + integer seed !seed to initialize random number stream + integer gtype !choose which RNG is used (1="standard" genetic version,2=RANLUX) + integer cont !initialize random number stream (1) or continue with already initialited stream (0) + + !LOCAL VARIABLES ("standard" genetic) + integer ierr,iseed + double precision rand + save ierr + + !LOCAL VARIABLES (RANLUX) + integer lux + integer length + parameter (length=1) + real random_vec(length) + + !OUTPUT VARIABLE + double precision rn + + if (gtype.eq.1) then + write(6,*) 'ERROR: No longer supported.' + stop + elseif(gtype.eq.2) then + + !Initialize RANLUX generator + if (cont.eq.1) then + lux=223 !choice of luxury level; see Documentation of RANLUX + call RLUXGO(lux,abs(seed),0,0) !initialize random number stream + endif + !Get one random number and write it to rn, rn will be returned + call RANLUX(random_vec,length) + rn=dble(random_vec(1)) + + else + + write(6,*) "No random number generator specified for GTYPE=", + $ gtype + + endif + + + end + + +c################################################################################### + +c INTERFACE TO RANLUX + +c################################################################################### + + +c ACPRRANLUX. RANLUX, A FORTRAN IMPLEMENTATION OF THE HIGH-QUALITY ACPR0000 +c PSEUDORANDOM NUMBER GENERATOR OF LUSCHER. F. JAMES. ACPR0000 +c REF. IN COMP. PHYS. COMMUN. 79 (1994) 111 ACPR0000 + SUBROUTINE RANLUX(RVEC,LENV) ACPR0001 +C Subtract-and-borrow random number generator proposed by ACPR0002 +C Marsaglia and Zaman, implemented by F. James with the name ACPR0003 +C RCARRY in 1991, and later improved by Martin Luescher ACPR0004 +C in 1993 to produce "Luxury Pseudorandom Numbers". ACPR0005 +C Fortran 77 coded by F. James, 1993 ACPR0006 +C ACPR0007 +C LUXURY LEVELS. ACPR0008 +C ------ ------ The available luxury levels are: ACPR0009 +C ACPR0010 +C level 0 (p=24): equivalent to the original RCARRY of Marsaglia ACPR0011 +C and Zaman, very long period, but fails many tests. ACPR0012 +C level 1 (p=48): considerable improvement in quality over level 0, ACPR0013 +C now passes the gap test, but still fails spectral test. ACPR0014 +C level 2 (p=97): passes all known tests, but theoretically still ACPR0015 +C defective. ACPR0016 +C level 3 (p=223): DEFAULT VALUE. Any theoretically possible ACPR0017 +C correlations have very small chance of being observed. ACPR0018 +C level 4 (p=389): highest possible luxury, all 24 bits chaotic. ACPR0019 +C ACPR0020 +C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ACPR0021 +C!!! Calling sequences for RANLUX: ++ ACPR0022 +C!!! CALL RANLUX (RVEC, LEN) returns a vector RVEC of LEN ++ ACPR0023 +C!!! 32-bit random floating point numbers between ++ ACPR0024 +C!!! zero (not included) and one (also not incl.). ++ ACPR0025 +C!!! CALL RLUXGO(LUX,INT,K1,K2) initializes the generator from ++ ACPR0026 +C!!! one 32-bit integer INT and sets Luxury Level LUX ++ ACPR0027 +C!!! which is integer between zero and MAXLEV, or if ++ ACPR0028 +C!!! LUX .GT. 24, it sets p=LUX directly. K1 and K2 ++ ACPR0029 +C!!! should be set to zero unless restarting at a break++ ACPR0030 +C!!! point given by output of RLUXAT (see RLUXAT). ++ ACPR0031 +C!!! CALL RLUXAT(LUX,INT,K1,K2) gets the values of four integers++ ACPR0032 +C!!! which can be used to restart the RANLUX generator ++ ACPR0033 +C!!! at the current point by calling RLUXGO. K1 and K2++ ACPR0034 +C!!! specify how many numbers were generated since the ++ ACPR0035 +C!!! initialization with LUX and INT. The restarting ++ ACPR0036 +C!!! skips over K1+K2*E9 numbers, so it can be long.++ ACPR0037 +C!!! A more efficient but less convenient way of restarting is by: ++ ACPR0038 +C!!! CALL RLUXIN(ISVEC) restarts the generator from vector ++ ACPR0039 +C!!! ISVEC of 25 32-bit integers (see RLUXUT) ++ ACPR0040 +C!!! CALL RLUXUT(ISVEC) outputs the current values of the 25 ++ ACPR0041 +C!!! 32-bit integer seeds, to be used for restarting ++ ACPR0042 +C!!! ISVEC must be dimensioned 25 in the calling program ++ ACPR0043 +C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ACPR0044 + DIMENSION RVEC(LENV) ACPR0045 + DIMENSION SEEDS(24), ISEEDS(24), ISDEXT(25) ACPR0046 + PARAMETER (MAXLEV=4, LXDFLT=3) ACPR0047 + DIMENSION NDSKIP(0:MAXLEV) ACPR0048 + DIMENSION NEXT(24) ACPR0049 + PARAMETER (TWOP12=4096., IGIGA=1000000000,JSDFLT=314159265) ACPR0050 + PARAMETER (ITWO24=2**24, ICONS=2147483563) ACPR0051 + SAVE NOTYET, I24, J24, CARRY, SEEDS, TWOM24, TWOM12, LUXLEV ACPR0052 + SAVE NSKIP, NDSKIP, IN24, NEXT, KOUNT, MKOUNT, INSEED ACPR0053 + INTEGER LUXLEV ACPR0054 + LOGICAL NOTYET ACPR0055 + DATA NOTYET, LUXLEV, IN24, KOUNT, MKOUNT /.TRUE., LXDFLT, 0,0,0/ ACPR0056 + DATA I24,J24,CARRY/24,10,0./ ACPR0057 +C default ACPR0058 +C Luxury Level 0 1 2 *3* 4 ACPR0059 + DATA NDSKIP/0, 24, 73, 199, 365 / ACPR0060 +Corresponds to p=24 48 97 223 389 ACPR0061 +C time factor 1 2 3 6 10 on slow workstation ACPR0062 +C 1 1.5 2 3 5 on fast mainframe ACPR0063 +C ACPR0064 +C NOTYET is .TRUE. if no initialization has been performed yet. ACPR0065 +C Default Initialization by Multiplicative Congruential ACPR0066 + IF (NOTYET) THEN ACPR0067 + NOTYET = .FALSE. ACPR0068 + JSEED = JSDFLT ACPR0069 + INSEED = JSEED ACPR0070 + WRITE(6,'(A,I12)') ' RANLUX DEFAULT INITIALIZATION: ',JSEED ACPR0071 + LUXLEV = LXDFLT ACPR0072 + NSKIP = NDSKIP(LUXLEV) ACPR0073 + LP = NSKIP + 24 ACPR0074 + IN24 = 0 ACPR0075 + KOUNT = 0 ACPR0076 + MKOUNT = 0 ACPR0077 + WRITE(6,'(A,I2,A,I4)') ' RANLUX DEFAULT LUXURY LEVEL = ', ACPR0078 + + LUXLEV,' p =',LP ACPR0079 + TWOM24 = 1. ACPR0080 + DO 25 I= 1, 24 ACPR0081 + TWOM24 = TWOM24 * 0.5 ACPR0082 + K = JSEED/53668 ACPR0083 + JSEED = 40014*(JSEED-K*53668) -K*12211 ACPR0084 + IF (JSEED .LT. 0) JSEED = JSEED+ICONS ACPR0085 + ISEEDS(I) = MOD(JSEED,ITWO24) ACPR0086 + 25 CONTINUE ACPR0087 + TWOM12 = TWOM24 * 4096. ACPR0088 + DO 50 I= 1,24 ACPR0089 + SEEDS(I) = REAL(ISEEDS(I))*TWOM24 ACPR0090 + NEXT(I) = I-1 ACPR0091 + 50 CONTINUE ACPR0092 + NEXT(1) = 24 ACPR0093 + I24 = 24 ACPR0094 + J24 = 10 ACPR0095 + CARRY = 0. ACPR0096 + IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24 ACPR0097 + ENDIF ACPR0098 +C ACPR0099 +C The Generator proper: "Subtract-with-borrow", ACPR0100 +C as proposed by Marsaglia and Zaman, ACPR0101 +C Florida State University, March, 1989 ACPR0102 +C ACPR0103 + DO 100 IVEC= 1, LENV ACPR0104 + UNI = SEEDS(J24) - SEEDS(I24) - CARRY ACPR0105 + IF (UNI .LT. 0.) THEN ACPR0106 + UNI = UNI + 1.0 ACPR0107 + CARRY = TWOM24 ACPR0108 + ELSE ACPR0109 + CARRY = 0. ACPR0110 + ENDIF ACPR0111 + SEEDS(I24) = UNI ACPR0112 + I24 = NEXT(I24) ACPR0113 + J24 = NEXT(J24) ACPR0114 + RVEC(IVEC) = UNI ACPR0115 +C small numbers (with less than 12 "significant" bits) are "padded". ACPR0116 + IF (UNI .LT. TWOM12) THEN ACPR0117 + RVEC(IVEC) = RVEC(IVEC) + TWOM24*SEEDS(J24) ACPR0118 +C and zero is forbidden in case someone takes a logarithm ACPR0119 + IF (RVEC(IVEC) .EQ. 0.) RVEC(IVEC) = TWOM24*TWOM24 ACPR0120 + ENDIF ACPR0121 +C Skipping to luxury. As proposed by Martin Luscher. ACPR0122 + IN24 = IN24 + 1 ACPR0123 + IF (IN24 .EQ. 24) THEN ACPR0124 + IN24 = 0 ACPR0125 + KOUNT = KOUNT + NSKIP ACPR0126 + DO 90 ISK= 1, NSKIP ACPR0127 + UNI = SEEDS(J24) - SEEDS(I24) - CARRY ACPR0128 + IF (UNI .LT. 0.) THEN ACPR0129 + UNI = UNI + 1.0 ACPR0130 + CARRY = TWOM24 ACPR0131 + ELSE ACPR0132 + CARRY = 0. ACPR0133 + ENDIF ACPR0134 + SEEDS(I24) = UNI ACPR0135 + I24 = NEXT(I24) ACPR0136 + J24 = NEXT(J24) ACPR0137 + 90 CONTINUE ACPR0138 + ENDIF ACPR0139 + 100 CONTINUE ACPR0140 + KOUNT = KOUNT + LENV ACPR0141 + IF (KOUNT .GE. IGIGA) THEN ACPR0142 + MKOUNT = MKOUNT + 1 ACPR0143 + KOUNT = KOUNT - IGIGA ACPR0144 + ENDIF ACPR0145 + RETURN ACPR0146 +C ACPR0147 +C Entry to input and float integer seeds from previous run ACPR0148 + ENTRY RLUXIN(ISDEXT) ACPR0149 + TWOM24 = 1. ACPR0150 + DO 195 I= 1, 24 ACPR0151 + NEXT(I) = I-1 ACPR0152 + 195 TWOM24 = TWOM24 * 0.5 ACPR0153 + NEXT(1) = 24 ACPR0154 + TWOM12 = TWOM24 * 4096. ACPR0155 + WRITE(6,'(A)') ' FULL INITIALIZATION OF RANLUX WITH 25 INTEGERS:' ACPR0156 + WRITE(6,'(5X,5I12)') ISDEXT ACPR0157 + DO 200 I= 1, 24 ACPR0158 + SEEDS(I) = REAL(ISDEXT(I))*TWOM24 ACPR0159 + 200 CONTINUE ACPR0160 + CARRY = 0. ACPR0161 + IF (ISDEXT(25) .LT. 0) CARRY = TWOM24 ACPR0162 + ISD = IABS(ISDEXT(25)) ACPR0163 + I24 = MOD(ISD,100) ACPR0164 + ISD = ISD/100 ACPR0165 + J24 = MOD(ISD,100) ACPR0166 + ISD = ISD/100 ACPR0167 + IN24 = MOD(ISD,100) ACPR0168 + ISD = ISD/100 ACPR0169 + LUXLEV = ISD ACPR0170 + IF (LUXLEV .LE. MAXLEV) THEN ACPR0171 + NSKIP = NDSKIP(LUXLEV) ACPR0172 + WRITE (6,'(A,I2)') ' RANLUX LUXURY LEVEL SET BY RLUXIN TO: ', ACPR0173 + + LUXLEV ACPR0174 + ELSE IF (LUXLEV .GE. 24) THEN ACPR0175 + NSKIP = LUXLEV - 24 ACPR0176 + WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXIN TO:',LUXLEV ACPR0177 + ELSE ACPR0178 + NSKIP = NDSKIP(MAXLEV) ACPR0179 + WRITE (6,'(A,I5)') ' RANLUX ILLEGAL LUXURY RLUXIN: ',LUXLEV ACPR0180 + LUXLEV = MAXLEV ACPR0181 + ENDIF ACPR0182 + INSEED = -1 ACPR0183 + RETURN ACPR0184 +C ACPR0185 +C Entry to ouput seeds as integers ACPR0186 + ENTRY RLUXUT(ISDEXT) ACPR0187 + DO 300 I= 1, 24 ACPR0188 + ISDEXT(I) = INT(SEEDS(I)*TWOP12*TWOP12) ACPR0189 + 300 CONTINUE ACPR0190 + ISDEXT(25) = I24 + 100*J24 + 10000*IN24 + 1000000*LUXLEV ACPR0191 + IF (CARRY .GT. 0.) ISDEXT(25) = -ISDEXT(25) ACPR0192 + RETURN ACPR0193 +C ACPR0194 +C Entry to output the "convenient" restart point ACPR0195 + ENTRY RLUXAT(LOUT,INOUT,K1,K2) ACPR0196 + LOUT = LUXLEV ACPR0197 + INOUT = INSEED ACPR0198 + K1 = KOUNT ACPR0199 + K2 = MKOUNT ACPR0200 + RETURN ACPR0201 +C ACPR0202 +C Entry to initialize from one or three integers ACPR0203 + ENTRY RLUXGO(LUX,INS,K1,K2) ACPR0204 + IF (LUX .LT. 0) THEN ACPR0205 + LUXLEV = LXDFLT ACPR0206 + ELSE IF (LUX .LE. MAXLEV) THEN ACPR0207 + LUXLEV = LUX ACPR0208 + ELSE IF (LUX .LT. 24 .OR. LUX .GT. 2000) THEN ACPR0209 + LUXLEV = MAXLEV ACPR0210 + WRITE (6,'(A,I7)') ' RANLUX ILLEGAL LUXURY RLUXGO: ',LUX ACPR0211 + ELSE ACPR0212 + LUXLEV = LUX ACPR0213 + DO 310 ILX= 0, MAXLEV ACPR0214 + IF (LUX .EQ. NDSKIP(ILX)+24) LUXLEV = ILX ACPR0215 + 310 CONTINUE ACPR0216 + ENDIF ACPR0217 + IF (LUXLEV .LE. MAXLEV) THEN ACPR0218 + NSKIP = NDSKIP(LUXLEV) ACPR0219 + WRITE(6,'(A,I2,A,I4)') ' RANLUX LUXURY LEVEL SET BY RLUXGO :', ACPR0220 + + LUXLEV,' P=', NSKIP+24 ACPR0221 + ELSE ACPR0222 + NSKIP = LUXLEV - 24 ACPR0223 + WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXGO TO:',LUXLEV ACPR0224 + ENDIF ACPR0225 + IN24 = 0 ACPR0226 + IF (INS .LT. 0) WRITE (6,'(A)') ACPR0227 + + ' Illegal initialization by RLUXGO, negative input seed' ACPR0228 + IF (INS .GT. 0) THEN ACPR0229 + JSEED = INS ACPR0230 + WRITE(6,'(A,3I12)') ' RANLUX INITIALIZED BY RLUXGO FROM SEEDS', ACPR0231 + + JSEED, K1,K2 ACPR0232 + ELSE ACPR0233 + JSEED = JSDFLT ACPR0234 + WRITE(6,'(A)')' RANLUX INITIALIZED BY RLUXGO FROM DEFAULT SEED' ACPR0235 + ENDIF ACPR0236 + INSEED = JSEED ACPR0237 + NOTYET = .FALSE. ACPR0238 + TWOM24 = 1. ACPR0239 + DO 325 I= 1, 24 ACPR0240 + TWOM24 = TWOM24 * 0.5 ACPR0241 + K = JSEED/53668 ACPR0242 + JSEED = 40014*(JSEED-K*53668) -K*12211 ACPR0243 + IF (JSEED .LT. 0) JSEED = JSEED+ICONS ACPR0244 + ISEEDS(I) = MOD(JSEED,ITWO24) ACPR0245 + 325 CONTINUE ACPR0246 + TWOM12 = TWOM24 * 4096. ACPR0247 + DO 350 I= 1,24 ACPR0248 + SEEDS(I) = REAL(ISEEDS(I))*TWOM24 ACPR0249 + NEXT(I) = I-1 ACPR0250 + 350 CONTINUE ACPR0251 + NEXT(1) = 24 ACPR0252 + I24 = 24 ACPR0253 + J24 = 10 ACPR0254 + CARRY = 0. ACPR0255 + IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24 ACPR0256 +C If restarting at a break point, skip K1 + IGIGA*K2 ACPR0257 +C Note that this is the number of numbers delivered to ACPR0258 +C the user PLUS the number skipped (if luxury .GT. 0). ACPR0259 + KOUNT = K1 ACPR0260 + MKOUNT = K2 ACPR0261 + IF (K1+K2 .NE. 0) THEN ACPR0262 + DO 500 IOUTER= 1, K2+1 ACPR0263 + INNER = IGIGA ACPR0264 + IF (IOUTER .EQ. K2+1) INNER = K1 ACPR0265 + DO 450 ISK= 1, INNER ACPR0266 + UNI = SEEDS(J24) - SEEDS(I24) - CARRY ACPR0267 + IF (UNI .LT. 0.) THEN ACPR0268 + UNI = UNI + 1.0 ACPR0269 + CARRY = TWOM24 ACPR0270 + ELSE ACPR0271 + CARRY = 0. ACPR0272 + ENDIF ACPR0273 + SEEDS(I24) = UNI ACPR0274 + I24 = NEXT(I24) ACPR0275 + J24 = NEXT(J24) ACPR0276 + 450 CONTINUE ACPR0277 + 500 CONTINUE ACPR0278 +C Get the right value of IN24 by direct calculation ACPR0279 + IN24 = MOD(KOUNT, NSKIP+24) ACPR0280 + IF (MKOUNT .GT. 0) THEN ACPR0281 + IZIP = MOD(IGIGA, NSKIP+24) ACPR0282 + IZIP2 = MKOUNT*IZIP + IN24 ACPR0283 + IN24 = MOD(IZIP2, NSKIP+24) ACPR0284 + ENDIF ACPR0285 +C Now IN24 had better be between zero and 23 inclusive ACPR0286 + IF (IN24 .GT. 23) THEN ACPR0287 + WRITE (6,'(A/A,3I11,A,I5)') ACPR0288 + + ' Error in RESTARTING with RLUXGO:',' The values', INS, ACPR0289 + + K1, K2, ' cannot occur at luxury level', LUXLEV ACPR0290 + IN24 = 0 ACPR0291 + ENDIF ACPR0292 + ENDIF ACPR0293 + RETURN ACPR0294 + END ACPR0295 diff --git a/src/ranlfg.inc b/src/ranlfg.inc new file mode 100644 index 0000000..60a4aad --- /dev/null +++ b/src/ranlfg.inc @@ -0,0 +1,50 @@ +c---------------------------- ranlfg.inc ------------------------------- +c---+----|----+----|----+----|----+----|----+----|----+----|----+----|-- +c +c parameters for lagged fibonacci generators and common block with +c generator state +c +c----------------------------------------------------------------------- +c +c possible (np,nq) values, (np,np-nq) is also valid: +c (17,5), (250,103), (521,158), (1279,418), +c (2281,715), (4423,1393), (1279,1063) +c ref.: Bhanot et al., phys. rev b 33, 7841 (1986); +c Zierler, inf. control 15, 67 (1961) +c +c mersenne prime primitive trinomials: +c (heringa et al. int.j.mod.phys.c 3, 561 (1992)) +c +c (89,38) +c (127,1), (127,7), (127,15), (127,30), (127,63) +c (521,32), (521,48), (521,158), (521,168) +c (607,105), (607,147), (607, 273) +c (1279,216), (1279,418) +c (2281,715), (2281,915), (2281,1029) +c (3217,67), (3217,576) +c (4423,271), (4423,369), (4423,370), (4423,649), (4424,1393), +c (4423,1419), (4423,2098) +c (9689,84), (9689,471), (9689,1836), (9689,2444), (9689,4187) +c (19937,881), (19937,7083), (19937,9842) +c (23209,1530), (23209,6619), (23209,9739) +c (44497,8575), (44497,21034) +c (110503,25230), (110503,53719) +c (132049,7000), (132049,33912), (132049,41469), (132049,52549), +c (132049,54454) +c +c another pair from brent92 who recommends q=0.618p : (258,175) +c brent's ranu4 uses (132049,79500) +c +c----------------------------------------------------------------------- +c parameter (np=250,nq=103) + integer np,nq + parameter (np=1279,nq=418) +c parameter (np=2281,nq=715) +c parameter (np=274674,nq=67874) + integer init + integer last + double precision x(np) !??? + save /xrandf/ + common /xrandf/ x,last,init +c---+----|----+----|----+----|----+----|----+----|----+----|----+----|-- +c----------------------------- last line -------------------------------