jnshuti
/
Fitting-L-matrix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

First commit for the rep of L-matrix

This commit is contained in:
jean paul nshuti 2025-10-06 12:57:32 +02:00
commit fc9159bc32
48 changed files with 17083 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.gitignore vendored Normal file
View File

@ -0,0 +1,6 @@
# Author: jnshuti
# Created: 2025-10-06 11:46:14
# Last modified: 2025-10-06 12:56:39 jnshuti
./bin/
./obj/

173
Makefile Normal file
View File

@ -0,0 +1,173 @@
SHELL = /bin/bash
.SUFFIXES :
.SUFFIXES : .f .o .f90
src = ./src/
build = ./obj/
bin = ./bin/
######################################################################
version=localdw-1.0
######################################################################
#IFORT VERSION (DEFAULT)
FC = ifort
#MODERN IFORT VERSION (for compiling on laptops)
FFLAGS =-O2 -qopenmp -qmkl -heap-arrays -module $(build) -cpp -g -diag-disable=10448
#-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
#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 -O0 #-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 accuracy_constants.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 Potential_no3_5s_jcp2021_cart_corrected.o surface_mod.o matrix_form.o ctrans.o model.o weight.o adia.o
#model_obj = ptr_structure.o Potential_no3_5s_jcp2021_cart_corrected.o select_monom_mod.o maik_ctrans.o surface_mod.o matrix_form.o model.o weight.o adia.o
model_obj = ptr_structure.o ctrans.o surface_mod.o matrix_form.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) )
#plot_dip_obj = $(addprefix $(build), io_parameters.o accuracy_constants.o dim_parameter.oi model.o)
#Note: Since we are using modules, you have carefully choose the order of compilation and take dependencies between modules and subroutines into account!
######################################################################
# Lib path to pes libray
PATH_PES = $(HOME)/Documents/work/NO3/NO3_PES/NO3_PES_FABIAN/
PES_LIB = $(PATH_PES)libno3_pes_ffabian.a
FFLAGS += -I$(PATH_PES)
LDFLAGS = -L$(PATH_PES) -lno3_pes_ffabian
# define main goal
main = genetic
main1 = plot_dipole
.PHONY: ifort gfortran
ifort: $(main)
# define main compilation
gfortran: override FC = $(GNUFC)
gfortran: override FFLAGS = $(GNUFFLAGS)
gfortran: $(main)
$(main) : dirs $(random_obj) $(objects) $(PES_LIB)
$(FC) $(FFLAGS) $(random_obj) $(objects) $(LDFLAGS) -o $(bin)$(main)
parser.o : io_parameters.o keys.o dim_parameter.o parameterkeys.o parse_errors.o
$(FC) -c $(FFLAGS) $^ -o $@
$(build)%.o : %.f
$(FC) -c $(FFLAGS) $^ -o $@
$(build)%.o : %.f90
$(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 *.o)
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

12
src/accuracy_constants.f Normal file
View File

@ -0,0 +1,12 @@
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 :: idp= int32
integer,parameter :: dp = real64
! integer, parameter :: iacc = int16 !int*2
integer, parameter :: iacc = int32 !int*4
! integer, parameter :: iacc = int64 !int*8
end module

54
src/data_module.f Normal file
View File

@ -0,0 +1,54 @@
module data_module
implicit none
double precision,protected, dimension(:,:), allocatable :: q_m
double precision,protected, dimension(:,:), allocatable :: x1_m
double precision,protected, dimension(:,:), allocatable :: x2_m
double precision,protected, dimension(:,:), allocatable :: y_m
double precision,protected, dimension(:,:), allocatable :: wt_m
double precision,protected, dimension(:,:), allocatable :: ny_m
contains
!------------------------------
subroutine init_data(numdatpt,q,x1,x2,y,wt,ny)
use dim_parameter, only: qn, ntot
implicit none
integer i,numdatpt
double precision q(qn,*)
double precision x1(qn,*)
double precision x2(qn,*)
double precision y(ntot,*)
double precision wt(ntot,*)
double precision ny(ntot,*)
allocate(q_m(qn,numdatpt))
allocate(x1_m(qn,numdatpt))
allocate(x2_m(qn,numdatpt))
allocate(y_m(ntot,numdatpt))
allocate(wt_m(ntot,numdatpt))
allocate(ny_m(ntot,numdatpt))
do i=1,numdatpt
q_m(1:qn,i)=q(1:qn,i)
x1_m(1:qn,i)=x1(1:qn,i)
x2_m(1:qn,i)=x2(1:qn,i)
y_m(1:ntot,i)=y(1:ntot,i)
wt_m(1:ntot,i)=wt(1:ntot,i)
ny_m(1:ntot,i)=ny(1:ntot,i)
enddo
end subroutine
!------------------------------
subroutine dealloc_data()
deallocate(q_m,x1_m,x2_m,y_m,wt_m,ny_m)
end subroutine
end module data_module

36
src/dim_parameter.f Normal file
View File

@ -0,0 +1,36 @@
module dim_parameter
use io_parameters,only: maxpar_keys
implicit none
integer,parameter :: max_ntot = 200 ,max_par = 600
!Standard
integer :: qn,qn_read,ntot,numdatpt
integer :: nstat,ndiab,nci
!Fabian
! integer :: numdatpt
! integer,parameter :: qn=9,ntot=162,nstat=8,ndiab=22,nci=7
integer :: sets
integer, allocatable :: ndata(:)
logical :: hybrid, anagrad,lbfgs
integer :: lbfgs_corr
double precision :: facspread
logical :: log_convergence
! Weight Parameter
double precision :: wt_en2ci
double precision, allocatable :: wt_en(:),wt_ci(:) !< parameters for weightingroutine, nstat or ndiab long
! which coord to use for plotting
integer, allocatable :: plot_coord(:)
! pst vector
integer pst(2,maxpar_keys)
! thresholds for error calculation
double precision ,allocatable :: rms_thr(:)
contains
subroutine dealloc_dim()
deallocate(ndata,wt_ci,wt_en,rms_thr,plot_coord)
end subroutine
end module

500
src/fit_MeX.f Normal file
View File

@ -0,0 +1,500 @@
module fit_mod
implicit none
contains
! > Routine to controll the genetic fitting algorithm
subroutine fit(q,x1,x2,y,frms,difper,wt,par,p_spread,mut,
> npar,p_act,seed,gtype,nset,nsel,chkpnt,old,iter,maxit,
$ micit,ny,filename)
use idxsrt_mod, only: idxsrt
use dim_parameter,only: qn,numdatpt,ntot
use init_mod,only: actinit
use write_mod,only: write_output
#ifdef mpi_version
use mpi
#endif
implicit none
! MPI Variables
#ifdef mpi_version
integer ierror,my_rank,workernum,mpi_control_data(4)
#endif
! Input variables (not changed within this subroutine).
double precision q(qn,numdatpt),x1(qn,numdatpt),x2(qn,numdatpt)!< coordinates/input values
double precision y(ntot,numdatpt),ny(ntot,numdatpt) !< Output/(energie and ci) values
double precision wt(ntot,numdatpt) !< weights
integer npar !< number of parameters
integer nset !< number of parameter sets
integer maxit !< maximum number of macroiterations
integer micit !< maximum number of microiterations (i.e. LM iterations)
!Fabian 15.03.2022: Used for babies or parent generation
integer gtype!< type of random number generator --> is this ever really used??
integer nsel !< number of parents selected for having babies
integer seed !< random seed for babies generation
double precision p_spread(npar)
double precision difper, mut
!Fabian 15.03.2022: Used for checkfile
character(len=80) :: chkpnt
character(len=10) :: writer
integer iter
double precision old !< old rms
!Fabian 15.03.2022: Used for wrout
character(len=80) filename
!Fabian 15.03.2022: Used in parameter initialization
integer p_act(npar) !< array that contains info if a parameter is active or not == equivalent to ma in mrqmin
! Input/output variables (changed/updated within this subroutine)
double precision par(npar,nset) !< parameters
! Output variables
double precision frms !< best rms after macro iteration
! Internal variables
integer i
! logical conver, ldum !< logicals for checking if calculation is converged
logical ldum !< logicals for checking if calculation is converged
integer start
logical enough_parents
integer mfit !< number of active parameters
integer flag !< flag for write routine for fitting status(converged,maxiterationsreach,no convergence)
! Fabian 12.04. These are automatic arrays, maybe make them allocated or static
integer idx(nset) !< array for sorting the parameter sets after their rms
double precision rms(nset) !< array that contains rms of all parameter sets
integer lauf !< counter for macroiteration
double precision newpar(npar,nset) !< temporary storage array before parents&babies
integer iact(npar) !< array pointing to the position of active parameters
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
#ifdef mpi_version
call MPI_Comm_rank(MPI_COMM_WORLD, my_rank, ierror)
#endif
!> Initialize mfit,iact
call actinit(p_act,iact,mfit,npar)
#ifdef mpi_version
call bcastact(p_act,npar)
call MPI_Bcast(mfit, 1, MPI_INT, 0, MPI_COMM_WORLD,ierror)
#endif
!> Initialize rms vector
rms=0.d0
rms(1:nset)=1d10
!> Write number of the present iteration and increase start to iter, if it is a restarted fit
if (iter.ne.1) then
write(6,*) 'Genetic restart, proceed with iteration', iter
endif
start=iter
!> Start the genetic algorithm that consists of maxit macroiterations
do lauf=start,maxit
write(6,*) ''
write(6,'(150("#"))')
write(6,*) ''
write(6,'(''Iteration:'',i5)') lauf
!ATTENTION: THIS SUBROUTINE IS THE PARALLIZED SECTION !!!
!Perform optimization for the parameter sets of generation lauf
call fit_sets(lauf,nset,npar,par,rms,
$ p_act,mfit,micit)
!-------------------------------------------------------------------------
!Sort the rms vector and assign the set number to each rms
call idxsrt(rms,idx,nset)
!write out sorted errors and indicate with which set each error was obtained
do i=1,nset
write(6,'(A8,I3,A8,F12.8,A8,I3)') 'Rank:', i,'RMS:', rms(i),
$ 'Set',idx(i)
enddo
!write best rms onto the output variable frms
frms=rms(1)
!-------------------------------------------------------------------------
!Resort the parameter array sucht that the parameter sets with the lowest rms are listed first
newpar(1:npar,1:nset)=par(1:npar,idx(1:nset))
par(1:npar,1:nset)=newpar(1:npar,1:nset)
!-------------------------------------------------------------------------
!Return if maximum number of macro iterations is reached
if (lauf.ge.maxit) return
!-------------------------------------------------------------------------
!Prepare next iteration of the genetic algorithm
!Select the best parameter sets and sufficiently distinct sets as parents for the next iteration
!Note: After parents, the first nsel entries of par and rms contain the parents
!Note: However, rms is not strictly sorted after this (especially if the best parameter set were too similar)
call parents(par,rms,difper,npar,idx,nset,nsel,p_act,mfit
$ ,enough_parents)
!Check for convergence of genetic algorithm, i.e. whether the generation of new parents leads to
!a decrease of the rms as well as sufficiently distinct parameter set; return if convergence is reached
ldum=conver(old,rms,idx,nsel)
! initialize flag for write routine
flag=1
! set converged flag for write routine
if (ldum) flag=2
! write intermediate output
call write_output(q,x1,x2,y,wt,par,p_act,p_spread,
> nset,npar,flag,lauf)
if (ldum) return
! call flush
! flush(6)
!Check if there are enough parents for next macro iteration
if (enough_parents .eqv. .false.) then
write(6,*) "Warning: Found too few different parents
$ for next macroiteration, exit genetic algorithm"
exit
endif
!Generate new parameter sets and proceed to the next iteration
call babies(par,p_spread,mut,npar,mfit,nset,nsel,iact,
$ seed,gtype)
iter=iter+1
!-------------------------------------------------------------------------
!write checkpoint:
! writer='write'
! call chkfile(chkpnt,par,npar,p_act,seed,gtype,nset,iter,
! & old,writer)
!-------------------------------------------------------------------------
enddo
write(6,*) "Finished fit, return to main program"
end subroutine
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine fit_sets(lauf,nset,npar,par,rms,
$ p_act,mfit,micit)
use dim_parameter,only: lbfgs
use marq_mod,only: mrqmin
use lbfgsb_mod,only: lbfgs_driver
#ifndef mpi_version
use omp_lib
#else
use mpi
integer ierror,my_rank
integer workernum
#endif
! Input variables
integer lauf !number of the current macroiteration
integer nset !number of parameter sets
integer npar !number of parameters
!Input / output variables
double precision par(npar,nset) !< parameters
double precision rms(nset) !< array that contains rms of all parameter sets
! Input variables (necessary solely for mrqmin)
integer p_act(npar) !< array that contains info if a parameter is active or not == equivalent to ma in mrqmin
integer mfit !< number of active parameters
integer micit ! number of microiterations
! Internal variables in parallel section
double precision lrms !< rms for one parameter set
double precision lpar(npar) !array for one parameter set !Fabian 31.03.2022: New test to reduce sice of parameters
integer i,j
! Internal variables for OpenMP
double precision startzeit,endzeit,start_totzeit,end_totzeit
integer thread_num
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!> ATTENTION: THIS IS THE PARALLIZED SECTION !!!
!> Perform non-linear least squares fit for each parameter set:
#ifdef mpi_version
! write(*,*) 'mpi_version'
start_totzeit=MPI_Wtime()
call MPI_Comm_size(MPI_COMM_WORLD, workernum, ierror)
call workshare(workernum, par, rms, npar, nset)
end_totzeit=MPI_Wtime()
#else
start_totzeit=omp_get_wtime()
!$omp parallel do schedule(dynamic)
!$omp& default(shared)
!$omp& private(i,j,lpar,lrms,thread_num,startzeit,endzeit)
do i=lauf,nset
! > Fabian 15.03.2022: Variable for timing the duration of optimizing one parameter set
startzeit=omp_get_wtime() !Fabian
!> Write the parameters and the initial rms for this set onto private variables
lpar(1:npar)=par(1:npar,i)
lrms=rms(i)
!Fabian 05.04.2022: Here I could separate the active and inactive parameters and perform the LM optimization purely with the active params
!Fabian 05.04.2022: However, this would require to store the inactive parameter and the vector that decides if a variable is active onto a module since I need it in funcs then!
!> Levenberg-Marquardt-Optimization of the current parameter set
!Fabian 16.03.2022: This version might be MPI compatible since it contains purely of private variables
!Fabian 16.03.2022: Use this instead of the above, if the data is declared global via a module and pst is only then used when necessary!
if(lbfgs) then
call lbfgs_driver(lpar,npar,p_act,mfit,
& lrms,micit,i)
else
call mrqmin(lpar,npar,p_act,mfit,
& lrms,micit,i)
endif
!> Write the optimized parameters and the optimized rms back onto the arrays that collect all parameters and rms
par(1:npar,i)=lpar(1:npar)
rms(i)=lrms
!> Fabian 15.03.2022: Some output for timing the duration of optimizing one parameter set
thread_num = omp_get_thread_num()
endzeit=omp_get_wtime()
write(6,*) 'Thread', thread_num ,'Time:', endzeit-startzeit
!> Write output for the spezific set of parameters
write(6,99) i, rms(i), rms(i)*219474.69d0
99 format('Set:',i5,5x,'RMS:',g16.6,3x,'(',f16.6,' cm-1)')
enddo
!$omp end parallel do
end_totzeit=omp_get_wtime()
#endif
write(6,*) 'Total time for Macroiteration: '
> ,end_totzeit-start_totzeit
write(6,*) 'Finished parallel fit for Iteration', lauf
end subroutine
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C% SUBROUTINE PARENTS(...)
C%
C% subroutine to select the parent parameter sets according to their
C% RMS error
C%
C % variables:
C % par: parameter vector (double[npar,nset])
C % rms: error for each set (double[nset])
C % difper:
C % npar: number of parameters (int)
C % idx: sorted indeces according to rms(1..nset) (int[nset])
C % nset: number of sets
C % nsel: number of selected parents
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine parents(par,rms,difper,npar,idx,nset,nsel,p_act,mfit
$ ,enough_parents)
implicit none
integer i, j, k, nset, idx(nset), npar, nsel, p_act(npar), mfit
double precision par(npar,nset), dum(npar,nset), rms(nset), last
double precision thr
double precision difper, drms(nset)
integer dum_idx(nset), rank_parent(nsel)
! logical difchk
logical enough_parents
thr=1.d-8
dum=0.d0
dum_idx = 0
rank_parent = 0
drms=0.d0
c write the best parameter set on the dummy
dum(1:npar,1)=par(1:npar,1)
dum_idx(1)=idx(1)
rank_parent(1) = 1
!Choose exactly (beside the best parameter set) nsel-1 parameter sets as new parents and write them on dum
!These parents are selected according to the lowest possible rms AND sufficient dissimilarity
!to the overall best parameter sets
last=1.d14
k=1
do i=1,nset
if (difchk(dum,par(1:npar,i),difper,k,npar,p_act,mfit,nset))
> then
k=k+1
dum(1:npar,k)=par(1:npar,i)
drms(k)=rms(i)
dum_idx(k) = idx(i)
rank_parent(k) = i
endif
if (k.eq.nsel) exit
enddo
!Terminate programm if too few parents are found
enough_parents=.true.
if(k.lt.nsel) then
enough_parents=.false.
endif
!Copy the selected parent parameter sets back to the array par
do i=2,nsel
par(1:npar,i)=dum(1:npar,i)
rms(i)=drms(i)
enddo
!Write out some information on the chosen parent parameter sets
write(6,*) 'nsel:', nsel
write(6,*)
write(6,*) 'Selected parents:'
do j=1,nsel
write(6,201) rank_parent(j), rms(j), dum_idx(j)
write(6,200) (par(k,j), k=1,npar)
enddo
200 format('Par:',6g16.7)
201 format('>>> Rank:',i5,' RMS:' ,g14.4,' set:',i5,' <<<' )
! call flush
! flush(6)
end subroutine
!----------------------------------------------------------------------
! function to check whether new parameter set is sufficiently different
! from already selected sets:
logical function difchk(dum,par,difper,k,npar,p_act,mfit,nset)
implicit none
integer i, j, k, npar, p_act(npar), mfit,nset
double precision dum(npar,nset), par(npar), per, thr, difper
double precision epsilon
parameter(epsilon=1d-8)
!.. this threshold specifies that parameter set must have an average
! difference of at least 1% with respect to any other selected set.
thr=1.d0-difper
if (thr.gt.0.99d0) thr=0.99d0 !avoids no difference
difchk=.true.
do i=1,k
per=0.d0
!Calculate relative difference between between current set (par) and the already selected sets (dum)
do j=1,npar
if (p_act(j).ge.1) then !Added flexible value for p_act; Nicole 15.12.2022; only active parameters are counted
per=per+(min(dum(j,i),par(j))+epsilon)
$ /(max(dum(j,i),par(j))+epsilon)
endif
enddo
per=per/mfit !Modified Version that only active parameters are counted; Fabian 14.12.2021
!Discard the current set if it is too similar to one already selected
if (per.gt.thr) then
difchk=.false.
return
endif
enddo
end function
!--------------------------------------------------------------------
! subroutine to create the baby sets of parameters from the selected
! parent sets
subroutine babies(par,p_spread,mut,npar,mfit,nset,nsel,iact,
$ seed,gtype)
implicit none
c functions
double precision rn !gets one random number
integer i, j, k, npar, nset, nsel, mfit, iact(npar)
double precision par(npar,nset), p_spread(npar), mut, dum
integer seed,gtype
!loop over all dieing sets (only the nsel parent sets survive)
do i=nsel+1,nset
!loop over all active parameters
do j=1,mfit
!picking a random parameter set of the first nsel parent sets !(Fabian 16.03.2022: Add feature, to ensure that at least one baby is generated from each parent?)
k=int(rn(seed,gtype,0)*nsel)+1 !Fabian 08.04.2022: Even though seed isnt passed here, the rn call is dependent on the earlier initialized seed
!writing the j'th parameter of the selected parent set onto the j'th parameter of the i'th of the remaining sets (only the active parameters are copied)
!(Fabian 16.03.2022: This way, I recombinate a number of parents to new babies. However, recombination might not be good, if these parent sets are relatively distinct; maybe use only two parent sets for recombination?)
par(iact(j),i)=par(iact(j),k)
!select whether the j'th parameter of this new set is mutated !(Fabian 16.03.2022: Add feature, to ensure that at least one parameter is mutated?)
if (rn(seed,gtype,0).lt.mut) then
dum=rn(seed,gtype,0) - 0.5d0
dum=dum*p_spread(iact(j))
par(iact(j),i)=par(iact(j),i)*(1.d0+dum)
endif
enddo
enddo
end subroutine
!-----------------------------------------------------------------------
! check convergence of genetic algorithm
function conver(old,rms,idx,nsel)
implicit none
integer i, j, nsel, idx(*), baby
double precision rms(*), new, old, thresh, percent, thrper
logical conver
!Thresholds and initializiation
conver=.false.
thresh=old*1.d-3
thrper=0.2d0
! Lets use all values in the selected subset:
j=nsel
baby=0
! Calculate average error for the nsel best parameter sets
new=0.d0
do i=1,j
new=new+rms(i)
enddo
new=new/dble(j)
! calculate the number of selected parent sets that were originally babies in the previous iteration
do i=1,nsel
if (idx(i).gt.nsel) baby=baby+1
enddo
! calculate the percentage
percent=dble(baby)/dble(nsel)
! some output
write(6,100) baby
write(6,101) new, j
write(6,*)
100 format('Number of babies in chosen subsets:', i3)
101 format('Average RMS error of chosen subsets:', g12.4,
$ ' / averaged values:', i4)
write(6,110) percent*100.d0
write(6,111) old, new, old-new
110 format('Percent babies:',f6.1)
111 format('Old RMS:',d12.4,' New RMS:',d12.4,' Diff:',d12.4)
!Set convergence to true if
!1. too few previous babies are among the new parents
!2. or the average rms of the selected parents between the current & previous macro iteration is sufficiently small
conver=(percent.le.thrper).and.(abs(new-old).lt.thresh)
write(6,*) 'Convergence:', conver
!Set average rms of this iteration to the comparison variable old for the next iteration
old=new
end function
end module fit_mod

132
src/funcs.f Normal file
View File

@ -0,0 +1,132 @@
module funcs_mod
implicit none
logical,parameter:: dbg =.false.
double precision, parameter:: thr_grad_diff = 1.d-3
contains
subroutine funcs(n,p,ymod,dymod,npar,p_act,skip)
! use dim_parameter,only:ntot,ndiab,anagrad
use dim_parameter,only:ntot,ndiab,anagrad,nstat,nci !Fabian
use data_module,only: x1_m
use adia_mod,only: adia
! In variables
integer n, npar, p_act(npar)
double precision ymod(ntot)
double precision p(npar)
logical skip
! out variables
double precision dymod(ntot,npar)
double precision dum_dymod(ntot,npar)
logical diff(ntot,npar)
! internal varibales
double precision ew(ndiab),ev(ndiab,ndiab) ! eigenvalues(ew) and eigenvectors(ev)
integer i,j
logical,parameter:: dbg =.false.
skip=.false.
diff=.false.
! get adiabatic energies:
call adia(n,p,npar,ymod,ew,ev,skip)
if(skip) return
if(eigchk(ew,nci)) then !Fabian: since pseudo-inverse is only calculated for first nci eigenvalues and their ci-vectors, if changed the check to nci
dymod = 0.d0
if(dbg) write(6,*)'funcs skipping point,n: ',n
return
endif
! compute gradient with respect to parameter vector:
if(anagrad) then
write(6,*) 'ERROR: NOT SUPPORTED.'
stop
else
! compute gradients numerically
call num_grad(dymod,n,p,npar,p_act,skip)
endif
end subroutine
!----------------------------------------------------------------------
! compute gradient of adiabatic energies nummerically with respect to parameters:
subroutine num_grad(dymod,n,p,npar,p_act,skip)
use dim_parameter,only: ntot,ndiab
use adia_mod,only: adia
integer n, i, j, npar
integer p_act(npar)
double precision ymod(ntot), dymod(ntot,npar), p(npar)
double precision dp(npar)
logical skip
double precision ew(ndiab),ev(ndiab,ndiab)
! determine finite differences for each parameter:
call pdiff(p,dp,npar)
! generate numerical gradients for all parameters individually
do i=1,npar
do j=1,ntot
dymod(j,i)=0.d0
enddo
! calculate gradient for active parameter, for inactive parameter gradient is always zero
! Nicole: added flexible value of p_act
if (p_act(i).ge.1) then
! change parameter in forward direction
p(i)=p(i)+dp(i)
call adia(n,p,npar,ymod,ew,ev,skip)
if (skip) then
p(i)=p(i)-dp(i)
return
endif
do j=1,ntot
dymod(j,i)=ymod(j)
enddo
! change parameter in backward direction
p(i)=p(i)-2.d0*dp(i)
call adia(n,p,npar,ymod,ew,ev,skip)
if (skip) then
p(i)=p(i)+2.d0*dp(i)
return
endif
do j=1,ntot
dymod(j,i)=(dymod(j,i)-ymod(j))/(2.d0*dp(i)) !Form symmetric difference quotient
enddo
! restore original parameter
p(i)=p(i)+dp(i)
endif
enddo
end subroutine num_grad
!----------------------------------------------------------------------
! determine appropriate finite differences for each parameter:
subroutine pdiff(p,dp,npar)
integer i, npar
double precision p(npar), dp(npar)
! double precision, parameter :: d = 1.d-4
double precision, parameter :: d = 1.d-6 !Standard
! double precision, parameter :: d = 1.d-8
double precision, parameter :: thr = 1.d-12
do i=1,npar
dp(i)=abs(p(i)*d)
if (dp(i).lt.thr) dp(i)=thr
enddo
end subroutine pdiff
!--------------------------------------------------------------------------------------
!.. check vector of eigenvalues for (near) degeneragies
logical function eigchk(v,n)
!.. on input:
integer n
double precision v(n)
!.. local variables:
double precision thr
parameter (thr=1.d-8) !threshold for degeneracy
integer j
eigchk=.false.
do j=1,n-1
if (abs((v(j+1)-v(j))).lt.thr) then
eigchk=.true.
return
endif
enddo
end function eigchk
end module funcs_mod

163
src/genetic.f Normal file
View File

@ -0,0 +1,163 @@
program genetic
! module for dimensioning parameters
use dim_parameter,only: qn,ntot,numdatpt,dealloc_dim
!data module
use data_module, only: init_data, dealloc_data
! parser module
use parser, only: les
! matrix derivatives module
! use matrix_derivatives, only: dealloc_dw_ptr
! monome module
! use monome_module, only: dealloc_vwzprec
! diab3D precalculate module
! use diab3D_precalculate, only: dealloc_diab3D
! parameter initialization module
use init_mod,only: rinit,pinit
! fitting module
use fit_mod,only: fit
! writing module
use write_mod,only: write_output
! MPI module
#ifdef mpi_version
use mpi
#endif
implicit none
! Declare Variables
! MPI variables
#ifdef mpi_version
integer my_rank,ierror,threadnum,stopnum,ping(8),i
#endif
! Data variables
double precision, allocatable :: q_in(:,:),x1_in(:,:),x2_in(:,:)
double precision, allocatable :: y_in(:,:),wt_in(:,:)
! Fiting Model Parameters
double precision, allocatable :: p(:),par(:,:) !< vector(npar) for the values of read parameters
integer, allocatable :: p_act(:) !< vector(npar) containing 0 or 1 defining if corresponding parameters are activ in Fit
double precision, allocatable :: p_spread(:),prange(:,:) !< vector(npar) for the spread values for each parameter
integer npar !< read length of parameter arrays
! Fit control Parameters
integer seed !< Seed for RNG
integer nset !< number of diffrent parameter sets
logical freeze !< determines if parameters are active
double precision mut, difper !< percentage of selected Parents, number of mutations in parents, minimum diffrence between selected parents
integer nsel !< number of selected parameter sets for parents
integer gtype !< type of RNG used
integer maxit, micit !<maximum makro and micro iterations for the genetic program
! -----------------------------
! Fabian
integer iter
double precision rms,old
character(len=80) filename
character(len=80) chkpnt
! -----------------------------
#ifdef mpi_version
call MPI_Init(ierror)
call MPI_Comm_rank(MPI_COMM_WORLD,my_rank,ierror)
call MPI_Comm_size(MPI_COMM_WORLD,threadnum,ierror)
if(threadnum.lt.2) then
write(*,*) 'USING MPI VERSION WITH 1 THREAD: ABORTING'
stop
endif
#endif
! -----------------------------
nsel=0
mut=0.d0
difper=0.d0
call les(q_in,y_in,wt_in,p,p_act,p_spread,npar,
> seed,gtype,nset,maxit,micit,nsel,mut,difper,freeze)
allocate(par(npar,nset),prange(2,npar))
allocate(x1_in(qn,numdatpt),x2_in(qn,numdatpt))
call rinit(p,prange,p_spread,p_act,npar)
par=0.d0
par(1:npar,1)=p(1:npar)
call pinit(par,prange,npar,nset,seed,gtype)
!-------------------------------------------------
call data_transform(q_in,x1_in,x2_in,y_in,wt_in,p,npar,p_act)
!Fabian: Read data into module
call init_data(numdatpt,q_in,x1_in,x2_in,y_in,wt_in,y_in)
!-------------------------------------------------
#ifdef mpi_version
if(my_rank.eq.0) then
#endif
call write_output(q_in,x1_in,x2_in,y_in,wt_in,par,p_act,p_spread,
> nset,npar,0,0)
#ifdef mpi_version
endif
#endif
!-------------------------------------------------
!Fabian: THIS IS THE PLACE WHERE MY ROUTINES START THERE EXECUTION
!Fabian: We should either include these into Maiks routines or remove it from the fitting routines
chkpnt='test'
filename='test2'
old=1.e+5
iter=1
#ifdef mpi_version
if(my_rank.eq.0) then
#endif
if(.not.freeze) then
call fit(q_in,x1_in,x2_in,y_in,rms,difper,wt_in,
$ par,p_spread,mut,npar,p_act,
$ seed,gtype,nset,nsel,chkpnt,old,iter,
$ maxit,micit,y_in,
$ filename)
endif
#ifdef mpi_version
else
call mpi_rest_control(micit,npar)
endif
#endif
#ifdef mpi_version
if(my_rank.eq.0) then
#endif
call write_output(q_in,x1_in,x2_in,y_in,wt_in,par,p_act,p_spread,
> nset,npar,1,iter)
#ifdef mpi_version
endif
#endif
! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Final cleanup of programm (quit MPI, deallocate data, etc.)
#ifdef mpi_version
if(my_rank.eq.0) then
call MPI_Comm_size(MPI_COMM_WORLD,threadnum,ierror)
stopnum = 0
do i = 1,threadnum-1
call MPI_Send(stopnum, 1, MPI_INTEGER,
$ i, 69, MPI_COMM_WORLD, ping, ierror)
enddo
call MPI_Barrier(MPI_COMM_WORLD, ierror)
endif
#endif
deallocate(q_in,x1_in,x2_in,y_in,wt_in,
$ p,par,p_act,p_spread,prange)
call dealloc_data
call dealloc_dim
! call dealloc_dw_ptr
! call dealloc_vwzprec
! call dealloc_diab3D
#ifdef mpi_version
call MPI_Barrier(MPI_COMM_WORLD, ierror)
call MPI_Finalize(ierror)
#endif
end program

35
src/idxsrt_mod.f Normal file
View File

@ -0,0 +1,35 @@
module idxsrt_mod
implicit none
contains
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! % SUBROUTINE IDXSRT(...)
! %
! % indices are sorted by ascending values of x, that means if you go
! % throug x(idx(1..n)) from one to n, you will get an list of growing
! % values
! %
! % variables:
! % idx: indeces which are going to be sorted(int[n])
! % n: number of indices (int)
! % x: array of values (real[n]))
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine idxsrt(x,idx,n)
integer i, j, k, n, idx(n)
double precision x(n), dum
do i=1,n
idx(i)=i
enddo
do i=1,n
do j=i+1,n
if (x(j).lt.x(i)) then
dum=x(i)
x(i)=x(j)
x(j)=dum
k=idx(i)
idx(i)=idx(j)
idx(j)=k
endif
enddo
enddo
end subroutine idxsrt
end module idxsrt_mod

107
src/init.f Normal file
View File

@ -0,0 +1,107 @@
module init_mod
implicit none
contains
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!% SUBROUTINE RINIT
!%
!% Subroutine to define the allowed range for each parameter:
!% for the moment this is a distribution around zero with a given width
!% for each parameter
!%
!% Input variables:
!% par: Parameter vectot (double[])
!% spread: Spread of each parameter (double[])
!% ma: Active cards for every parameter (int[])
!% npar: Number of Parameters
!%
!% Output variables
!% prange: Spread interval vector (double[])
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine rinit(par,prange,p_spread,p_act,npar)
implicit none
integer i,npar,p_act(npar)
double precision par(npar), prange(2,npar), p_spread(npar),de,dum
!minimum absolute spread
double precision minspread
parameter(minspread=1.d-4)
do i=1,npar
if (abs(p_act(i)).eq.0) p_spread(i)=0.d0
dum=par(i)
if (abs(dum).lt.1.d-6) dum=minspread
de=abs(dum*p_spread(i)/2.d0)
prange(1,i)=par(i)-de
prange(2,i)=par(i)+de
enddo
end subroutine
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!% SUBROUTINE PINIT(...)
!%
!% subroutine to initialize the nset parameter sets with random
!% numbers in the range defined by prange
!%
!% Input Variables:
!% par: parameter vector (double[])
!% prange: Spread interval vector (double[])
!% npar: number of parameters (int)
!% nset: number of sets (int)
!% seed: seed for random.f (int)
!% gtype: selects random number generator (int)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine pinit(par,prange,npar,nset,seed,gtype)
implicit none
integer i, j, npar, nset, seed, gtype,cont
double precision par(npar,nset), prange(2,npar), rn, dum
!.. initialize new random number stream:
cont=1
dum=rn(seed,gtype,cont)
!.. create all the parameter sets by random numbers
!continue with the initialized random number stream
cont=0
do i=2,nset
do j=1,npar
par(j,i)=prange(1,j)+rn(seed,gtype,cont) *
$ (prange(2,j)-prange(1,j))
enddo
enddo
end subroutine
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!% SUBROUTINE ACTINIT(...)
!%
!% subroutine to select the active parameters and assign their indices
!%
!% Input Variables:
!% p_act: vector of active cards
!% npar: total number of parameters
!%
!% Output Variables:
!% iact: list of active parameters
!% mfit: number of active parameters
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine actinit(p_act,iact,mfit,npar)
implicit none
integer i, npar, p_act(npar), iact(npar), mfit
mfit=0
iact=0
do i=1,npar
! Nicole: added flexible value of p_act
if (p_act(i).ge.1) then
mfit=mfit+1
iact(mfit)=i
endif
enddo
end subroutine
end module init_mod

4808
src/lbfgsb.f Normal file
View File

File diff suppressed because it is too large Load Diff

563
src/marq.f Normal file
View File

