dwilliams
/
genetic
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Initial commit.

This commit is contained in:
David Williams 2024-10-15 11:12:13 +02:00
commit ab55f478ba
28 changed files with 10512 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.gitignore vendored Normal file
View File

@ -0,0 +1,5 @@
/obj/
.#*
/bin/
src/model/
/src/parser/keys.f90

152
Makefile Normal file
View File

@ -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

11
src/accuracy_constants.f Normal file
View File

@ -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

54
src/data_module.f Normal file
View File

@ -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

36
src/dim_parameter.f Normal file
View File

@ -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

500
src/fit_MeX.f Normal file
View File

@ -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

132
src/funcs.f Normal file
View File

@ -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

163
src/genetic.f Normal file
View File

@ -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 !<maximum makro and micro iterations for the genetic program
! -----------------------------
! Fabian
integer iter
double precision rms,old
character(len=80) filename
character(len=80) chkpnt
! -----------------------------
#ifdef mpi_version
call MPI_Init(ierror)
call MPI_Comm_rank(MPI_COMM_WORLD,my_rank,ierror)
call MPI_Comm_size(MPI_COMM_WORLD,threadnum,ierror)
if(threadnum.lt.2) then
write(*,*) 'USING MPI VERSION WITH 1 THREAD: ABORTING'
stop
endif
#endif
! -----------------------------
nsel=0
mut=0.d0
difper=0.d0
call les(q_in,y_in,wt_in,p,p_act,p_spread,npar,
> 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

35
src/idxsrt_mod.f Normal file
View File

@ -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

107
src/init.f Normal file
View File

@ -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

4808
src/lbfgsb.f Normal file
View File

File diff suppressed because it is too large Load Diff

558
src/marq.f Normal file
View File

@ -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

203
src/mpi_fit_MeX.f Normal file
View File

@ -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

32
src/parser/errcat.incl Normal file
View File

@ -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)=

55
src/parser/io_parameters.f Normal file
View File

@ -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 !<maximum number of parameter keys
character(len=klen) :: key(4,maxpar_keys) !<list of parameter keys (1-4: number,value,active?,spread)
integer :: parkeynum !< actual number of parameterkeys specified
integer :: parkeylen !< lenght of longest parameterkey string
!**********************************************************
!**** Error Codes
!*** Codes should be powers of 2. Binary representation of return value
!*** should correspond to all exceptions invoked. ec_error should never
!*** be invoked with any other.
!***
!*** ec_error: generic error (catch-all, avoid!)
!*** ec_read: parsing error during les()
!*** ec_dim: dimensioning error
!*** ec_log: logic error
!***
!**** Inferred error codes
!*** ec_dimrd: ec_dim+ec_read
integer, parameter :: ec_error=1, ec_read=2, ec_dim=4, ec_log=8
integer, parameter :: ec_dimrd=ec_dim+ec_read
end module

301
src/parser/keylist.incl Normal file
View File

