Initial commit.
This commit is contained in:
David Williams
commit
ab55f478ba
|
|
@ -0,0 +1,5 @@
|
||||||
|
/obj/
|
||||||
|
.#*
|
||||||
|
/bin/
|
||||||
|
src/model/
|
||||||
|
/src/parser/keys.f90
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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)=
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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)=
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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 -------------------------------
|
||||||
Loading…
Reference in New Issue