@ -0,0 +1,563 @@
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 ! commented out by JP on 08.10.2025
! In fitting dipole nstat is meaningless, I always go with ntot
! and send to zero the unused parts of y_m and ymod
do i=1,numdatpt
call funcs(i,par,ymod,dyda,npar,ma,skip)
write(58,*) "ymod ",i,nloop,ymod(1:ntot)
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)
!write(58,*) "dy ",n,i,ymod(n),y_m(n,i),dy(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
src/model/.giosaveVT1ebr Normal file
View File

38
src/model/JTmod.incl Normal file
View File

@ -0,0 +1,38 @@
!*** Relevant parameters for the analytic model
!*** offsets:
!*** offsets(1): morse equilibrium (N-H, Angström)
!*** offsets(2): reference angle (H-N-H)
!*** offsets(3): --
!*** pat_index: vector giving the position of the
!*** various coordinates (see below)
!*** ppars: polynomial parameters for tmcs
!*** vcfs: coefficients for V expressions.
!*** wzcfs: coefficients for W & Z expressions.
!*** ifc: inverse factorials.
integer matdim
parameter (matdim=5) ! matrix is (matdim)x(matdim)
real*8 offsets(2)
integer pat_index(maxnin)
! NH3 params
parameter (offsets=[2.344419d0,120.d0])
!##########################################################################
! coordinate order; the first #I number of coords are given to the
! ANN, where #I is the number of input neurons. The position i in
! pat_index corresponds to a coordinate, the value of pat_index(i)
! signifies its position.
!
! The vector is ordered as follows:
! a,xs,ys,xb,yb,b,rs**2,rb**2,b**2,
! es*eb, es**3, eb**3,es**2*eb, es*eb**2
! ri**2 := xi**2+yi**2 = ei**2; ei := (xi,yi), i = s,b
!
! parts not supposed to be read by ANN are marked by ';' for your
! convenience.
!##########################################################################
! a,rs**2,rb**2,es*eb,es**3,eb**3,es**2*eb,es*eb**2,b**2 #I=9 (6D)
parameter (pat_index=[1,2,3,4,5,6,7,8,9,10,11,12,13,14])
!**************************************************************************

673
src/model/Maik_chngs/maik_ctrans.f90 Normal file
View File

@ -0,0 +1,673 @@
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! % SUBROUTINE CTRANS(...)
! %
! % M. Vossel 21.03.2023
! %
! % Routine to transform symmetryinput coordinates to symmetrized
! % coordinates. Distances Are discribet by Morse coordinates or
! % TMC depending on Set Parameters in the Genetic Input.
! %
! % input variables
! % q:
! % q(1): H1x
! % q(2): y
! % q(3): z
! % q(4): H2x
! % q(5): y
! % q(6): z
! % q(7): H3x
! % q(8): y
! % q(9): z
!
!
!
! % Internal variables:
! % t: primitive coordinates (double[qn])
! % t(1):
! % t(2):
! % t(3):
! % t(4):
! % t(5):
! % t(6):
! % t(7):
! % t(8):
! % t(9):
! % t: dummy (double[qn])
! % p: parameter vector
! % npar: length of parameter vector
! %
! % Output variables
! % s: symmetrized coordinates (double[qn])
! % s(1): CH-symetric streatch
! % s(2): CH-asymetric streatch-ex
! % s(3): CH-asymetric streatch-ey
! % s(4): CH-bend-ex
! % s(5): CH-bend-ey
! % s(6): CH-umbrella
! % s(7): CH-umbrella**2
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
module ctrans_mod
use accuracy_constants, only: dp, idp
implicit none
! precalculate pi, 2*pi and angle to radian conversion
real(dp), parameter :: pi = 4.0_dp*datan(1.0_dp)
real(dp), parameter :: pi2 = 2.0_dp*pi
real(dp), parameter :: ang2rad = pi/180.0_dp
! precalculate roots
real(dp), parameter:: sq2 = 1.0_dp/dsqrt(2.0_dp)
real(dp), parameter:: sq3 = 1.0_dp/dsqrt(3.0_dp)
real(dp), parameter:: sq6 = 1.0_dp/dsqrt(6.0_dp)
! change distances for equilibrium
!real(dp), parameter :: dchequi = 1.02289024_dp
real(dp), parameter :: dchequi = 2.344419_dp ! NO3
!real(dp), parameter :: dchequi = 2.34451900_dp
! see changes
contains
subroutine ctrans(q, x1,x2, invariants)
use dim_parameter, only: qn
integer(idp) k !running indices
real(dp), intent(in) :: q(qn) !given coordinates
real(dp), intent(out) :: x1(qn) !output coordinates symmetry adapted and scaled
real(dp), intent(out) :: x2(qn) !output coordinates symmetry adapted but not scaled
! ANN Variables
real(dp), optional, intent(out) :: invariants(:)
real(dp) :: s(qn),t(qn)
! kartesian coordianates copy from MeF+ so substitute c by n and removed f
real(dp) ch1(3), ch2(3), ch3(3), c_atom(3)
real(dp) nh1(3), nh2(3), nh3(3)
real(dp) zaxis(3), xaxis(3), yaxis(3)
real(dp) ph1(3), ph2(3), ph3(3)
! primitive coordinates
real(dp) dch1, dch2, dch3 !nh-distances
real(dp) umb !Umbrella Angle from xy-plane
! Symmetry coordinates
real(dp) aR !a1-modes H-Dist.,
real(dp) exR, exAng !ex components H-Dist., H-Ang.
real(dp) eyR, eyAng !ey components H-Dist., H-Ang.
! debugging
logical, parameter :: dbg = .false.
! initialize coordinate vectors
s = 0.0_dp
t = 0.0_dp
! write kartesian coords for readability
c_atom(1:3) = q(1:3)
do k = 1, 3
ch1(k) = q(k + 3)
ch2(k) = q(k + 6)
ch3(k) = q(k + 9)
end do
! construct z-axis
nh1 = normalized(ch1)
nh2 = normalized(ch2)
nh3 = normalized(ch3)
zaxis = create_plane(nh1, nh2, nh3)
! calculate bonding distance
dch1 = norm(ch1)
dch2 = norm(ch2)
dch3 = norm(ch3)
! construct symmertic and antisymmetric strech
aR = symmetrize(dch1 - dchequi, dch2 - dchequi, dch3 - dchequi, 'a')
exR = symmetrize(dch1, dch2, dch3, 'x')
eyR = symmetrize(dch1, dch2, dch3, 'y')
! construc x-axis and y axis
ph1 = normalized(project_point_into_plane(nh1, zaxis, c_atom))
xaxis = normalized(ph1)
yaxis = xproduct(zaxis, xaxis) ! right hand side koordinates
! project H atoms into C plane
ph2 = normalized(project_point_into_plane(nh2, zaxis, c_atom))
ph3 = normalized(project_point_into_plane(nh3, zaxis, c_atom))
call construct_HBend(exAng, eyAng, ph1, ph2, ph3, xaxis, yaxis)
umb = construct_umbrella(nh1, nh2, nh3, zaxis)
! set symmetry coordinates and even powers of umbrella
!s(1) = dch1- dchequi !aR
!s(2) = dch2 - dchequi !exR
!s(3) = dch3 - dchequi !eyR
s(1) = aR
s(2) = exR
s(3) = eyR
s(4) = exAng
s(5) = eyAng
s(6) = umb
s(7) = umb**2
s(8) = 0
s(9) = 0
! pairwise distances as second coordinate set
t = 0._dp
call pair_distance(q, t(1:6))
if (dbg) write (6, '("sym coords s=",9f16.8)') s(1:qn)
if (dbg) write (6, '("sym coords t=",9f16.8)') t(1:qn)
if (present(invariants)) then
call get_invariants(s, invariants)
end if
! transform s and t to x1 and x2
x1(1:qn)=s(1:qn)
x1(5)=x1(5)
! set other x coordinate to zero other than strech
!X1(4:qn)=0.0d0
x2(1:qn)=t(1:qn)
end subroutine ctrans
subroutine pair_distance(q, r)
real(dp), intent(in) :: q(9)
real(dp), intent(out) :: r(6)
real(dp) :: atom(3, 4)
integer :: n, k, count
!atom order: H1 H2 H3 N
atom(:, 1:3) = reshape(q, [3, 3])
atom(:, 4) = (/0.0_dp, 0.0_dp, 0.0_dp/)
! disntace order 12 13 14 23 24 34
count = 0
do n = 1, size(atom, 2)
do k = n + 1, size(atom, 2)
count = count + 1
r(count) = sqrt(sum((atom(:, k) - atom(:, n))**2))
end do
end do
end subroutine pair_distance
function morse_and_symmetrize(x,p,pst) result(s)
real(dp), intent(in),dimension(3) :: x
real(dp), intent(in),dimension(11) :: p
integer, intent(in),dimension(2) :: pst
integer :: k
real(dp), dimension(3) :: s
real(dp), dimension(3) :: t
! Morse transform
do k=1,3
t(k) = morse_transform(x(k), p, pst)
end do
s(1) = symmetrize(t(1), t(2), t(3), 'a')
s(2) = symmetrize(t(1), t(2), t(3), 'x')
s(3) = symmetrize(t(1), t(2), t(3), 'y')
end function morse_and_symmetrize
subroutine get_invariants(s, inv_out)
use dim_parameter, only: qn
use select_monom_mod, only: v_e_monom, v_ee_monom
real(dp), intent(in) :: s(qn)
real(dp), intent(out) :: inv_out(:)
! real(dp), parameter :: ck = 1.0_dp, dk = 1.0_dp/ck ! scaling for higher order invariants
real(dp) inv(24)
integer, parameter :: inv_order(12) = & ! the order in which the invariants are selected
& [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12]
real(dp) Rch, umb, xR, yR, xAng, yAng
! for readability
Rch = s(1)
xR = s(2)
yR = s(3)
xAng = s(4)
yAng = s(5)
umb = s(6)**2
! invarianten
! a moden
inv(1) = Rch
inv(2) = umb
! invariante e pairs
inv(3) = v_e_monom(xR, yR, 1)
inv(4) = v_e_monom(xAng, yAng, 1)
! third order e pairs
inv(5) = v_e_monom(xR, yR, 2)
inv(6) = v_e_monom(xAng, yAng, 2)
! invariant ee coupling
inv(7) = v_ee_monom(xR, yR, xAng, yAng, 1)
! mode combinations
inv(8) = Rch*umb
inv(9) = Rch*v_e_monom(xR, yR, 1)
inv(10) = umb*v_e_monom(xR, yR, 1)
inv(11) = Rch*v_e_monom(xAng, yAng, 1)
inv(12) = umb*v_e_monom(xAng, yAng, 1)
! damp coordinates because of second order and higher invariants
inv(3) = sign(sqrt(abs(inv(3))), inv(3))
inv(4) = sign(sqrt(abs(inv(4))), inv(4))
inv(5) = sign((abs(inv(5))**(1./3.)), inv(5))
inv(6) = sign((abs(inv(6))**(1./3.)), inv(6))
inv(7) = sign((abs(inv(7))**(1./3.)), inv(7))
inv(8) = sign(sqrt(abs(inv(8))), inv(8))
inv(9) = sign((abs(inv(9))**(1./3.)), inv(9))
inv(10) = sign((abs(inv(10))**(1./3.)), inv(10))
inv(11) = sign((abs(inv(11))**(1./3.)), inv(11))
inv(12) = sign((abs(inv(12))**(1./3.)), inv(12))
inv_out(:) = inv(inv_order(1:size(inv_out, 1)))
end subroutine get_invariants
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! % real part of spherical harmonics
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Ylm shifted to 0 for theta=0
real(dp) function ylm(theta, phi, l, m)
implicit none
real(dp) theta, phi
integer(idp) l, m
ylm = plm2(dcos(theta), l, m)*cos(m*phi) - plm2(1.0_dp, l, m)
end function ylm
!----------------------------------------------------------
real(dp) function plm2(x, l, n)
implicit none
real(dp) x
integer(idp) l, m, n
real(dp) pmm, p_mp1m, pllm
integer(idp) ll
! negative m und bereich von x abfangen
if ((l .lt. 0)&
&.or. (abs(n) .gt. abs(l))&
&.or. (abs(x) .gt. 1.)) then
write (6, '(''bad arguments in legendre'')')
stop
end if
! fix sign of m to compute the positiv m
m = abs(n)
pmm = (-1)**m*dsqrt(fac(2*m))*1./((2**m)*fac(m))& !compute P(m,m) not P(l,l)
&*(dsqrt(1.-x**2))**m
if (l .eq. m) then
plm2 = pmm !P(l,m)=P(m,m)
else
p_mp1m = x*dsqrt(dble(2*m + 1))*pmm !compute P(m+1,m)
if (l .eq. m + 1) then
plm2 = p_mp1m !P(l,m)=P(m+1,m)
else
do ll = m + 2, l
pllm = x*(2*l - 1)/dsqrt(dble(l**2 - m**2))*p_mp1m& ! compute P(m+2,m) up to P(l,m) recursively
&- dsqrt(dble((l - 1)**2 - m**2))&
&/dsqrt(dble(l**2 - m**2))*pmm
! schreibe m+2 und m+1 jeweils fuer die naechste iteration
pmm = p_mp1m !P(m,m) = P(m+1,m)
p_mp1m = pllm !P(m+1,m) = P(m+2,m)
end do
plm2 = pllm !P(l,m)=P(m+k,m), k element N
end if
end if
! sets the phase of -m term right (ignored to gurantee Ylm=(Yl-m)* for JT terms
! if(n.lt.0) then
! plm2 = (-1)**m * plm2 !* fac(l-m)/fac(l+m)
! endif
end function
!----------------------------------------------------------------------------------------------------
real(dp) function fac(i)
integer(idp) i
select case (i)
case (0)
fac = 1.0_dp
case (1)
fac = 1.0_dp
case (2)
fac = 2.0_dp
case (3)
fac = 6.0_dp
case (4)
fac = 24.0_dp
case (5)
fac = 120.0_dp
case (6)
fac = 720.0_dp
case (7)
fac = 5040.0_dp
case (8)
fac = 40320.0_dp
case (9)
fac = 362880.0_dp
case (10)
fac = 3628800.0_dp
case (11)
fac = 39916800.0_dp
case (12)
fac = 479001600.0_dp
case default
write (*, *) 'ERROR: no case for given faculty, Max is 12!'
stop
end select
end function fac
! Does the simplest morse transform possible
! one skaling factor + shift
function morse_transform(x, p, pst) result(t)
real(dp), intent(in) :: x
real(dp), intent(in) :: p(11)
integer, intent(in) :: pst(2)
real(dp) :: t
if (pst(2) == 11) then
t = 1.0_dp - exp(-abs(p(2))*(x - p(1)))
else
error stop 'in morse_transform key required or wrong number of parameters'
end if
end function morse_transform
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! % FUNCTION F(...) ! MAIK DEPRICATING OVER THE TOP MORSE FUNCTION FOR MYSELF
! %
! % Returns exponent of tunable Morse coordinate
! % exponent is polynomial * gaussian (skewed)
! % ilabel = 1 or 2 selects the parameters a and sfac to be used
! %
! % Background: better representation of the prefector in the
! % exponend of the morse function.
! % Formular: f(r) = lest no3 paper
! %
! % Variables:
! % x: distance of atoms (double)
! % p: parameter vector (double[20])
! % ii: 1 for CCl and 2 for CCH (int)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
pure function f(x, p, ii)
integer(idp), intent(in) :: ii !1 for CCL and 2 for CCH
real(dp), intent(in) :: x !coordinate
real(dp), intent(in) :: p(11) !parameter-vector
integer(idp) i !running index
real(dp) r !equilibrium distance
real(dp) gaus !gaus part of f
real(dp) poly !polynom part of f
real(dp) skew !tanh part of f
real(dp) f !prefactor of exponent and returned value
integer(idp) npoly(2) !order of polynom
! Maximum polynom order
npoly(1) = 5
npoly(2) = 5
! p(1): position of equilibrium
! p(2): constant of exponent
! p(3): constant for skewing the gaussian
! p(4): tuning for skewing the gaussian
! p(5): Gaussian exponent
! p(6): Shift of Gaussian maximum
! p(7)...: polynomial coefficients
! p(8+n)...: coefficients of Morse Power series
! 1-exp{[p(2)+exp{-p(5)[x-p(6)]^2}[Taylor{p(7+n)}(x-p(6))]][x-p(1)]}
! Tunable Morse function
! Power series in Tunable Morse coordinates of order m
! exponent is polynomial of order npoly * gaussian + switching function
! set r r-r_e
r = x
r = r - p(1)
! set up skewing function:
skew = 0.5_dp*p(3)*(dtanh(dabs(p(4))*(r - p(6))) + 1.0_dp)
! set up gaussian function:
gaus = dexp(-dabs(p(5))*(r - p(6))**2)
! set up power series:
poly = 0.0_dp
do i = 0, npoly(ii) - 1
poly = poly + p(7 + i)*(r - p(6))**i
end do
! set up full exponent function:
f = dabs(p(2)) + skew + gaus*poly
end function
!----------------------------------------------------------------------------------------------------
pure function xproduct(a, b) result(axb)
real(dp), intent(in) :: a(3), b(3)
real(dp) :: axb(3) !crossproduct a x b
axb(1) = a(2)*b(3) - a(3)*b(2)
axb(2) = a(3)*b(1) - a(1)*b(3)
axb(3) = a(1)*b(2) - a(2)*b(1)
end function xproduct
pure function normalized(v) result(r)
real(dp), intent(in) :: v(:)
real(dp) :: r(size(v))
r = v/norm(v)
end function normalized
pure function norm(v) result(n)
real(dp), intent(in) :: v(:)
real(dp) n
n = dsqrt(sum(v(:)**2))
end function norm
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! % FUNCTION Project_Point_Into_Plane(x,n,r0) result(p)
! % return the to n orthogonal part of a vector x-r0
! % p: projected point in plane
! % x: point being projected
! % n: normalvector of plane
! % r0: Point in plane
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
pure function project_point_into_plane(x, n, r0) result(p)
real(dp), intent(in) :: x(:), n(:), r0(:)
real(dp) :: p(size(x)), xs(size(x))
xs = x - r0
p = xs - plane_to_point(x, n, r0)
end function project_point_into_plane
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! % Function Plane_To_Point(x,n,r0) result(p)
! % p: part of n in x
! % x: point being projected
! % n: normalvector of plane
! % r0: Point in plane
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
pure function plane_to_point(x, n, r0) result(p)
real(dp), intent(in) :: x(:), n(:), r0(:)
real(dp) p(size(x)), xs(size(x)), nn(size(n))
nn = normalized(n)
xs = x - r0
p = dot_product(nn, xs)*nn
end function plane_to_point
subroutine check_coordinates(q)
! check for faulty kartesain coordinates
real(dp), intent(in) :: q(:)
integer(idp) :: i
if (all(abs(q) <= epsilon(0.0_dp))) then
stop 'Error (ctrans): all kartesian coordinates are<=1d-8'
end if
do i = 1, 9, 3
if (all(abs(q(i:i + 2)) <= epsilon(0.0_dp))) then
write (*, *) q
stop 'Error(ctrans):kartesian coordinates zero for one atom'
end if
end do
end subroutine
pure function rotor_a_to_z(a, z) result(r)
real(dp), intent(in) :: a(3), z(3)
real(dp) :: r(3, 3)
real(dp) :: alpha
real(dp) :: s1(3), s(3, 3), rotor(3, 3)
s1 = xproduct(normalized(a), normalized(z))
alpha = asin(norm(s1))
s(:, 1) = normalized(s1)
s(:, 2) = normalized(z)
s(:, 3) = xproduct(s1, z)
rotor = init_rotor(alpha, 0.0_dp, 0.0_dp)
r = matmul(s, matmul(rotor, transpose(s)))
end function
! function returning Rz(gamma) * Ry(beta) * Rx(alpha) for basis order xyz
pure function init_rotor(alpha, beta, gamma) result(rotor)
real(dp), intent(in) :: alpha, beta, gamma
real(dp) :: rotor(3, 3)
rotor = 0.0_dp
rotor(1, 1) = dcos(beta)*dcos(gamma)
rotor(1, 2) = dsin(alpha)*dsin(beta)*dcos(gamma)&
&- dcos(alpha)*dsin(gamma)
rotor(1, 3) = dcos(alpha)*dsin(beta)*dcos(gamma)&
&+ dsin(alpha)*dsin(gamma)
rotor(2, 1) = dcos(beta)*dsin(gamma)
rotor(2, 2) = dsin(alpha)*dsin(beta)*dsin(gamma)&
&+ dcos(alpha)*dcos(gamma)
rotor(2, 3) = dcos(alpha)*dsin(beta)*dsin(gamma)&
&- dsin(alpha)*dcos(gamma)
rotor(3, 1) = -dsin(beta)
rotor(3, 2) = dsin(alpha)*dcos(beta)
rotor(3, 3) = dcos(alpha)*dcos(beta)
end function init_rotor
pure function create_plane(a, b, c) result(n)
real(dp), intent(in) :: a(3), b(3), c(3)
real(dp) :: n(3)
real(dp) :: axb(3), bxc(3), cxa(3)
axb = xproduct(a, b)
bxc = xproduct(b, c)
cxa = xproduct(c, a)
n = normalized(axb + bxc + cxa)
end function create_plane
function symmetrize(q1, q2, q3, sym) result(s)
real(dp), intent(in) :: q1, q2, q3
character, intent(in) :: sym
real(dp) :: s
select case (sym)
case ('a')
s = (q1 + q2 + q3)*sq3
case ('x')
s = sq6*(2.0_dp*q1 - q2 - q3)
case ('y')
s = sq2*(q2 - q3)
case default
write (*, *) 'ERROR: no rule for symmetrize with sym=', sym
stop
end select
end function symmetrize
subroutine construct_HBend(ex, ey, ph1, ph2, ph3, x_axis, y_axis)
real(dp), intent(in) :: ph1(3), ph2(3), ph3(3)
real(dp), intent(in) :: x_axis(3), y_axis(3)
real(dp), intent(out) :: ex, ey
real(dp) :: x1, y1, alpha1
real(dp) :: x2, y2, alpha2
real(dp) :: x3, y3, alpha3
! get x and y components of projected points
x1 = dot_product(ph1, x_axis)
y1 = dot_product(ph1, y_axis)
x2 = dot_product(ph2, x_axis)
y2 = dot_product(ph2, y_axis)
x3 = dot_product(ph3, x_axis)
y3 = dot_product(ph3, y_axis)
! -> calculate H deformation angles
alpha3 = datan2(y2, x2)
alpha2 = -datan2(y3, x3) !-120*ang2rad
! write(*,*)' atan2'
! write(*,*) 'alpha2:' , alpha2/ang2rad
! write(*,*) 'alpha3:' , alpha3/ang2rad
if (alpha2 .lt. 0) alpha2 = alpha2 + pi2
if (alpha3 .lt. 0) alpha3 = alpha3 + pi2
alpha1 = (pi2 - alpha2 - alpha3)
! write(*,*)' fixed break line'
! write(*,*) 'alpha1:' , alpha1/ang2rad
! write(*,*) 'alpha2:' , alpha2/ang2rad
! write(*,*) 'alpha3:' , alpha3/ang2rad
alpha1 = alpha1 !- 120.0_dp*ang2rad
alpha2 = alpha2 !- 120.0_dp*ang2rad
alpha3 = alpha3 !- 120.0_dp*ang2rad
! write(*,*)' delta alpha'
! write(*,*) 'alpha1:' , alpha1/ang2rad
! write(*,*) 'alpha2:' , alpha2/ang2rad
! write(*,*) 'alpha3:' , alpha3/ang2rad
! write(*,*)
! construct symmetric and antisymmetric H angles
ex = symmetrize(alpha1, alpha2, alpha3, 'x')
ey = symmetrize(alpha1, alpha2, alpha3, 'y')
end subroutine construct_HBend
pure function construct_umbrella(nh1, nh2, nh3, n)&
&result(umb)
real(dp), intent(in) :: nh1(3), nh2(3), nh3(3)
real(dp), intent(in) :: n(3)
real(dp) :: umb
real(dp) :: theta(3)
! calculate projections for umberella angle
theta(1) = dacos(dot_product(n, nh1))
theta(2) = dacos(dot_product(n, nh2))
theta(3) = dacos(dot_product(n, nh3))
! construct umberella angle
umb = sum(theta(1:3))/3.0_dp - 90.0_dp*ang2rad
end function construct_umbrella
pure subroutine construct_sphericals&
&(theta, phi, cf, xaxis, yaxis, zaxis)
real(dp), intent(in) :: cf(3), xaxis(3), yaxis(3), zaxis(3)
real(dp), intent(out) :: theta, phi
real(dp) :: x, y, z, v(3)
v = normalized(cf)
x = dot_product(v, normalized(xaxis))
y = dot_product(v, normalized(yaxis))
z = dot_product(v, normalized(zaxis))
theta = dacos(z)
phi = -datan2(y, x)
end subroutine construct_sphericals
subroutine int2kart(internal, kart)
real(dp), intent(in) :: internal(6)
real(dp), intent(out) :: kart(9)
real(dp) :: h1x, h1y, h1z
real(dp) :: h2x, h2y, h2z
real(dp) :: h3x, h3y, h3z
real(dp) :: dch0, dch1, dch2, dch3
real(dp) :: a1, a2, a3, wci
kart = 0.0_dp
dch1 = dchequi + sq3*internal(1) + 2*sq6*internal(2)
dch2 = dchequi + sq3*internal(1) - sq6*internal(2) + sq2*internal(3)
dch3 = dchequi + sq3*internal(1) - sq6*internal(2) - sq2*internal(3)
a1 = 2*sq6*internal(4)
a2 = -sq6*internal(4) + sq2*internal(5)
a3 = -sq6*internal(4) - sq2*internal(5)
wci = internal(6)
! Berechnung kartesische Koordinaten
! -----------------------
h1x = dch1*cos(wci*ang2rad)
h1y = 0.0
h1z = -dch1*sin(wci*ang2rad)
h3x = dch2*cos((a2 + 120)*ang2rad)*cos(wci*ang2rad)
h3y = dch2*sin((a2 + 120)*ang2rad)*cos(wci*ang2rad)
h3z = -dch2*sin(wci*ang2rad)
h2x = dch3*cos((-a3 - 120)*ang2rad)*cos(wci*ang2rad)
h2y = dch3*sin((-a3 - 120)*ang2rad)*cos(wci*ang2rad)
h2z = -dch3*sin(wci*ang2rad)
kart(1) = h1x
kart(2) = h1y
kart(3) = h1z
kart(4) = h2x
kart(5) = h2y
kart(6) = h2z
kart(7) = h3x
kart(8) = h3y
kart(9) = h3z
end subroutine int2kart
end module ctrans_mod

2293
src/model/Maik_chngs/select_monom_mod.f90 Normal file
View File

File diff suppressed because it is too large Load Diff

575
src/model/Maik_chngs/sphericalharmonics_mod.f90 Normal file
View File

@ -0,0 +1,575 @@
! Module contains the spherical harmonics up to l=5 m=-l,..,0,..,l listed on https://en.wikipedia.org/wiki/Table_of_spherical_harmonics from 19.07.2022
! the functions are implementde by calling switch case function for given m or l value and return the corresdpondig value for given theta and phi
! the functions are split for diffrent l values and are named by P_lm.
! example for l=1 and m=-1 the realpart of the spherical harmonic for given theta and phi
! is returned by calling Re_Y_lm(1,-1,theta,phi) which itself calls the corresponding function P_1m(m,theta) and multilpies it by cos(m*phi) to account for the real part of exp(m*phi*i)
! Attention the legendre polynoms are shifted to account for the missing zero order term in spherical harmonic expansions
module sphericalharmonics_mod
use accuracy_constants, only: dp, idp
implicit none
real(kind=dp), parameter :: PI = 4.0_dp * atan( 1.0_dp )
contains
!----------------------------------------------------------------------------------------------------
function Y_lm( l , m , theta , phi ) result( y )
integer(kind=idp), intent( in ) :: l , m
real(kind=dp), intent( in ) :: theta , phi
real(kind=dp) y
character(len=70) :: errmesg
select case ( l )
case (1)
y = Y_1m( m , theta , phi )
case (2)
y = Y_2m( m , theta , phi )
case (3)
y = Y_3m( m , theta , phi )
case (4)
y = Y_4m( m , theta , phi )
case (5)
y = Y_5m( m , theta , phi )
case default
write(errmesg,'(A,i0)')&
&'order of spherical harmonics not implemented', l
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function Y_lm
!----------------------------------------------------------------------------------------------------
function Re_Y_lm( l , m , theta , phi ) result( y )
integer(kind=idp), intent( in ) :: l , m
real(kind=dp), intent( in ) :: theta , phi
real(kind=dp) y
character(len=70) :: errmesg
select case ( l )
case (1)
y = P_1m( m , theta ) * cos(m*phi)
case (2)
y = P_2m( m , theta ) * cos(m*phi)
case (3)
y = P_3m( m , theta ) * cos(m*phi)
case (4)
y = P_4m( m , theta ) * cos(m*phi)
case (5)
y = P_5m( m , theta ) * cos(m*phi)
case (6)
y = P_6m( m , theta ) * cos(m*phi)
case default
write(errmesg,'(A,i0)')&
&'order of spherical harmonics not implemented', l
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function Re_Y_lm
!----------------------------------------------------------------------------------------------------
function Im_Y_lm( l , m , theta , phi ) result( y )
integer(kind=idp), intent( in ) :: l , m
real(kind=dp), intent( in ) :: theta , phi
real(kind=dp) y
character(len=70) :: errmesg
select case ( l )
case (1)
y = P_1m( m , theta ) * sin(m*phi)
case (2)
y = P_2m( m , theta ) * sin(m*phi)
case (3)
y = P_3m( m , theta ) * sin(m*phi)
case (4)
y = P_4m( m , theta ) * sin(m*phi)
case (5)
y = P_5m( m , theta ) * sin(m*phi)
case (6)
y = P_6m( m , theta ) * sin(m*phi)
case default
write(errmesg,'(a,i0)')&
&'order of spherical harmonics not implemented',l
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function Im_Y_lm
!----------------------------------------------------------------------------------------------------
!----------------------------------------------------------------------------------------------------
function Y_1m( m , theta , phi ) result( y )
integer(kind=idp),intent( in ):: m
real(kind=dp),intent( in ):: theta , phi
real(kind=dp) y
character(len=70) :: errmesg
select case ( m )
case (-1)
y = 0.5_dp*sqrt(3.0_dp/(PI*2.0_dp))*sin(theta)*cos(phi)
case (0)
y = 0.5_dp*sqrt(3.0_dp/PI)*cos(theta)
case (1)
y = -0.5_dp*sqrt(3.0_dp/(PI*2.0_dp))*sin(theta)*cos(phi)
case default
write(errmesg,'(a,i0)') 'in y_1m given m not logic, ', m
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function Y_1m
!----------------------------------------------------------------------------------------------------
function Y_2m(m,theta,phi) result(y)
integer(kind=idp),intent(in):: m
real(kind=dp),intent(in):: theta,phi
real(kind=dp) y
character(len=70) :: errmesg
select case (m)
case (-2)
y=0.25_dp*sqrt(15.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*cos(2.0_dp*phi)
case (-1)
y=0.5_dp*sqrt(15.0_dp/(PI*2.0_dp))&
&*sin(theta)*cos(theta)*cos(phi)
case (0)
y=0.25_dp*sqrt(5.0_dp/PI)&
&*(3.0_dp*cos(theta)**2-1.0_dp)
case (1)
y=-0.5_dp*sqrt(15.0_dp/(PI*2.0_dp))&
&*sin(theta)*cos(theta)*cos(phi)
case (2)
y=0.25_dp*sqrt(15.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*cos(2.0_dp*phi)
case default
write(errmesg,'(A,i0)')'in y_2m given m not logic, ', m
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function Y_2m
!----------------------------------------------------------------------------------------------------
function Y_3m(m,theta,phi) result(y)
integer(kind=idp), intent(in) :: m
real(kind=dp), intent(in) :: theta,phi
real(kind=dp) y
character(len=70) :: errmesg
select case (m)
case (-3)
y=0.125_dp*sqrt(35.0_dp/PI)&
&*sin(theta)**3*cos(3.0_dp*phi)
case (-2)
y=0.25_dp*sqrt(105.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*cos(theta)*cos(2.0_dp*phi)
case (-1)
y=0.125_dp*sqrt(21.0_dp/(PI))&
&*sin(theta)*(5.0_dp*cos(theta)**2-1.0_dp)*cos(phi)
case (0)
y=0.25_dp*sqrt(7.0_dp/PI)&
&*(5.0_dp*cos(theta)**3-3.0_dp*cos(theta))
case (1)
y=-0.125_dp*sqrt(21.0_dp/(PI))&
&*sin(theta)*(5.0_dp*cos(theta)**2-1.0_dp)*cos(phi)
case (2)
y=0.25_dp*sqrt(105.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*cos(theta)*cos(2.0_dp*phi)
case (3)
y=-0.125_dp*sqrt(35.0_dp/PI)&
&*sin(theta)**3*cos(3.0_dp*phi)
case default
write(errmesg,'(A,i0)')'in y_3m given m not logic, ', m
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function Y_3m
!----------------------------------------------------------------------------------------------------
function Y_4m(m,theta,phi) result(y)
integer(kind=idp), intent(in) :: m
real(kind=dp), intent(in) :: theta,phi
real(kind=dp) y
character(len=70) :: errmesg
select case (m)
case (-4)
y=(3.0_dp/16.0_dp)*sqrt(35.0_dp/2.0_dp*PI)&
&*sin(theta)**4*cos(4.0_dp*phi)
case (-3)
y=0.375_dp*sqrt(35.0_dp/PI)&
&*sin(theta)**3*cos(theta)*cos(3.0_dp*phi)
case (-2)
y=0.375_dp*sqrt(5.0_dp/(PI*2.0_dp))&
&*sin(theta)**2&
&*(7.0_dp*cos(theta)**2-1)*cos(2.0_dp*phi)
case (-1)
y=0.375_dp*sqrt(5.0_dp/(PI))&
&*sin(theta)*(7.0_dp*cos(theta)**3&
&-3.0_dp*cos(theta))*cos(phi)
case (0)
y=(3.0_dp/16.0_dp)/sqrt(PI)&
&*(35.0_dp*cos(theta)**4&
&-30.0_dp*cos(theta)**2+3.0_dp)
case (1)
y=-0.375_dp*sqrt(5.0_dp/(PI))&
&*sin(theta)*(7.0_dp*cos(theta)**3&
&-3.0_dp*cos(theta))*cos(phi)
case (2)
y=0.375_dp*sqrt(5.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*(7.0_dp*cos(theta)**2-1.0_dp)&
&*cos(2*phi)
case (3)
y=-0.375_dp*sqrt(35.0_dp/PI)&
&*sin(theta)**3*cos(theta)*cos(3.0_dp*phi)
case (4)
y=(3.0_dp/16.0_dp)*sqrt(35.0_dp/2.0_dp*PI)&
&*sin(theta)**4*cos(4.0_dp*phi)
case default
write(errmesg,'(a,i0)')'in y_4m given m not logic, ', m
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function Y_4m
!----------------------------------------------------------------------------------------------------
function Y_5m(m,theta,phi) result(y)
integer(kind=idp), intent(in) :: m
real(kind=dp), intent(in) :: theta,phi
real(kind=dp) y
character(len=70) :: errmesg
select case (m)
case (-5)
y=(3.0_dp/32.0_dp)*sqrt(77.0_dp/PI)&
&*sin(theta)**5*cos(5*phi)
case (-4)
y=(3.0_dp/16.0_dp)*sqrt(385.0_dp/2.0_dp*PI)&
&*sin(theta)**4*cos(theta)*cos(4*phi)
case (-3)
y=(1.0_dp/32.0_dp)*sqrt(385.0_dp/PI)&
&*sin(theta)**3*(9*cos(theta)**2-1.0_dp)*cos(3*phi)
case (-2)
y=0.125*sqrt(1155.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*(3*cos(theta)**3-cos(theta))*cos(2*phi)
case (-1)
y=(1.0_dp/16.0_dp)*sqrt(165.0_dp/(2.0_dp*PI))&
&*sin(theta)*(21.0_dp*cos(theta)**4&
&-14.0_dp*cos(theta)**2+1.0_dp)*cos(phi)
case (0)
y=(1.0_dp/16.0_dp)/sqrt(11.0_dp/PI)&
&*(63.0_dp*cos(theta)**5-70.0_dp*cos(theta)**3&
&+15.0_dp*cos(theta))
case (1)
y=(-1.0_dp/16.0_dp)*sqrt(165.0_dp/(2.0_dp*PI))&
&*sin(theta)*(21.0_dp*cos(theta)**4&
&-14.0_dp*cos(theta)**2+1.0_dp)*cos(phi)
case (2)
y=0.125*sqrt(1155.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*(3*cos(theta)**3-cos(theta))*cos(2*phi)
case (3)
y=(-1.0_dp/32.0_dp)*sqrt(385.0_dp/PI)&
&*sin(theta)**3*(9.0_dp*cos(theta)**2-1.0_dp)&
&*cos(3.0_dp*phi)
case (4)
y=(3.0_dp/16.0_dp)*sqrt(385.0_dp/2.0_dp*PI)&
&*sin(theta)**4*cos(theta)*cos(4.0_dp*phi)
case (5)
y=(-3.0_dp/32.0_dp)*sqrt(77.0_dp/PI)&
&*sin(theta)**5*cos(5.0_dp*phi)
case default
write(errmesg,'(A,i0)')'in y_5m given m not logic, ', m
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function Y_5m
!----------------------------------------------------------------------------------------------------
function P_1m( m , theta ) result( y )
! >Function returns the value of the corresponding normalized Associated legendre polynom for l=1 and given m and theta
integer(kind=idp),intent( in ):: m
real(kind=dp),intent( in ):: theta
real(kind=dp) y
character(len=70) :: errmesg
select case ( m )
case (-1)
y = 0.5_dp*sqrt(3.0_dp/(PI*2.0_dp))*sin(theta)
case (0)
y = 0.5_dp*sqrt(3.0_dp/PI)*(cos(theta)-1.0_dp) ! -1 is subtracted to shift so that for theta=0 y=0
case (1)
y = -0.5_dp*sqrt(3.0_dp/(PI*2.0_dp))*sin(theta)
case default
write(errmesg,'(A,i0)')'in p_1m given m not logic, ', m
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function P_1m
!----------------------------------------------------------------------------------------------------
function P_2m( m , theta ) result( y )
! >Function returns the value of the corresponding normalized Associated legendre polynom for l=2 and given m and theta
integer(kind=idp),intent(in):: m
real(kind=dp),intent(in):: theta
real(kind=dp) y
character(len=70) :: errmesg
select case ( m )
case (-2)
y=0.25_dp*sqrt(15.0_dp/(PI*2.0_dp))&
&*sin(theta)**2
case (-1)
y=0.5_dp*sqrt(15.0_dp/(PI*2.0_dp))&
&*sin(theta)*cos(theta)
case (0)
y = (3.0_dp*cos(theta)**2-1.0_dp)
y = y - 2.0_dp !2.0 is subtracted to shift so that for theta=0 y=0
y = y * 0.25_dp*sqrt(5.0_dp/PI) ! normalize
case (1)
y = -0.5_dp*sqrt(15.0_dp/(PI*2.0_dp))&
&*sin(theta)*cos(theta)
case (2)
y = 0.25_dp*sqrt(15.0_dp/(PI*2.0_dp))&
&*sin(theta)**2
case default
write(errmesg,'(A,i0)')'in p_2m given m not logic, ', m
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function P_2m
!----------------------------------------------------------------------------------------------------
function P_3m( m , theta ) result( y )
! >Function returns the value of the corresponding normalized Associated legendre polynom for l=3 and given m and theta
integer(kind=idp), intent(in) :: m
real(kind=dp), intent(in) :: theta
real(kind=dp) y
character(len=70) :: errmesg
select case ( m )
case (-3)
y=0.125_dp*sqrt(35.0_dp/PI)&
&*sin(theta)**3
case (-2)
y=0.25_dp*sqrt(105.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*cos(theta)
case (-1)
y=0.125_dp*sqrt(21.0_dp/(PI))&
&*sin(theta)*(5*cos(theta)**2-1.0_dp)
case (0)
y=(5.0_dp*cos(theta)**3-3*cos(theta))
y=y-2.0_dp ! 2.0 is subtracted to shift so that for theta=0 y=0
y=y*0.25_dp*sqrt(7.0_dp/PI) ! normalize
case (1)
y=-0.125_dp*sqrt(21.0_dp/(PI))&
&*sin(theta)*(5.0_dp*cos(theta)**2-1.0_dp)
case (2)
y=0.25*sqrt(105.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*cos(theta)
case (3)
y=-0.125*sqrt(35.0_dp/PI)&
&*sin(theta)**3
case default
write(errmesg,'(A,i0)')'in p_3m given m not logic, ', m
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function P_3m
!----------------------------------------------------------------------------------------------------
function P_4m(m,theta) result(y)
! >Function returns the value of the corresponding normalized Associated legendre polynom for l=4 and given m and theta
integer(kind=idp), intent(in) :: m
real(kind=dp), intent(in) :: theta
real(kind=dp) y
character(len=70) :: errmesg
select case ( m )
case (-4)
y=(3.0_dp/16.0_dp)*sqrt(35.0_dp/2.0_dp*PI)&
&*sin(theta)**4
case (-3)
y=0.375*sqrt(35.0_dp/PI)&
&*sin(theta)**3*cos(theta)
case (-2)
y=0.375*sqrt(5.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*(7*cos(theta)**2-1)
case (-1)
y=0.375*sqrt(5.0_dp/(PI))&
&*sin(theta)*(7*cos(theta)**3-3*cos(theta))
case (0)
y=(35*cos(theta)**4-30*cos(theta)**2+3)
y = y - 8.0_dp !8.0 is subtracted to shift so that for theta=0 y=0
y = y * (3.0_dp/16.0_dp)/sqrt(PI)
case (1)
y=-0.375*sqrt(5.0_dp/(PI))&
&*sin(theta)*(7*cos(theta)**3-3*cos(theta))
case (2)
y=0.375*sqrt(5.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*(7*cos(theta)**2-1)
case (3)
y=-0.375*sqrt(35.0_dp/PI)&
&*sin(theta)**3*cos(theta)
case (4)
y=(3.0_dp/16.0_dp)*sqrt(35.0_dp/2.0_dp*PI)&
&*sin(theta)**4
case default
write(errmesg,'(A,i0)')'in p_4m given m not logic, ', m
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function P_4m
!----------------------------------------------------------------------------------------------------
function P_5m(m,theta) result(y)
! >Function returns the value of the corresponding normalized Associated legendre polynom for l=5 and given m and theta
integer(kind=idp), intent(in) :: m
real(kind=dp), intent(in) :: theta
real(kind=dp) y
character(len=70) :: errmesg
select case ( m )
case (-5)
y=(3.0_dp/32.0_dp)*sqrt(77.0_dp/PI)&
&*sin(theta)**5
case (-4)
y=(3.0_dp/16.0_dp)*sqrt(385.0_dp/2.0_dp*PI)&
&*sin(theta)**4*cos(theta)
case (-3)
y=(1.0_dp/32.0_dp)*sqrt(385.0_dp/PI)&
&*sin(theta)**3*(9*cos(theta)**2-1.0_dp)
case (-2)
y=0.125*sqrt(1155.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*(3*cos(theta)**3-cos(theta))
case (-1)
y=(1.0_dp/16.0_dp)*sqrt(165.0_dp/(2.0_dp*PI))&
&*sin(theta)*(21*cos(theta)**4-14*cos(theta)**2+1)
case (0)
y = (63*cos(theta)**5-70*cos(theta)**3+15*cos(theta))
y = y - 8.0_dp !8.0 is subtracted to shift so that for theta=0 y=0
y = y * (1.0_dp/16.0_dp)/sqrt(11.0_dp/PI)
case (1)
y=(-1.0_dp/16.0_dp)*sqrt(165.0_dp/(2.0_dp*PI))&
&*sin(theta)*(21*cos(theta)**4-14*cos(theta)**2+1)
case (2)
y=0.125*sqrt(1155.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*(3*cos(theta)**3-cos(theta))
case (3)
y=(-1.0_dp/32.0_dp)*sqrt(385.0_dp/PI)&
&*sin(theta)**3*(9*cos(theta)**2-1.0_dp)
case (4)
y=(3.0_dp/16.0_dp)*sqrt(385.0_dp/2.0_dp*PI)&
&*sin(theta)**4*cos(theta)
case (5)
y=(-3.0_dp/32.0_dp)*sqrt(77.0_dp/PI)&
&*sin(theta)**5
case default
write(errmesg,'(A,i0)')'in p_5m given m not logic, ', m
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function P_5m
!----------------------------------------------------------------------------------------------------
function P_6m(m,theta) result(y)
! >Function returns the value of the corresponding normalized Associated legendre polynom for l=6 and given m and theta
integer(kind=idp), intent(in) :: m
real(kind=dp), intent(in) :: theta
real(kind=dp):: y
character(len=70) :: errmesg
select case ( m )
case (-6)
y = (1.0_dp/64.0_dp)*sqrt(3003.0_dp/PI)&
&* sin(theta)**6
case (-5)
y = (3.0_dp/32.0_dp)*sqrt(1001.0_dp/PI)&
&* sin(theta)**5&
&* cos(theta)
case (-4)
y= (3.0_dp/32.0_dp)*sqrt(91.0_dp/(2.0_dp*PI))&
&* sin(theta)**4&
&* (11*cos(theta)**2 - 1 )
case (-3)
y= (1.0_dp/32.0_dp)*sqrt(1365.0_dp/PI)&
&* sin(theta)**3&
&* (11*cos(theta)**3 - 3*cos(theta) )
case (-2)
y= (1.0_dp/64.0_dp)*sqrt(1365.0_dp/PI)&
&* sin(theta)**2&
&* (33*cos(theta)**4 - 18*cos(theta)**2 + 1 )
case (-1)
y= (1.0_dp/16.0_dp)*sqrt(273.0_dp/(2.0_dp*PI))&
&* sin(theta)&
&* (33*cos(theta)**5 - 30*cos(theta)**3 + 5*cos(theta) )
case (0)
y = 231*cos(theta)**6 - 315*cos(theta)**4 + 105*cos(theta)**2-5
y = y - 16.0_dp !16.0 is subtracted to shift so that for theta=0 y=0
y = y * (1.0_dp/32.0_dp)*sqrt(13.0_dp/PI)
case (1)
y= -(1.0_dp/16.0_dp)*sqrt(273.0_dp/(2.0_dp*PI))&
&* sin(theta)&
&* (33*cos(theta)**5 - 30*cos(theta)**3 + 5*cos(theta) )
case (2)
y= (1.0_dp/64.0_dp)*sqrt(1365.0_dp/PI)&
&* sin(theta)**2&
&* (33*cos(theta)**4 - 18*cos(theta)**2 + 1 )
case (3)
y= -(1.0_dp/32.0_dp)*sqrt(1365.0_dp/PI)&
&* sin(theta)**3&
&* (11*cos(theta)**3 - 3*cos(theta) )
case (4)
y= (3.0_dp/32.0_dp)*sqrt(91.0_dp/(2.0_dp*PI))&
&* sin(theta)**4&
&* (11*cos(theta)**2 - 1 )
case (5)
y= -(3.0_dp/32.0_dp)*sqrt(1001.0_dp/PI)&
&* sin(theta)**5 * cos(theta)
case (6)
y = (1.0_dp/64.0_dp)*sqrt(3003.0_dp/PI)&
&* sin(theta)**6
case default
write(errmesg,'(A,i0)')'in p_6m given m not logic, ', m
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function P_6m
!----------------------------------------------------------------------------------------------------
end module

117
src/model/adia.f90 Normal file
View File

@ -0,0 +1,117 @@
module adia_mod
implicit none
contains
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! % SUBROUTINE ADIA(N,P,NPAR,ymod,v,u,SKIP)
! %
! % determines the adiabatic energies by diagonalizing diabatic matrix.
! % The Eingenvalues are sorted according to the best fitting ordering
! % of the CI vectors.
! %
! % ATTENTION: The interface has changed. To sort by the ci's,
! % the datavalue of the current points are given
! %
! % input variables:
! % n: number of point (int)
! % p: parameter evector(double[npar])
! % npar: number of parameters (int)
! % skip: .false. if everything should be done
! %
! % output variables:
! % ymod: firtst nstat energies and than nci*ndiab ci's (double[ntot])
! % v: eigenvalues (double[ndiab])
! % u: eigenvectors (double[ndiab,ndiab])
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine adia(n,p,npar,ymod,vx,u,skip)
use dim_parameter,only: ndiab,nstat,ntot,nci,pst
use data_module,only: q_m,x1_m,x2_m,y_m
use diabmodel, only:diab
use data_matrix
!use dipole, only: diab
implicit none
integer i,j !running indices
integer iref !getting correction or refference
double precision e(ndiab,ndiab) !full diabatic matrix
double precision mx(ndiab,ndiab)
double precision my(ndiab,ndiab)
double precision vxs,vys,vxb,vyb
integer n !current point
integer npar !number of parameters
double precision p(npar) !parameters
double precision u(ndiab,ndiab),ut(ndiab,ndiab) !ci-vectors
double precision ymod(ntot) !fitted data
double precision vx(ndiab),vy(nstat) !eigen values
double precision,allocatable,dimension(:,:):: mat
logical skip,dbg
parameter (dbg=.false.)
double precision,dimension(2,2):: T,TT,TX,TY
! lapack variables
integer,parameter :: lwork = 1000
double precision work(lwork)
integer info
integer TYPES, BLK ! TYPE OF THE CALCULATION
! variabke for dgemm
double precision,dimension(ndiab,ndiab):: ex,ey
double precision:: alpha
integer:: lda,ldb,beta,ldc
double precision,dimension(ndiab,ndiab):: temp1,temp2
call diab(ex,ey,n,x1_m(:,n),x2_m(:,n),p)
! init eigenvector matrix
TYPES = int(p(pst(1,28)))
BLK = int(p(pst(1,28)+1)) ! BLOCK IF TYPE IS 3
u = 0.d0
vx=0.0d0
skip=.false.
ymod=0.0d0
if (TYPES .eq.1 ) then
! Trace of the potential
call trace_mat(ex,ey,ymod)
else if (TYPES .eq.2) then
! Eigenvalue decomposition of the potential
call Eigen(ex,ey,ymod)
else if (TYPES .eq.3) then
CALL BLOCK_DIAB(ex,ey,ymod,BLK)
else if (TYPES .EQ.4) then
call Full_diab_upper(ex,ey,ymod)
else if (TYPES .eq.5) then
call Transformation_mat(ex,vx,ymod)
ymod=0.0d0
else
write(*,*) "Error in TYPE of calculation here",TYPES
stop
end if
if (dbg) then
do i=1,ndiab
write(*,'(5f14.6)') (ex(i,j),j=1,ndiab)
enddo
write(*,*)""
endif
end subroutine
subroutine matrix_mult(C,A,B,N)
implicit none
integer:: n,i,j,k
double precision,dimension(n,n):: A,B,C
do i = 1, n ! Rows of C
do j = 1, n ! Columns of C
C(i,j) = 0.0 ! Initialize element
do k = 1, n ! Dot product
C(i,j) = C(i,j) + A(i,k) * B(k,j)
end do
end do
end do
end subroutine
end module adia_mod

386
src/model/ctrans.f90 Normal file
View File

@ -0,0 +1,386 @@
module ctrans_mod
use dim_parameter, only: qn
contains
!! subroutine ctrans
subroutine ctrans(q,x1,x2)
implicit none
include 'nnparams.incl'
include 'JTmod.incl'
double precision,intent(in):: q(qn)
double precision,intent(out):: x1(qn),x2(qn)
double precision:: cart(3,4),qint(maxnin)
integer i
!cart(:,1)=0.0d0
!cart(1:3,2:4) = reshape([ q(4:12) ], shape(cart(1:3,2:4)))
cart(1,1)=q(1)
cart(2,1)=q(2)
cart(3,1)=q(3)
cart(1,2)=q(4)
cart(2,2)=q(5)
cart(3,2)=q(6)
cart(1,3)=q(7)
cart(2,3)=q(8)
cart(3,3)=q(9)
cart(1,4)=q(10)
cart(2,4)=q(11)
cart(3,4)=q(12)
call cart2int(cart,qint)
do i=1,qn
if (abs(qint(i)) .lt. 1.0d-5) qint(i) =0.0d0
enddo
x1(1:qn)=qint(1:qn)
!x1(2)=0.0d0
x1(5)=-x1(5)
x1(3)=-x1(3)
!x1(6)=0.0d0
x2(1:qn)=0.0d0 !qint(1:qn)
end subroutine ctrans
subroutine cart2int(cart,qint)
implicit none
! This version merges both coordinate transformation routines into
! one. JTmod's sscales(2:3) are ignored.
! This is the first version to be compatible with one of my proper 6D fits
! Time-stamp: <2024-10-22 13:52:59 dwilliams>
! Input (cartesian, in Angström)
! cart(:,1): N
! cart(:,1+i): Hi
! Output
! qint(i): order defined in JTmod.
! Internal Variables
! no(1:3): NO distances 1-3
! pat_in: temporary coordinates
! axis: main axis of NO3
include 'nnparams.incl'
include 'JTmod.incl'
real*8 cart(3,4),qint(maxnin)
real*8 no(3), r1, r2, r3
real*8 v1(3), v2(3), v3(3)
real*8 n1(3), n2(3), n3(3), tr(3)
real*8 ortho(3)
real*8 pat_in(maxnin)
logical ignore_umbrella,dbg_umbrella
logical dbg_distances
!.. Debugging parameters
!.. set umbrella to 0
parameter (ignore_umbrella=.false.)
! parameter (ignore_umbrella=.true.)
!.. break if umbrella is not 0
parameter (dbg_umbrella=.false.)
! parameter (dbg_umbrella=.true.)
!.. break for tiny distances
parameter (dbg_distances=.false.)
! parameter (dbg_distances=.true.)
integer k
!.. get N-O vectors and distances:
do k=1,3
v1(k)=cart(k,2)-cart(k,1)
v2(k)=cart(k,3)-cart(k,1)
v3(k)=cart(k,4)-cart(k,1)
enddo
no(1)=norm(v1,3)
no(2)=norm(v2,3)
no(3)=norm(v3,3)
!.. temporarily store displacements
do k=1,3
pat_in(k)=no(k)-offsets(1)
enddo
do k=1,3
v1(k)=v1(k)/no(1)
v2(k)=v2(k)/no(2)
v3(k)=v3(k)/no(3)
enddo
!.. compute three normal vectors for the ONO planes:
call xprod(n1,v1,v2)
call xprod(n2,v2,v3)
call xprod(n3,v3,v1)
do k=1,3
tr(k)=(n1(k)+n2(k)+n3(k))/3.d0
enddo
r1=norm(tr,3)
do k=1,3
tr(k)=tr(k)/r1
enddo
! rotate trisector
call rot_trisec(tr,v1,v2,v3)
!.. determine trisector angle:
if (ignore_umbrella) then
pat_in(7)=0.0d0
else
pat_in(7)=pi/2.0d0 - acos(scalar(v1,tr,3))
pat_in(7)=sign(pat_in(7),cart(1,2))
endif
!.. molecule now lies in yz plane, compute projected ONO angles:
v1(1)=0.d0
v2(1)=0.d0
v3(1)=0.d0
r1=norm(v1,3)
r2=norm(v2,3)
r3=norm(v3,3)
do k=2,3
v1(k)=v1(k)/r1
v2(k)=v2(k)/r2
v3(k)=v3(k)/r3
enddo
! make orthogonal vector to v3
ortho(1)=0.0d0
ortho(2)=v3(3)
ortho(3)=-v3(2)
!.. projected ONO angles in radians
pat_in(4)=get_ang(v2,v3,ortho)
pat_in(5)=get_ang(v1,v3,ortho)
pat_in(6)=dabs(pat_in(5)-pat_in(4))
!.. account for rotational order of atoms
if (pat_in(4).le.pat_in(5)) then
pat_in(5)=2*pi-pat_in(4)-pat_in(6)
else
pat_in(4)=2*pi-pat_in(5)-pat_in(6)
endif
pat_in(4)=rad2deg*pat_in(4)-offsets(2)
pat_in(5)=rad2deg*pat_in(5)-offsets(2)
pat_in(6)=rad2deg*pat_in(6)-offsets(2)
pat_in(7)=rad2deg*pat_in(7)
call genANN_ctrans(pat_in)
qint(:)=pat_in(:)
contains
!-------------------------------------------------------------------
! compute vector product n1 of vectors v1 x v2
subroutine xprod(n1,v1,v2)
implicit none
real*8 n1(3), v1(3), v2(3)
n1(1) = v1(2)*v2(3) - v1(3)*v2(2)
n1(2) = v1(3)*v2(1) - v1(1)*v2(3)
n1(3) = v1(1)*v2(2) - v1(2)*v2(1)
end subroutine
!-------------------------------------------------------------------
! compute scalar product of vectors v1 and v2:
real*8 function scalar(v1,v2,n)
implicit none
integer i, n
real*8 v1(*), v2(*)
scalar=0.d0
do i=1,n
scalar=scalar+v1(i)*v2(i)
enddo
end function
!-------------------------------------------------------------------
! compute norm of vector:
real*8 function norm(x,n)
implicit none
integer i, n
real*8 x(*)
norm=0.d0
do i=1,n
norm=norm+x(i)**2
enddo
norm=sqrt(norm)
end function
!-------------------------------------------------------------------
subroutine rot_trisec(tr,v1,v2,v3)
implicit none
real*8 tr(3),v1(3),v2(3),v3(3)
real*8 vrot(3)
real*8 rot_ax(3)
real*8 cos_phi,sin_phi
! evaluate cos(-phi) and sin(-phi), where phi is the angle between
! tr and (1,0,0)
cos_phi=tr(1)
sin_phi=dsqrt(tr(2)**2+tr(3)**2)
if (sin_phi.lt.1.0d-12) then
return
endif
! determine rotational axis
rot_ax(1) = 0.0d0
rot_ax(2) = tr(3)
rot_ax(3) = -tr(2)
! normalize
rot_ax=rot_ax/sin_phi
! now the rotation can be done using Rodrigues' rotation formula
! v'=v*cos(p) + (k x v)sin(p) + k (k*v) (1-cos(p))
! for v=tr k*v vanishes by construction:
! check that the rotation does what it should
call rodrigues(vrot,tr,rot_ax,cos_phi,sin_phi)
if (dsqrt(vrot(2)**2+vrot(3)**2).gt.1.0d-12) then
write(6,*) "ERROR: BROKEN TRISECTOR"
stop
endif
tr=vrot
call rodrigues(vrot,v1,rot_ax,cos_phi,sin_phi)
v1=vrot
call rodrigues(vrot,v2,rot_ax,cos_phi,sin_phi)
v2=vrot
call rodrigues(vrot,v3,rot_ax,cos_phi,sin_phi)
v3=vrot
end subroutine
!-------------------------------------------------------------------
subroutine rodrigues(vrot,v,axis,cos_phi,sin_phi)
implicit none
real*8 vrot(3),v(3),axis(3)
real*8 cos_phi,sin_phi
real*8 ortho(3)
call xprod(ortho,axis,v)
vrot = v*cos_phi + ortho*sin_phi+axis*scalar(axis,v,3)*(1-cos_phi)
end subroutine
!-------------------------------------------------------------------
real*8 function get_ang(v,xaxis,yaxis)
implicit none
! get normalized [0:2pi) angle from vectors in the yz plane
real*8 v(3),xaxis(3),yaxis(3)
real*8 phi
real*8 pi
parameter (pi=3.141592653589793d0)
phi=atan2(scalar(yaxis,v,3),scalar(xaxis,v,3))
if (phi.lt.0.0d0) then
phi=2*pi+phi
endif
get_ang=phi
end function
end subroutine cart2int
subroutine genANN_ctrans(pat_in)
implicit none
include 'nnparams.incl'
include 'JTmod.incl'
real*8 pat_in(maxnin)
real*8 raw_in(maxnin),off_in(maxnin),ptrans_in(7)
real*8 r0
real*8 a,b,xs,ys,xb,yb
integer k
off_in(1:7)=pat_in(1:7)
r0=offsets(1)
! transform primitives
! recover raw distances from offset coords
do k=1,3
raw_in(k)=off_in(k)+offsets(1)
enddo
do k=1,3
ptrans_in(k)=off_in(k)
enddo
! rescale ONO angles
ptrans_in(4)=deg2rad*off_in(4)
ptrans_in(5)=deg2rad*off_in(5)
ptrans_in(6)=deg2rad*off_in(6)
! rescale umbrella
ptrans_in(7)=off_in(7)*deg2rad
! compute symmetry coordinates
! A (breathing)
a=(ptrans_in(1)+ptrans_in(2)+ptrans_in(3))/dsqrt(3.0d0)
! ES
call prim2emode(ptrans_in(1:3),xs,ys)
! EB
call prim2emode(ptrans_in(4:6),xb,yb)
! B (umbrella)
b=ptrans_in(7)
! overwrite input with output
pat_in(pat_index(1))=a ! 1
pat_in(pat_index(2))=xs
pat_in(pat_index(3))=ys
pat_in(pat_index(4))=xb
pat_in(pat_index(5))=yb
pat_in(pat_index(6))=b
! totally symmetric monomials
pat_in(pat_index(7))=xs**2 + ys**2 ! 2
pat_in(pat_index(8))=xb**2 + yb**2 ! 3
pat_in(pat_index(9))=b**2 ! 9
pat_in(pat_index(10))=xs*xb+ys*yb ! 4
! S^3, B^3
pat_in(pat_index(11))=xs*(xs**2-3*ys**2) ! 5
pat_in(pat_index(12))=xb*(xb**2-3*yb**2) ! 6
! S^2 B, S B^2
pat_in(pat_index(13))=xb*(xs**2-ys**2) - 2*yb*xs*ys ! 7
pat_in(pat_index(14))=xs*(xb**2-yb**2) - 2*ys*xb*yb ! 8
do k=11,14
pat_in(pat_index(k))=tanh(0.1d0*pat_in(pat_index(k)))*10.0d0
enddo
end subroutine
subroutine prim2emode(prim,ex,ey)
implicit none
! Takes a 2D-vector prim and returns the degenerate modes x and y
! following our standard conventions.
real*8 prim(3),ex,ey
ex=(2.0d0*prim(1)-prim(2)-prim(3))/dsqrt(6.0d0)
ey=(prim(2)-prim(3))/dsqrt(2.0d0)
end
end module ctrans_mod

126
src/model/data_transform.f90 Normal file
View File

@ -0,0 +1,126 @@
! <subroutine for manipulating the input Data before the Fit
subroutine data_transform(q,x1,x2,y,wt,p,npar,p_act)
use dim_parameter,only : nstat,pst,ntot,qn,numdatpt,ndiab,ndata,sets
use ctrans_mod, only: ctrans
use surface_mod, only: eval_surface
use data_matrix
! use david_ctrans_mod, only: ctrans_d
implicit none
! IN: variables
integer npar
double precision q(qn,numdatpt),x1(qn,numdatpt),x2(qn,numdatpt)
double precision y(ntot,numdatpt),wt(ntot,numdatpt)
double precision p(npar),mat_x(ndiab,ndiab),mat_y(ndiab,ndiab)
double precision v(ndiab,ndiab),E(nstat), energies(nstat)
integer p_act(npar), pt
logical dbg
parameter (dbg=.false.)
integer TYPES,BLK ! TYPE OF THE CALCULATION AND THE BLOCK IF TYEPE IS 3
double precision U(ndiab,ndiab), U_ref(ndiab,ndiab) ! Transformation matrix
integer:: i,j,k,l
if (pst(2,28) .ne. 2) then
write(*,*) "Error in Paramater Keys, TYPE_CAL should be 2 parameter", pst(2,28)
stop
end if
TYPES = int(p(pst(1,28)))! TYPE OF THE CALCULATION
BLK= int(p(pst(1,28)+1))! BLOCK IF TYPE IS 3
write(*,*) "TYPE of calculation:",TYPES
pt=1
do i=1,sets ! loop over the number of sets
do j=1,ndata(i) ! loop over the nbr of points in each sets
! remember to increment pt at the end of the loop
call ctrans(q(1:qn,pt),x1(:,pt),x2(:,pt)) ! transform the coordinate
! get the reference U matrix
!if (j .eq. 3) then
! call eval_surface(E,V,U_ref,q(1:qn,pt))
! call transform_U(U_ref)
!endif
!do pt=1,numdatpt
!call ctrans(q(1:qn,pt),x1(:,pt),x2(:,pt))! ctrans the dipole cooordinate.
write(7,'(I3,*(E17.8))') pt,x1(:,pt)
call eval_surface(E,V,U,q(1:qn,pt))
! Transform U mmatrix
call transform_U(U) ! Transform the U matrix
! write U matrix on f16
if (dbg) then
!write(7,*) "U matrix at point", pt
do k=1,ndiab
write(50+i,'(2E17.8,5X,5E17.8)')x1(2:3,pt),(U(k,l),l=1,ndiab)
enddo
write(50+i,*) ""
endif
!call overlap(U_ref,U)
call Y2mat(y(1:ntot,pt),mat_x,mat_y)
mat_y=-mat_y
if (ntot .ne. ndiab*(ndiab+1)) then
energies(1:nstat)= y(31:ntot,pt)
end if
if (TYPES .eq.1 ) then
!call adiabatic_transform(mat_x,mat_y,U)
! Trace of the potential
call trace_mat(mat_x,mat_y,y(1:ntot,pt))
else if (TYPES .eq.2) then
! Eigenvalue decomposition of the potential
call Eigen(mat_x,mat_y,y(1:ntot,pt))
else if (TYPES .eq.3) then
! Adiabatic transformation of the potential
call adiabatic_transform(mat_x,mat_y,U)
call block_diab(mat_x,mat_y,y(1:ntot,pt),BLK)
else if (TYPES .eq.4) then
! Write the full upper diabatic matrix
call adiabatic_transform(mat_x,mat_y,U)
! and write the full diabatic matrix to y
! This is the full diabatic matrix
call Full_diab_upper(mat_x,mat_y,y(1:ntot,pt))
else if (TYPES .eq.5) then
call adiabatic_transform(mat_x,mat_y,U)
call Transformation_mat(mat_x,E,y(1:ntot,pt))
if (dbg) then
do k=1,ndiab
write(34,'(5f14.6)') (mat_x(k,l),l=1,ndiab)
enddo
write(34,*) ""
endif
!y(31:ntot,pt)=energies(1:nstat)
else
write(*,*) "Error in TYPE of calculationss",TYPES
write(*,*) "the value:,", p(pst(1,28))
stop
end if
pt=pt+1
enddo ! j
write(34,*) "#---- End of set ", i
write(7,*) "#---- End of set ", i
enddo ! i
!enddo
call weight(wt,y)
end subroutine

85
src/model/keys.f90 Normal file
View File

@ -0,0 +1,85 @@
module keys_mod
implicit none
contains
!program gen_key
! implicit none
! call init_keys()
!end program gen_key
subroutine init_keys
use io_parameters, only: key
character(len=1) prefix(4)
parameter (prefix=['N','P','A','S'])
!character (len=20) key(4,25)
integer,parameter:: np=34
character(len=16) parname(np)
integer i,j
! Defining keys for potential
! the electronic state of NO3 A2' E" E'
! Naming convention
! the keys for Lx and Ly
! the coupling between A2' and A2"
parname(1)='LXYVA2O1'
parname(2)='LXYVE1O1'
parname(3)='LXYVE2O1'
parname(4)='LXYVA2O2'
parname(5)='LXYVE1O2'
parname(6)='LXYVE2O2'
parname(7)='LXYVA2O3'
parname(8)='LXYVE1O3'
parname(9)='LXYVE2O3'
! W & Z of E1
parname(10)='LXYWZE1O0'
parname(11)='LXYWZE1O1'
parname(12)='LXYWZE1O2'
parname(13)='LXYWZE1O3'
parname(14)='LXYWZE2O0'
parname(15)='LXYWZE2O1'
parname(16)='LXYWZE2O2'
parname(17)='LXYWZE2O3'
! WW and Z Pseudo between E1 and E2
! p STANDS FOR PSEUDO JAHN-TELLER
parname(18)='LXYPE1E2O0'
parname(19)='LXYPE1E2O1'
parname(20)='LXYPE1E2O2'
! no order 3
! PSEUDO A2 & E1
parname(21)='LXYPA2E1O0'
parname(22)='LXYPA2E1O1'
parname(23)='LXYPA2E1O2'
! Pseudo JAHN-TELLER BETWEEN A2 AND E1
parname(24)='LXYPA2E2O0'
parname(25)='LXYPA2E2O1'
parname(26)='LXYPA2E2O2'
parname(27)='LXYPA2E2O3'
! keys for lz
parname(28)='LZWZE1O1'
parname(29)='LZWZE1O2'
parname(30)='LZWZE2O1'
parname(31)='LZWZE2O2'
parname(33)='LZPE1E2O0'
parname(34)='LZPE1E2O1'
parname(35)='LZPE1E2O2'
parname(36)='LZPA2E1O1'
parname(37)='LZPA2E2O2'
parname(39)='LZPA2E2O1'
parname(34)='TYPE_CAL'! TYPE OF THE CALCULATION WHETHER IT IS THE TRACE OR SOMETHING ELSE
do i=1,np
do j=1,4
key(j, i)=prefix(j)//trim(parname(i))//':' ! first 86 keys are the potential keys
enddo
enddo
end subroutine
end module keys_mod

358
src/model/matrix_form.f90 Normal file
View File

@ -0,0 +1,358 @@
module data_matrix
use dim_parameter, only:ndiab,nstat,ntot,pst
! use surface_mod, only: eval_surface
contains
! subroutine trace
subroutine trace_mat(mx,my,y)
IMPLICIT NONE
integer::i
double precision,intent(inout):: y(:)
double precision, intent(in):: mx(:,:),my(:,:)
y=0.0d0
!y(1)=mx(4,4)+mx(5,5)
do i=2,3
y(1)=y(1)+mx(i,i)
y(2)=y(2)+my(i,i)
enddo
END SUBROUTINE trace_mat
!! subroutine Ydata to matrix
subroutine Y2mat(Y,Mx,My)
IMPLICIT NONE
integer:: ii,i,j
double precision, intent(in):: y(:)
double precision,intent(out):: Mx(ndiab,ndiab),My(ndiab,ndiab)
!if (ndiab .ne. 4 ) then
!write(*,*) " NDIAB should be equal to 4",NDIAB
!write(*,*) "CHECK DATA_TRANSFORM TO MAKE IT ADAPTABLE"
!stop
!endif
ii=1
do i=1,ndiab
do j=1,i
! !mx
mx(i,j)=y(ii)
! ! My
if (ntot .eq. ndiab*(ndiab+1)) then
my(i,j)=y( (ntot/2)+ii)
else
my(i,j)=y(15+ii)
end if
! remember to adjust here I added the energy
!
ii=ii+1
enddo
enddo
call copy_2_upper(mx)
call copy_2_upper(my)
end subroutine
subroutine Full_diab_upper(mx,my,y)
implicit none
double precision,intent(inout) :: y(:)
double precision, intent(in) :: mx(ndiab,ndiab), my(ndiab,ndiab)
integer i,j,ii
ii=1
y=0.0d0
do i=1,ndiab
do j=i,ndiab
! mx
y(ii) = mx(i,j)
! my
y((ntot/2)+ii) = my(i,j)
! increment the index
ii=ii+1
enddo
enddo
end subroutine Full_diab_upper
Subroutine adiabatic_transform(mx,my,U)
implicit none
double precision, intent(inout) :: mx(ndiab,ndiab), my(ndiab,ndiab)
double precision, dimension(:,:), intent(inout) :: U
double precision, dimension(ndiab,ndiab) :: temp1, temp2
integer i, j
!call transform_U(U) ! Transform the U matrix
! Transform mx and my to adiabatic basis
temp1 = matmul(mx, transpose(U))
mx = matmul(U, temp1)
temp2 = matmul(my, transpose(U))
my = matmul(U, temp2)
end subroutine adiabatic_transform
! the eigenvalue of the dipole
SUBROUTINE Eigen(mx,my,Yres)
implicit none
double precision,dimension(:,:),intent(inout) :: mx,my
double precision,dimension(:),intent(out) :: Yres
double precision,dimension(ndiab) :: vx,vy
double precision,dimension(size(mx,1),size(my,2)) :: temp
! create a temorary matrix fo the eigenvctors
double precision, allocatable :: mux(:,:), muy(:,:)
! Lapak parameters
integer :: n,info,i
integer,parameter :: lwork = 100
double precision :: work(lwork)
! temporary
double precision:: max_row
Yres = 0.0d0
Allocate(mux,source=mx)
call DSYEV('V', 'U', size(mx,1), mux, size(mx,1), vx, work, lwork, info)
mx=mux
if (info /= 0) then
write(*,*) "Error in Eigenvalue decomposition of mx info = ", info
stop
end if
deallocate(mux)
Allocate(muy,source=my)
call DSYEV('V', 'U', size(my,1), muy, size(my,1), vy, work, lwork, info)
if (info /= 0) then
write(*,*) "Error in Eigenvalue decomposition of my info = ", info
stop
end if
deallocate(muy)
Yres(1:size(mx,1)) = vx(1:size(mx,1))
do i=1,size(mx,1)
max_row=maxloc(abs(mx(:,i)),1)
!yres(size(mx,1)+i)=(mx(max_row,i))**2
!yres(size(mx,1)+i)=real(max_row)
enddo
!Yres(size(mx,1)+1:2*size(mx,1)) = vy(1:size(my,1))
end subroutine
subroutine copy_2_upper(m)
implicit none
double precision, intent(inout) :: m(:,:)
integer :: i,j
! copy the lower part of the matrix to the upper part
do i=1,size(m,1)
do j=1,i-1
m(j,i) = m(i,j)
enddo
enddo
end subroutine copy_2_upper
subroutine coppy_2_low(m)
implicit none
double precision, intent(inout) :: m(:,:)
integer :: i,j
! copy the upper part of the matrix to the lower part
do i=1,size(m,1)
do j=i+1,size(m,2)
m(j,i) = m(i,j)
enddo
enddo
end subroutine coppy_2_low
!1 SUBROUTNE BLOCKS
!! EACH BLOCK OF dIABTIC MATRIX
SUBROUTINE block_diab(mx,my,Y,block)
implicit none
double precision, intent(inout):: Y(:)
double precision, intent(in) :: mx(ndiab,ndiab), my(ndiab,ndiab)
integer, intent(in) :: block
integer i,j,ii,nn
y=0.0d0
select case (block)
case(1)
! fill the first E1 block state 2 &3
y(1)=mx(2,2)
y(2)=mx(2,3)
!y(3)=mx(3,2)
y(4)=mx(3,3)
!y(5)=my(2,2)
!y(6)=my(2,3)
!y(7)=my(3,2)
!y(8)=my(3,3)
case(2)
! fill the second E2 block state 4 & 5
y(1)=mx(4,4)
y(2)=mx(4,5)
!y(3)=mx(5,4)
y(4)=mx(5,5)
y(5)=my(4,4)
y(6)=my(4,5)
!y(7)=my(5,4)
y(8)=my(5,5)
case(3)
! Filling the pseudo block E1 and E2
y(1)=mx(2,4)
y(2)=mx(2,5)
y(3)=mx(3,4)
y(4)=mx(3,5)
y(5)=my(2,4)
y(6)=my(2,5)
y(7)=my(3,4)
y(8)=my(3,5)
case(4)
! filling the block of A2 coupling with E1
y(1)=mx(1,2)
y(2)=mx(1,3)
y(3)=mx(2,1)
y(4)=mx(3,1)
!y(5)=my(1,2)
!y(6)=my(1,3)
!y(7)=my(2,1)
!y(8)=my(3,1)
case(5)
! couplinng A2 with E2
Y(1)=mx(1,4)
Y(2)=mx(1,5)
!Y(3)=mx(4,1)
!Y(4)=mx(5,1)
Y(5)=my(1,4)
Y(6)=my(1,5)
!Y(7)=my(4,1)
!Y(8)=my(5,1)
case(6)
! Filling A only
y(1)=mx(1,1)
y(5)=my(1,1)
case default
write(*,*) "Error in block_diab subroutine, block not recognized"
write(*,*) "The block is:", block
stop
end select
end subroutine block_diab
subroutine ident(A)
implicit none
integer i,j
double precision,intent(inout)::A(:,:)
do i=1,size(A,1)
do j=1,size(A,1)
if (i==j) then
A(i,j)=1.0d0
else
A(i,j)=0.0d0
endif
enddo
enddo
end subroutine
! subroutine trasform the U matrix
subroutine transform_U(U)
implicit none
double precision, intent(inout) :: U(ndiab,ndiab)
double precision :: U_ref(ndiab,ndiab), V(ndiab,ndiab), E(nstat)
integer i,max_row
double precision:: dot_prod,q_ref(9)
logical,parameter:: dbg_sign =.true.
!q_ref= [1.000174,0.000000,0.000000,-0.503595,-0.872253,0.000000,-0.530624,0.919068,0.000000]
!call eval_surface(E,V,U_ref,q_ref,p) ! get the reference transformation matrix
do i=1,ndiab
max_row = maxloc(abs(U(:,i)),1)
if (U(max_row,i) .lt. 0) then
U(:,i) = -1*U(:,i)
endif
enddo
!dot_prod=dot_product(U(2:3,4),U_ref(2:3,4))
!if (dot_prod .lt. 0.0d0) then
! U(:,4) = -1.0d0*U(:,4)
!endif
end subroutine transform_U
subroutine write_type_calc(p,id_write)
! Subroutine to write the type of calculation
implicit none
double precision, intent(in) :: p(:)
integer, intent(in) :: id_write
integer :: type_calc, blk
type_calc = int(p(pst(1,28)))
blk = int(p(pst(1,28)+1))
if (type_calc ==1) then
write(id_write,*) "Type of calculation: TRACE"
else if (type_calc ==2) then
write(id_write,*) "Type of calculation: EIGENVALUE"
else if (type_calc ==3) then
IF (blk == 1) then
write(id_write,*) "Type of calculation: E1 BLOCK"
ELSE IF (BLK ==2) THEN
write(id_write,*) "Type of calculation: E2 BLOCK"
ELSE IF (BLK ==3) THEN
write(id_write,*) "Type of calculation: Pseudo E1 and E2 BLOCK"
ELSE IF (BLK ==4) THEN
write(id_write,*) "Type of calculation: COUPLING A2 with E1 BLOCK"
ELSE IF (BLK ==5) THEN
write(id_write,*) "Type of calculation: COUPLING A2 with E2 BLOCK"
ELSE IF (BLK ==6) THEN
write(id_write,*) "Type of calculation: A2 ONLY"
ELSE
write(id_write,*) "Type of calculation: Diabatic transformation with unknown block size", blk
END IF
else if (type_calc ==4) then
write(id_write,*) "Type of calculation: Full Diabatic Matrix"
else if (type_calc ==5) then
write(id_write,*) "Type of calculation: Transformation matrix U"
else
write(id_write,*) "Error in type of calculation:", type_calc
stop
end if
END SUBROUTINE write_type_calc
!! subroutine for writting the transformtion matrix U
subroutine Transformation_mat(temp,v,y)
implicit none
double precision, intent(in) :: temp(ndiab,ndiab), v(:)
double precision, intent(inout) :: y(:)
double precision :: U(ndiab,ndiab )
integer i,j,ii
U(1:ndiab,1:ndiab) = temp(1:ndiab,1:ndiab)
!call transform_U(U,P)
y=0.0d0
!y(1:4) = v(1:4) ! copy the first 4 elements of v to y
ii=1
do i=1,ndiab
do j=1,ndiab
y(ii) = U(i,j)
ii=ii+1
enddo
enddo
y(ii:30)=v(:)
end subroutine
! compute the overlap between U matrix
subroutine overlap(U_ref,U)
implicit none
double precision, intent(in):: U_ref(ndiab,ndiab)
double precision, intent(inout):: U(ndiab,ndiab)
double precision:: over
integer i
do i=1,ndiab
over=dot_product(U_ref(:,i),U(:,i))
if (over .lt. 0.0d0 ) then
U(:,i)=-U(:,i)
endif
enddo
end subroutine
end module

523
src/model/model.f90 Normal file
View File

@ -0,0 +1,523 @@
! Author: jnshuti
! Created: 2025-10-03 14:09:49
! Last modified: 2025-10-03 14:10:10 jnshuti
! model for L-matrix of NO3 radical
module diab_mod:
use accuracy_constants, only: dp, idp
use dim_parameter, only: ndiab, nstat, ntot,npar,qn,pst
implicit none
contains
subroutine Lx_diab(E,q,t,p)
implicit none
real(dp),dimension(ndiab,ndiab), intent(out):: E
real(dp),dimension(:),intent(in):: q,t
real(dp),dimension(npar),intent(in):: p
real(dp):: xs,ys,xb,yb,a,b
real(dp):: v3_vec(8)
integer(idp):: i,j,id
! check the dimension of the matrix
if (size(E,1) .ne. ndiab) then
write(*,*) " Error in Lx_diab: wrong dimension of L matrix ", size(E,1)
stop
endif
! rewrite the coordinate array q into symmetry adapted coordinates
call rewrite_coord(q,a,xs,ys,xb,yb,b,1)
e(1,1)=e(1,1)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb ! 2 param
id=id+1 ! 2
e(2,2)=e(2,2)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb ! 2 p
e(3,3)=e(3,3)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb
id =id+1 ! 3
e(4,4)=e(4,4)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb ! 2 p
e(5,5)=e(5,5)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb
id=id+1 ! 4
! order 2
e(1,1)=e(1,1)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) & ! 5 p
+p(pst(1,id)+2)*(xs*xb-ys*yb)
id =id+1 ! 5
e(2,2)=e(2,2)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) &
+p(pst(1,id)+2)*(xs*xb-ys*yb)
e(3,3)=e(3,3)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) &
+p(pst(1,id)+2)*(xs*xb-ys*yb)
id =id+1 ! 6
e(4,4)=e(4,4)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) &
+p(pst(1,id)+2)*(xs*xb-ys*yb)
e(5,5)=e(5,5)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) &
+p(pst(1,id)+2)*(xs*xb-ys*yb)
! order 3
id=id+1 ! 7
e(1,1)=e(1,1)+p(pst(1,id))*xs*ss+p(pst(1,id)+1)*xb *sb ! 2 param
id=id+1 ! 8
e(2,2)=e(2,2)+p(pst(1,id))*xs*ss+p(pst(1,id)+1)*xb *sb ! 2 p
e(3,3)=e(3,3)+p(pst(1,id))*xs*ss+p(pst(1,id)+1)*xb*sb
id =id+1 ! 9
e(4,4)=e(4,4)+p(pst(1,id))*xs*ss+p(pst(1,id)+1)*xb*sb ! 2 p
e(5,5)=e(5,5)+p(pst(1,id))*xs*ss+p(pst(1,id)+1)*xb*sb
! W and Z term of E1
! order 0
id=id+1 ! 10
e(2,2)=e(2,2)+p(pst(1,id))
e(3,3)=e(3,3)-p(pst(1,id))
!e(2,3)=e(2,3)
! order 1
id=id+1 ! 11 ! 2 param
e(2,2)=e(2,2)+ p(pst(1,id))*xs+p(pst(1,id)+1)*xb
e(3,3)=e(3,3)- (p(pst(1,id))*xs+p(pst(1,id)+1)*xb)
e(2,3)=e(2,3)- p(pst(1,id))*ys -p(pst(1,id)+1)*yb
! order 2
id=id+1 ! 12 ! 3p
do i=1,3
e(2,2)=e(2,2)+p(pst(1,id)+(i-1))*v2(i)
e(3,3)=e(3,3)-p(pst(1,id)+(i-1))*v2(i)
e(2,3)=e(2,3)+ p(pst(1,id)+(i-1))*v2(i+3)
enddo
! order 3
id=id+1 ! 13 ! 8 param
do i=1,4
e(2,2)=e(2,2)+(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3(i)
e(3,3)=e(3,3)-(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3(i)
e(2,3)=e(2,3)+(-p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3(i+4)
enddo
! try the testing of higher order terms
!e(2,3)=e(2,3)- p(pst(1,id))*ys*ss +p(pst(1,id)+1)*ss*2*xs*ys
! W and Z for E2
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
id=id+1 ! 14
e(4,4)=e(4,4)+p(pst(1,id))
e(5,5)=e(5,5)-p(pst(1,id))
e(4,5)=e(4,5)
! order 1
id=id+1 ! 2 param 15
e(4,4)=e(4,4)+ p(pst(1,id))*xs+p(pst(1,id)+1)*xb
e(5,5)=e(5,5)- (p(pst(1,id))*xs+p(pst(1,id)+1)*xb)
e(4,5)=e(4,5)- p(pst(1,id))*ys-p(pst(1,id)+1)*yb
! order 2
id=id+1 ! 16 ! 3p
do i=1,3
e(4,4)=e(4,4)+p(pst(1,id)+(i-1))*v2(i)
e(5,5)=e(5,5)-p(pst(1,id)+(i-1))*v2(i)
e(4,5)=e(4,5)+ p(pst(1,id)+(i-1))*v2(i+3)
enddo
! order 3
id=id+1 ! 17 ! 8 param
do i=1,4
e(4,4)=e(4,4)+(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3(i)
e(5,5)=e(5,5)-(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3(i)
e(4,5)=e(4,5)+(-p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3(i+4)
enddo
! make the dipole E = b* E
e = b * e
! E1 X E2
! WW and ZZ
id =id+1 ! 18
e(2,4)=e(2,4)+p(pst(1,id))*b
e(3,5)=e(3,5)-p(pst(1,id))*b
! ORDER 1
id=id+1 ! 19 ! 6 parama
e(2,4)=e(2,4)+b*((p(pst(1,id))+p(pst(1,id)+1)+p(pst(1,id)+2))*xs+(p(pst(1,id)+3)+p(pst(1,id)+4)+p(pst(1,id)+5))*xb)
e(3,5)=e(3,5)+b*((p(pst(1,id))+p(pst(1,id)+1)-p(pst(1,id)+2))*xs+(p(pst(1,id)+3)+p(pst(1,id)+4)-p(pst(1,id)+5))*xb)
e(2,5)=e(2,5)+b*((p(pst(1,id))-p(pst(1,id)+1)-p(pst(1,id)+2))*ys+(p(pst(1,id)+3)-p(pst(1,id)+4)-p(pst(1,id)+5))*yb)
e(3,4)=e(3,4)+b*((-p(pst(1,id))+p(pst(1,id)+1)-p(pst(1,id)+2))*ys+(-p(pst(1,id)+3)+p(pst(1,id)+4)-p(pst(1,id)+5))*yb)
! order 2
id=id+1 ! 20
do i=1,3 ! 9 param
e(2,4)=e(2,4)+b*(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+2))+p(pst(1,id)+(i+5)))*v2(i)
e(3,5)=e(3,5)+b*(-p(pst(1,id)+(i-1))+p(pst(1,id)+(i+2))+p(pst(1,id)+(i+5)))*v2(i)
e(2,5)=e(2,5)+b*(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+2))-p(pst(1,id)+(i+5)))*v2(i+3)
e(3,4)=e(3,4)+b*(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+2))+p(pst(1,id)+(i+5)))*v2(i+3)
enddo
! pseudo A2 & E1
! ##################################################
!###################################################
! order 0
id=id+1 ! 1 param ! 21
e(1,3)=e(1,3)+b*(p(pst(1,id)))
! order 1
id = id +1 ! 22
e(1,2)=e(1,2)-b*(p(pst(1,id))*ys + p(pst(1,id)+1)*yb)
e(1,3)=e(1,3)+b*(p(pst(1,id))*xs + p(pst(1,id)+1)*xb)
! order 2
id=id+1 ! 23
e(1,2)=e(1,2)+b*(p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)+p(pst(1,id)+2)*(xs*yb+xb*ys))
e(1,3)=e(1,3)+b*(p(pst(1,id))*(xs**2-ys**2) + p(pst(1,id)+1)*(xb**2-yb**2) &
+p(pst(1,id)+2)*(xs*xb-ys*yb))
! COUPLING OF A2 WITH E2
!##########################################################################################################
! order 0
id =id+1 !24
e(1,5)=e(1,5)+p(pst(1,id))
! order 1
id = id +1 ! 25
e(1,4)=e(1,4)-(p(pst(1,id))*ys + p(pst(1,id)+1)*yb)
e(1,5)=e(1,5)+(p(pst(1,id))*xs + p(pst(1,id)+1)*xb)
! order 2
id=id+1 ! 26
e(1,4)=e(1,4)+p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)+p(pst(1,id)+2)*(xs*yb+xb*ys)
e(1,5)=e(1,5)+p(pst(1,id))*(xs**2-ys**2) + p(pst(1,id)+1)*(xb**2-yb**2) &
+p(pst(1,id)+2)*(xs*xb-ys*yb)
! order 3
id=id+1 ! 27 ! 8 param
do i=1,4
e(1,4)=e(1,4)+(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+3)))*v3(i+4)
e(1,5)=e(1,5)+(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3(i)
enddo
e(1,4:5) = b* e(1,4:5)
call copy_2_lower_triangle(e)
end subroutine Lx_diab
! Ly matrix
subroutine Ly_diab(e,q,t,p)
implicit none
real(dp),dimension(ndiab,ndiab), intent(out):: e
real(dp),dimension(:),intent(in):: q,t
real(dp),dimension(npar),intent(in):: p
real(dp):: xs,ys,xb,yb,a,b
real(dp):: v3_vec(8)
integer(idp):: i,j,id
! check the dimension of the matrix
if (size(e,1) .ne. ndiab) then
write(*,*) " Error in Ly_diab: wrong dimension of L matrix ", size(e,1)
stop
endif
! rewrite the coordinate array q into symmetry adapted coordinates
call rewrite_coord(q,a,xs,ys,xb,yb,b,1)
e=0.0d0
ss=xs**2+ys**2 ! totaly symmetric term
sb=xb**2+yb**2
v3( 1) = xs*(xs**2-3*ys**2)
v3( 2) = xb*(xb**2-3*yb**2)
v3( 3) = xb*(xs**2-ys**2) - 2*yb*xs*ys
v3( 4) = xs*(xb**2-yb**2) - 2*ys*xb*yb
v3( 5) = ys*(3*xs**2-ys**2)
v3( 6) = yb*(3*xb**2-yb**2)
v3( 7) = yb*(xs**2-ys**2)+2*xb*xs*ys
v3( 8) = ys*(xb**2-yb**2)+2*xs*xb*yb
e=0.0d0
! V-term
id=1 ! 1
! order 1
e(1,1)=e(1,1)+p(pst(1,id))*ys + p(pst(1,id)+1)*yb
id=id+1 ! 2
e(2,2)=e(2,2)+p(pst(1,id))*ys + p(pst(1,id)+1)*yb
e(3,3)=e(3,3)+p(pst(1,id))*ys + p(pst(1,id)+1)*yb
id =id+1 ! 3
e(4,4)=e(4,4)+p(pst(1,id))*ys + p(pst(1,id)+1)*yb
e(5,5)=e(5,5)+p(pst(1,id))*ys + p(pst(1,id)+1)*yb
id=id+1 ! 4b*(
e(1,1)=e(1,1)-(p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)+p(pst(1,id)+2)*(xs*yb+xb*ys))
id =id+1 ! 5
e(2,2)=e(2,2)-(p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)+p(pst(1,id)+2)*(xs*yb+xb*ys))
e(3,3)=e(3,3)-(p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)+p(pst(1,id)+2)*(xs*yb+xb*ys))
id=id+1 ! 6
e(4,4)=e(4,4)-(p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)+p(pst(1,id)+2)*(xs*yb+xb*ys))
e(5,5)=e(5,5)-(p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)+p(pst(1,id)+2)*(xs*yb+xb*ys))
! order 3
id=id+1 ! 7
e(1,1)=e(1,1)+p(pst(1,id))*ys*ss + p(pst(1,id)+1)*yb*sb
id=id+1 ! 2
e(2,2)=e(2,2)+p(pst(1,id))*ys*ss + p(pst(1,id)+1)*yb*sb
e(3,3)=e(3,3)+p(pst(1,id))*ys*ss + p(pst(1,id)+1)*yb*sb
id =id+1 ! 3
e(4,4)=e(4,4)+p(pst(1,id))*ys*ss + p(pst(1,id)+1)*yb*sb
e(5,5)=e(5,5)+p(pst(1,id))*ys*ss + p(pst(1,id)+1)*yb*sb
! W and Z of E1
! order 0
id=id+1 ! 10
e(2,3)=e(2,3)+p(pst(1,id))
! order 1
id=id+1 !
e(2,2)=e(2,2)-p(pst(1,id))*ys -p(pst(1,id)+1)*yb
e(3,3)=e(3,3)+p(pst(1,id))*ys+ p(pst(1,id)+1)*yb
e(2,3)=e(2,3)-p(pst(1,id))*xs -p(pst(1,id)+1)*xb
! order 2
id=id+1 ! 12
do i=1,3
e(2,2)=e(2,2)+p(pst(1,id)+(i-1))*v2(i+3)
e(3,3)=e(3,3)-p(pst(1,id)+(i-1))*v2(i+3)
e(2,3)=e(2,3)-p(pst(1,id)+(i-1))*v2(i)
enddo
id=id+1 ! 8
do i=1,4
e(2,2)=e(2,2)+(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+3)))*v3(i+4)
e(3,3)=e(3,3)-(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+3)))*v3(i+4)
e(2,3)=e(2,3)+(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3(i)
enddo
!! W and Z of E2
!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! order 0
id=id+1 ! 14
e(4,5)=e(4,5)+p(pst(1,id))
! order 1
id=id+1 ! 15
e(4,4)=e(4,4)-p(pst(1,id))*ys -p(pst(1,id)+1)*yb
e(5,5)=e(5,5)+p(pst(1,id))*ys+ p(pst(1,id)+1)*yb
e(4,5)=e(4,5)-p(pst(1,id))*xs -p(pst(1,id)+1)*xb
! order 2
id=id+1 ! 16
do i=1,3
e(4,4)=e(4,4)+p(pst(1,id)+(i-1))*v2(i+3)
e(5,5)=e(5,5)-p(pst(1,id)+(i-1))*v2(i+3)
e(4,5)=e(4,5)-p(pst(1,id)+(i-1))*v2(i)
enddo
id=id+1 ! 17
do i=1,4
e(4,4)=e(4,4)+(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+3)))*v3(i+4)
e(5,5)=e(5,5)-(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+3)))*v3(i+4)
e(4,5)=e(4,5)+(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3(i)
enddo
! PSEUDO JAHN-TELLER E1 AND E2
e = b* e
!ORDER 0
id=id+1 ! 18
e(2,5)=e(2,5)+p(pst(1,id))
e(3,4)=e(3,4)+p(pst(1,id))
! order 1
id=id+1
e(2,4)=e(2,4)+((p(pst(1,id))+p(pst(1,id)+1)-p(pst(1,id)+2))*ys+(p(pst(1,id)+3)+p(pst(1,id)+4)-p(pst(1,id)+5))*yb)
e(3,5)=e(3,5)+((p(pst(1,id))+p(pst(1,id)+1)+p(pst(1,id)+2))*ys+(p(pst(1,id)+3)+p(pst(1,id)+4)+p(pst(1,id)+5))*yb)
e(2,5)=e(2,5)+((-p(pst(1,id))+p(pst(1,id)+1)-p(pst(1,id)+2))*xs+(-p(pst(1,id)+3)+p(pst(1,id)+4)-p(pst(1,id)+5))*xb)
e(3,4)=e(3,4)+((p(pst(1,id))-p(pst(1,id)+1)-p(pst(1,id)+2))*xs+(+p(pst(1,id)+3)-p(pst(1,id)+4)-p(pst(1,id)+5))*xb)
! order 2
id=id+1
e(2,4)=e(2,4)+(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+2))-p(pst(1,id)+(i+5)))*v2(i+3)
e(3,5)=e(3,5)+(-p(pst(1,id)+(i-1))-p(pst(1,id)+(i+2))-p(pst(1,id)+(i+5)))*v2(i+3)
e(2,5)=e(2,5)+(-p(pst(1,id)+(i-1))+p(pst(1,id)+(i+2))-p(pst(1,id)+(i+5)))*v2(i)
e(3,4)=e(3,4)+(-p(pst(1,id)+(i-1))-p(pst(1,id)+(i+2))+p(pst(1,id)+(i+5)))*v2(i)
! no order 3
!!!!!!!!!!!!!!!!
! the coupling A2 & E1
! #####################
! order 0
id=id+1
e(1,2)=e(1,2)+(p(pst(1,id)))
! order 1
id=id+1
e(1,2)=e(1,2)-(p(pst(1,id))*xs + p(pst(1,id)+1)*xb)
e(1,3)=e(1,3)-(p(pst(1,id))*ys + p(pst(1,id)+1)*yb)
! order 2
id=id+1
e(1,2)=e(1,2)-(p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) &
+p(pst(1,id)+2)*(xs*xb-ys*yb))
e(1,3)=e(1,3)+(p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)+ &
+p(pst(1,id)+2)*(xs*yb+xb*ys))
! COUPLING OF A2 WITH E2
!#######################################################################################
!###############################################################################
! order 0
id = id+1
e(1,4)=e(1,4)+p(pst(1,id))
! order 1
id=id+1
e(1,4)=e(1,4)-(p(pst(1,id))*xs + p(pst(1,id)+1)*xb)
e(1,5)=e(1,5)-(p(pst(1,id))*ys + p(pst(1,id)+1)*yb)
! order 2
id=id+1
e(1,4)=e(1,4)-(p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) &
+p(pst(1,id)+2)*(xs*xb-ys*yb))
e(1,5)=e(1,5)+(p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)+ &
p(pst(1,id)+2)*(xs*yb+xb*ys))
!write(*,*)'idy=',id
e(1:4,5) = b * e(1:4,5)
call copy_2_lower_triangle(e)
end subroutine Ly_diab
! Lz matrix
subroutine Lz_diab(e,q,t,p)
implicit none
real(dp),dimension(ndiab,ndiab), intent(out):: e
real(dp),dimension(:),intent(in):: q,t
real(dp),dimension(npar),intent(in):: p
real(dp):: xs,ys,xb,yb,a,b
real(dp):: v3_vec(8)
integer(idp):: i,j
! check the dimension of the matrix
if (size(e,1) .ne. ndiab) then
write(*,*) " Error in Lz_diab: wrong dimension of e matrix ", size(e,1)
stop
endif
call rewrite_coord(q,a,xs,xb,yb,b,1)
e = 0.0_dp
! id for lz
id = ! has to be
! the diagonal terms
! the v-term is 0th order and 3rd order.
! There is no zeroth order for diagonal
! w and z of E''
! order 1
id =id +1
e(2,2) = e(2,2) + p(pst(1,id))*ys + p(pst(1,id)+1)*yb
e(3,3) = e(3,3) - p(pst(1,id))*ys - p(pst(1,id)+1)*yb
e(2,3) = e(2,3) - p(pst(1,id))*xs -p(pst(1,id)+1)*xb
! order 2
id = id +1
do i =1,3
e(2,2) = e(2,2) + p(pst(1,id)+(i-1))*v2(i+3)
e(3,3) = e(3,3) - p(pst(1,id)+(i-1))*v2(i+3)
e(2,3) = e(2,3) + p(pst(1,id)+(i-1))*v2(i)
enddo
! W and Z of E'
! order 1
id = id +1
e(4,4) = e(4,4) + p(pst(1,id))*ys + p(pst(1,id)+1)*yb
e(5,5) = e(5,5) - p(pst(1,id))*ys - p(pst(1,id)+1)*yb
e(4,5) = e(4,5) - p(pst(1,id))*xs -p(pst(1,id)+1)*xb
! order 2
id = id +1
do i =1,3
e(4,4) = e(4,4) + p(pst(1,id)+(i-1))*v2(i+3)
e(5,5) = e(5,5) - p(pst(1,id)+(i-1))*v2(i+3)
e(4,5) = e(4,5) + p(pst(1,id)+(i-1))*v2(i)
enddo
! the coupling
! Pseudo of E' and E''
! it must have odd power of b
id = id +1
! order 0
e(2,4) = e(2,4)
e(3,5) = e(3,5)
e(2,5) = e(2,5) + b*(p(pst(1,id)))
e(3,4) = e(3,4) - b*(p(pst(1,id)))
! order 1
id = id +1
e(2,4) = e(2,4) + b*(p(pst(1,id))*ys + p(pst(1,id)+1)*yb)
e(3,5) = e(3,5) + b*(p(pst(1,id))*ys + p(pst(1,id)+1)*yb)
e(2,5) = e(2,5) - b*(p(pst(1,id))*xs + p(pst(1,id)+1)*xb)
e(3,4) = e(3,4) + b*(p(pst(1,id))*xs + p(pst(1,id)+1)*xb)
! order 2
id = id +1
do i=1,3
e(2,4) = e(2,4) + b*(p(pst(1,id)+(i-1)))*v2(i+3)
e(3,5) = e(3,5) + b*(p(pst(1,id)+(i-1)))*v2(i+3)
e(2,5) = e(2,5) + b*(p(pst(1,id)+(i-1)))*v2(i)
e(3,4) = e(3,4) - b*(p(pst(1,id)+(i-1)))*v2(i)
enddo
! no third order
! the coupling between A2' and E''
! order 1
id = id +1
e(1,2) = e(1,2) + b*(p(pst(1,id))*xs + p(pst(1,id)*xb))
e(1,3) = e(1,3) - b*(p(pst(1,id))*ys + p(pst(1,id)*yb))
id = id +1
! order 2
do i=1,3
e(1,2) = e(1,2) + b*(p(pst(1,id)+(i-1)))*v2(i)
e(1,3) = e(1,3) + b*(p(pst(1,id)+(i-1)))*v2(i+3)
enddo
! the coupling of A2' and E'
! order 1
id = id +1
e(1,2) = e(1,2) + (p(pst(1,id))*xs + p(pst(1,id)*xb))
e(1,3) = e(1,3) - (p(pst(1,id))*ys + p(pst(1,id)*yb))
id = id +1
! order 2
do i=1,3
e(1,2) = e(1,2) + (p(pst(1,id)+(i-1)))*v2(i)
e(1,3) = e(1,3) + (p(pst(1,id)+(i-1)))*v2(i+3)
enddo
call copy_2_lower_triangle(e)
end subroutine Lz_diab
subroutine rewrite_coord(q,a,xs,ys,xb,yb,b,start)
implicit none
real(dp),dimension(:),intent(in):: q
real(dp),intent(out):: xs,ys,xb,yb,a,b
integer(idp),intent(in):: start
integer(idp):: i,j
a= q(start)
xs = q(start+1)
ys = q(start+2)
xb = q(start+3)
yb = q(start+4)
b = q(start+5)
end subroutine rewrite_coord
end module diab_mod