@ -0,0 +1,301 @@
**** KEYLIST -- this defines what kind of keys genANN is able to process syntactially
keylist=' '
! The only "special" key in the sense that it terminates input
keylist(1, 1)='DATA:'
keylist(2, 1)='E!'
keylist(1, 2)='SEED:'
keylist(2, 2)='I1'
keylist(1, 3)='NSET:'
keylist(2, 3)='+I1'
keylist(1, 4)='FREEZE:'
keylist(2, 4)='E'
keylist(1, 5)='NSTAT:'
keylist(2, 5)='+I1!'
keylist(1, 6)='NCI:'
keylist(2, 6)='+I1'
keylist(1, 7)='NDIAB:'
keylist(2, 7)='+I1'
keylist(1, 8)='HYBRID:'
keylist(2, 8)='E'
keylist(1, 9)='SEL:'
keylist(2, 9)='+D1'
keylist(1,10)='MUT:'
keylist(2,10)='+D1'
keylist(1,11)='DIFPER:'
keylist(2,11)='+D1'
keylist(1,12)='GTYPE:'
keylist(2,12)='+I1'
keylist(1,13)='MAXIT:'
keylist(2,13)='+I1'
keylist(1,14)='MICIT:'
keylist(2,14)='+I1'
keylist(1,15)='GSPREAD:'
keylist(2,15)='+D1'
keylist(1,16)='SETS:'
keylist(2,16)='+IN!'
keylist(1,17)='INPUTS:'
keylist(2,17)='+IN!'
keylist(1,18)='ENCIRATIO:'
keylist(2,18)='+D1'
keylist(1,19)='WTEN:'
keylist(2,19)='+DN'
keylist(1,20)='WTCI:'
keylist(2,20)='+DN'
keylist(1,21)='NPOINTS:'
keylist(2,21)='+IN!'
keylist(1,22)='NTOT:'
keylist(2,22)='+I1'
keylist(1,23)='RMSTHR:'
keylist(2,23)='+DN'
keylist(1,24)='ANAGRAD:'
keylist(2,24)='E'
keylist(1,25)='LBFGS:'
keylist(2,25)='E'
keylist(1,26)='LBFGSCORR:'
keylist(2,26)='+I1'
keylist(1,27)='FACSPREAD:'
keylist(2,27)='+D1'
keylist(1,28)='LOGCONVERGENCE:'
keylist(2,28)='E'
keylist(1,29)='COORD:'
keylist(2,29)='IN'
! keylist(1,30)=
! keylist(2,30)=
!
! keylist(1,31)=
! keylist(2,31)=
!
! keylist(1,32)=
! keylist(2,32)=
!
! keylist(1,33)=
! keylist(2,33)=
!
! keylist(1,34)=
! keylist(2,34)=
!
! keylist(1,35)=
! keylist(2,35)=
!
! keylist(1,36)=
! keylist(2,36)=
!
! keylist(1,37)=
! keylist(2,37)=
!
! keylist(1,38)=
! keylist(2,38)=
!
! keylist(1,39)=
! keylist(2,39)=
!
! keylist(1,40)=
! keylist(2,40)=
!
! keylist(1,41)=
! keylist(2,41)=
!
! keylist(1,42)=
! keylist(2,42)=
!
! keylist(1,43)=
! keylist(2,43)=
!
! keylist(1,44)=
! keylist(2,44)=
!
! keylist(1,45)=
! keylist(2,45)=
!
! keylist(1,46)=
! keylist(2,46)=
!
! keylist(1,47)=
! keylist(2,47)=
!
! keylist(1,48)=
! keylist(2,48)=
!
! keylist(1,49)=
! keylist(2,49)=
!
! keylist(1,50)=
! keylist(2,50)=
!
! keylist(1,51)=
! keylist(2,51)=
!
! keylist(1,52)=
! keylist(2,52)=
!
! keylist(1,53)=
! keylist(2,53)=
!
! keylist(1,54)=
! keylist(2,54)=
!
! keylist(1,55)=
! keylist(2,55)=
!
! keylist(1,56)=
! keylist(2,56)=
!
! keylist(1,57)=
! keylist(2,57)=
!
! keylist(1,58)=
! keylist(2,58)=
!
! keylist(1,59)=
! keylist(2,59)=
!
! keylist(1,60)=
! keylist(2,60)=
! keylist(1,61)=
! keylist(2,61)=
!
! keylist(1,62)=
! keylist(2,62)=
!
! keylist(1,63)=
! keylist(2,63)=
!
! keylist(1,64)=
! keylist(2,64)=
!
! keylist(1,65)=
! keylist(2,65)=
!
! keylist(1,66)=
! keylist(2,66)=
!
! keylist(1,67)=
! keylist(2,67)=
!
! keylist(1,68)=
! keylist(2,68)=
!
! keylist(1,69)=
! keylist(2,69)=
!
! keylist(1,70)=
! keylist(2,70)=
!
! keylist(1,71)=
! keylist(2,71)=
!
! keylist(1,72)=
! keylist(2,72)=
!
! keylist(1,73)=
! keylist(2,73)=
!
! keylist(1,74)=
! keylist(2,74)=
!
! keylist(1,75)=
! keylist(2,75)=
!
! keylist(1,76)=
! keylist(2,76)=
!
! keylist(1,77)=
! keylist(2,77)=
!
! keylist(1,78)=
! keylist(2,78)=
!
! keylist(1,79)=
! keylist(2,79)=
!
! keylist(1,80)=
! keylist(2,80)=
!
! keylist(1,81)=
! keylist(2,81)=
!
! keylist(1,82)=
! keylist(2,82)=
!
! keylist(1,83)=
! keylist(2,83)=
!
! keylist(1,84)=
! keylist(2,84)=
!
! keylist(1,85)=
! keylist(2,85)=
!
! keylist(1,86)=
! keylist(2,86)=
!
! keylist(1,87)=
! keylist(2,87)=
!
! keylist(1,88)=
! keylist(2,88)=
!
! keylist(1,89)=
! keylist(2,89)=
!
! keylist(1,90)=
! keylist(2,90)=
!
! keylist(1,91)=
! keylist(2,91)=
!
! keylist(1,92)=
! keylist(2,92)=
!
! keylist(1,93)=
! keylist(2,93)=
!
! keylist(1,94)=
! keylist(2,94)=
!
! keylist(1,95)=
! keylist(2,95)=
!
! keylist(1,96)=
! keylist(2,96)=
!
! keylist(1,97)=
! keylist(2,97)=
!
! keylist(1,98)=
! keylist(2,98)=
!
! keylist(1,99)=
! keylist(2,99)=