43
src/model/nnparams.incl Normal file
View File

@ -0,0 +1,43 @@
!**** Declarations
real*8 pi
real*8 hart2eV, eV2hart
real*8 hart2icm, icm2hart
real*8 eV2icm, icm2eV
real*8 deg2rad, rad2deg
integer maxnin,maxnout
!**********************************************************
!**** Parameters
!*** maxnin: max. number of neurons in input layer
!*** maxnout: max. number of neurons in output layer
parameter (maxnin=14,maxnout=15)
!**********************************************************
!**** Numerical Parameters
!*** infty: largest possible double precision real value.
!*** iinfty: largest possible integer value.
! 3.14159265358979323846264338327950...
parameter (pi=3.1415926536D0)
!**********************************************************
!**** Unit Conversion Parameters
!*** X2Y: convert from X to Y.
!***
!*** hart: hartree
!*** eV: electron volt
!*** icm: inverse centimeters (h*c/cm)
!****
!*** deg: degree
!*** rad: radians
parameter (hart2icm=219474.69d0)
parameter (hart2eV=27.211385d0)
parameter (eV2icm=hart2icm/hart2eV)
parameter (icm2hart=1.0d0/hart2icm)
parameter (eV2hart=1.0d0/hart2eV)
parameter (icm2eV=1.0d0/eV2icm)
parameter (deg2rad=pi/180.0d0)
parameter (rad2deg=1.0d0/deg2rad)

85
src/model/surface_mod.f90 Normal file
View File

@ -0,0 +1,85 @@
module surface_mod
use accuracy_constants, only: dp
implicit none
private
public eval_surface
contains
subroutine eval_surface(e, w, u, x1)
use accuracy_constants, only: dp, idp
use dim_parameter, only: ndiab
implicit none
real(dp), dimension(:, :), intent(out) :: w, u
real(dp), dimension(:), intent(out) :: e
real(dp), dimension(:), intent(in) :: x1
real(dp), allocatable, dimension(:, :) :: Mat
! debug parameter
logical, parameter:: dbg=.false.
integer(kind=idp):: i,j
! lapack variables
integer(kind=idp), parameter :: lwork = 1000
real(kind=dp) work(lwork)
integer(kind=idp) info
!write(*,*)"# Calling the potential routine "
call init_pot_para
call potentialno35s(W,X1)
allocate (Mat, source=w)
call dsyev('V', 'U', ndiab, Mat, ndiab, e, work, lwork, info)
if( info .ne. 0) then
write(*,*) " Error in eigenvalues decomposition routine of potential info=", info
stop
endif
u(:, :) = Mat(:, :)
deallocate (Mat)
if (dbg) then
do i=1,ndiab
write(19,99) e(i),(U(i,j),j=1,ndiab)
enddo
write(19,*)""
endif
99 format(2x,f16.8,2X,5f16.8)
end subroutine eval_surface
! subroutine init_surface(p)
! use dim_parameter, only: ndiab, nstat, ntot, nci ,qn
! use parameterkeys, only: parameterkey_read
! use fileread_mod, only: get_datfile, internalize_datfile
! use io_parameters, only: llen
! use accuracy_constants, only: dp
! implicit none
! real(dp), dimension(:), allocatable, intent(out) :: p
! character(len=llen), allocatable, dimension(:) :: infile
!
! qn = 9
! ndiab = 4
! nstat = 4
! nci = 4
! ntot = ndiab + nstat + nci
!
! block
! character(len=:),allocatable :: datnam
! integer :: linenum
! !get parameter file
! call get_datfile(datnam)
! !internalize datfile
! call internalize_datfile(datnam, infile, linenum, llen)
! end block
!
! !read parameters from file
! block
! real(dp), dimension(:), allocatable :: p_spread
! integer,dimension(:),allocatable :: p_act
! integer :: npar
! real(dp), parameter :: facspread = 1.0_dp, gspread = 1.0_dp
! call parameterkey_read(infile, size(infile, 1), p, p_act, p_spread, npar, gspread, facspread)
! end block
! end subroutine init_surface
end module surface_mod

38
src/model/trans/JTmod.incl Normal file
View File

@ -0,0 +1,38 @@
!*** Relevant parameters for the analytic model
!*** offsets:
!*** offsets(1): morse equilibrium (N-H, Angström)
!*** offsets(2): reference angle (H-N-H)
!*** offsets(3): --
!*** pat_index: vector giving the position of the
!*** various coordinates (see below)
!*** ppars: polynomial parameters for tmcs
!*** vcfs: coefficients for V expressions.
!*** wzcfs: coefficients for W & Z expressions.
!*** ifc: inverse factorials.
integer matdim
parameter (matdim=5) ! matrix is (matdim)x(matdim)
real*8 offsets(2)
integer pat_index(maxnin)
! NH3 params
parameter (offsets=[1.0228710942d0,120.d0])
!##########################################################################
! coordinate order; the first #I number of coords are given to the
! ANN, where #I is the number of input neurons. The position i in
! pat_index corresponds to a coordinate, the value of pat_index(i)
! signifies its position.
!
! The vector is ordered as follows:
! a,xs,ys,xb,yb,b,rs**2,rb**2,b**2,
! es*eb, es**3, eb**3,es**2*eb, es*eb**2
! ri**2 := xi**2+yi**2 = ei**2; ei := (xi,yi), i = s,b
!
! parts not supposed to be read by ANN are marked by ';' for your
! convenience.
!##########################################################################
! a,rs**2,rb**2,es*eb,es**3,eb**3,es**2*eb,es*eb**2,b**2 #I=9 (6D)
parameter (pat_index=[1,2,3,4,5,6,7,8,9,10,11,12,13,14])
!**************************************************************************

260
src/model/trans/cart2int.f Normal file
View File