148
src/parser/lib/fileread.f Normal file
View File

@ -0,0 +1,148 @@
module fileread_mod
contains
!-------------------------------------------------------------------
subroutine get_datfile(datnam,dnlen)
implicit none
! Get name of input data file DATNAM either from the program's first
! command line argument or ask the user.
integer dnlen
character(len=dnlen) datnam
integer argcount
argcount=iargc()
if (argcount.gt.0) then
call getarg(1,datnam)
else
write(6,'(A)') 'Specify input file:'
read(*,*) datnam
endif
if (len_trim(datnam).eq.dnlen) then
write(6,'(A)') 'ERROR: TRUNCATED FILENAME'
write(6,'(A)') '"' // datnam // '"'
endif
end subroutine get_datfile
!-------------------------------------------------------------------
subroutine internalize_datfile(datnam,infile,linenum,llen,
> 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<llen>)',end=20) line !<var> 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

274
src/parser/lib/keyread.f Normal file
View File

@ -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

601
src/parser/lib/long_keyread.f Normal file
View File

@ -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

505
src/parser/lib/strings.f Normal file
View File

@ -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

6
src/parser/lib/typedef.incl Normal file
View File

@ -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

103
src/parser/long_write.f Normal file
View File

@ -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

248
src/parser/parameterkeys.f Normal file
View File