@ -0,0 +1,260 @@
subroutine cart2int(cart,qint)
implicit none
! This version merges both coordinate transformation routines into
! one. JTmod's sscales(2:3) are ignored.
! This is the first version to be compatible with one of my proper 6D fits
! Time-stamp: <2024-10-22 13:52:59 dwilliams>
! Input (cartesian, in Angström)
! cart(:,1): N
! cart(:,1+i): Hi
! Output
! qint(i): order defined in JTmod.
! Internal Variables
! no(1:3): NO distances 1-3
! pat_in: temporary coordinates
! axis: main axis of NO3
include 'nnparams.incl'
include 'JTmod.incl'
real*8 cart(3,4),qint(maxnin)
real*8 no(3), r1, r2, r3
real*8 v1(3), v2(3), v3(3)
real*8 n1(3), n2(3), n3(3), tr(3)
real*8 ortho(3)
real*8 pat_in(maxnin)
logical ignore_umbrella,dbg_umbrella
logical dbg_distances
!.. Debugging parameters
!.. set umbrella to 0
parameter (ignore_umbrella=.false.)
! parameter (ignore_umbrella=.true.)
!.. break if umbrella is not 0
parameter (dbg_umbrella=.false.)
! parameter (dbg_umbrella=.true.)
!.. break for tiny distances
parameter (dbg_distances=.false.)
! parameter (dbg_distances=.true.)
integer k
!.. get N-O vectors and distances:
do k=1,3
v1(k)=cart(k,2)-cart(k,1)
v2(k)=cart(k,3)-cart(k,1)
v3(k)=cart(k,4)-cart(k,1)
enddo
no(1)=norm(v1,3)
no(2)=norm(v2,3)
no(3)=norm(v3,3)
!.. temporarily store displacements
do k=1,3
pat_in(k)=no(k)-offsets(1)
enddo
do k=1,3
v1(k)=v1(k)/no(1)
v2(k)=v2(k)/no(2)
v3(k)=v3(k)/no(3)
enddo
!.. compute three normal vectors for the ONO planes:
call xprod(n1,v1,v2)
call xprod(n2,v2,v3)
call xprod(n3,v3,v1)
do k=1,3
tr(k)=(n1(k)+n2(k)+n3(k))/3.d0
enddo
r1=norm(tr,3)
do k=1,3
tr(k)=tr(k)/r1
enddo
! rotate trisector
call rot_trisec(tr,v1,v2,v3)
!.. determine trisector angle:
if (ignore_umbrella) then
pat_in(7)=0.0d0
else
pat_in(7)=pi/2.0d0 - acos(scalar(v1,tr,3))
pat_in(7)=sign(pat_in(7),cart(1,2))
endif
!.. molecule now lies in yz plane, compute projected ONO angles:
v1(1)=0.d0
v2(1)=0.d0
v3(1)=0.d0
r1=norm(v1,3)
r2=norm(v2,3)
r3=norm(v3,3)
do k=2,3
v1(k)=v1(k)/r1
v2(k)=v2(k)/r2
v3(k)=v3(k)/r3
enddo
! make orthogonal vector to v3
ortho(1)=0.0d0
ortho(2)=v3(3)
ortho(3)=-v3(2)
!.. projected ONO angles in radians
pat_in(4)=get_ang(v2,v3,ortho)
pat_in(5)=get_ang(v1,v3,ortho)
pat_in(6)=dabs(pat_in(5)-pat_in(4))
!.. account for rotational order of atoms
if (pat_in(4).le.pat_in(5)) then
pat_in(5)=2*pi-pat_in(4)-pat_in(6)
else
pat_in(4)=2*pi-pat_in(5)-pat_in(6)
endif
pat_in(4)=rad2deg*pat_in(4)-offsets(2)
pat_in(5)=rad2deg*pat_in(5)-offsets(2)
pat_in(6)=rad2deg*pat_in(6)-offsets(2)
pat_in(7)=rad2deg*pat_in(7)
call genANN_ctrans(pat_in)
qint(:)=pat_in(:)
contains
!-------------------------------------------------------------------
! compute vector product n1 of vectors v1 x v2
subroutine xprod(n1,v1,v2)
implicit none
real*8 n1(3), v1(3), v2(3)
n1(1) = v1(2)*v2(3) - v1(3)*v2(2)
n1(2) = v1(3)*v2(1) - v1(1)*v2(3)
n1(3) = v1(1)*v2(2) - v1(2)*v2(1)
end subroutine
!-------------------------------------------------------------------
! compute scalar product of vectors v1 and v2:
real*8 function scalar(v1,v2,n)
implicit none
integer i, n
real*8 v1(*), v2(*)
scalar=0.d0
do i=1,n
scalar=scalar+v1(i)*v2(i)
enddo
end function
!-------------------------------------------------------------------
! compute norm of vector:
real*8 function norm(x,n)
implicit none
integer i, n
real*8 x(*)
norm=0.d0
do i=1,n
norm=norm+x(i)**2
enddo
norm=sqrt(norm)
end function
!-------------------------------------------------------------------
subroutine rot_trisec(tr,v1,v2,v3)
implicit none
real*8 tr(3),v1(3),v2(3),v3(3)
real*8 vrot(3)
real*8 rot_ax(3)
real*8 cos_phi,sin_phi
! evaluate cos(-phi) and sin(-phi), where phi is the angle between
! tr and (1,0,0)
cos_phi=tr(1)
sin_phi=dsqrt(tr(2)**2+tr(3)**2)
if (sin_phi.lt.1.0d-12) then
return
endif
! determine rotational axis
rot_ax(1) = 0.0d0
rot_ax(2) = tr(3)
rot_ax(3) = -tr(2)
! normalize
rot_ax=rot_ax/sin_phi
! now the rotation can be done using Rodrigues' rotation formula
! v'=v*cos(p) + (k x v)sin(p) + k (k*v) (1-cos(p))
! for v=tr k*v vanishes by construction:
! check that the rotation does what it should
call rodrigues(vrot,tr,rot_ax,cos_phi,sin_phi)
if (dsqrt(vrot(2)**2+vrot(3)**2).gt.1.0d-12) then
write(6,*) "ERROR: BROKEN TRISECTOR"
stop
endif
tr=vrot
call rodrigues(vrot,v1,rot_ax,cos_phi,sin_phi)
v1=vrot
call rodrigues(vrot,v2,rot_ax,cos_phi,sin_phi)
v2=vrot
call rodrigues(vrot,v3,rot_ax,cos_phi,sin_phi)
v3=vrot
end subroutine
!-------------------------------------------------------------------
subroutine rodrigues(vrot,v,axis,cos_phi,sin_phi)
implicit none
real*8 vrot(3),v(3),axis(3)
real*8 cos_phi,sin_phi
real*8 ortho(3)
call xprod(ortho,axis,v)
vrot = v*cos_phi + ortho*sin_phi
> + axis*scalar(axis,v,3)*(1-cos_phi)
end subroutine
!-------------------------------------------------------------------
real*8 function get_ang(v,xaxis,yaxis)
implicit none
! get normalized [0:2pi) angle from vectors in the yz plane
real*8 v(3),xaxis(3),yaxis(3)
real*8 phi
real*8 pi
parameter (pi=3.141592653589793d0)
phi=atan2(scalar(yaxis,v,3),scalar(xaxis,v,3))
if (phi.lt.0.0d0) then
phi=2*pi+phi
endif
get_ang=phi
end function
end subroutine cart2int

88
src/model/trans/ctrans.f Normal file
View File

@ -0,0 +1,88 @@
!-------------------------------------------------------------------
! Time-stamp: "2024-10-09 13:33:50 dwilliams"
subroutine genANN_ctrans(pat_in)
implicit none
include 'nnparams.incl'
include 'JTmod.incl'
real*8 pat_in(maxnin)
real*8 raw_in(maxnin),off_in(maxnin),ptrans_in(7)
real*8 r0
real*8 a,b,xs,ys,xb,yb
integer k
off_in(1:7)=pat_in(1:7)
r0=offsets(1)
! transform primitives
! recover raw distances from offset coords
do k=1,3
raw_in(k)=off_in(k)+offsets(1)
enddo
do k=1,3
ptrans_in(k)=off_in(k)
enddo
! rescale ONO angles
ptrans_in(4)=deg2rad*off_in(4)
ptrans_in(5)=deg2rad*off_in(5)
ptrans_in(6)=deg2rad*off_in(6)
! rescale umbrella
ptrans_in(7)=off_in(7)*deg2rad
! compute symmetry coordinates
! A (breathing)
a=(ptrans_in(1)+ptrans_in(2)+ptrans_in(3))/dsqrt(3.0d0)
! ES
call prim2emode(ptrans_in(1:3),xs,ys)
! EB
call prim2emode(ptrans_in(4:6),xb,yb)
! B (umbrella)
b=ptrans_in(7)
! overwrite input with output
pat_in(pat_index(1))=a ! 1
pat_in(pat_index(2))=xs
pat_in(pat_index(3))=ys
pat_in(pat_index(4))=xb
pat_in(pat_index(5))=yb
pat_in(pat_index(6))=b
! totally symmetric monomials
pat_in(pat_index(7))=xs**2 + ys**2 ! 2
pat_in(pat_index(8))=xb**2 + yb**2 ! 3
pat_in(pat_index(9))=b**2 ! 9
pat_in(pat_index(10))=xs*xb+ys*yb ! 4
! S^3, B^3
pat_in(pat_index(11))=xs*(xs**2-3*ys**2) ! 5
pat_in(pat_index(12))=xb*(xb**2-3*yb**2) ! 6
! S^2 B, S B^2
pat_in(pat_index(13))=xb*(xs**2-ys**2) - 2*yb*xs*ys ! 7
pat_in(pat_index(14))=xs*(xb**2-yb**2) - 2*ys*xb*yb ! 8
do k=11,14
pat_in(pat_index(k))=tanh(0.1d0*pat_in(pat_index(k)))*10.0d0
enddo
contains
subroutine prim2emode(prim,ex,ey)
implicit none
! Takes a 2D-vector prim and returns the degenerate modes x and y
! following our standard conventions.
real*8 prim(3),ex,ey
ex=(2.0d0*prim(1)-prim(2)-prim(3))/dsqrt(6.0d0)
ey=(prim(2)-prim(3))/dsqrt(2.0d0)
end
end subroutine

43
src/model/trans/nnparams.incl Normal file
View File

@ -0,0 +1,43 @@
!**** Declarations
real*8 pi
real*8 hart2eV, eV2hart
real*8 hart2icm, icm2hart
real*8 eV2icm, icm2eV
real*8 deg2rad, rad2deg
integer maxnin,maxnout
!**********************************************************
!**** Parameters
!*** maxnin: max. number of neurons in input layer
!*** maxnout: max. number of neurons in output layer
parameter (maxnin=14,maxnout=15)
!**********************************************************
!**** Numerical Parameters
!*** infty: largest possible double precision real value.
!*** iinfty: largest possible integer value.
! 3.14159265358979323846264338327950...
parameter (pi=3.1415926536D0)
!**********************************************************
!**** Unit Conversion Parameters
!*** X2Y: convert from X to Y.
!***
!*** hart: hartree
!*** eV: electron volt
!*** icm: inverse centimeters (h*c/cm)
!****
!*** deg: degree
!*** rad: radians
parameter (hart2icm=219474.69d0)
parameter (hart2eV=27.211385d0)
parameter (eV2icm=hart2icm/hart2eV)
parameter (icm2hart=1.0d0/hart2icm)
parameter (eV2hart=1.0d0/hart2eV)
parameter (icm2eV=1.0d0/eV2icm)
parameter (deg2rad=pi/180.0d0)
parameter (rad2deg=1.0d0/deg2rad)

50
src/model/weight.f Normal file
View File

@ -0,0 +1,50 @@
! <Subroutine weight(wt,y,ntot,numdatpt)
subroutine weight(wt,y)
use dim_parameter, only: nstat,ndiab,nci,ntot,numdatpt,
> hybrid,wt_en2ci,wt_en,wt_ci
implicit none
! data arrays and their dimensions
double precision wt(ntot,numdatpt),y(ntot,numdatpt)
! loop index
integer i,j,k,n
do i=1,numdatpt
wt(1,i)=1.d0
enddo
call norm_weight(wt,ntot,numdatpt)
end
!----------------------------------------------------------------------------------------------------
! <Subroutine norm_weight(wt,ntot,numdatpt)
subroutine norm_weight(wt,ntot,numdatpt)
implicit none
integer ntot,numdatpt
double precision norm,wt(ntot,numdatpt)
integer i,j,count
write(6,*) 'Normalizing Weights...'
norm=0.d0
count = 0
do i=1,numdatpt
do j=1,ntot
norm = norm + wt(j,i)*wt(j,i)
if (wt(j,i).gt.0.d0) count=count+1
enddo
enddo
norm = dsqrt(norm)
if(norm.gt.0.d0) then
do i=1,numdatpt
do j=1,ntot
wt(j,i) = wt(j,i)/norm
enddo
enddo
else
write(6,*) 'Warning: Norm of Weights is Zero'
endif
Write(6,'(''No. of weigthed data points:'',i0)') count
end subroutine

763
src/model/write.f Normal file
View File

@ -0,0 +1,763 @@
module write_mod
implicit none
! unit conversion
double precision ,parameter :: h2icm = 219474.69d0
double precision, parameter :: au2Debye = 2.541746d0
character(len=250), parameter :: sep_line = '(250("-"))'
character(len=250), parameter :: block_line = '(250("="))'
contains
! <Subroutine for writing the Output
subroutine write_output
> (q,x1,x2,y,wt,par,p_act,p_spread,nset,npar,
> flag,lauf)
use adia_mod, only: adia
use dim_parameter,only: qn,ntot,numdatpt,ndiab
use ctrans_mod,only: ctrans
implicit none
! IN: variables
integer lauf
integer flag !< 0= initial output 1=fit not converged 2= Fit Converged, 3= max iteration reached
integer npar,nset
double precision par(npar,nset),p_spread(npar)
integer p_act(npar)
double precision q(qn,numdatpt),x1(qn,numdatpt),x2(qn,numdatpt)
double precision y(ntot,numdatpt),wt(ntot,numdatpt)
! INTERNAL: Variables
integer,parameter :: id_out = 20 , std_out = 6
integer pt
integer i, id_print
double precision, allocatable :: ymod(:,:)
double precision, allocatable :: ew(:,:)
double precision, allocatable :: ev(:,:,:)
logical skip
allocate(ymod(ntot,numdatpt))
allocate(ew(ndiab,numdatpt))
allocate(ev(ndiab,ndiab,numdatpt))
skip=.false.
! get Model Outputs for all geometries for current best parameter set par(:,1)
do pt=1,numdatpt
call adia(pt,par(1:npar,1),npar,ymod(1:ntot,pt),
> ew(1:ndiab,pt),ev(1:ndiab,1:ndiab,pt),skip)
call ctrans(q(:,pt),x1(:,pt),x2(:,pt))
enddo
! Initial write print everything you want to see before the fit and return
if(flag.eq.0) then
call print_parameterstate(std_out,par(:,1),p_act,npar)
call print_ErrorSummary(std_out,y,ymod,wt)
! print Data into the plotfiles
return
endif
! open output files for individual makro iterations
call open_outfile(id_out,lauf)
! print Data into the plotfiles
call print_plotfiles(x1,y,wt,ymod)
! print Genetic output into files
do i=1, 2
if (i.eq.1) then
id_print= std_out
else
id_print= id_out
endif
write(id_print,'("Writing Iteration: ",i4)') lauf
write(id_print,block_line)
! write data information only in outfile
if(i.eq.2) then
call print_data(id_print,x1,y,ymod,wt)
call print_Set_Errors(id_print,y,ymod,wt)
endif
call print_parameterblock
> (id_print,par(:,1),p_act,p_spread,npar)
call print_ErrorSummary(id_print,y,ymod,wt)
enddo
call print_fortranfile(par(:,1),npar)
! write the type of calc at the end of the output
close (id_out)
deallocate(ymod,ev,ew)
end subroutine
!----------------------------------------------------------------------------------------------------
! <subroutine for scan seperated Error analysis>
subroutine print_Set_Errors(id_out,y, ymod, wt)
use io_parameters,only: llen
use dim_parameter,only: ndata,nstat,ntot,numdatpt,sets
integer , intent(in) :: id_out
double precision, intent(in) :: y(ntot,numdatpt),
> ymod(ntot,numdatpt), wt(ntot,numdatpt)
integer :: set, setpoint, pt
double precision :: Set_rms(sets,ntot), Set_num(sets,ntot)
double precision :: Total_rms, Total_Energy_rms,Energy_rms(nstat)
character(len=llen) fmt
write(id_out,'(A)') 'Errors in icm for individual Sets' //
> '(specified by sets: and npoints:)'
write(id_out,'(A5,3A16)')'Set','Total',
> 'Total_Energy', 'Energy[nstat]'
write(id_out,sep_line)
write(fmt,'("(I5,2f16.1,",I2,"f16.1)")') nstat
Set_rms = 0.d0
pt = 0
do set=1, sets
do setpoint=1, ndata(set)
pt = pt + 1
where(wt(:,pt) > 0.d0)
Set_rms(set,:) = Set_rms(set,:)+(ymod(:,pt)-y(:,pt))**2
Set_num(set,:) = Set_num(set,:) + 1
end where
enddo
Total_rms
> = dsqrt(sum(Set_rms(set,:))
> / (sum(Set_num(set,:))))
Total_Energy_rms
> = dsqrt(sum(Set_rms(set,1:nstat))
> / (sum(Set_num(set,1:nstat))))
Energy_rms(1:nstat)
> = dsqrt(Set_rms(set,1:nstat)
> / (Set_num(set,1:nstat)))
write(id_out,fmt) set, Total_rms*h2icm, Total_Energy_rms*h2icm,
> Energy_rms(1:nstat)*h2icm
enddo
write(id_out,block_line)
write(id_out,*) ''
end subroutine print_Set_Errors
!----------------------------------------------------------------------------------------------------
! <subroutine for printing the parameter and the pst vector in fortran readable style for including the fitted parameters in other programs
subroutine print_fortranfile(p,npar)
use io_parameters,only: maxpar_keys
use dim_parameter,only: pst
implicit none
! IN: variables
integer npar
double precision p(npar)
! INTERNAL: variables
integer i
integer, parameter :: id_out = 49
character(len=32), parameter :: fname ='fit_genric_bend_no3.f90'
open(id_out,file=fname)
30 format(6x,A2,i3,A2,d18.9)
31 format(6x,A6,i3,A2,i3)
write(id_out,'(2X,A)') "Module dip_param"
write(id_out,'(5X,A)') "IMPLICIT NONE"
write(id_out,'(5X,A,I0)') "Integer,parameter :: np=",npar
write(id_out,'(5X,A,I0,A)') "Double precision :: p(",npar,")"
write(id_out,'(5X,A,I0,A)') "integer :: pst(2,",maxpar_keys,")"
write(id_out,'(5X,A)') "contains"
write(id_out,*)''
write (id_out,'(5x,a)') "SUBROUTINE init_dip_planar_data()"
write (id_out,'(8X,A)') "implicit none"
do i=1,npar
write(id_out,30) 'p(',i,')=',p(i)
enddo
do i=1,maxpar_keys
write(id_out,31) 'pst(1,',i,')=',pst(1,i)
write(id_out,31) 'pst(2,',i,')=',pst(2,i)
enddo
write(id_out,"(A)") "End SUBROUTINE init_dip_planar_data"
write(id_out,"(A)") "End Module dip_param"
close(id_out)
end subroutine
!----------------------------------------------------------------------------------------------------
! <subroutine print_ErrorSummary: calculates the rms errros and prints them in the corresponding file
subroutine print_ErrorSummary(id_out,y,ymod,wt)
use dim_parameter,only: nstat,rms_thr,ntot,numdatpt
use io_parameters,only: llen
implicit none
! IN: variables
integer id_out
double precision y(ntot,numdatpt),ymod(ntot,numdatpt)
double precision wt(ntot,numdatpt)
! INTERNAL: variables
! Counter and RMS variables
double precision Cut_thr(nstat)
double precision Output_rms(ntot),Cut_rms(nstat),Weighted_rms
integer Output_num(ntot),Cut_num(nstat)
double precision Weighted_wt
double precision Total_rms,Total_Weighted_rms
double precision Total_Energie_rms,Total_State_rms(nstat)
double precision Cut_Energie_rms, Cut_State_rms(nstat)
! Variables for computing the NRMSE
!double precision:: ymean(ntot),ysum(ntot),NRMSE
! loop control
integer j,pt
! Fabian
character(len=llen) fmt
! initialize RMS variables
Output_rms(1:ntot) = 0.d0
Output_num(1:ntot) = 0
Weighted_rms = 0.d0
Weighted_wt = 0.d0
Cut_rms(1:nstat)= 0.d0
Cut_num(1:nstat)= 0
! Define Threshold for Cut_* RMS Values
Cut_thr(1:nstat) = rms_thr(1:nstat)
! SUMM!
! Loop over all Datapoints
do pt=1,numdatpt
! get unweighted rms for each output value and count their number
do j=1,ntot
if(wt(j,pt).gt.0.d0) then
Output_rms(j) = Output_rms(j) +
> (ymod(j,pt)-y(j,pt))**2
Output_num(j)=Output_num(j) + 1
endif
enddo
! get the unweighted rms under the given threshold and count their number
do j=1,nstat
if(wt(j,pt).gt.0.d0) then
if(y(j,pt).le.Cut_thr(j)) then
Cut_rms(j) = Cut_rms(j) +
> (ymod(j,pt)-y(j,pt))**2
Cut_num(j) = Cut_num(j) + 1
endif
endif
enddo
! get the weighted rms over all output values
Weighted_rms = Weighted_rms +
> sum(((ymod(1:ntot,pt)-y(1:ntot,pt))**2)
> *(wt(1:ntot,pt)**2))
Weighted_wt = Weighted_wt + sum(wt(1:ntot,pt)**2)
enddo
! NORM!
! TOTAL RMS:
! unweighted
Total_rms =
> dsqrt(sum(Output_rms(1:ntot)) /(sum(Output_num(1:ntot))))
! Weighted
Total_Weighted_rms = dsqrt(Weighted_rms/Weighted_wt)
! unweighted, considering only first nstat values
Total_Energie_rms =
> dsqrt(sum(Output_rms(1:nstat)) /(sum(Output_num(1:nstat))))
! unweighted,for each of the first nstat values separatly
Total_State_rms(1:nstat) =
> dsqrt(Output_rms(1:nstat) / Output_num(1:nstat))
! unweighted,first nstat values only counting points under given threshold
Cut_Energie_rms =
> dsqrt(sum(Cut_rms(1:nstat)) /(sum(Cut_num(1:nstat))))
! unweighted,each nstat values seperatly only counting points under threshold
Cut_State_rms(1:nstat) =
> dsqrt(Cut_rms(1:nstat)/Cut_num(1:nstat))
! WRITE!
! make the actual writing into the file
write(id_out,39)
write(id_out,40)
write(id_out,41) Total_rms, Total_rms*au2Debye!Total_rms*h2icm
write(id_out,42) sum(Output_num(1:ntot))
write(id_out,43) Total_Weighted_rms, Total_Weighted_rms*h2icm
write(id_out,44) Weighted_wt
write(id_out,45) Total_Energie_rms, Total_Energie_rms*h2icm
write(id_out,42) sum(Output_num(1:nstat))
write(fmt,'("(A,10x,A,",I2,"f8.1)")') nstat
write(id_out,fmt) '#','State resolved RMS(icm): ',
$ Total_State_rms(1:nstat)*h2icm
write(fmt,'("(A,10x,A,",I2,"i8)")') nstat
write(id_out,fmt) '#','No. of Points per State: ',
$ Output_num(1:nstat)
write(id_out,51)
! write the errors under a given threshold if there were any points
if(any(Cut_num(1:nstat).gt.0)) then
write(id_out,48) Cut_Energie_rms, Cut_Energie_rms*h2icm
write(id_out,42) sum(Cut_num(1:nstat))
write(fmt,'("(A,10x,A,",I2,"f8.1,A)")') nstat
write(id_out,fmt) '#','Red. State resolved RMS: ',
$ Cut_State_rms(1:nstat)*h2icm,' icm'
write(fmt,'("(A,10x,A,",I2,"i8)")') nstat
write(id_out,fmt) '#','No. of Points per State: ',
$ Cut_num(1:nstat)
write(fmt,'("(A,10x,A,",I2,"f8.1,A)")') nstat
write(id_out,fmt) '#','Threshold per State: ',
$ Cut_thr(1:nstat)*h2icm,' icm above Reference Point.'
endif
write(id_out,39)
! FORMAT! specifications for the writing
39 format(250('#'))
40 format('#',10x,'ERROR SUMMARY: ')
41 format('#',10x,'Total RMS: ',g16.8, '(',g16.8,
> ' Debye)')
42 format('#',10x,'No. of Points: ',i10)
43 format('#',10x,'Total weighted RMS: ',g16.8, '(',f8.1,' icm)')
44 format('#',10x,'Sum of point weights: ',f16.8)
45 format('#',10x,'Total Energie RMS: ',g16.8, '(',f8.1,' icm)')
48 format('#',10x,'Red. Energie RMS: ',g16.8,'(',f8.1,' icm)')
51 format('#')
end subroutine
!----------------------------------------------------------------------------------------------------
subroutine print_plotfiles(x,y,wt,ymod)
use dim_parameter,only: ndata,sets,qn,ntot,numdatpt,plot_coord
implicit none
! IN: variables
double precision x(qn,numdatpt),y(ntot,numdatpt)
double precision wt(ntot,numdatpt), ymod(ntot,numdatpt)
! INTERNAL: variables
integer sstart,ssend,set,id_plot
! Initialize position pointer
ssend=0
! loop over datasets and print the plotfiles
do set=1 ,sets
if(ndata(set).eq.0) cycle
id_plot=50+set
call open_plotfile(id_plot,set)
write(id_plot,'(A)') '# -*- truncate-lines: t -*-'
! get start and end point of each set
sstart=ssend+1
ssend=ssend+ndata(set)
if (plot_coord(set).eq.0) then
call print_plotwalk(x(:,sstart:ssend),y(:,sstart:ssend),
> wt(:,sstart:ssend),ymod(:,sstart:ssend),
> ndata(set),id_plot,set)
else
call print_plotcoord(plot_coord(set),
> x(:,sstart:ssend),y(:,sstart:ssend),
> wt(:,sstart:ssend),ymod(:,sstart:ssend),
> ndata(set),id_plot,set)
endif
close(id_plot)
enddo
end subroutine
!----------------------------------------------------------------------------------------------------
subroutine print_plotwalk(x,y,wt,ymod,npt,id_plot,set)
use dim_parameter,only: qn,ntot
use io_parameters,only: llen
implicit none
! IN: variables
integer id_plot,npt,set
double precision x(qn,npt),y(ntot,npt),ymod(ntot,npt),wt(ntot,npt)
! INTERNAL: variables
double precision xdiff(qn),walktime
double precision walknorm
! loop control
integer i,j
character(len=llen) fmt
j=ntot-1
call print_plotheader(id_plot,0,npt,set)
call getwalknorm(x,walknorm,npt)
walktime = 0.d0
do i=1,npt
if(i.gt.1) then
xdiff(1:qn) = x(1:qn,i) - x(1:qn,i-1)
walktime = walktime + dsqrt(sum(xdiff(1:qn)**2))/walknorm
endif
write(id_plot,"(ES16.8,*(3(ES16.8),:))")
> walktime ,ymod(:,i),y(:,i),(wt(:,i))
enddo
end subroutine
!----------------------------------------------------------------------------------------------------
subroutine print_plotcoord(coord,x,y,wt,ymod,npt,id_plot,set)
use dim_parameter,only: qn,ntot
use io_parameters,only: llen
implicit none
! IN: variables
integer, intent(in) :: id_plot,npt,set,coord
double precision, intent(in) :: x(qn,npt),y(ntot,npt)
double precision, intent(in) :: ymod(ntot,npt),wt(ntot,npt)
! loop control
integer i
call print_plotheader(id_plot,coord,npt,set)
do i=1,npt
write(id_plot,"(ES16.8,*(3(ES16.8),:))")
> x(coord,i), ymod(:,i),y(:,i),(wt(:,i))
! write(id_plot,"(2ES16.8,*(3(ES16.8),:))")
! > x(coord,i), x(coord+1,i),y(:,i)
enddo
end subroutine
!----------------------------------------------------------------------------------------------------
subroutine print_plotheader(id_plot,coord,npt,set)
use dim_parameter,only: qn,ntot
use io_parameters,only: llen
implicit none
integer, intent(in) :: id_plot,npt,set,coord
character(len=llen) fmt
write(id_plot,'("#SET: ",i5)') set
write(id_plot,'("#OUTPUT VALUES",i4)') ntot
write(id_plot,'("#DATA POINTS: ",i4)') npt
if (coord.le.0) then
write(id_plot,'("#t(x) = WALK")')
else
write(id_plot,'("#t(x) = x(",I0,")")') coord
endif
write(id_plot,'("#UNIT: hartree")')
write(id_plot,'()')
write(id_plot,'("#",A15)',advance='no') "t(x)"
write(fmt,'("(3(7X,A9,",I3,"(16x)))")') ntot-1
write(id_plot,fmt) 'ymod(p,x)','y(x) ','wt(x) '
end subroutine
!----------------------------------------------------------------------------------------------------
! <subroutine walknorm calulates the distance in coordinate space for each set
subroutine getwalknorm(x,walknorm,npt)
use dim_parameter,only: qn
implicit none
! IN: variables
integer npt
double precision x(qn,npt)
double precision walknorm
! INTERNAL: variables
double precision xdiff(qn)
integer i
walknorm =0.d0
do i=2,npt
xdiff(1:qn) = x(1:qn,i) - x(1:qn,i-1)
walknorm = walknorm + dsqrt(sum(xdiff(1:qn)**2))
enddo
end subroutine
!----------------------------------------------------------------------------------------------------
! <Subroutine for generating output filenames and openeing the correspondign files
subroutine open_plotfile(id_plot,set)
implicit none
! IN: Variables
integer id_plot,set
! INTERNAL: Variables
character(len=30) name !name of output file
! define name sheme for plot files
if (set .lt. 10 ) then
write(name,203) set
else
write(name,202) set
endif
202 format('scan',I2,'.dat')
203 format('scan0',I1,'.dat')
!write (name,202) set
c open plotfile
open(id_plot,file=name)
end subroutine
!----------------------------------------------------------------------------------------------------
! <Subroutine for generating output filenames and openeing the correspondign files
subroutine open_outfile(id_out,it_makro)
implicit none
integer id_out,it_makro
character(len=30) outname !name of output file
543 format('mnlfit-',i1,'.out')
544 format('mnlfit-',i2,'.out')
545 format('mnlfit-',i3,'.out')
if(it_makro.lt.10) then
write(outname,543) it_makro
else if (it_makro.lt.100) then
write(outname,544) it_makro
else if (it_makro.lt.1000) then
write(outname,545) it_makro
else
write(6,*)
> 'ERROR: No rule for Outputfile naming for MAXIT >= 1000'
stop
endif
open (id_out,file=outname)
end subroutine
!----------------------------------------------------------------------------------------------------
! <Subroutine for printing the Parameterkeys for use in Input File
! < prints the keystring given in keys.incl and the corresponding parameters when there was atleast one parameter given in the input for the spcific key
! < how many parameters and spreads per line are printed can be specified with the hardcoded parameters np and nsp but they must be atleast >=2
! <@param id_out specifies the file in which the Parameters are Printed
! <@param p vector containing one set of parameter values
! <@param p_act vector containing the active state 0 (inactive) or 1 (active) for each parameter
! <@param p_spread vector containing the spreads for each parameter
! <@param npar lenght of the parmeter vectors (p,p_act,p_spread)
! <@TODO extract subroutine for printing the multiline values, would make this more readable
subroutine print_parameterblock(id_out,p,p_act,p_spread,npar)
use dim_parameter,only: pst, facspread
use io_parameters,only: key, parkeynum,parkeylen,llen
implicit none
! IN: Variables
integer id_out,npar,p_act(npar)
double precision p(npar),p_spread(npar)
! INTERNAL: variables
! loop index
integer i,k,l,t,n !< internal variables for loops and positions in parameter vectors
! number of values per line, values must be atleast 2 set this to personal preference
integer, parameter :: np=5,nsp=5
character(len=llen) fmt
! Write header for Parameter block
1 format('!',200('='))
write(id_out,1)
write(id_out,'(A2,5x,A11,i3)') '! ','PARAMETER: ',npar
write(id_out,1)
! loop over all Parameter Keys
do i = 1, parkeynum
! save start and end of parameter block for specific key
k = pst(1,i)
l = pst(1,i)+pst(2,i)-1
! print only used keys with atleast one parameter
if(pst(2,i).gt.0) then
write(fmt,'("(a",I3,"'' ''i3)")') parkeylen
write(id_out,fmt) adjustl(key(1,i)), pst(2,i)
! write the actual parameters -> subroutine print_parameterlines()?
if(l-k.le.(np-1)) then
write(fmt,'("(a",I3,"'' ''",I3,"g24.15)")') parkeylen,np
write(id_out,fmt) key(2,i),(p(n), n=k,l)
else
! start of multi line parameter print, number of values per line specified by np
write(fmt,'("(a",I3,"'' ''",I3,"g24.15'' &'')")')
$ parkeylen,np
write(id_out,fmt) key(2,i),(p(n), n=k,k+(np-1))
t=k+np
! write continuation lines till left parameters fit on last line
do while(t.le.l)
if(l-t.le.(np-1)) then
write(fmt,'("(",I3,"x'' ''",I3,"g24.15)")')
$ parkeylen,np
write(id_out,fmt) (p(n), n=t, l)
else
write(fmt,'("(",I3,"x'' ''",I3,"g24.15'' &'')")')
$ parkeylen,np
write(id_out,fmt) (p(n), n=t, t+(np-1))
endif
t=t+np
enddo
endif !-> end subroutine print_parameterlines
! write parameter active state in one line
write(fmt,'("(a",I3,"'' ''","50i3)")') parkeylen
write(id_out,fmt) key(3,i),(p_act(n),n=k,l)
! write the spreads for each parameter
if(l-k.le.(np-1)) then
write(fmt,'("(a",I3,"'' ''",I3,"g24.8)")') parkeylen,nsp
write(id_out,fmt) key(4,i),(p_spread(n)/facspread, n=k,l)
else
! start of multiline spread values
write(fmt,'("(a",I3,"'' ''",I3,"g24.8'' &'')")')
$ parkeylen,nsp
write(id_out,fmt) key(4,i),(p_spread(n)/facspread, n=k,k
> +(np-1))
t=k+nsp
! write continuation lines till left spreads fit on last line
do while(t.le.l)
if(l-t.le.(np-1)) then
write(fmt,'("(",I3,"x'' ''",I3,"g24.8)")')
$ parkeylen,nsp
write(id_out,fmt) (p_spread(n)/facspread, n=t, l)
else
write(fmt,'("(",I3,"x'' ''",I3,"g24.8'' &'')")')
$ parkeylen,nsp
write(id_out,fmt) (p_spread(n)/facspread, n=t, t
> +(np-1))
endif
t=t+np
enddo
endif
! print empty line between diffrent parameter blocks for better readability
write(id_out,'(" ")')
endif
enddo
end subroutine
!----------------------------------------------------------------------------------------------------
! <Subroutine for printing the current Parameters and their active state
! < prints only the numeric values of the parameters and does not specify the corresponding key
! <@param npar number of parameter
! <@param id_out specifies the output file
! <@param p,p_act parameter vectors containing the values and the activity state of parameters
subroutine print_parameterstate(id_out,p,p_act,npar)
implicit none
! IN: Variables
integer npar,id_out
double precision p(npar)
integer p_act(npar)
! INTERNAL: Variables
integer i !< loop control
integer nopt !< number of counted active parameters
character(len=16) opt(npar) !< string for optimisation state
! initialize number of opt parameters and the string vector opt
nopt=0
opt = ' not opt. '
! loop over all parameters and check their active state count if active and set string to opt
do i=1,npar
! Nicole: change due to value 2 of p_act
! if(p_act(i).eq.1) then
if(p_act(i).ge.1) then
opt(i) = ' opt. '
nopt=nopt+1
endif
enddo
! print the Parameters and their active state within separating lines
write(id_out,*)''
write(id_out,block_line)
write(id_out,*) 'Parameters:'
write(id_out,sep_line)
write(id_out,'(5g14.6)') (p(i),i=1,npar)
write(id_out,'(5a14)') (opt(i),i=1,npar)
write(id_out,sep_line)
write(id_out,'("No. of optimized parameters: ",i6)') nopt
write(id_out,block_line)
write(id_out,*)''
end subroutine
!----------------------------------------------------------------------------------------------------
! <Subroutine for printing coordinates,refdata,modeldata,diffrence between them and the weights
! <@param id_out identiefies the output file
! <@param x vector of input pattern for each datapoint
! <@param y vector of expected output patterns for each datapoint
! <@param ymod vector of output patterns generated by the model depending on paramerters
! <@param wt vector of weights for each datapoint
! <@param qn number of input patterns
! <@param ntot total number of output patterns for each datapoint
! <@param numdatpt number of totatl datapoints
! <@param sets number of sets the datapoints are divided into
! <@param ndata vector containing the number of included datapoints for each set
! <@param i,j,point internal variables for loop controll and datapoint counting
subroutine print_data(id_out,x,y,ymod,wt)
use dim_parameter,only: sets,ndata,qn,ntot,numdatpt,qn_read
implicit none
! IN: Variables
integer id_out
double precision x(qn,numdatpt)
double precision y(ntot,numdatpt),ymod(ntot,numdatpt)
double precision wt(ntot,numdatpt)
! INTERNAL: Variables
integer i,j,point
18 format(A8,i6)
19 format (3(A15,3x), 2x, A18 , 4x, A12)
! print seperating line and header for Data output
write(id_out,*) 'Printing Data Sets:'
write(id_out,19) adjustl('y(x)'),adjustl('ymod(x)'),
> adjustl('y(x)-ymod(x)'),adjustl('weight'),
> adjustl('x(1:qn_read) ')
write(id_out,sep_line)
! loop over all datapoints for each set and count the actual datapointnumber with point
point=0
do i=1,sets
write(id_out,18) 'Set: ', i
do j=1,ndata(i)
write(id_out,18) 'Point: ', j
point=point+1
! print all data for one datapoint
call print_datapoint(id_out,x(:,point),y(:,point),
> ymod(:,point),wt(:,point))
write(id_out,sep_line)
enddo
enddo
! write end of data statement and two seperating lines
write(id_out,block_line)
write(id_out,*) ''
end subroutine
!----------------------------------------------------------------------------------------------------
! <Subroutine prints a single Datapoint splits Data in nstat nci(ndiab) blocks for readability
! <@param id_out identiefies the output file
! <@param x vector of input pattern for each datapoint
! <@param y vector of expected output patterns for each datapoint
! <@param ymod vector of output patterns generated by the model depending on paramerters
! <@param wt vector of weights for each datapoint
! <@param qn number of input patterns
! <@param ntot total number of output patterns for each datapoint
! <@param i,j,k internal variables for loop controll and counting
subroutine print_datapoint(id_out,x,y,ymod,wt)
use dim_parameter,only: nstat,ndiab,nci,qn,ntot,qn_read
use io_parameters,only: llen
implicit none
integer id_out
double precision x(qn),y(ntot),ymod(ntot),wt(ntot)
integer i,j,k
18 format(A10,i3)
19 format(3F18.8, 2X, F18.6, 4X,*(F12.6))
! print the nstat output patterns
do i=1,nstat
write(id_out,19)y(i),ymod(i),ymod(i)-y(i), wt(i), x(1:qn)
enddo
! loop over number (nci) of metadata with lenght (ndiab)
do i=1,nci
write(id_out,18) 'nci: ',i
do j=1,ndiab
k=nstat + (i-1)*ndiab + j
write(id_out,19) y(k),ymod(k),(ymod(k)-y(k)),
> wt(k), x(1:qn_read)
enddo
enddo
end subroutine
end module write_mod

203
src/mpi_fit_MeX.f Normal file
View File

@ -0,0 +1,203 @@
#ifdef mpi_version
subroutine mpi_rest_control(micit,npar)
use mpi
implicit none
! global permanent data (only transferred once)
integer npar
integer mfit
integer micit
integer ma(npar)
integer ierror
integer i
integer mode
logical runner
integer status(MPI_STATUS_SIZE)
! do loop around this, checking for next fit or finish
call bcastact(ma,npar)
call MPI_Bcast(mfit, 1, MPI_INT, 0, MPI_COMM_WORLD,ierror)
runner=.true.
do while(runner)
call MPI_Recv(mode, 1, MPI_INTEGER, 0, 69, MPI_COMM_WORLD,
$ status,ierror)
if(mode.ne.0) then
call mpi_fit_single_set(npar,mfit,micit,ma,mode)
else
runner=.false.
endif
end do
call MPI_Barrier(MPI_COMM_WORLD, ierror)
end
!-----------------------------------------------
c this does a single crunch of data
subroutine mpi_fit_single_set(npar,mfit,micit,ma,nset)
use mpi
use dim_parameter, only: lbfgs
use marq_mod,only: mrqmin
use lbfgsb_mod,only: lbfgs_driver
implicit none
integer npar,mfit,micit,ierror,ma(*)
integer status(MPI_STATUS_SIZE), nset, my_rank
double precision par(npar), rms, startzeit, endzeit
startzeit = MPI_Wtime()
! receive data via blocking receive
call MPI_Recv(par, npar, MPI_DOUBLE_PRECISION, 0, 13,
$ MPI_COMM_WORLD, status, ierror)
call MPI_Recv(rms, 1, MPI_DOUBLE_PRECISION, 0, 14,
$ MPI_COMM_WORLD, status, ierror)
if(lbfgs) then
call lbfgs_driver(par,npar,ma,mfit,
& rms,micit,nset)
else
call mrqmin(par,npar,ma,mfit,
& rms,micit,nset)
endif
call MPI_Comm_rank(MPI_COMM_WORLD, my_rank, ierror)
! send back data via blocking send
call MPI_Send(par, npar, MPI_DOUBLE_PRECISION, 0, 23,
$ MPI_COMM_WORLD, ierror)
call MPI_Send(rms, 1, MPI_DOUBLE_PRECISION, 0, 24, MPI_COMM_WORLD,
$ ierror)
endzeit = MPI_Wtime()
write(6,*) 'Thread', my_rank ,'Zeit:', endzeit-startzeit
!> Write output for the spezific set of parameters
write(6,99) nset, rms, rms*219474.69d0
99 format('Set:',i5,5x,'RMS:',g16.6,3x,'(',f16.6,' cm-1)')
end
!-----------------------------------------------
subroutine bcastact(act,len)
use mpi
implicit none
integer len
integer act(len)
integer ierror
call MPI_Bcast(act, len, MPI_INT, 0, MPI_COMM_WORLD,ierror)
end
!-----------------------------------------------
subroutine workshare(numthreads, par, rms, npar, nset)
use mpi
implicit none
integer numthreads,ierror,nset,npar
double precision, asynchronous :: par(npar,nset),rms(nset)
logical working(numthreads-1)
logical sent,received_rms,received_par,received
integer request_par(8,numthreads-1)
integer request_rms(8,numthreads-1)
integer ping(8)
integer nextworker
integer i,j,k
integer worksignal
integer status(MPI_STATUS_SIZE)
integer (kind=MPI_ADDRESS_KIND) :: iadummy
! init working array
do i = 1,numthreads
working(i) = .false.
enddo
do i = 1,nset
! do a round of sending
sent=.false.
do while(.not.sent)
do j = 1,numthreads-1
if(.not.working(j)) then
working(j)=.true.
nextworker = j
sent=.true.
exit
endif
enddo
if(sent) then
call MPI_Issend(i, 1, MPI_INTEGER,
$ nextworker, 69, MPI_COMM_WORLD, ping(1), ierror)
call MPI_Issend(par(1,i), npar, MPI_DOUBLE_PRECISION,
$ nextworker, 13, MPI_COMM_WORLD, request_par(1
$ ,nextworker), ierror)
call MPI_Issend(rms(i), 1, MPI_DOUBLE_PRECISION,
$ nextworker, 14, MPI_COMM_WORLD, request_rms(1
$ ,nextworker), ierror)
! wait for Issend to finish (Hannes initial position for these statements --> runs parallel)
call MPI_Wait(ping(1), status, ierror)
call MPI_Wait(request_par(1,nextworker), status, ierror)
call MPI_Wait(request_rms(1,nextworker), status, ierror)
call MPI_Irecv(par(1,i), npar, MPI_DOUBLE_PRECISION,
$ nextworker, 23, MPI_COMM_WORLD, request_par(1
$ ,nextworker) , ierror)
call MPI_Irecv(rms(i), 1, MPI_DOUBLE_PRECISION,
$ nextworker, 24, MPI_COMM_WORLD, request_rms(1
$ ,nextworker), ierror)
endif
! check finished workers
do j = 1,numthreads-1
if(working(j)) then
received_rms=.false.
received_par=.false.
call MPI_Test(request_par(1,j), received_rms,
$ status, ierror)
call MPI_Test(request_rms(1,j), received_par,
$ status, ierror)
if(received_par.and.received_rms) then
working(j) = .false.
endif
endif
enddo
enddo
enddo
received = .false.
do while(.not.received)
do j = 1,numthreads-1
if(working(j)) then
received_rms=.false.
received_par=.false.
call MPI_Test(request_par(1,j), received_rms,
$ MPI_STATUS_IGNORE, ierror)
call MPI_Test(request_rms(1,j), received_par,
$ MPI_STATUS_IGNORE, ierror)
if(received_par.and.received_rms) then
working(j) = .false.
endif
endif
enddo
received=.true.
do j = 1,numthreads-1
if(working(j)) then
received = .false.
exit
endif
enddo
enddo
end
#endif

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

@ -0,0 +1,32 @@
**** ERROR CATALOGUE -- this defines what kind of errors parse.f throws
! 1 32 64
! v v v
! '................................................................'
errcat( 1)='ILLOGICALLY SMALL VALUE'
errcat( 2)='VALUE EXCEEDS SET MAXIMUM'
errcat( 3)='GIVEN DATA STRUCTURE SIZE INCONSISTENT WITH'
> // ' PREVIOUS DECLARATION'
errcat( 4)='VALUE GREATER THAN SET MAXIMUM'
errcat( 5)='VALUE LESS THAN SET MINIMUM'
errcat( 6)='IMPLIED DATA POINT NUMBER INCONSISTENT WITH NPAT'
errcat( 7)='PERCENTAGE NOT WITHIN MEANINGFUL RANGE (0.0-100.0)'
errcat( 8)='MISSING KEY CLASHES WITH PREVIOUS DECLARATION'
errcat( 9)='MAXIMUM IDENTICAL TO MINIMUM'
errcat(10)='DEPRECATED COMMAND: FEATURE HAS BEEN REMOVED, '
> // 'SEE PARSER.'
errcat(11)='TOO MANY ARGUMENTS'
! errcat(12)=
! errcat(13)=
! errcat(14)=
! errcat(15)=
! errcat(16)=
! errcat(17)=
! errcat(18)=
! errcat(19)=
! errcat(20)=
! errcat(21)=
! errcat(22)=
! errcat(23)=
! errcat(24)=

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

@ -0,0 +1,55 @@
module io_parameters
implicit none
! ******************************************************************************
! **** I/O-Parameters
! ***
! *** dnlen: maximum char length of data file path
! *** maxlines: maximum input file length
! *** llen: character maximum per line
! *** maxdat: maximum number of input data values of one kind
! *** (e.g. integer values) excluding DATA: block
! *** clen: max. character length of string data
! *** klen: maximum length of key or typestring
! *** maxkeys: max. number of keys
! *** maxerrors: max. number of pre-defined error messages.
integer, parameter :: dnlen = 8192
integer, parameter :: maxlines = 3000000,llen = 750
integer, parameter :: klen=20,maxkeys=200
integer, parameter :: maxdat=2000,clen=1024
integer, parameter :: maxerrors=100
! Declarations for general Keylist and error massages
integer :: keynum !< keynum number of general keys
integer :: datpos(3,maxdat) !< datpos Pointer to type, data adress and length for each general key
character(len=klen) :: keylist(2,maxkeys) !< list of general program keys for programm control and parameter initialisation defined in keylist.incl
character(len=64) :: errcat(maxerrors) !< list of generic error Messages defined in errcat.incl
! parameter key declaration
integer, parameter :: maxpar_keys=400 !<maximum number of parameter keys
character(len=klen) :: key(4,maxpar_keys) !<list of parameter keys (1-4: number,value,active?,spread)
integer :: parkeynum !< actual number of parameterkeys specified
integer :: parkeylen !< lenght of longest parameterkey string
!**********************************************************
!**** Error Codes
!*** Codes should be powers of 2. Binary representation of return value
!*** should correspond to all exceptions invoked. ec_error should never
!*** be invoked with any other.
!***
!*** ec_error: generic error (catch-all, avoid!)
!*** ec_read: parsing error during les()
!*** ec_dim: dimensioning error
!*** ec_log: logic error
!***
!**** Inferred error codes
!*** ec_dimrd: ec_dim+ec_read
integer, parameter :: ec_error=1, ec_read=2, ec_dim=4, ec_log=8
integer, parameter :: ec_dimrd=ec_dim+ec_read
end module

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

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

1
src/parser/keys.f90 Symbolic link
View File

@ -0,0 +1 @@
../model/keys.f90

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

@ -0,0 +1,148 @@
module fileread_mod
contains
!-------------------------------------------------------------------
subroutine get_datfile(datnam,dnlen)
implicit none
! Get name of input data file DATNAM either from the program's first
! command line argument or ask the user.
integer dnlen
character(len=dnlen) datnam
integer argcount
argcount=iargc()
if (argcount.gt.0) then
call getarg(1,datnam)
else
write(6,'(A)') 'Specify input file:'
read(*,*) datnam
endif
if (len_trim(datnam).eq.dnlen) then
write(6,'(A)') 'ERROR: TRUNCATED FILENAME'
write(6,'(A)') '"' // datnam // '"'
endif
end subroutine get_datfile
!-------------------------------------------------------------------
subroutine internalize_datfile(datnam,infile,linenum,llen,
> maxlines,dnlen)
use strings_mod,only:write_oneline,int2string
implicit none
! Read input file located at DATNAM, skipping comments and blank lines.
integer dnlen,llen,maxlines
integer linenum
character(len=dnlen) datnam
character(len=llen) infile(maxlines)
character(len=llen) line
!character*16 int2string
integer j
!Fabian
character(len=llen) fmt,fmt2
integer,parameter :: std_out = 6
integer,parameter :: funit = 10
write(fmt,'(A)') 'Reading file ''' // trim(datnam) // ''' ...'
call write_oneline(fmt,std_out)
open(unit=funit,file=datnam)
linenum=0
do j=1,maxlines
!read(funit,fmt='(A<llen>)',end=20) line !<var> works only for ifort, not for gfortran or mpif90
write(fmt2,'("(A",I3,")")') llen !Fabian
read(funit,fmt=fmt2,end=20) line !Fabian
if (line(1:3).eq.'---') then
write(fmt,'(A)') 'EOF-mark "---" found at line'
> // trim(int2string(j))
call write_oneline(fmt,std_out)
exit
endif
call internalize_line(linenum,infile,line,llen,maxlines)
enddo
20 close(funit)
if (j.ge.maxlines) then
write(6,'(A)') 'ERROR: FILE LENGTH EXCEEDING MAXLINES.'
stop 1
endif
write(fmt,'(A)') 'File read successfully ('
> // trim(int2string(linenum)) // ' lines).'
call write_oneline(fmt,std_out)
end subroutine internalize_datfile
!-------------------------------------------------------------------
subroutine internalize_line(linenum,infile,line,llen,maxlines)
use strings_mod,only: strip_string,upcase
implicit none
! Parse a single line of input. Ignore comments ("!..") and blank
! lines, and turn all input to uppercase.
!
! infile: data file's internalized form
! line: single verbatim line read from physical file
! linenum: current number of non-commentlines read
! increased by 1 if read line is not a comment
! llen: maximum character length of a single line
! maxlines: maximum number of lines in infile
integer llen,maxlines
integer linenum
character(len=llen) infile(maxlines)
character(len=llen) line
character(len=llen) strip
integer line_pos,text_end
integer j
line_pos=linenum+1
! ignore empty lines
if (len_trim(line).eq.0) then
return
endif
! strip needless whitespace
call strip_string(line,strip,llen)
! determine EOL
! ignore comments
text_end=0
do j=1,len_trim(strip)
if (strip(j:j).eq.'!') then
exit
endif
text_end=text_end+1
enddo
if (text_end.eq.llen) then
write(6,'(A,I6)') 'WARNING: POTENTIALLY TRUNCATED LINE:'
write(6,'(A)') '"' // strip(1:60) // '"...'
endif
! skip if line is a comment
if (text_end.eq.0) then
return
endif
infile(line_pos)=' '
! turn string to uppercase and write to infile, ignoring comments
call upcase(strip,infile(line_pos),text_end)
! increment line number
linenum=linenum+1
end subroutine internalize_line
end module

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