@ -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
! <returns: the parameter arrays p, p_act, p_spread and their length npar
! <needs: internalized file (infile) it's length (linenum), the keylist from keys.incl (key) and the counted number of keys (parkeynum)
subroutine parameterkey_read
> (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
!----------------------------------------------------------------------------------------------------
! <Subroutine returns error message for inconsistent number of Parameters
! <needs: the corresponding key as string (keystr) the number of values read (val) and the expected number (expval)
subroutine signal_parameter_error(keystr,val,expval)
use strings_mod,only:int2string
character(len=klen) :: keystr !< string containing the Card (EXAMPLE:)
integer :: val, expval !< number of read and expected number of Parametervalues
write(6,'(A)')'ERROR: Reading ' // trim(keystr) // ' counted: '
> // trim(int2string(val)) // ' Parameters, but expected: '
> // trim(int2string(expval))
stop ec_read
end subroutine
!----------------------------------------------------------------------------------------------------
! <Subroutine returns error message for inconsistent number of Parameters
! <needs: the corresponding key as string (keystr) the number of values read (val) and the expected number (expval)
subroutine signal_maxparameter_error(val,maxval)
use strings_mod,only:int2string
integer :: val, maxval !< number of read and expected number of Parametervalues
write(6,'(A)')'ERROR: More Parameters then given maximum counted:'
> // trim(int2string(val)) // ' Parameters, but maximum: '
> // trim(int2string(maxval))
stop ec_dim
end subroutine
!----------------------------------------------------------------------------------------------------
! <Subroutine returns error message for inconsistent number of Parameters
! <needs: the corresponding key as string (keystr) the number of values read (val) and the expected number (expval)
subroutine signal_noparameters_error(val)
use strings_mod,only:int2string
integer :: val !< number of read and expected number of Parametervalues
write(6,'(A)')'ERROR: No. of counted parameters is <= 0:'
> // trim(int2string(val))
stop ec_dim
end subroutine
end module

117
src/parser/parse_errors.f Normal file
View File

@ -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

875
src/parser/parser.f Normal file
View File

@ -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 !<maximum makro and micro iterations for the genetic program
! weighting parameters
! Declare INTERNAL variables
character(len=dnlen) :: datname, dbgdatname !< name of the input File
character(len=llen), dimension(:), allocatable :: infile !< internalized array of capitalized input file without comments, blanklines
integer linenum !< linenumber in infile
double precision gspread
! data arrays
integer idat(maxdat)
double precision ddat(maxdat)
character(len=clen) cdat(maxdat)
! minimum ntot (inferred from ndiab etc)
integer min_ntot
! running index
integer j !< running index
! general key variables
integer key_id !< integer identifying a key from keylist.incl
logical legacy_wt
! length or position variables
integer dat_start !< linenumber in infile where DATA: Block starts
! Fabian
character(len=llen) :: fmt,fmt2
integer, parameter :: id_internal = 10 ! hardcoded until queue is ready for modern features
integer, parameter :: std_out = 6
! allocate relevant arrays
allocate(infile(maxlines))
! define Error Messages
include 'errcat.incl'
! include general keylist
include 'keylist.incl'
do j=1,maxkeys
if (keylist(1,j)(1:1).eq.' ') then
keynum=j-1
write(fmt,'("Number of accepted input keys: ",I3)') keynum
call write_oneline(fmt,std_out)
exit
endif
enddo
!############################################################
! Read input file
!############################################################
call get_datfile(datname,dnlen)
call internalize_datfile
> (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<D coordinates off
! the DATA: block.
!************************************************************************
key_id=17
qn=-1
qn=idat(datIdx(1,key_id))
if (datlen(key_id).eq.1) then
qn_read=qn
else if (datlen(key_id).eq.2) then
qn_read=idat(datIdx(2,key_id))
if (qn_read.gt.qn) then
call signal_val_error(key_id,4,qn_read,qn)
else if (qn_read.le.0) then
call signal_val_error(key_id,5,qn_read,1)
endif
else if (datlen(key_id).gt.2) then
call signal_dim_error(key_id,11,datlen(key_id),2)
endif
if(qn.le.0) call signal_val_error(key_id,5,qn,1)
!************************************************************************
! ENCIRATIO
!************************************************************************
! parameter used for weighting ratio between energies and CI vectors
!************************************************************************
key_id=18
if(nci.gt.0) then
wt_en2ci=1./(ndiab+0.d0)
else
wt_en2ci=1.d0
endif
if(is_present(key_id)) then
wt_en2ci=ddat(datIdx(1,key_id))
endif
write(fmt,82) wt_en2ci
call write_oneline(fmt,std_out)
82 format('Setting Ratio between Energie and CI Weights to:',g9.1)
!************************************************************************
! WTEN:
!************************************************************************
! parameter used for weighting states independent
!************************************************************************
key_id=19
allocate(wt_en(nstat))
wt_en=1.d0
if(is_present(key_id)) then
if(datlen(key_id).ne.nstat)
> 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: ",
! ><nstat>g12.4)') rms_thr(1:nstat) !<var> 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: ",
! ><nstat>g12.4)') rms_thr !<var> 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

71
src/ptr_structure.f Normal file
View File

@ -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

362
src/random.f Normal file
View File

@ -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

50
src/ranlfg.inc Normal file
View File

@ -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 -------------------------------