@ -0,0 +1,274 @@
module keyread_mod
contains
subroutine keyread(keylist,infile,keynum,idat,ddat,cdat,datpos,
> klen,llen,clen,linenum,maxdat)
use long_keyread_mod,only:long_intkey,long_realkey,long_strkey
use strings_mod,only:int2string,dble2string
implicit none
! Read all keys from KEYLIST from INFILE and write their associated
! data to the corresponding data block. Memory management is
! handled by DATPOS.
!
! keylist: Registry of keys containing the name of the key
! and it's type information.
! keylist(N,1): keyname. It should be in all-caps.
! keylist(N,2): type string of the form "X#"
!
! Note: Key 1 (keylist(1,1)) has the special property that all
! lines of the input file after it's first occurence will be
! ignored. This allows for long input files holding non-key
! information.
!
! typestring syntax:
! X should be I (Integer), +I (Int >= 0), D (double precision),
! C (character string), +D (real >= 0.0d0)
! or E (checks whether key exists).
! X! (e.g. +I!, D!,..) makes a key non-optional.
! E!, while absurd, is a valid option.
! # should be either N (meaning variable length) or an integer >0.
! it encodes the expected number of read values
!
! note: the E-type has no associated *dat-array, instead
! datpos(2,N) is either -1 or it's last occurence in infile,
! depending on whether the key was found. Furthermore,
! E-type keys accept no arguments.
!
! *dat: data arrays for respective items
! klen: length of key/typestring
! llen: line length of infile
! clen: length of read strings
! keynum: number of keys
! linenum: number of lines the file has
! maxdat: maximum number of total input values read
! infile: input file
! datpos: integer array assigning read values to the keys
! datpos(1,N): internalized type (0: I, 1: +I, 2: D, 3: +D,
! 4: C, 5: E)
! datpos(2,N): starting pos. in respective data array
! datpos(3,N): length of data block
!
!? WARNING: *dat() MAY BE WRITTEN BEYOND THEIR LENGTH FOR BAD DIMENSIONS.
!? CATCH THIS!
integer klen, llen, clen
integer keynum, linenum, maxdat
character(len=klen) keylist(2,keynum)
character(len=llen) infile(linenum)
integer datpos(3,maxdat)
integer idat(maxdat)
double precision ddat(maxdat)
character(len=clen) cdat(maxdat)
character(len=klen) key
character(len=64) errmsg
integer intype,inlen,readlen
integer cstart,istart,dstart
integer key_end
integer datnum,inpos,datlen
integer file_stop
logical optional2
integer j,k
cstart=1
istart=1
dstart=1
datnum=0
file_stop=linenum
key=keylist(1,1)
key_end=len_trim(key)
if (key_end.ne.0) then
do k=1,linenum
if (infile(k)(1:key_end).eq.trim(key)) then
file_stop=k
exit
endif
enddo
endif
do j=1,keynum
key=keylist(1,j)
! get information needed to read key
call get_key_kind(keylist(:,j),intype,optional2,inlen,klen)
datpos(1,j)=intype
key_end=len_trim(key)
! find last invocation of key (if present)
inpos=0
do k=1,file_stop
if (infile(k)(1:key_end).eq.trim(key)) then
inpos=k
endif
enddo
if (inpos.eq.0) then
if (.not.optional2) then
errmsg='MISSING, NON-OPTIONAL KEY'
call signal_key_error(key,errmsg,klen)
endif
datpos(2,j)=-1
datpos(3,j)=0
cycle
endif
! read from last occurence of key
readlen=0
if (intype.le.1) then
datlen=maxdat-istart+1
call long_intkey(infile,inpos,key_end,
> idat,istart,readlen,llen,maxdat,linenum)
else if (intype.le.3) then
datlen=maxdat-dstart+1
call long_realkey(infile,inpos,key_end,
> ddat,dstart,readlen,llen,maxdat,linenum)
else if (intype.eq.4) then
call long_strkey(infile,inpos,key_end,
> cdat,cstart,readlen,llen,maxdat,linenum,clen)
else if (intype.eq.5) then
! since datpos already encodes whether the key was found,
! there is no need to save anything
readlen=0
else
write(6,*) 'ERROR: ENCOUNTERED FAULTY TYPE SPEC.'
stop 1
endif
! check validity of input length
if (inlen.eq.-1) then
inlen=readlen
else if (inlen.ne.readlen) then
errmsg='WRONG NUMBER OF ARGUMENTS'
call signal_key_error(key,errmsg,klen)
endif
! check sign of +X types
if (intype.eq.1) then
do k=1,inlen
if (idat(istart-1+k).lt.0) then
errmsg='UNEXPECTED NEGATIVE INTEGER: '
> // trim(int2string(idat(istart-1+k)))
call signal_key_error(key,errmsg,klen)
endif
enddo
else if (intype.eq.3) then
do k=1,inlen
if (ddat(dstart-1+k).lt.0.0d0) then
errmsg='UNEXPECTED NEGATIVE REAL: '
> // trim(dble2string(ddat(dstart-1+k)))
call signal_key_error(key,errmsg,klen)
endif
enddo
endif
if (intype.le.1) then
datpos(2,j)=istart
istart=istart+inlen
else if (intype.le.3) then
datpos(2,j)=dstart
dstart=dstart+inlen
else if (intype.eq.4) then
datpos(2,j)=cstart
dstart=cstart+inlen
else if (intype.eq.5) then
! remember where you last found the key in infile
datpos(2,j)=inpos
endif
datpos(3,j)=inlen
enddo
end subroutine keyread
subroutine get_key_kind(kentry,dattype,optional2,datlen,klen)
use strings_mod,only:trimnum,nth_word
implicit none
! Read typestring from a keylist entry KENTRY and extract the
! specific type and expected length of KEYs input.
!
! dattype: type of the data, encoded as int
! optional: true if key does not need to be present
! datlen: number of values expected
! klen: length of keys
include 'typedef.incl'
integer klen
integer dattype,datlen
character(len=klen) kentry(2)
logical optional2
character(len=klen) typestr,key,tmp,numstr
character(len=64) errmsg
integer strpos,typelen
integer j
key=kentry(1)
typestr=kentry(2)
strpos=0
dattype=-1
! check type declaration against defined types in typedef.incl
do j=1,typenum
typelen=len_trim(types(j))
if (typestr(1:typelen).eq.trim(types(j))) then
dattype=j-1
strpos=typelen+1
exit
endif
enddo
if (dattype.eq.-1) then
errmsg='INVALID TYPE SPEC: '//'"'//typestr(1:maxtypelen)//'"'
call signal_key_error(key,errmsg,klen)
endif
! Any type followed by ! makes the card non-optional, crashing the
! program if it is missing.
optional2=(typestr(strpos:strpos).ne.'!')
if (.not.optional2) then
strpos=strpos+1
endif
if (dattype.eq.5) then
! since only the key's presence is checked, there is no need to
! read beyond the key
datlen=0
else if (typestr(strpos:strpos).eq.'N') then
datlen=-1
else
call trimnum(typestr,tmp,klen)
call nth_word(tmp,numstr,1,klen)
! crash gracefully if the expected number of values is neither
! int nor "N" (hackey version, but i can't think of a cleaner one)
do j=1,1
read(numstr,*,err=600,end=600) datlen
cycle
600 errmsg='CORRUPTED NUMBER OF VALUES: '
> //'"'//trim(typestr)//'"'
call signal_key_error(key,errmsg,klen)
enddo
if (datlen.le.0) then
errmsg='INVALID TYPE SPEC: '//'"'//trim(typestr)//'"'
call signal_key_error(key,errmsg,klen)
endif
endif
end subroutine get_key_kind
subroutine signal_key_error(key,msg,klen)
implicit none
integer klen
character(len=klen) key
character(len=*) msg
write(6,'(A)') 'ERROR: ' // trim(key) // ' ' // trim(msg)
stop 1
end subroutine signal_key_error
end module

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

@ -0,0 +1,601 @@
module long_keyread_mod
contains
! NOTE: all routines other than long_intkey and long_intline are
! copy-pasted versions of different types.
! replacements:
! idat -> *dat
! ipos -> *pos
! istart -> *start
! LONG_INT -> LONG_*
!---------------------------------------------------------------------------
subroutine long_intkey(infile,inpos,key_end,idat,istart,
> readlen,linelen,maxdat,maxlines)
implicit none
! Read an arbitrary number of integers for a single key from infile
! and write to idat.
!
! Data in infile is expected to have the general format
!
! KEY: ... ... ... ... &
! .... ... ... ... ... &
! .... ... ... ... ...
!
! Lines can be continued using the continuation marker arbitrarily
! often. A continuation marker at the last line causes the program
! to read undefined data following below. If that data is not a
! valid line of integers, the program breaks appropiately.
!
! idat: vector to write read data on
! istart: current position in vector idat (first empty entry)
! maxdat: length of idat
! readlen: the number of read integers for current key
!
! infile: string vector containing the read input file linewise
! key_end: length of key, expected at the first line read
! inpos: current position in infile
! linelen: max. character length of a single line
! maxlines: length of infile
!
! broken: if true, assume read data to be corrupt
! continued: if true, the next input line should continue
! the current data block.
integer maxlines,linelen,maxdat
integer key_end
integer istart,inpos,readlen
integer idat(maxdat)
character(len=linelen) infile(maxlines)
logical continued, broken
integer line_start,ipos
character(len=linelen) key
integer n
ipos=istart
readlen=0
key=' '
key=infile(inpos)(1:key_end)
! skip key on first line
line_start=key_end+1
call long_intline(infile(inpos),linelen,line_start,
> idat,ipos,maxdat,readlen,
> continued,broken)
line_start=1
do n=inpos+1,maxlines
if (broken) then
continued=.false.
exit
endif
if (.not.continued) then
exit
endif
call long_intline(infile(n),linelen,line_start,
> idat,ipos,maxdat,readlen,
> continued,broken)
enddo
if (continued) then
write(6,'(A)') 'ERROR: LONG_INTKEY: '
> // trim(key) //' CONTINUATION PAST EOF'
write(6,'(A,I5.5)') 'LINE #',n
endif
if (broken) then
write(6,'(A)') 'ERROR: LONG_INTKEY: '
> // trim(key) //' BROKEN INPUT.'
write(6,'(A,I5.5)') 'LINE #',n
write(6,'(A,I5.5,A)') 'AFTER ', n-inpos-1, ' CONTINUATIONS'
stop 1
endif
end subroutine long_intkey
!---------------------------------------------------------------------------
subroutine long_intline(inline,linelen,line_start,
> idat,ipos,maxdat,readlen,
> continued,broken)
use strings_mod,only: count_words,nth_word
implicit none
! Read a single line of string input INLINE encoding integers.
!
! idat: vector to write read data on
! ipos: current position in vector idat (first empty entry)
! maxdat: length of idat
! inline: string containing line from read input file
! linelen: max. character length of a single line
! broken: if true, assume read data to be corrupt
! continued: if true, the next input line should continue
! the current data block.
! readlen: increment counting the number of read ints
! ASSUMED TO BE INITIALIZED.
integer linelen,maxdat
integer line_start,ipos
integer idat(maxdat)
integer readlen
! character(len=linelen) inline
character(len=linelen) inline
logical continued, broken
integer line_end, wordcount
character(len=linelen) workline, word
integer n
line_end=len_trim(inline)
broken=.false.
! check whether line will be continued
if (inline(line_end:line_end).eq.'&') then
continued=.true.
line_end=line_end-1
else
continued=.false.
endif
! create working copy of line
workline=' '
workline=inline(line_start:line_end)
! check the number of wordcount on line
call count_words(workline,wordcount,linelen)
! if the number of entries exceeds the length of idat, break
if ((wordcount+ipos-1).gt.maxdat) then
write(6,'(A)') 'ERROR: LONG_INTLINE: PARSER OUT OF MEMORY '
> // 'ON READ'
write(6,'(A)') 'CURRENT LINE:'
write(6,'(A)') trim(inline)
broken=.true.
return
endif
do n=1,wordcount
call nth_word(workline,word,n,linelen)
read(word,fmt=*,err=600,end=600) idat(ipos)
readlen=readlen+1
ipos=ipos+1
cycle
! avoid segfault in parser at all costs, throw error instead
600 write(6,'(A,I4.4)') 'ERROR: LONG_INTLINE: '
> // 'A FATAL ERROR OCCURED ON ENTRY #',
> n
write(6,'(A)') 'CURRENT LINE:'
write(6,'(A)') trim(inline)
broken=.true.
return
enddo
end subroutine long_intline
!---------------------------------------------------------------------------
subroutine long_realkey(infile,inpos,key_end,ddat,dstart,
> readlen,linelen,maxdat,maxlines)
implicit none
! Read an arbitrary number of double precisions for a single key from infile
! and write to ddat.
!
! Data in infile is expected to have the general format
!
! KEY: ... ... ... ... &
! .... ... ... ... ... &
! .... ... ... ... ...
!
! Lines can be continued using the continuation marker arbitrarily
! often. A continuation marker at the last line causes the program
! to read undefined data following below. If that data is not a
! valid line of integers, the program breaks appropiately.
!
! ddat: vector to write read data on
! dstart: current position in vector ddat (first empty entry)
! maxdat: length of ddat
! readlen: the number of read integers for current key
!
! infile: string vector containing the read input file linewise
! key_end: length of key, expected at the first line read
! inpos: current position in infile
! linelen: max. character length of a single line
! maxlines: length of infile
!
! broken: if true, assume read data to be corrupt
! continued: if true, the next input line should continue
! the current data block.
integer maxlines,linelen,maxdat
integer key_end
integer dstart,inpos,readlen
double precision ddat(maxdat)
character(len=linelen) infile(maxlines)
logical continued, broken
integer line_start,dpos
character(len=linelen) key
integer n
dpos=dstart
readlen=0
key=' '
key=infile(inpos)(1:key_end)
! skip key on first line
line_start=key_end+1
call long_realline(infile(inpos),linelen,line_start,
> ddat,dpos,maxdat,readlen,
> continued,broken)
line_start=1
do n=inpos+1,maxlines
if (broken) then
continued=.false.
exit
endif
if (.not.continued) then
exit
endif
call long_realline(infile(n),linelen,line_start,
> ddat,dpos,maxdat,readlen,
> continued,broken)
enddo
if (continued) then
write(6,'(A)') 'ERROR: LONG_REALKEY: '
> // trim(key) //' CONTINUATION PAST EOF'
write(6,'(A,I5.5)') 'LINE #',n
endif
if (broken) then
write(6,'(A)') 'ERROR: LONG_REALKEY: '
> // trim(key) //' BROKEN INPUT.'
write(6,'(A,I5.5)') 'LINE #',n
write(6,'(A,I5.5,A)') 'AFTER ', n-inpos-1, ' CONTINUATIONS'
stop 1
endif
end subroutine long_realkey
!---------------------------------------------------------------------------
subroutine long_realline(inline,linelen,line_start,
> ddat,dpos,maxdat,readlen,
> continued,broken)
use strings_mod,only: count_words,nth_word
implicit none
! Read a single line of string input INLINE encoding double precisions.
!
! ddat: vector to write read data on
! dpos: current position in vector ddat (first empty entry)
! maxdat: length of ddat
! inline: string containing line from read input file
! linelen: max. character length of a single line
! broken: if true, assume read data to be corrupt
! continued: if true, the next input line should continue
! the current data block.
! readlen: increment counting the number of read ints
! ASSUMED TO BE INITIALIZED.
integer linelen,maxdat
integer line_start,dpos
integer readlen
double precision ddat(maxdat)
character(len=linelen) inline
logical continued, broken
integer line_end, wordcount
character(len=linelen) workline, word
integer n
line_end=len_trim(inline)
broken=.false.
! check whether line will be continued
if (inline(line_end:line_end).eq.'&') then
continued=.true.
line_end=line_end-1
else
continued=.false.
endif
! create working copy of line
workline=' '
workline=inline(line_start:line_end)
! check the number of wordcount on line
call count_words(workline,wordcount,linelen)
! if the number of entries exceeds the length of ddat, break
if ((wordcount+dpos-1).gt.maxdat) then
write(6,'(A)') 'ERROR: LONG_REALLINE: PARSER OUT OF MEMORY '
> // 'ON READ'
write(6,'(A)') 'CURRENT LINE:'
write(6,'(A)') trim(inline)
write(6,*) 'wordcount',wordcount
write(6,*) 'dpos',dpos
write(6,*) 'maxdat',maxdat
write(6,*) 'ddat',ddat(1:maxdat)
broken=.true.
return
endif
do n=1,wordcount
call nth_word(workline,word,n,linelen)
read(word,fmt=*,err=600,end=600) ddat(dpos)
readlen=readlen+1
dpos=dpos+1
cycle
! avoid segfault in parser at all costs, throw error instead
600 write(6,'(A,I4.4)') 'ERROR: LONG_REALLINE: '
> // 'A FATAL ERROR OCCURED ON ENTRY #',
> n
write(6,'(A)') 'CURRENT LINE:'
write(6,'(A)') trim(inline)
broken=.true.
return
enddo
end subroutine long_realline
!---------------------------------------------------------------------------
subroutine long_strkey(infile,inpos,key_end,cdat,cstart,
> readlen,linelen,datlen,maxlines,clen)
implicit none
! Read an arbitrary number of strings for a single key from infile
! and write to idat.
!
! Data in infile is expected to have the general format
!
! KEY: ... ... ... ... &
! .... ... ... ... ... &
! .... ... ... ... ...
!
! Lines can be continued using the continuation marker arbitrarily
! often. A continuation marker at the last line causes the program
! to read undefined data following below. If that data is not a
! valid line of strings, the program breaks appropiately.
!
! cdat: vector to write read data on
! cstart: current position in vector idat (first empty entry)
! datlen: length of idat
! readlen: the number of read integers for current key
!
! infile: string vector containing the read input file linewise
! key_end: length of key, expected at the first line read
! inpos: current position in infile
! linelen: max. character length of a single line
! maxlines: length of infile
! clen: maximum length of a given string
!
! broken: if true, assume read data to be corrupt
! continued: if true, the next input line should continue
! the current data block.
! append: if true, continue appending to an existing string.
integer maxlines,linelen,datlen,clen
integer key_end
integer cstart,inpos,readlen
character(len=linelen) infile(maxlines)
character(len=clen) cdat(datlen)
integer line_start,cpos
integer strpos
character(len=linelen) key
logical continued, broken
integer n
cpos=cstart
readlen=0
key=' '
key=infile(inpos)(1:key_end)
! skip key on first line
line_start=key_end+1
strpos=0
call long_strline(infile(inpos),linelen,line_start,
> cdat,cpos,datlen,readlen,clen,
> continued,broken,strpos)
line_start=1
do n=inpos+1,maxlines
if (broken) then
continued=.false.
exit
endif
if (.not.continued) then
exit
endif
call long_strline(infile(n),linelen,line_start,
> cdat,cpos,datlen,readlen,clen,
> continued,broken,strpos)
enddo
if (continued) then
write(6,'(A)') 'ERROR: LONG_STRKEY: '
> // trim(key) //' CONTINUATION PAST EOF'
write(6,'(A,I5.5)') 'LINE #',n
endif
if (broken) then
write(6,'(A)') 'ERROR: LONG_STRKEY: '
> // trim(key) //' BROKEN INPUT.'
write(6,'(A,I5.5)') 'LINE #',n
write(6,'(A,I5.5,A)') 'AFTER ', n-inpos-1, ' CONTINUATIONS'
stop 1
endif
end subroutine long_strkey
!---------------------------------------------------------------------------
subroutine long_strline(inline,linelen,line_start,
> cdat,cpos,datlen,readlen,clen,
> continued,broken,strpos)
use strings_mod,only:iswhitespace, downcase
implicit none
! Read a single line of string input INLINE encoding integers.
!
! cdat: vector to write read data on
! cpos: current position in vector cdat (first empty/incomplete entry)
! datlen: length of idat
! inline: string containing line from read input file
! linelen: max. character length of a single line
! broken: if true, assume read data to be corrupt
! continued: if true, the next input line should continue
! the current data block.
! readlen: increment counting the number of read strings
! ASSUMED TO BE INITIALIZED.
! strpos: if 0, create new string. Otherwise, append to string of assumed
! length strpos.
integer :: linelen,datlen,clen
integer :: line_start,cpos,strpos
integer :: readlen
character(len=linelen) :: inline
character(len=clen) :: cdat(datlen)
logical :: continued, broken
character,parameter :: esc = ACHAR(92) ! "\"
integer :: line_end
character(len=linelen) :: workline
character(len=1) :: char, tmp_char
logical :: cont_string, escaped
integer :: j
! logical :: iswhitespace
broken=.false.
continued=.false.
cont_string=.false.
escaped=.false.
! create working copy of line
workline=' '
workline=inline(line_start:len_trim(inline))
line_end=len_trim(workline)
! If needed, initialize working position in cdat
if (strpos.eq.0) then
cdat(cpos)=' '
endif
! iterate over characters in line
do j=1,line_end
char=workline(j:j)
if (escaped) then
! Insert escaped character and proceed.
escaped=.false.
! Special escape sequences
if (char.eq.'.') then
! \. = !
char='!'
endif
else if (char.eq.esc) then
! Consider next character escaped, skip char.
escaped=.true.
cycle
else if (char.eq.'&') then
continued=.true.
if (j.eq.line_end) then
exit
endif
! Deal with unusual continuations, look at char after "&"
char=workline(j+1:j+1)
if (char.eq.'&') then
! "&&" allows multi-line strings
cont_string=.true.
if (j+1.eq.line_end) then
exit
endif
endif
write(6,'(A)') 'WARNING: LONG_STRLINE: IGNORED'
> // ' JUNK CHARACTER(S) FOLLOWING'
> // ' CONTINUATION CHARACTER.'
exit
else if (iswhitespace(char)) then
! Whitespace separates strings; skip char.
if (strpos.gt.0) then
! Begin a new string unless the current one is empty.
strpos=0
cpos=cpos+1
cdat(cpos)=' '
endif
cycle
else
! assume char to be meant as a downcase char
call downcase(char,tmp_char,1)
char=tmp_char
endif
! Incorporate new char into string
strpos=strpos+1
! Break if a boundary exception occurs
if (cpos.gt.datlen) then
write(6,'(A)') 'ERROR: LONG_STRLINE: PARSER OUT OF MEMORY'
> // ' ON READ'
write(6,'(A)') 'CURRENT LINE:'
write(6,'(A)') trim(inline)
broken=.true.
return
else if (strpos.gt.clen) then
write(6,'(A)') 'ERROR: LONG_STRLINE: PARSER OUT OF MEMORY'
> // ' ON READ: STRING ARGUMENT EXCEEDS CLEN'
write(6,'(A)') 'CURRENT LINE:'
write(6,'(A)') trim(inline)
broken=.true.
return
endif
! insert character
cdat(cpos)(strpos:strpos)=char
if (strpos.eq.1) then
readlen=readlen+1
endif
enddo
! Fix incomplete escape sequences and deal with continuation
if (escaped) then
write(6,'(A)') 'WARNING: LONG_STRLINE: ENCOUNTERED ESCAPE'
> // ' CHARACTER AT EOL. IGNORED.'
endif
! Unless the line ended with "&&", consider the current, non-empty
! string complete.
if ((cont_string).or.(strpos.eq.0)) then
return
else
cpos=cpos+1
strpos=0
endif
end subroutine long_strline
end module

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

@ -0,0 +1,505 @@
module strings_mod
implicit none
contains
!----------------------------------------------------------------------------
subroutine capital(in,str,lauf,mmax,sl)
integer mmax,lauf,i,j,sl
character in(mmax)*(*), str*(*)
if (str.eq.'') return
j=0
do i=1,sl
if (str(i:i).ne.' ') then
j=i-1
goto 10
endif
enddo
10 do i=1,sl-j
str(i:i)=str(i+j:i+j)
enddo
do i=sl-j+1,sl
str(i:i)=' '
enddo
if (str(1:1).eq.'!') return
lauf=lauf+1
do i=1,sl
in(lauf)(i:i)=str(i:i)
if (str(i:i).eq.'a') in(lauf)(i:i)='A'
if (str(i:i).eq.'b') in(lauf)(i:i)='B'
if (str(i:i).eq.'c') in(lauf)(i:i)='C'
if (str(i:i).eq.'d') in(lauf)(i:i)='D'
if (str(i:i).eq.'e') in(lauf)(i:i)='E'
if (str(i:i).eq.'f') in(lauf)(i:i)='F'
if (str(i:i).eq.'g') in(lauf)(i:i)='G'
if (str(i:i).eq.'h') in(lauf)(i:i)='H'
if (str(i:i).eq.'i') in(lauf)(i:i)='I'
if (str(i:i).eq.'j') in(lauf)(i:i)='J'
if (str(i:i).eq.'k') in(lauf)(i:i)='K'
if (str(i:i).eq.'l') in(lauf)(i:i)='L'
if (str(i:i).eq.'m') in(lauf)(i:i)='M'
if (str(i:i).eq.'n') in(lauf)(i:i)='N'
if (str(i:i).eq.'o') in(lauf)(i:i)='O'
if (str(i:i).eq.'p') in(lauf)(i:i)='P'
if (str(i:i).eq.'q') in(lauf)(i:i)='Q'
if (str(i:i).eq.'r') in(lauf)(i:i)='R'
if (str(i:i).eq.'s') in(lauf)(i:i)='S'
if (str(i:i).eq.'t') in(lauf)(i:i)='T'
if (str(i:i).eq.'u') in(lauf)(i:i)='U'
if (str(i:i).eq.'v') in(lauf)(i:i)='V'
if (str(i:i).eq.'w') in(lauf)(i:i)='W'
if (str(i:i).eq.'x') in(lauf)(i:i)='X'
if (str(i:i).eq.'y') in(lauf)(i:i)='Y'
if (str(i:i).eq.'z') in(lauf)(i:i)='Z'
C..... Addition of the first if-loop
if (i-3.gt.0) then
if (in(lauf)(i-3:i).eq.'CHK:') then
in(lauf)(i+1:sl)=str(i+1:sl)
return
endif
endif
! if (i+3.le.sl) then
! if (in(lauf)(i:i+3).eq.'CHK:') then
! in(lauf)(i+1:sl)=str(i+1:sl)
! return
! endif
! endif
enddo
end subroutine capital
!-----------------------------------------------------------------------
subroutine lcap(str,n)
integer i, n
character str*(*), dum*750
dum=''
do i=1,n
dum(i:i)=str(i:i)
if (str(i:i).eq.'a') dum(i:i)='A'
if (str(i:i).eq.'b') dum(i:i)='B'
if (str(i:i).eq.'c') dum(i:i)='C'
if (str(i:i).eq.'d') dum(i:i)='D'
if (str(i:i).eq.'e') dum(i:i)='E'
if (str(i:i).eq.'f') dum(i:i)='F'
if (str(i:i).eq.'g') dum(i:i)='G'
if (str(i:i).eq.'h') dum(i:i)='H'
if (str(i:i).eq.'i') dum(i:i)='I'
if (str(i:i).eq.'j') dum(i:i)='J'
if (str(i:i).eq.'k') dum(i:i)='K'
if (str(i:i).eq.'l') dum(i:i)='L'
if (str(i:i).eq.'m') dum(i:i)='M'
if (str(i:i).eq.'n') dum(i:i)='N'
if (str(i:i).eq.'o') dum(i:i)='O'
if (str(i:i).eq.'p') dum(i:i)='P'
if (str(i:i).eq.'q') dum(i:i)='Q'
if (str(i:i).eq.'r') dum(i:i)='R'
if (str(i:i).eq.'s') dum(i:i)='S'
if (str(i:i).eq.'t') dum(i:i)='T'
if (str(i:i).eq.'u') dum(i:i)='U'
if (str(i:i).eq.'v') dum(i:i)='V'
if (str(i:i).eq.'w') dum(i:i)='W'
if (str(i:i).eq.'x') dum(i:i)='X'
if (str(i:i).eq.'y') dum(i:i)='Y'
if (str(i:i).eq.'z') dum(i:i)='Z'
enddo
str(1:n)=dum(1:n)
end subroutine lcap
!--------------------------------------------------------------------------
! function to test how many entries are on one line:
function clen(str,sl)
integer clen, i, j, sl
character str*(sl)
clen=0
j=0
do i=sl,1,-1
if ((str(i:i).ne.' ').and.(j.eq.0)) then
clen=clen+1
j=1
endif
if (str(i:i).eq.' ') j=0
enddo
end function clen
!--------------------------------------------------------------------------
logical function isnumeral(char)
! Check whether character CHAR is a numeral.
character char
character numerals(10)
parameter (numerals = ['0','1','2','3','4','5','6','7','8','9'])
isnumeral=any(numerals.eq.char)
end function isnumeral
!--------------------------------------------------------------------------
logical function iswhitespace(char)
! Check whether CHAR is tab or spc character
character char
character whitespace(2)
parameter (whitespace = [' ', ' '])
iswhitespace=any(whitespace.eq.char)
end function iswhitespace
!--------------------------------------------------------------------------
subroutine trimnum(string,outstr,str_len)
! Extract numbers in STRING as a space separated list in OUTSTR.
integer str_len
character(len=str_len) string
character(len=str_len) outstr
integer length
logical foundnum
integer k
! logical isnumeral
length=len_trim(string)
foundnum=.false.
outstr=' '
do k=1,length
if (isnumeral(string(k:k))) then
if (foundnum) then
outstr = trim(outstr) // string(k:k)
else if (len_trim(outstr).ne.0) then
outstr = trim(outstr) // ' ' // string(k:k)
foundnum=.true.
else
outstr = trim(outstr) // string(k:k)
foundnum=.true.
endif
else
foundnum=.false.
endif
enddo
end subroutine trimnum
!--------------------------------------------------------------------------
subroutine strip_string(string,stripped,str_len)
! Strip lefthand whitespace of STRING as well as excessive
! whitespace and save to STRIPPED.
! Example:
! " the quick brown fox" -> "the quick brown fox"
integer str_len
character(len=str_len) string,stripped
character char
logical spaced
! logical iswhitespace
integer k, trimpos
stripped=' '
trimpos=1
! spaced indicates whether if a space is found it is the first
! (separating the word from the next) or redundant
spaced=.true.
do k=1,len_trim(string)
char=string(k:k)
if (.not.iswhitespace(char)) then
spaced=.false.
else if (.not.spaced) then
! replace TAB characters if present
char=' '
spaced=.true.
else
! ignore redundant spaces
cycle
endif
stripped(trimpos:trimpos)=char
trimpos=trimpos+1
enddo
end subroutine strip_string
!--------------------------------------------------------------------------
subroutine nth_word(string,word,n,str_len)
! If STRING is a space separated list of words, return the Nth word.
integer str_len
character(len=str_len) string,word
integer n
character(len=str_len) strip
integer wc
! logical iswhitespace
integer k,j
call strip_string(string,strip,str_len)
word=' '
wc=1
! find the word
do k=1,len_trim(strip)
if (wc.eq.n) exit
if (iswhitespace(strip(k:k))) then
wc=wc+1
endif
enddo
do j=k,len_trim(strip)
if (iswhitespace(strip(j:j))) exit
word = trim(word) // strip(j:j)
enddo
end subroutine nth_word
!--------------------------------------------------------------------------
subroutine count_words(string,wordcount,str_len)
! If STRING is a space separated list of words, return the Nth word.
integer str_len
character(len=str_len) string
integer wordcount
character(len=str_len) strip
integer wc
! logical iswhitespace
integer k
call strip_string(string,strip,str_len)
if (len_trim(strip).gt.0) then
wc=1
else
wordcount=0
return
endif
! find the word
do k=1,len_trim(strip)
if (iswhitespace(strip(k:k))) then
wc=wc+1
endif
enddo
wordcount=wc
end subroutine count_words
!--------------------------------------------------------------------------
subroutine upcase(string,upstring,str_len)
! Transform arbitrary string to uppercase and save to upstring
integer str_len
character(len=str_len) string,upstring
integer j
upstring=' '
do j=1,len_trim(string)
select case (string(j:j))
case ('a')
upstring(j:j)= 'A'
case ('b')
upstring(j:j)= 'B'
case ('c')
upstring(j:j)= 'C'
case ('d')
upstring(j:j)= 'D'
case ('e')
upstring(j:j)= 'E'
case ('f')
upstring(j:j)= 'F'
case ('g')
upstring(j:j)= 'G'
case ('h')
upstring(j:j)= 'H'
case ('i')
upstring(j:j)= 'I'
case ('j')
upstring(j:j)= 'J'
case ('k')
upstring(j:j)= 'K'
case ('l')
upstring(j:j)= 'L'
case ('m')
upstring(j:j)= 'M'
case ('n')
upstring(j:j)= 'N'
case ('o')
upstring(j:j)= 'O'
case ('p')
upstring(j:j)= 'P'
case ('q')
upstring(j:j)= 'Q'
case ('r')
upstring(j:j)= 'R'
case ('s')
upstring(j:j)= 'S'
case ('t')
upstring(j:j)= 'T'
case ('u')
upstring(j:j)= 'U'
case ('v')
upstring(j:j)= 'V'
case ('w')
upstring(j:j)= 'W'
case ('x')
upstring(j:j)= 'X'
case ('y')
upstring(j:j)= 'Y'
case ('z')
upstring(j:j)= 'Z'
case default
upstring(j:j)=string(j:j)
end select
enddo
end subroutine upcase
!--------------------------------------------------------------------------
subroutine downcase(string,downstring,str_len)
! Transform arbitrary string to downcase and save to downstring
integer str_len
character(len=str_len) string,downstring
integer j
downstring=' '
do j=1,len_trim(string)
select case (string(j:j))
case ('A')
downstring(j:j)= 'a'
case ('B')
downstring(j:j)= 'b'
case ('C')
downstring(j:j)= 'c'
case ('D')
downstring(j:j)= 'd'
case ('E')
downstring(j:j)= 'e'
case ('F')
downstring(j:j)= 'f'
case ('G')
downstring(j:j)= 'g'
case ('H')
downstring(j:j)= 'h'
case ('I')
downstring(j:j)= 'i'
case ('J')
downstring(j:j)= 'j'
case ('K')
downstring(j:j)= 'k'
case ('L')
downstring(j:j)= 'l'
case ('M')
downstring(j:j)= 'm'
case ('N')
downstring(j:j)= 'n'
case ('O')
downstring(j:j)= 'o'
case ('P')
downstring(j:j)= 'p'
case ('Q')
downstring(j:j)= 'q'
case ('R')
downstring(j:j)= 'r'
case ('S')
downstring(j:j)= 's'
case ('T')
downstring(j:j)= 't'
case ('U')
downstring(j:j)= 'u'
case ('V')
downstring(j:j)= 'v'
case ('W')
downstring(j:j)= 'w'
case ('X')
downstring(j:j)= 'x'
case ('Y')
downstring(j:j)= 'y'
case ('Z')
downstring(j:j)= 'z'
case default
downstring(j:j)=string(j:j)
end select
enddo
end subroutine downcase
!--------------------------------------------------------------------------
pure function int2string(int) result(string)
character(len=:), allocatable :: string
integer, intent(in) :: int
character(len=100) :: str
write(str,'(i0)') int
string = trim(adjustl(str))
end function int2string
!--------------------------------------------------------------------------
pure function dble2string(dble) result(string)
character(len=:), allocatable :: string
double precision, intent(in) :: dble
character(len=100) :: str
write(str,'(ES16.9)') dble
string = trim(adjustl(str))
end function dble2string
!--------------------------------------------------------------------------
pure function shortdble2string(dble) result(string)
character(len=:), allocatable :: string
double precision, intent(in) :: dble
character(len=100) :: str
write(str,'(ES11.2)') dble
string = trim(adjustl(str))
end function shortdble2string
!----------------------------------------------------------------------------------
subroutine write_oneline(string,id_print)
#ifdef mpi_version
use mpi
#endif
integer,intent(in) :: id_print
character(len=*) string
#ifdef mpi_version
integer my_rank,ierror
call MPI_Comm_rank(MPI_COMM_WORLD, my_rank, ierror)
#endif
#ifdef mpi_version
if (my_rank.eq.0) then
#endif
write(id_print,'(A)') adjustl(trim(string))
#ifdef mpi_version
endif
#endif
end subroutine write_oneline
end module

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

@ -0,0 +1,6 @@
integer typenum,maxtypelen
parameter (typenum=6,maxtypelen=2)
character(len=maxtypelen) types(typenum)
! parameter (types=['I', '+I', 'D', '+D', 'C', 'E'])
parameter (types=['I ', '+I', 'D ', '+D', 'C ', 'E ']) !Fabian

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

@ -0,0 +1,103 @@
************************************************************************
*** long_write
*** writing genetic's long input format
***
************************************************************************
module long_write
implicit none
contains
subroutine write_longint(f_unit,params,plen,intfmt,maxvals)
implicit none
! Routine writing long integer output of the form
! x1 x2 x3 .... xN &
! ... &
!
! f_unit: UNIT to be written on, directly passed to write
! params: integer vector to be written out
! plen: number of elements to be printed
! maxvals: (maximum) number of values per line
! intfmt: format of a single interger, e.g. '(I6)'
integer f_unit
integer params(*)
integer plen,maxvals
character*16 intfmt
integer pcount
integer j,k
pcount=0 ! count parameters written so far
! write all values that fill entire lines.
do k=1,(plen/maxvals)
do j=1,maxvals
write(unit=f_unit,fmt=intfmt,advance='NO') params(pcount+j)
enddo
pcount=pcount+maxvals
if (pcount.lt.plen) then
write(unit=f_unit,fmt='(A)') ' &'
endif
enddo
pcount=pcount+1
! write remaining few
do k=pcount,plen
write(unit=f_unit,fmt=intfmt,advance='NO') params(k)
enddo
write(f_unit,'(A)') ''
end subroutine
!----------------------------------------------------------------------------
subroutine write_longreal(f_unit,params,plen,dfmt,maxvals)
implicit none
! Routine writing long real(*8) output of the form
! x1 x2 x3 .... xN &
! ... &
!
! f_unit: UNIT to be written on, directly passed to write
! params: integer vector to be written out
! plen: number of elements to be printed
! maxvals: (maximum) number of values per line
! dfmt: format of a single real, e.g. '(ES23.15)'
real*8 params(*)
integer f_unit
integer plen,maxvals
character*16 dfmt
integer pcount
integer j,k
pcount=0 ! count parameters written so far
! write all values that fill entire lines.
do k=1,(plen/maxvals)
do j=1,maxvals
write(unit=f_unit,fmt=dfmt,advance='NO') params(pcount+j)
enddo
pcount=pcount+maxvals
if (pcount.lt.plen) then
write(unit=f_unit,fmt='(A)') ' &'
endif
enddo
pcount=pcount+1
! write remaining few
do k=pcount,plen
write(unit=f_unit,fmt=dfmt,advance='NO') params(k)
enddo
write(f_unit,'(A)') ''
end subroutine
end module

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

@ -0,0 +1,246 @@
module parameterkeys
use io_parameters, only: llen,klen,
> key,maxpar_keys,parkeynum,parkeylen,ec_read,ec_dim
use dim_parameter,only: pst,max_par
use keys_mod, only: init_keys
implicit none
contains
! < Subroutine reading the user defined Parameter keys from keys.incl
! <returns: the parameter arrays p, p_act, p_spread and their length npar
! <needs: internalized file (infile) it's length (linenum), the keylist from keys.incl (key) and the counted number of keys (parkeynum)
subroutine parameterkey_read
> (infile,linenum,p,p_act,p_spread,npar,gspread,facspread)
use strings_mod,only:write_oneline
use long_keyread_mod,only:long_intkey,long_realkey,long_strkey
! dir$ optimize:1
! IN: variables
integer linenum !< number of lines in internalized input file (infile)
character(len=llen) :: infile(linenum) !< internalized input file
double precision gspread !< general parameterspread used to initialize p_spread
double precision facspread !< multiplicative factor for spreads
! OUT: read parameters and their lenght,spread and active state
integer npar !< lenght oo parameter vector
double precision, allocatable :: p(:) !< vector for the values of read parameters
double precision, allocatable :: p_spread(:) !< vector for the spread values for each parameter
integer, allocatable :: p_act(:) !< vector containing 0 or 1 defining if corresponding parameters are activ in Fit ! Nicole: added flexible value for nonlinear terms
! Private: variables
integer i,j !< running indicies
integer ktype,key_end !< dummys for keytype and keylength
integer pcount !< dummy for number of read values
logical dbg !< logical for debugging state
! Fabian
character(len=llen) fmt
integer,parameter :: std_out = 6
dbg =.false.
!Fabian: No need that these are within keys.incl since these are generic statements
parkeynum=0
parkeylen=0
key = ' '
!Fabian: Include user specific keys
call init_keys
! include 'keys.incl'
!Fabian: No need that this is within keys.incl since it is generic
do j=1,maxpar_keys
if (key(1,j)(1:1).eq.' ') then
parkeynum=j-1
write(fmt,'("Number of accepted parameter keys: ",I3)')
> parkeynum
call write_oneline(fmt,std_out)
exit
endif
enddo
do i=1,4
do j=1,maxpar_keys
if(parkeylen.lt.len_trim(key(i,j))) then
parkeylen = len_trim(key(i,j))
endif
enddo
enddo
if(parkeylen.ge.klen) then
write(fmt,*)
> 'WARNING: Lenght of Parameterkey >= Maximum Keylenght'
call write_oneline(fmt,std_out)
endif
! reading cards for the number of parameters'
npar =0
ktype = 1 !reading number of parameters per key
do i=1,linenum
do j=1, parkeynum
! get string length of key
key_end=len_trim(key(ktype,j))
! check if key is present and read values if present
if (infile(i)(1:key_end).eq.key(ktype,j)) then
if(dbg) write(6,*) key(ktype,j),' read'
read (infile(i)(key_end+1:llen),*) pst(2,j)
endif
enddo
enddo
!.. compute total number of parameters:
do i=1, parkeynum
npar=npar + pst(2,i)
enddo
if(npar.gt.max_par) call signal_maxparameter_error(npar,max_par)
if(npar.le.0) call signal_noparameters_error(npar)
write(fmt,'("Number of Expected Parameters: ",I9)') npar
call write_oneline(fmt,std_out)
!.. determine start and end points of parameter blocks:
pst(1,1)=1 ! 1 = start of block
do i=2,parkeynum
pst(1,i)= pst(1,i-1)+pst(2,i-1)
if(dbg) write(6,'("pst(1:2,i): ",2i9)') pst(1:2,i)
enddo
! allocate parameter arrays
allocate(p(npar),p_act(npar),p_spread(npar))
! initialize parameter arrays
p=0.d0
! DW: UNDOCUMENTED BEHAVIOR: What does act=2 do???
p_act=10
p_spread=gspread
! read parameter values
ktype = 2 !reading value of parameters per key
do i=1,linenum
do j=1, parkeynum
! get string length of key
key_end=len_trim(key(ktype,j))
! check if key is present and read values if present
if (infile(i)(1:key_end).eq.key(ktype,j)) then
if(dbg) write(6,*) key(ktype,j),' read'
call long_realkey(infile,i,key_end,
> p,pst(1,j),pcount,llen,npar,linenum)
! check if number of parameters consistent
if(pcount.ne.pst(2,j)) then
call signal_parameter_error
> (key(ktype,j),pcount,pst(2,j))
endif
endif
enddo
enddo
! read if parameters are activ
ktype = 3 !reading activity of parameter per key
do i=1,linenum
do j=1, parkeynum
! get string length of key
key_end=len_trim(key(ktype,j))
! check if key is present and read values if present
if (infile(i)(1:key_end).eq.key(ktype,j)) then
if(dbg) write(6,*) key(ktype,j),' read'
call long_intkey(infile,i,key_end,
> p_act,pst(1,j),pcount,llen,npar,linenum)
! check if number of parameters consistent
if(pcount.ne.pst(2,j)) then
call signal_parameter_error
> (key(ktype,j),pcount,pst(2,j))
endif
endif
enddo
enddo
! check if all values for p_act are in valid range
do i=1,npar
! Nicole: added flexible p_act values
! in my case now up tp 6
if((abs(p_act(i)).gt.6)) then
write(fmt,*) 'Invalid value for p_act: ', p_act(i), i
call write_oneline(fmt,std_out)
endif
enddo
! read spread for parameters
ktype = 4 !reading spread of parameters per key
do i=1,linenum
do j=1, parkeynum
! get string length of key
key_end=len_trim(key(ktype,j))
! check if key is present and read values if present
if (infile(i)(1:key_end).eq.key(ktype,j)) then
if(dbg) write(6,*) key(ktype,j),' read'
call long_realkey(infile,i,key_end,
> p_spread,pst(1,j),pcount,llen,npar,linenum)
! check if number of parameters consistent
if(pcount.ne.pst(2,j)) then
call signal_parameter_error
> (key(ktype,j),pcount,pst(2,j))
endif
endif
enddo
enddo
!Multiply p_spread by facspread
!(default facspread=1, unless it is explicitly declared)
p_spread=p_spread*facspread
end subroutine
!----------------------------------------------------------------------------------------------------
! <Subroutine returns error message for inconsistent number of Parameters
! <needs: the corresponding key as string (keystr) the number of values read (val) and the expected number (expval)
subroutine signal_parameter_error(keystr,val,expval)
use strings_mod,only:int2string
character(len=klen) :: keystr !< string containing the Card (EXAMPLE:)
integer :: val, expval !< number of read and expected number of Parametervalues
write(6,'(A)')'ERROR: Reading ' // trim(keystr) // ' counted: '
> // trim(int2string(val)) // ' Parameters, but expected: '
> // trim(int2string(expval))
stop ec_read
end subroutine
!----------------------------------------------------------------------------------------------------
! <Subroutine returns error message for inconsistent number of Parameters
! <needs: the corresponding key as string (keystr) the number of values read (val) and the expected number (expval)
subroutine signal_maxparameter_error(val,maxval)
use strings_mod,only:int2string
integer :: val, maxval !< number of read and expected number of Parametervalues
write(6,'(A)')'ERROR: More Parameters then given maximum counted:'
> // trim(int2string(val)) // ' Parameters, but maximum: '
> // trim(int2string(maxval))
stop ec_dim
end subroutine
!----------------------------------------------------------------------------------------------------
! <Subroutine returns error message for inconsistent number of Parameters
! <needs: the corresponding key as string (keystr) the number of values read (val) and the expected number (expval)
subroutine signal_noparameters_error(val)
use strings_mod,only:int2string
integer :: val !< number of read and expected number of Parametervalues
write(6,'(A)')'ERROR: No. of counted parameters is <= 0:'
> // trim(int2string(val))
stop ec_dim
end subroutine
end module

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

@ -0,0 +1,117 @@
module parse_errors
use io_parameters, only:
> keylist, errcat, ec_dim, ec_log, ec_read, ec_error
implicit none
contains
!--------------------------------------------------------------------------------
subroutine signal_p_error(key_id,msg)
! Signal generic error with user-defined message MSG.
integer key_id
character(len=*) msg
write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id))
> // ' ' // trim(msg)
stop ec_error
end subroutine
!--------------------------------------------------------------------------------
subroutine signal_dim_error(key_id,msg_code,value,expval)
use strings_mod,only:int2string
! Signals errors where one specific dimensioning value is ill-set.
! If the optional parameter EXPVAL is given, return it as expected
! dimensioning value.
integer key_id, value
integer, optional :: expval
integer msg_code
write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id))
> // ' ' // trim(errcat(msg_code))
write(6,'(A)') 'OFFENDING VALUE: ' // trim(int2string(value))
if (present(expval)) then
write(6,'(A)') 'EXPECTED: ' // trim(int2string(expval))
endif
stop ec_dim
end subroutine
!--------------------------------------------------------------------------------
subroutine signal_log_error(key_id,msg_code,alt_key)
! Signals errors where contradictory settings are provided which
! the program cannot resolve. If the optional parameter ALT_KEY
! is given, name the explicit key current settings clash with.
integer key_id
integer, optional :: alt_key
integer msg_code
write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id))
> // ' ' // trim(errcat(msg_code))
if (present(alt_key)) then
write(6,'(A)') 'OFFENDING KEY: ' // trim(keylist(1,alt_key))
endif
stop ec_log
end subroutine
!--------------------------------------------------------------------------------
subroutine signal_val_error(key_id,msg_code,value,expval)
use strings_mod,only:int2string
! Signals errors where a given value makes no sense in it's given context.
! If the optional parameter EXPVAL is given, return it as expected
! dimensioning value.
integer key_id, value
integer, optional :: expval
integer msg_code
write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id))
> // ' ' // trim(errcat(msg_code))
write(6,'(A)') 'OFFENDING VALUE: ' // trim(int2string(value))
if (present(expval)) then
write(6,'(A)') 'EXPECTED: ' // trim(int2string(expval))
endif
stop ec_read
end subroutine
!--------------------------------------------------------------------------------
subroutine signal_dval_error(key_id,msg_code,value,expval)
use strings_mod,only: shortdble2string
! Signals errors where a given value makes no sense in it's given context.
! If the optional parameter EXPVAL is given, return it as expected
! dimensioning value.
integer key_id
double precision value
double precision, optional :: expval
integer msg_code
write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id))
> // ' ' // trim(errcat(msg_code))
write(6,'(A)') 'OFFENDING VALUE: '
> // trim(shortdble2string(value))
if (present(expval)) then
write(6,'(A)') 'EXPECTED: ' // trim(shortdble2string(expval))
endif
stop ec_read
end subroutine
!--------------------------------------------------------------------------------
subroutine signal_meta_error(key_id,msg_code)
! Signals errors where a key (or key combinations) is/are not
! supported or maintained for reasons outside of the program's
! scope (e.g.: deprecation).
integer key_id,msg_code
write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id))
> // ' ' // trim(errcat(msg_code))
stop ec_read
end subroutine
end module

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

@ -0,0 +1,875 @@
! >Module Containing Subroutines relevant for reading cards and information from an inputfile
module parser
use io_parameters
use dim_parameter
use parse_errors
use parameterkeys, only: parameterkey_read
use long_write
implicit none
contains
!--------------------------------------------------------------------------------------------------------------------------------------
! >Reads Cards and Data from Inputfile
! !@param datname name of input file that is readed
! !@param infile internalized input file
! !@param linenum linenumber of internalized input file
! !@param idat
subroutine les(x,y,wt,p,p_act,p_spread,npar,
> seed,gtype,nset,maxit,micit,nsel,mut,difper,freeze)
use strings_mod,only:write_oneline
use fileread_mod,only:get_datfile,internalize_datfile
use keyread_mod,only:keyread
! implicit none
! Include Files for needed dimension parameters
! Declare OUT Variables
! Data variables
double precision, allocatable :: x(:,:) , y(:,:), wt(:,:)
! Fiting Model Parameters
double precision, allocatable :: p(:) !< vector(npar) for the values of read parameters
integer, allocatable :: p_act(:) !< vector(npar) containing 0 or 1 defining if corresponding parameters are activ in Fit
double precision, allocatable :: p_spread(:) !< vector(npar) for the spread values for each parameter
integer npar !< read length of parameter arrays
! Fit control Parameters
integer seed !< Seed for RNG
integer nset !< number of diffrent parameter sets
logical freeze !< determines if parameters are active
double precision mut, difper !< percentage of selected Parents, number of mutations in parents, minimum diffrence between selected parents
double precision psel !< percantage of selected parents
integer nsel !< number of selected parents , generated from psel and nset by rounding to nearest integer
integer gtype !< type of RNG used
integer maxit, micit !<maximum makro and micro iterations for the genetic program
! weighting parameters
! Declare INTERNAL variables
character(len=dnlen) :: datname, dbgdatname !< name of the input File
character(len=llen), dimension(:), allocatable :: infile !< internalized array of capitalized input file without comments, blanklines
integer linenum !< linenumber in infile
double precision gspread
! data arrays
integer idat(maxdat)
double precision ddat(maxdat)
character(len=clen) cdat(maxdat)
! minimum ntot (inferred from ndiab etc)
integer min_ntot
! running index
integer j !< running index
! general key variables
integer key_id !< integer identifying a key from keylist.incl
logical legacy_wt
! length or position variables
integer dat_start !< linenumber in infile where DATA: Block starts
! Fabian
character(len=llen) :: fmt,fmt2
integer, parameter :: id_internal = 10 ! hardcoded until queue is ready for modern features
integer, parameter :: std_out = 6
! allocate relevant arrays
allocate(infile(maxlines))
! define Error Messages
include 'errcat.incl'
! include general keylist
include 'keylist.incl'
do j=1,maxkeys
if (keylist(1,j)(1:1).eq.' ') then
keynum=j-1
write(fmt,'("Number of accepted input keys: ",I3)') keynum
call write_oneline(fmt,std_out)
exit
endif
enddo
!############################################################
! Read input file
!############################################################
call get_datfile(datname,dnlen)
call internalize_datfile
> (datname,infile,linenum,llen,maxlines,dnlen)
dbgdatname='.internal_input'
#ifndef mpi_version
write(6,'(A)') 'Writing internalized version of input to '''
> // trim(dbgdatname) // '''..'
open(unit=id_internal,file=trim(dbgdatname))
do j=1,linenum
write(id_internal,'(A)') trim(infile(j))
enddo
close(id_internal)
#endif
write(fmt,'("Parsing Keys..")')
call write_oneline(fmt,std_out)
call keyread(keylist,infile,keynum,idat,ddat,cdat,datpos,
> klen,llen,clen,linenum,maxdat)
!############################################################
! Read Individual keys for Program Control
!############################################################
!************************************************************************
! DATA:
!************************************************************************
! This card separates the data to be fitted from the rest of the
! file.
!************************************************************************
key_id=1
! Find where in the input file the DATA:-block begins and
! exclude the line of the card itself
dat_start=datIdx(2,key_id)
!************************************************************************
! SEED:
!************************************************************************
! Random seed for the RNG.
!************************************************************************
key_id=2
seed=8236475
if (is_present(key_id)) then
seed=idat(datIdx(1,key_id))
else
write(fmt,76) seed
call write_oneline(fmt,std_out)
endif
76 format('No random seed specified; seed set to',i12)
if (abs(seed).lt.10**5) then
call signal_val_error(key_id,5,seed)
endif
write(fmt,'("Random seed set to: ",I12)') seed
call write_oneline(fmt,std_out)
seed=-iabs(seed)
!************************************************************************
! NSET:
!************************************************************************
! Number of diffrent Parameter sets.
!************************************************************************
key_id=3
nset=1
if (is_present(key_id)) then
nset=idat(datIdx(1,key_id))
if (nset.le.0)
> call signal_val_error(key_id,5,nset)
else
write(fmt,77) nset
call write_oneline(fmt,std_out)
endif
77 format('No number of Parametersets specified; nset set to',i9)
write(fmt,'("Number of Parametersets set to: ",I9)') nset
call write_oneline(fmt,std_out)
!************************************************************************
! FREEZE:
!************************************************************************
! Determines if All parameters are nonactive if present.
!************************************************************************
key_id=4
freeze=is_present(key_id)
!************************************************************************
! NSTAT:
!************************************************************************
! Number of Energievalues in y for each Point
!************************************************************************
key_id=5
nstat = idat(datIdx(1,key_id))
write(fmt,'("Number of Energie values set to: ",I9 )') nstat
call write_oneline(fmt,std_out)
!************************************************************************
! NCI:
!************************************************************************
! Number of CI vectors in y for each Geometry
!************************************************************************
key_id=6
nci = 0
if(is_present(key_id)) then
nci =idat(datIdx(1,key_id))
endif
write(fmt,'("Number of CI vectors set to: ",I9 )') nci
call write_oneline(fmt,std_out)
!************************************************************************
! NDIAB:
!************************************************************************
! Size of diabatic space = lenght of ci vectors
!************************************************************************
key_id=7
ndiab=nstat
if(is_present(key_id)) then
ndiab = idat(datIdx(1,key_id))
endif
write(fmt,'("Setting ndiab to:",I9)') ndiab
call write_oneline(fmt,std_out)
!************************************************************************
min_ntot= nstat + (nci*ndiab)
if(min_ntot.gt.max_ntot) then
write(6,*)'ERROR: ntot exceeds set Maximum: ',min_ntot,max_ntot
stop
endif
!************************************************************************
! HYBRID:
!************************************************************************
! If present then CI vectors are used in Fit
!************************************************************************
key_id=8
hybrid=is_present(key_id)
if(hybrid.and.(nci.le.0)) then
write(6,*) 'Cant do Hybrid Fit without ci vectors, nci: ',nci
stop ec_log
endif
!************************************************************************
! SEL:
!************************************************************************
! Percentage of selected Parameter sets as Parents
!************************************************************************
key_id=9
psel=0.15d0
if(is_present(key_id)) then
psel = ddat(datIdx(1,key_id))
if (psel.gt.1.d0) call signal_dval_error(key_id,7,psel*100)
endif
nsel=max(int(psel*nset),1)
write(fmt,79) psel*100, nsel
call write_oneline(fmt,std_out)
79 format(f5.1,'%(#',i5,')of Parameters will be selected as parents')
!************************************************************************
! MUT:
!************************************************************************
! Percentage of how many mutations happen in parameters
!************************************************************************
key_id=10
mut=0.d0
if(is_present(key_id)) then
mut = ddat(datIdx(1,key_id))
if (mut.gt.1.d0) call signal_dval_error(key_id,7,mut*100.d0)
endif
write(fmt,80) mut
call write_oneline(fmt,std_out)
80 format('MUTATION set to: ',g9.1)
!************************************************************************
! DIFPER:
!************************************************************************
! minimum Percentage of diffrence between selected parents
!************************************************************************
key_id=11
difper=0.05d0
if(is_present(key_id)) then
difper = ddat(datIdx(1,key_id))
if (difper.gt.1.d0) then
call signal_dval_error(key_id,7,difper*100.d0)
endif
endif
write(fmt,81) difper
call write_oneline(fmt,std_out)
81 format('DIFPER set to: ',g9.1)
!************************************************************************
! GTYPE:
!************************************************************************
! Type of used RNG
!************************************************************************
key_id=12
gtype=2
if(is_present(key_id)) then
gtype = idat(datIdx(1,key_id))
endif
write(fmt,'("GTYPE set to: ",i9)') gtype
call write_oneline(fmt,std_out)
!************************************************************************
! MAXIT:
!************************************************************************
! number of maximum makro Iterations
!************************************************************************
key_id=13
maxit=5
if(is_present(key_id)) then
maxit=idat(datIdx(1,key_id))
endif
write(fmt,'("max. number of makro iterations set to: ",i9)') maxit
call write_oneline(fmt,std_out)
!************************************************************************
! MICIT:
!************************************************************************
! number of maximum micro Iterations
!************************************************************************
key_id=14
micit=1000
if(is_present(key_id)) then
micit=idat(datIdx(1,key_id))
endif
write(fmt,'("max. number of micro iterations set to: ",i9)') micit
call write_oneline(fmt,std_out)
!************************************************************************
! GSPREAD:
!************************************************************************
! read general Spread for Parameter keys
!************************************************************************
key_id=15
gspread=1.d0
if(is_present(key_id)) then
gspread = ddat(datIdx(1,key_id))
endif
write(fmt,'("General Parameterspread set to: ",f5.2)') gspread
call write_oneline(fmt,std_out)
!************************************************************************
! SETS:
!************************************************************************
! Number of seperatly grouped geometries.
! With more than one argument, total sets = sum of all entries.
!************************************************************************
key_id=16
sets=-1
sets=idat(datIdx(1,key_id))
do j=2,datlen(key_id)
sets=sets+idat(datIdx(j,key_id))
enddo
if(sets.eq.0) call signal_val_error(key_id,5,sets,1)
write(fmt,'("Number of Data Sets set to: ",i9)') sets
call write_oneline(fmt,std_out)
!************************************************************************
! INPUTS:
!************************************************************************
! Dimension of input values.
! INPUTS: D [d]
! If given the optional second argument d, read d<D coordinates off
! the DATA: block.
!************************************************************************
key_id=17
qn=-1
qn=idat(datIdx(1,key_id))
if (datlen(key_id).eq.1) then
qn_read=qn
else if (datlen(key_id).eq.2) then
qn_read=idat(datIdx(2,key_id))
if (qn_read.gt.qn) then
call signal_val_error(key_id,4,qn_read,qn)
else if (qn_read.le.0) then
call signal_val_error(key_id,5,qn_read,1)
endif
else if (datlen(key_id).gt.2) then
call signal_dim_error(key_id,11,datlen(key_id),2)
endif
if(qn.le.0) call signal_val_error(key_id,5,qn,1)
!************************************************************************
! ENCIRATIO
!************************************************************************
! parameter used for weighting ratio between energies and CI vectors
!************************************************************************
key_id=18
if(nci.gt.0) then
wt_en2ci=1./(ndiab+0.d0)
else
wt_en2ci=1.d0
endif
if(is_present(key_id)) then
wt_en2ci=ddat(datIdx(1,key_id))
endif
write(fmt,82) wt_en2ci
call write_oneline(fmt,std_out)
82 format('Setting Ratio between Energie and CI Weights to:',g9.1)
!************************************************************************
! WTEN:
!************************************************************************
! parameter used for weighting states independent
!************************************************************************
key_id=19
allocate(wt_en(nstat))
wt_en=1.d0
if(is_present(key_id)) then
if(datlen(key_id).ne.nstat)
> call signal_dim_error(key_id,3,datlen(key_id),nstat)
do j=1,nstat
wt_en(j)=ddat(datIdx(j,key_id))
enddo
endif
!************************************************************************
! WTCI:
!************************************************************************
! parameter used for weighting CI vectors independent
!************************************************************************
key_id=20
allocate(wt_ci(nci))
wt_ci=1.d0
if(is_present(key_id)) then
if(datlen(key_id).ne.nstat)
> call signal_dim_error(key_id,3,datlen(key_id),nci)
do j=1,nci
wt_ci(j)=ddat(datIdx(j,key_id))
enddo
endif
!************************************************************************
! RMSTHR:
!************************************************************************
! Threshhold for RMSE calculation for cutting above the given threshold
! one or nstat real expected for each energie one threshold or one for all
!************************************************************************
key_id=23
allocate(rms_thr(nstat))
rms_thr = 0.d0
if(is_present(key_id)) then
if(datlen(key_id).eq.nstat) then
do j=1,nstat
rms_thr(j)=ddat(datIdx(j,key_id))
enddo
! write(6,'("Setting RMS Threshold for individual States to: ",
! ><nstat>g12.4)') rms_thr(1:nstat) !<var> works only for ifort, not for gfortran or mpif90
write(fmt2,'("(A,",I2,"g12.4)")') nstat
write(fmt,fmt2)
$ "Set RMS Threshold for individual states to:",
$ rms_thr(1:nstat)
call write_oneline(fmt,std_out)
else if (datlen(key_id).eq.1) then
rms_thr = ddat(datIdx(1,key_id))
! write(6,'("Setting RMS Threshold for all States to: ",
! ><nstat>g12.4)') rms_thr !<var> works only for ifort, not for gfortran or mpif90
write(fmt2,'("(A,",I2,"g12.4)")') nstat
write(fmt,fmt2)
$ "Set RMS Threshold for individual states to:",
$ rms_thr(1:nstat)
call write_oneline(fmt,std_out)
else
call signal_dim_error(key_id,3,datlen(key_id),nstat)
endif
endif
!************************************************************************
! NPOINTS:
!************************************************************************
! Number of geometries for each set
!************************************************************************
key_id=21
allocate(ndata(sets))
ndata=0
if (is_present(key_id)) then
if (datlen(key_id).ne.sets) then
call signal_dim_error(key_id,3,datlen(key_id),sets)
endif
do j=1,sets
ndata(j)=idat(datIdx(j,key_id))
enddo
numdatpt=sum(ndata(1:sets))
else
write(*,*)'WARNING: NO NPOINTS CARD GIVEN'
endif
!************************************************************************
! NTOT:
!************************************************************************
! Total number of output values.
!************************************************************************
key_id=22
ntot=min_ntot
if (is_present(key_id)) then
ntot=idat(datIdx(1,key_id))
if(ntot.lt.min_ntot) then
write(6,*)'ERROR: ntot less than set Minimum: ',
> ntot,min_ntot
stop
elseif(ntot.gt.max_ntot) then
write(6,*)'ERROR: ntot exceeds set Maximum: ',ntot,max_ntot
stop
endif
endif
!************************************************************************
! ANAGRAD:
!************************************************************************
! if present analytical gradients are used for eigenvalues and vectors
!************************************************************************
key_id=24
anagrad=is_present(key_id)
if(anagrad) then
write(fmt,'(A)') 'Using Analytical gradients.'
call write_oneline(fmt,std_out)
endif
!************************************************************************
! LBFGS:
!************************************************************************
! if present the LBFGS-B algorithm of Nocedal and Wright is used
! instead of the default Levenberg-Marquard algorithm
!************************************************************************
key_id=25
lbfgs=is_present(key_id)
if(lbfgs) then
write(fmt,'(A)') 'Using LBFGS-B algorithm for fit'
call write_oneline(fmt,std_out)
endif
key_id=26
lbfgs_corr=10 !Standard value
if (lbfgs) then
if(is_present(key_id)) then
lbfgs_corr=idat(datIdx(1,key_id))
endif
if(lbfgs_corr.eq.0)
$ call signal_val_error(key_id,5,lbfgs_corr,1)
write(fmt,'("Number of LBFGS corrections set to: ",i9)')
$ lbfgs_corr
call write_oneline(fmt,std_out)
endif
!************************************************************************
! FACSPREAD:
!************************************************************************
! read multiplicative factor for spreads of all parameters
!************************************************************************
key_id=27
facspread=1.d0
if(is_present(key_id)) then
facspread = ddat(datIdx(1,key_id))
if(facspread.le.0.d0) then
write(6,*) 'ERROR: facspread <= 0'
stop
endif
endif
write(fmt,'("Multiplicative factor for parameter spread: ",f5.2)')
$ facspread
call write_oneline(fmt,std_out)
!************************************************************************
! LOGCONVERGENCE:
!************************************************************************
! If present logging files for convergence are printed
!************************************************************************
key_id=28
log_convergence=is_present(key_id)
!************************************************************************
! COORD:
!************************************************************************
! For each set, specify a coord number N, where
! N=0 (default) computes a walk coordinate on q mapped to [0:1]
! N>0 plot against q(N)
!
!************************************************************************
key_id=29
allocate(plot_coord(sets))
plot_coord=0
if (is_present(key_id)) then
if (datlen(key_id).ne.sets) then
call signal_dim_error(key_id,3,datlen(key_id),sets)
endif
do j=1,sets
plot_coord(j)=idat(datIdx(j,key_id))
enddo
fmt='COORD: Scan file(s) will use the following coordinates:'
call write_oneline(fmt,std_out)
fmt='(I3)'
call write_longint(std_out,plot_coord,datlen(key_id),
> fmt,16)
endif
!************************************************************************
! PARMETER KEYS:
!************************************************************************
! read the parameter keys defined in keys.incl
!************************************************************************
call parameterkey_read
> (infile,linenum,p,p_act,p_spread,npar,gspread,facspread)
if (all(p_act.eq.0)) then
write(std_out,'(A)') 'WARNING: No active parameters. '
> // 'Setting FREEZE:'
freeze=.true.
endif
!************************************************************************
! DATA:
!************************************************************************
! reading x an y values in the datablock after DATA: card
!************************************************************************
legacy_wt=.true. !< @TODO consider implementing card for ANN weighting format
call read_data(infile,x,y,wt,
> legacy_wt,dat_start,linenum,ntot,qn,
> qn_read,numdatpt)
deallocate(infile)
end subroutine
!************************************************************************
subroutine read_data(in,x,y,wt,
> legacy_wt,st,lauf,y_dim,x_dim,
> x_read,ndatapoints)
! Routine reading DATA-block.
! If ndatapoints is nonzero, only the first ndatapoints pattern pairs are read.
!
! in: input file as string vector
! in(n) nth line of input file
! lauf: number of lines in input file
! st: starting position of DATA-block
!
!.....Splitting variables
! ndatapoints: number of given pattern pairs
! nref: number of reference patterns
!.....Data arrays containing the read out and in values
! wterr: weight factors for each element of the error vector e
! x: input patterns
! y: desired output patterns
! x/y(i,N): value of ith in-/output neuron for pattern N
! x_dim: physical dimension of x(:,N)
! x_read: number of read coordinates (rest is 0)
!
! expected format (for one pattern pair):
!.. y1 x1 x2 x3 ... xM
!.. y2 x1 x2 x3 ... xM
!.. .. .. .. .. ... ..
!.. yN x1 x2 x3 ... xM
!..
!.. WT: w1 w2 ... wN
!
!... wt-legacy mode format:
!.. y1 x1 x2 x3 ... xM
!.. WT: w1
!.. y2 x1 x2 x3 ... xM
!.. WT: w2
!.. .. .. .. .. ... ..
!.. yN x1 x2 x3 ... xM
!.. WT: wN
!
! where N=inp_out and M=inp_in
double precision, allocatable :: x(:,:),y(:,:)
double precision, allocatable :: wt(:,:)
! actual relevant Dimensions
integer ndatapoints,st,lauf,y_dim,x_dim
integer x_read
character(len=llen) in(lauf)
logical legacy_wt
integer pat_count,line
integer k
! allocate arrays
allocate(x(x_dim,ndatapoints),y(y_dim,ndatapoints),
> wt(y_dim,ndatapoints))
pat_count=0
line=st !count lines
do while (line.le.lauf)
if (in(line)(1:3).eq.'WT:') then
if (legacy_wt .or. (pat_count.eq.0)) then
write(6,419) 1
write(6,'(A)') '(preceding WT-block)'
stop ec_read
endif
read(in(line)(4:llen),*,err=511,end=508)
> wt(1:y_dim,pat_count)
line=line+1
if (pat_count.eq.ndatapoints) exit
cycle
508 write(6,419) pat_count
write(6,'(A)') '(broken WT: input)'
stop ec_read
511 write(6,418) pat_count
write(6,'(A)') 'LINE DUMP:'
write(6,'(A)') trim(in(line)(4:llen))
stop ec_read
else
! stop reading if desired number of patterns is read
if ((ndatapoints.gt.0).and.(pat_count.eq.ndatapoints)) exit
! new input set begins
pat_count=pat_count+1
wt(1:y_dim,pat_count)=1.0D0
x(:,pat_count)=0.d0
read(in(line)(1:llen),*,err=513,end=510) y(1,pat_count),
> x(1:x_read,pat_count)
line=line+1
! wt-legacy-mode: read single weight
if (legacy_wt .and. (in(line)(1:3).eq.'WT:')) then
read(in(line)(4:llen),*,err=515,end=514)
> wt(1:1,pat_count)
line=line+1
endif
do k=2,y_dim
! read y(k,pat_count) and copy x-vector for comparison
read(in(line)(1:llen),*,err=512,end=509)
> y(k,pat_count)
if (line.lt.lauf) then
line=line+1
if (legacy_wt .and. (in(line)(1:3).eq.'WT:')) then
read(in(line)(4:llen),*,err=515,end=514)
> wt(k:k,pat_count)
line=line+1
endif
cycle
else if (k.eq.y_dim) then
exit
endif
509 write(6,419) pat_count
write(6,'(A)') '(reached EOF before completion)'
stop ec_read
512 write(6,421) pat_count, line
write(6,'(A)') 'LINE DUMP:'
write(6,'(A)') trim(in(line)(1:llen))
stop ec_read
enddo
cycle
510 write(6,419) pat_count
stop ec_read
513 write(6,421) pat_count, line
write(6,'(A)') 'LINE DUMP:'
write(6,'(A)') trim(in(line)(1:llen))
stop ec_read
514 write(6,419) pat_count
write(6,'(A)') '(broken WT: input)'
stop ec_read
515 write(6,418) pat_count
write(6,'(A)') 'LINE DUMP:'
write(6,'(A)') trim(in(line)(4:llen))
stop ec_read
endif
enddo
! pat_count is now actual number of patterns
if (pat_count.le.0) then
write(6,419) 1
stop ec_read
else if (ndatapoints.ne.pat_count) then
write(6,420) ndatapoints,pat_count
stop ec_read
endif
! 417 format('ERROR: CORRUPTED WEIGHT INPUT (SET #',I9,')')
418 format('ERROR: NUMDATPT EXCEEDING MAX_NUMDATPT(',I9,' vs.',I9,')')
419 format('ERROR: INCOMPLETE OR MISSING DATA SET. SET #',I9)
420 format('ERROR: NUMBER OF DATA POINTS INCONSISTENT
> WITH NDATAPOINTS',
> '(',I9,' vs.',I9,')')
421 format('ERROR: CORRUPTED DATA POINT INPUT (SET #',I9,', LINE,',
> I9,')')
end subroutine
!--------------------------------------------------------------------------------
! Here follow convenience functions defined for this modul only.
integer function datIdx(j,key_id)
! Locate Jth value of KEY_IDth data block on *dat vector(s).
integer j,key_id
datIdx=IdxShift(j,datpos(2,key_id))
end function
!--------------------------------------------------------------------------
integer function IdxShift(j,start)
! Map linear index of a logical vector which is embedded in a memory
! vector and begins at START.
integer j,start
IdxShift=start-1+j
end function
!--------------------------------------------------------------------------------
logical function is_present(key_id,quiet)
use strings_mod,only:write_oneline
implicit none
! Checks whether optional key has been given in input file.
! If optional argument QUIET is true, do not print a message
! if the key wasn't found.
integer key_id
logical quiet
optional quiet
character(len=llen) fmt
integer,parameter :: std_out = 6
is_present=(datpos(2,key_id).ne.-1)
if (present(quiet)) then
if (quiet) then
return
endif
else if (.not.is_present) then
write(fmt,'(A)') 'No '//trim(keylist(1,key_id))//' card found.'
call write_oneline(fmt,std_out)
endif
end function
!----------------------------------------------------------------------------------
integer function datlen(key_id)
implicit none
integer key_id
datlen=datpos(3,key_id)
end function
end module

71
src/ptr_structure.f Normal file
View File

@ -0,0 +1,71 @@
module ptr_structure
use dim_parameter,only: pst,numdatpt,ndiab,qn
implicit none
public
type, public :: value_loc_ptr
!number of non-zero-elements
integer :: nnz=0
!row position of non-zero values
integer, allocatable :: rowPtr(:)
!column position of non-zero values
integer, allocatable :: colPtr(:)
!holds non-zero values
double precision, allocatable :: values(:,:)
end type value_loc_ptr
contains
subroutine init_ptr(ptr,occupation)
type(value_loc_ptr) :: ptr
logical, intent(in) :: occupation(ndiab,ndiab)
integer :: i,j,k
integer :: m,n,nnz
! Get occupation size for first and second index
m = size(occupation,1)
n = size(occupation,2)
!Count number of non-zero occupation elements
nnz = count(occupation .eqv. .true.)
ptr%nnz = nnz
!Allocate data for pointer arrays and value array
allocate(ptr%rowPtr(nnz),ptr%colPtr(nnz),ptr%values(nnz,numdatpt))
!Get all non-zero elements of occupation
!Write values on values, write positions on rowPtr and colPtr
k=1
!Loop over rows
do i=1,m
!Loop over columns
do j=1,n
!Get non-zero elements and write their values on values & write their positions on rowPtr and colPtr
if(occupation(i,j)) then
ptr%rowPtr(k)=i
ptr%colPtr(k)=j
!Increase counter
k=k+1
endif
enddo
enddo
end subroutine init_ptr
subroutine init_values(ptr,matrix,pt)
type(value_loc_ptr) :: ptr
double precision matrix(ndiab,ndiab)
integer pt
integer l
do l=1,ptr%nnz
ptr%values(l,pt)=matrix(ptr%rowPtr(l),ptr%colPtr(l))
enddo
end subroutine init_values
end module ptr_structure

362
src/random.f Normal file
View File

@ -0,0 +1,362 @@
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c interface for genetic to call random generator
c seed = initialization seed: large integer
c ierr=6 : output for error [only for Marius Lewerenz random number generator)
c gtype = choose which random number generator is invoked
c gtype = 1 is the DEFAULT behavior if the GTYPE card is not set within the input file
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
function rn(seed,gtype,cont)
implicit none
!INPUT
integer seed !seed to initialize random number stream
integer gtype !choose which RNG is used (1="standard" genetic version,2=RANLUX)
integer cont !initialize random number stream (1) or continue with already initialited stream (0)
!LOCAL VARIABLES ("standard" genetic)
integer ierr,iseed
double precision rand
save ierr
!LOCAL VARIABLES (RANLUX)
integer lux
integer length
parameter (length=1)
real random_vec(length)
!OUTPUT VARIABLE
double precision rn
if (gtype.eq.1) then
write(6,*) 'ERROR: Unsupported legacy RNG.'
stop
elseif(gtype.eq.2) then
!Initialize RANLUX generator
if (cont.eq.1) then
lux=223 !choice of luxury level; see Documentation of RANLUX
call RLUXGO(lux,abs(seed),0,0) !initialize random number stream
endif
!Get one random number and write it to rn, rn will be returned
call RANLUX(random_vec,length)
rn=dble(random_vec(1))
else
write(6,*) "No random number generator specified for GTYPE=",
$ gtype
endif
end
c###################################################################################
c INTERFACE TO RANLUX
c###################################################################################
c ACPRRANLUX. RANLUX, A FORTRAN IMPLEMENTATION OF THE HIGH-QUALITY ACPR0000
c PSEUDORANDOM NUMBER GENERATOR OF LUSCHER. F. JAMES. ACPR0000
c REF. IN COMP. PHYS. COMMUN. 79 (1994) 111 ACPR0000
SUBROUTINE RANLUX(RVEC,LENV) ACPR0001
C Subtract-and-borrow random number generator proposed by ACPR0002
C Marsaglia and Zaman, implemented by F. James with the name ACPR0003
C RCARRY in 1991, and later improved by Martin Luescher ACPR0004
C in 1993 to produce "Luxury Pseudorandom Numbers". ACPR0005
C Fortran 77 coded by F. James, 1993 ACPR0006
C ACPR0007
C LUXURY LEVELS. ACPR0008
C ------ ------ The available luxury levels are: ACPR0009
C ACPR0010
C level 0 (p=24): equivalent to the original RCARRY of Marsaglia ACPR0011
C and Zaman, very long period, but fails many tests. ACPR0012
C level 1 (p=48): considerable improvement in quality over level 0, ACPR0013
C now passes the gap test, but still fails spectral test. ACPR0014
C level 2 (p=97): passes all known tests, but theoretically still ACPR0015
C defective. ACPR0016
C level 3 (p=223): DEFAULT VALUE. Any theoretically possible ACPR0017
C correlations have very small chance of being observed. ACPR0018
C level 4 (p=389): highest possible luxury, all 24 bits chaotic. ACPR0019
C ACPR0020
C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ACPR0021
C!!! Calling sequences for RANLUX: ++ ACPR0022
C!!! CALL RANLUX (RVEC, LEN) returns a vector RVEC of LEN ++ ACPR0023
C!!! 32-bit random floating point numbers between ++ ACPR0024
C!!! zero (not included) and one (also not incl.). ++ ACPR0025
C!!! CALL RLUXGO(LUX,INT,K1,K2) initializes the generator from ++ ACPR0026
C!!! one 32-bit integer INT and sets Luxury Level LUX ++ ACPR0027
C!!! which is integer between zero and MAXLEV, or if ++ ACPR0028
C!!! LUX .GT. 24, it sets p=LUX directly. K1 and K2 ++ ACPR0029
C!!! should be set to zero unless restarting at a break++ ACPR0030
C!!! point given by output of RLUXAT (see RLUXAT). ++ ACPR0031
C!!! CALL RLUXAT(LUX,INT,K1,K2) gets the values of four integers++ ACPR0032
C!!! which can be used to restart the RANLUX generator ++ ACPR0033
C!!! at the current point by calling RLUXGO. K1 and K2++ ACPR0034
C!!! specify how many numbers were generated since the ++ ACPR0035
C!!! initialization with LUX and INT. The restarting ++ ACPR0036
C!!! skips over K1+K2*E9 numbers, so it can be long.++ ACPR0037
C!!! A more efficient but less convenient way of restarting is by: ++ ACPR0038
C!!! CALL RLUXIN(ISVEC) restarts the generator from vector ++ ACPR0039
C!!! ISVEC of 25 32-bit integers (see RLUXUT) ++ ACPR0040
C!!! CALL RLUXUT(ISVEC) outputs the current values of the 25 ++ ACPR0041
C!!! 32-bit integer seeds, to be used for restarting ++ ACPR0042
C!!! ISVEC must be dimensioned 25 in the calling program ++ ACPR0043
C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ACPR0044
DIMENSION RVEC(LENV) ACPR0045
DIMENSION SEEDS(24), ISEEDS(24), ISDEXT(25) ACPR0046
PARAMETER (MAXLEV=4, LXDFLT=3) ACPR0047
DIMENSION NDSKIP(0:MAXLEV) ACPR0048
DIMENSION NEXT(24) ACPR0049
PARAMETER (TWOP12=4096., IGIGA=1000000000,JSDFLT=314159265) ACPR0050
PARAMETER (ITWO24=2**24, ICONS=2147483563) ACPR0051
SAVE NOTYET, I24, J24, CARRY, SEEDS, TWOM24, TWOM12, LUXLEV ACPR0052
SAVE NSKIP, NDSKIP, IN24, NEXT, KOUNT, MKOUNT, INSEED ACPR0053
INTEGER LUXLEV ACPR0054
LOGICAL NOTYET ACPR0055
DATA NOTYET, LUXLEV, IN24, KOUNT, MKOUNT /.TRUE., LXDFLT, 0,0,0/ ACPR0056
DATA I24,J24,CARRY/24,10,0./ ACPR0057
C default ACPR0058
C Luxury Level 0 1 2 *3* 4 ACPR0059
DATA NDSKIP/0, 24, 73, 199, 365 / ACPR0060
Corresponds to p=24 48 97 223 389 ACPR0061
C time factor 1 2 3 6 10 on slow workstation ACPR0062
C 1 1.5 2 3 5 on fast mainframe ACPR0063
C ACPR0064
C NOTYET is .TRUE. if no initialization has been performed yet. ACPR0065
C Default Initialization by Multiplicative Congruential ACPR0066
IF (NOTYET) THEN ACPR0067
NOTYET = .FALSE. ACPR0068
JSEED = JSDFLT ACPR0069
INSEED = JSEED ACPR0070
WRITE(6,'(A,I12)') ' RANLUX DEFAULT INITIALIZATION: ',JSEED ACPR0071
LUXLEV = LXDFLT ACPR0072
NSKIP = NDSKIP(LUXLEV) ACPR0073
LP = NSKIP + 24 ACPR0074
IN24 = 0 ACPR0075
KOUNT = 0 ACPR0076
MKOUNT = 0 ACPR0077
WRITE(6,'(A,I2,A,I4)') ' RANLUX DEFAULT LUXURY LEVEL = ', ACPR0078
+ LUXLEV,' p =',LP ACPR0079
TWOM24 = 1. ACPR0080
DO 25 I= 1, 24 ACPR0081
TWOM24 = TWOM24 * 0.5 ACPR0082
K = JSEED/53668 ACPR0083
JSEED = 40014*(JSEED-K*53668) -K*12211 ACPR0084
IF (JSEED .LT. 0) JSEED = JSEED+ICONS ACPR0085
ISEEDS(I) = MOD(JSEED,ITWO24) ACPR0086
25 CONTINUE ACPR0087
TWOM12 = TWOM24 * 4096. ACPR0088
DO 50 I= 1,24 ACPR0089
SEEDS(I) = REAL(ISEEDS(I))*TWOM24 ACPR0090
NEXT(I) = I-1 ACPR0091
50 CONTINUE ACPR0092
NEXT(1) = 24 ACPR0093
I24 = 24 ACPR0094
J24 = 10 ACPR0095
CARRY = 0. ACPR0096
IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24 ACPR0097
ENDIF ACPR0098
C ACPR0099
C The Generator proper: "Subtract-with-borrow", ACPR0100
C as proposed by Marsaglia and Zaman, ACPR0101
C Florida State University, March, 1989 ACPR0102
C ACPR0103
DO 100 IVEC= 1, LENV ACPR0104
UNI = SEEDS(J24) - SEEDS(I24) - CARRY ACPR0105
IF (UNI .LT. 0.) THEN ACPR0106
UNI = UNI + 1.0 ACPR0107
CARRY = TWOM24 ACPR0108
ELSE ACPR0109
CARRY = 0. ACPR0110
ENDIF ACPR0111
SEEDS(I24) = UNI ACPR0112
I24 = NEXT(I24) ACPR0113
J24 = NEXT(J24) ACPR0114
RVEC(IVEC) = UNI ACPR0115
C small numbers (with less than 12 "significant" bits) are "padded". ACPR0116
IF (UNI .LT. TWOM12) THEN ACPR0117
RVEC(IVEC) = RVEC(IVEC) + TWOM24*SEEDS(J24) ACPR0118
C and zero is forbidden in case someone takes a logarithm ACPR0119
IF (RVEC(IVEC) .EQ. 0.) RVEC(IVEC) = TWOM24*TWOM24 ACPR0120
ENDIF ACPR0121
C Skipping to luxury. As proposed by Martin Luscher. ACPR0122
IN24 = IN24 + 1 ACPR0123
IF (IN24 .EQ. 24) THEN ACPR0124
IN24 = 0 ACPR0125
KOUNT = KOUNT + NSKIP ACPR0126
DO 90 ISK= 1, NSKIP ACPR0127
UNI = SEEDS(J24) - SEEDS(I24) - CARRY ACPR0128
IF (UNI .LT. 0.) THEN ACPR0129
UNI = UNI + 1.0 ACPR0130
CARRY = TWOM24 ACPR0131
ELSE ACPR0132
CARRY = 0. ACPR0133
ENDIF ACPR0134
SEEDS(I24) = UNI ACPR0135
I24 = NEXT(I24) ACPR0136
J24 = NEXT(J24) ACPR0137
90 CONTINUE ACPR0138
ENDIF ACPR0139
100 CONTINUE ACPR0140
KOUNT = KOUNT + LENV ACPR0141
IF (KOUNT .GE. IGIGA) THEN ACPR0142
MKOUNT = MKOUNT + 1 ACPR0143
KOUNT = KOUNT - IGIGA ACPR0144
ENDIF ACPR0145
RETURN ACPR0146
C ACPR0147
C Entry to input and float integer seeds from previous run ACPR0148
ENTRY RLUXIN(ISDEXT) ACPR0149
TWOM24 = 1. ACPR0150
DO 195 I= 1, 24 ACPR0151
NEXT(I) = I-1 ACPR0152
195 TWOM24 = TWOM24 * 0.5 ACPR0153
NEXT(1) = 24 ACPR0154
TWOM12 = TWOM24 * 4096. ACPR0155
WRITE(6,'(A)') ' FULL INITIALIZATION OF RANLUX WITH 25 INTEGERS:' ACPR0156
WRITE(6,'(5X,5I12)') ISDEXT ACPR0157
DO 200 I= 1, 24 ACPR0158
SEEDS(I) = REAL(ISDEXT(I))*TWOM24 ACPR0159
200 CONTINUE ACPR0160
CARRY = 0. ACPR0161
IF (ISDEXT(25) .LT. 0) CARRY = TWOM24 ACPR0162
ISD = IABS(ISDEXT(25)) ACPR0163
I24 = MOD(ISD,100) ACPR0164
ISD = ISD/100 ACPR0165
J24 = MOD(ISD,100) ACPR0166
ISD = ISD/100 ACPR0167
IN24 = MOD(ISD,100) ACPR0168
ISD = ISD/100 ACPR0169
LUXLEV = ISD ACPR0170
IF (LUXLEV .LE. MAXLEV) THEN ACPR0171
NSKIP = NDSKIP(LUXLEV) ACPR0172
WRITE (6,'(A,I2)') ' RANLUX LUXURY LEVEL SET BY RLUXIN TO: ', ACPR0173
+ LUXLEV ACPR0174
ELSE IF (LUXLEV .GE. 24) THEN ACPR0175
NSKIP = LUXLEV - 24 ACPR0176
WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXIN TO:',LUXLEV ACPR0177
ELSE ACPR0178
NSKIP = NDSKIP(MAXLEV) ACPR0179
WRITE (6,'(A,I5)') ' RANLUX ILLEGAL LUXURY RLUXIN: ',LUXLEV ACPR0180
LUXLEV = MAXLEV ACPR0181
ENDIF ACPR0182
INSEED = -1 ACPR0183
RETURN ACPR0184
C ACPR0185
C Entry to ouput seeds as integers ACPR0186
ENTRY RLUXUT(ISDEXT) ACPR0187
DO 300 I= 1, 24 ACPR0188
ISDEXT(I) = INT(SEEDS(I)*TWOP12*TWOP12) ACPR0189
300 CONTINUE ACPR0190
ISDEXT(25) = I24 + 100*J24 + 10000*IN24 + 1000000*LUXLEV ACPR0191
IF (CARRY .GT. 0.) ISDEXT(25) = -ISDEXT(25) ACPR0192
RETURN ACPR0193
C ACPR0194
C Entry to output the "convenient" restart point ACPR0195
ENTRY RLUXAT(LOUT,INOUT,K1,K2) ACPR0196
LOUT = LUXLEV ACPR0197
INOUT = INSEED ACPR0198
K1 = KOUNT ACPR0199
K2 = MKOUNT ACPR0200
RETURN ACPR0201
C ACPR0202
C Entry to initialize from one or three integers ACPR0203
ENTRY RLUXGO(LUX,INS,K1,K2) ACPR0204
IF (LUX .LT. 0) THEN ACPR0205
LUXLEV = LXDFLT ACPR0206
ELSE IF (LUX .LE. MAXLEV) THEN ACPR0207
LUXLEV = LUX ACPR0208
ELSE IF (LUX .LT. 24 .OR. LUX .GT. 2000) THEN ACPR0209
LUXLEV = MAXLEV ACPR0210
WRITE (6,'(A,I7)') ' RANLUX ILLEGAL LUXURY RLUXGO: ',LUX ACPR0211
ELSE ACPR0212
LUXLEV = LUX ACPR0213
DO 310 ILX= 0, MAXLEV ACPR0214
IF (LUX .EQ. NDSKIP(ILX)+24) LUXLEV = ILX ACPR0215
310 CONTINUE ACPR0216
ENDIF ACPR0217
IF (LUXLEV .LE. MAXLEV) THEN ACPR0218
NSKIP = NDSKIP(LUXLEV) ACPR0219
WRITE(6,'(A,I2,A,I4)') ' RANLUX LUXURY LEVEL SET BY RLUXGO :', ACPR0220
+ LUXLEV,' P=', NSKIP+24 ACPR0221
ELSE ACPR0222
NSKIP = LUXLEV - 24 ACPR0223
WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXGO TO:',LUXLEV ACPR0224
ENDIF ACPR0225
IN24 = 0 ACPR0226
IF (INS .LT. 0) WRITE (6,'(A)') ACPR0227
+ ' Illegal initialization by RLUXGO, negative input seed' ACPR0228
IF (INS .GT. 0) THEN ACPR0229
JSEED = INS ACPR0230
WRITE(6,'(A,3I12)') ' RANLUX INITIALIZED BY RLUXGO FROM SEEDS', ACPR0231
+ JSEED, K1,K2 ACPR0232
ELSE ACPR0233
JSEED = JSDFLT ACPR0234
WRITE(6,'(A)')' RANLUX INITIALIZED BY RLUXGO FROM DEFAULT SEED' ACPR0235
ENDIF ACPR0236
INSEED = JSEED ACPR0237
NOTYET = .FALSE. ACPR0238
TWOM24 = 1. ACPR0239
DO 325 I= 1, 24 ACPR0240
TWOM24 = TWOM24 * 0.5 ACPR0241
K = JSEED/53668 ACPR0242
JSEED = 40014*(JSEED-K*53668) -K*12211 ACPR0243
IF (JSEED .LT. 0) JSEED = JSEED+ICONS ACPR0244
ISEEDS(I) = MOD(JSEED,ITWO24) ACPR0245
325 CONTINUE ACPR0246
TWOM12 = TWOM24 * 4096. ACPR0247
DO 350 I= 1,24 ACPR0248
SEEDS(I) = REAL(ISEEDS(I))*TWOM24 ACPR0249
NEXT(I) = I-1 ACPR0250
350 CONTINUE ACPR0251
NEXT(1) = 24 ACPR0252
I24 = 24 ACPR0253
J24 = 10 ACPR0254
CARRY = 0. ACPR0255
IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24 ACPR0256
C If restarting at a break point, skip K1 + IGIGA*K2 ACPR0257
C Note that this is the number of numbers delivered to ACPR0258
C the user PLUS the number skipped (if luxury .GT. 0). ACPR0259
KOUNT = K1 ACPR0260
MKOUNT = K2 ACPR0261
IF (K1+K2 .NE. 0) THEN ACPR0262
DO 500 IOUTER= 1, K2+1 ACPR0263
INNER = IGIGA ACPR0264
IF (IOUTER .EQ. K2+1) INNER = K1 ACPR0265
DO 450 ISK= 1, INNER ACPR0266
UNI = SEEDS(J24) - SEEDS(I24) - CARRY ACPR0267
IF (UNI .LT. 0.) THEN ACPR0268
UNI = UNI + 1.0 ACPR0269
CARRY = TWOM24 ACPR0270
ELSE ACPR0271
CARRY = 0. ACPR0272
ENDIF ACPR0273
SEEDS(I24) = UNI ACPR0274
I24 = NEXT(I24) ACPR0275
J24 = NEXT(J24) ACPR0276
450 CONTINUE ACPR0277
500 CONTINUE ACPR0278
C Get the right value of IN24 by direct calculation ACPR0279
IN24 = MOD(KOUNT, NSKIP+24) ACPR0280
IF (MKOUNT .GT. 0) THEN ACPR0281
IZIP = MOD(IGIGA, NSKIP+24) ACPR0282
IZIP2 = MKOUNT*IZIP + IN24 ACPR0283
IN24 = MOD(IZIP2, NSKIP+24) ACPR0284
ENDIF ACPR0285
C Now IN24 had better be between zero and 23 inclusive ACPR0286
IF (IN24 .GT. 23) THEN ACPR0287
WRITE (6,'(A/A,3I11,A,I5)') ACPR0288
+ ' Error in RESTARTING with RLUXGO:',' The values', INS, ACPR0289
+ K1, K2, ' cannot occur at luxury level', LUXLEV ACPR0290
IN24 = 0 ACPR0291
ENDIF ACPR0292
ENDIF ACPR0293
RETURN ACPR0294
END ACPR0295

50
src/ranlfg.inc Normal file
View File

@ -0,0 +1,50 @@
c---------------------------- ranlfg.inc -------------------------------
c---+----|----+----|----+----|----+----|----+----|----+----|----+----|--
c
c parameters for lagged fibonacci generators and common block with
c generator state
c
c-----------------------------------------------------------------------
c
c possible (np,nq) values, (np,np-nq) is also valid:
c (17,5), (250,103), (521,158), (1279,418),
c (2281,715), (4423,1393), (1279,1063)
c ref.: Bhanot et al., phys. rev b 33, 7841 (1986);
c Zierler, inf. control 15, 67 (1961)
c
c mersenne prime primitive trinomials:
c (heringa et al. int.j.mod.phys.c 3, 561 (1992))
c
c (89,38)
c (127,1), (127,7), (127,15), (127,30), (127,63)
c (521,32), (521,48), (521,158), (521,168)
c (607,105), (607,147), (607, 273)
c (1279,216), (1279,418)
c (2281,715), (2281,915), (2281,1029)
c (3217,67), (3217,576)
c (4423,271), (4423,369), (4423,370), (4423,649), (4424,1393),
c (4423,1419), (4423,2098)
c (9689,84), (9689,471), (9689,1836), (9689,2444), (9689,4187)
c (19937,881), (19937,7083), (19937,9842)
c (23209,1530), (23209,6619), (23209,9739)
c (44497,8575), (44497,21034)
c (110503,25230), (110503,53719)
c (132049,7000), (132049,33912), (132049,41469), (132049,52549),
c (132049,54454)
c
c another pair from brent92 who recommends q=0.618p : (258,175)
c brent's ranu4 uses (132049,79500)
c
c-----------------------------------------------------------------------
c parameter (np=250,nq=103)
integer np,nq
parameter (np=1279,nq=418)
c parameter (np=2281,nq=715)
c parameter (np=274674,nq=67874)
integer init
integer last
double precision x(np) !???
save /xrandf/
common /xrandf/ x,last,init
c---+----|----+----|----+----|----+----|----+----|----+----|----+----|--
c----------------------------- last line -------------------------------