First commit for the rep of L-matrix
This commit is contained in:
jean paul nshuti
commit
fc9159bc32
|
|
@ -0,0 +1,6 @@
|
|||
# Author: jnshuti
|
||||
# Created: 2025-10-06 11:46:14
|
||||
# Last modified: 2025-10-06 12:56:39 jnshuti
|
||||
|
||||
./bin/
|
||||
./obj/
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1,54 @@
|
|||
module data_module
|
||||
|
||||
implicit none
|
||||
|
||||
double precision,protected, dimension(:,:), allocatable :: q_m
|
||||
double precision,protected, dimension(:,:), allocatable :: x1_m
|
||||
double precision,protected, dimension(:,:), allocatable :: x2_m
|
||||
double precision,protected, dimension(:,:), allocatable :: y_m
|
||||
double precision,protected, dimension(:,:), allocatable :: wt_m
|
||||
double precision,protected, dimension(:,:), allocatable :: ny_m
|
||||
|
||||
contains
|
||||
|
||||
!------------------------------
|
||||
|
||||
subroutine init_data(numdatpt,q,x1,x2,y,wt,ny)
|
||||
|
||||
use dim_parameter, only: qn, ntot
|
||||
|
||||
implicit none
|
||||
|
||||
integer i,numdatpt
|
||||
double precision q(qn,*)
|
||||
double precision x1(qn,*)
|
||||
double precision x2(qn,*)
|
||||
double precision y(ntot,*)
|
||||
double precision wt(ntot,*)
|
||||
double precision ny(ntot,*)
|
||||
|
||||
allocate(q_m(qn,numdatpt))
|
||||
allocate(x1_m(qn,numdatpt))
|
||||
allocate(x2_m(qn,numdatpt))
|
||||
allocate(y_m(ntot,numdatpt))
|
||||
allocate(wt_m(ntot,numdatpt))
|
||||
allocate(ny_m(ntot,numdatpt))
|
||||
|
||||
do i=1,numdatpt
|
||||
q_m(1:qn,i)=q(1:qn,i)
|
||||
x1_m(1:qn,i)=x1(1:qn,i)
|
||||
x2_m(1:qn,i)=x2(1:qn,i)
|
||||
y_m(1:ntot,i)=y(1:ntot,i)
|
||||
wt_m(1:ntot,i)=wt(1:ntot,i)
|
||||
ny_m(1:ntot,i)=ny(1:ntot,i)
|
||||
enddo
|
||||
|
||||
end subroutine
|
||||
|
||||
!------------------------------
|
||||
|
||||
subroutine dealloc_data()
|
||||
deallocate(q_m,x1_m,x2_m,y_m,wt_m,ny_m)
|
||||
end subroutine
|
||||
|
||||
end module data_module
|
||||
|
|
@ -0,0 +1,36 @@
|
|||
module dim_parameter
|
||||
use io_parameters,only: maxpar_keys
|
||||
implicit none
|
||||
integer,parameter :: max_ntot = 200 ,max_par = 600
|
||||
!Standard
|
||||
integer :: qn,qn_read,ntot,numdatpt
|
||||
integer :: nstat,ndiab,nci
|
||||
!Fabian
|
||||
! integer :: numdatpt
|
||||
! integer,parameter :: qn=9,ntot=162,nstat=8,ndiab=22,nci=7
|
||||
|
||||
integer :: sets
|
||||
integer, allocatable :: ndata(:)
|
||||
logical :: hybrid, anagrad,lbfgs
|
||||
integer :: lbfgs_corr
|
||||
double precision :: facspread
|
||||
logical :: log_convergence
|
||||
! Weight Parameter
|
||||
double precision :: wt_en2ci
|
||||
double precision, allocatable :: wt_en(:),wt_ci(:) !< parameters for weightingroutine, nstat or ndiab long
|
||||
! which coord to use for plotting
|
||||
integer, allocatable :: plot_coord(:)
|
||||
|
||||
! pst vector
|
||||
integer pst(2,maxpar_keys)
|
||||
|
||||
! thresholds for error calculation
|
||||
double precision ,allocatable :: rms_thr(:)
|
||||
|
||||
contains
|
||||
|
||||
subroutine dealloc_dim()
|
||||
deallocate(ndata,wt_ci,wt_en,rms_thr,plot_coord)
|
||||
end subroutine
|
||||
|
||||
end module
|
||||
|
|
@ -0,0 +1,500 @@
|
|||
module fit_mod
|
||||
implicit none
|
||||
contains
|
||||
|
||||
|
||||
! > Routine to controll the genetic fitting algorithm
|
||||
subroutine fit(q,x1,x2,y,frms,difper,wt,par,p_spread,mut,
|
||||
> npar,p_act,seed,gtype,nset,nsel,chkpnt,old,iter,maxit,
|
||||
$ micit,ny,filename)
|
||||
use idxsrt_mod, only: idxsrt
|
||||
use dim_parameter,only: qn,numdatpt,ntot
|
||||
use init_mod,only: actinit
|
||||
use write_mod,only: write_output
|
||||
#ifdef mpi_version
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
|
||||
! MPI Variables
|
||||
#ifdef mpi_version
|
||||
integer ierror,my_rank,workernum,mpi_control_data(4)
|
||||
#endif
|
||||
|
||||
! Input variables (not changed within this subroutine).
|
||||
double precision q(qn,numdatpt),x1(qn,numdatpt),x2(qn,numdatpt)!< coordinates/input values
|
||||
double precision y(ntot,numdatpt),ny(ntot,numdatpt) !< Output/(energie and ci) values
|
||||
double precision wt(ntot,numdatpt) !< weights
|
||||
integer npar !< number of parameters
|
||||
integer nset !< number of parameter sets
|
||||
integer maxit !< maximum number of macroiterations
|
||||
integer micit !< maximum number of microiterations (i.e. LM iterations)
|
||||
|
||||
!Fabian 15.03.2022: Used for babies or parent generation
|
||||
integer gtype!< type of random number generator --> is this ever really used??
|
||||
integer nsel !< number of parents selected for having babies
|
||||
integer seed !< random seed for babies generation
|
||||
double precision p_spread(npar)
|
||||
double precision difper, mut
|
||||
|
||||
!Fabian 15.03.2022: Used for checkfile
|
||||
character(len=80) :: chkpnt
|
||||
character(len=10) :: writer
|
||||
integer iter
|
||||
double precision old !< old rms
|
||||
|
||||
!Fabian 15.03.2022: Used for wrout
|
||||
character(len=80) filename
|
||||
|
||||
!Fabian 15.03.2022: Used in parameter initialization
|
||||
integer p_act(npar) !< array that contains info if a parameter is active or not == equivalent to ma in mrqmin
|
||||
|
||||
|
||||
! Input/output variables (changed/updated within this subroutine)
|
||||
double precision par(npar,nset) !< parameters
|
||||
|
||||
! Output variables
|
||||
double precision frms !< best rms after macro iteration
|
||||
|
||||
! Internal variables
|
||||
integer i
|
||||
! logical conver, ldum !< logicals for checking if calculation is converged
|
||||
logical ldum !< logicals for checking if calculation is converged
|
||||
integer start
|
||||
logical enough_parents
|
||||
integer mfit !< number of active parameters
|
||||
integer flag !< flag for write routine for fitting status(converged,maxiterationsreach,no convergence)
|
||||
|
||||
! Fabian 12.04. These are automatic arrays, maybe make them allocated or static
|
||||
integer idx(nset) !< array for sorting the parameter sets after their rms
|
||||
double precision rms(nset) !< array that contains rms of all parameter sets
|
||||
integer lauf !< counter for macroiteration
|
||||
double precision newpar(npar,nset) !< temporary storage array before parents&babies
|
||||
integer iact(npar) !< array pointing to the position of active parameters
|
||||
|
||||
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
||||
#ifdef mpi_version
|
||||
call MPI_Comm_rank(MPI_COMM_WORLD, my_rank, ierror)
|
||||
#endif
|
||||
|
||||
|
||||
!> Initialize mfit,iact
|
||||
call actinit(p_act,iact,mfit,npar)
|
||||
|
||||
#ifdef mpi_version
|
||||
call bcastact(p_act,npar)
|
||||
call MPI_Bcast(mfit, 1, MPI_INT, 0, MPI_COMM_WORLD,ierror)
|
||||
#endif
|
||||
|
||||
|
||||
!> Initialize rms vector
|
||||
|
||||
rms=0.d0
|
||||
rms(1:nset)=1d10
|
||||
|
||||
!> Write number of the present iteration and increase start to iter, if it is a restarted fit
|
||||
|
||||
if (iter.ne.1) then
|
||||
write(6,*) 'Genetic restart, proceed with iteration', iter
|
||||
endif
|
||||
start=iter
|
||||
|
||||
!> Start the genetic algorithm that consists of maxit macroiterations
|
||||
|
||||
do lauf=start,maxit
|
||||
|
||||
write(6,*) ''
|
||||
write(6,'(150("#"))')
|
||||
write(6,*) ''
|
||||
write(6,'(''Iteration:'',i5)') lauf
|
||||
|
||||
!ATTENTION: THIS SUBROUTINE IS THE PARALLIZED SECTION !!!
|
||||
|
||||
!Perform optimization for the parameter sets of generation lauf
|
||||
call fit_sets(lauf,nset,npar,par,rms,
|
||||
$ p_act,mfit,micit)
|
||||
|
||||
!-------------------------------------------------------------------------
|
||||
|
||||
!Sort the rms vector and assign the set number to each rms
|
||||
call idxsrt(rms,idx,nset)
|
||||
|
||||
!write out sorted errors and indicate with which set each error was obtained
|
||||
do i=1,nset
|
||||
write(6,'(A8,I3,A8,F12.8,A8,I3)') 'Rank:', i,'RMS:', rms(i),
|
||||
$ 'Set',idx(i)
|
||||
enddo
|
||||
|
||||
!write best rms onto the output variable frms
|
||||
frms=rms(1)
|
||||
|
||||
!-------------------------------------------------------------------------
|
||||
|
||||
!Resort the parameter array sucht that the parameter sets with the lowest rms are listed first
|
||||
newpar(1:npar,1:nset)=par(1:npar,idx(1:nset))
|
||||
par(1:npar,1:nset)=newpar(1:npar,1:nset)
|
||||
|
||||
!-------------------------------------------------------------------------
|
||||
|
||||
!Return if maximum number of macro iterations is reached
|
||||
if (lauf.ge.maxit) return
|
||||
|
||||
!-------------------------------------------------------------------------
|
||||
|
||||
!Prepare next iteration of the genetic algorithm
|
||||
|
||||
!Select the best parameter sets and sufficiently distinct sets as parents for the next iteration
|
||||
!Note: After parents, the first nsel entries of par and rms contain the parents
|
||||
!Note: However, rms is not strictly sorted after this (especially if the best parameter set were too similar)
|
||||
call parents(par,rms,difper,npar,idx,nset,nsel,p_act,mfit
|
||||
$ ,enough_parents)
|
||||
|
||||
!Check for convergence of genetic algorithm, i.e. whether the generation of new parents leads to
|
||||
!a decrease of the rms as well as sufficiently distinct parameter set; return if convergence is reached
|
||||
ldum=conver(old,rms,idx,nsel)
|
||||
|
||||
! initialize flag for write routine
|
||||
flag=1
|
||||
! set converged flag for write routine
|
||||
if (ldum) flag=2
|
||||
! write intermediate output
|
||||
call write_output(q,x1,x2,y,wt,par,p_act,p_spread,
|
||||
> nset,npar,flag,lauf)
|
||||
|
||||
if (ldum) return
|
||||
! call flush
|
||||
! flush(6)
|
||||
|
||||
!Check if there are enough parents for next macro iteration
|
||||
if (enough_parents .eqv. .false.) then
|
||||
write(6,*) "Warning: Found too few different parents
|
||||
$ for next macroiteration, exit genetic algorithm"
|
||||
exit
|
||||
endif
|
||||
|
||||
!Generate new parameter sets and proceed to the next iteration
|
||||
call babies(par,p_spread,mut,npar,mfit,nset,nsel,iact,
|
||||
$ seed,gtype)
|
||||
iter=iter+1
|
||||
!-------------------------------------------------------------------------
|
||||
|
||||
!write checkpoint:
|
||||
! writer='write'
|
||||
! call chkfile(chkpnt,par,npar,p_act,seed,gtype,nset,iter,
|
||||
! & old,writer)
|
||||
|
||||
!-------------------------------------------------------------------------
|
||||
|
||||
enddo
|
||||
|
||||
write(6,*) "Finished fit, return to main program"
|
||||
|
||||
end subroutine
|
||||
|
||||
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
subroutine fit_sets(lauf,nset,npar,par,rms,
|
||||
$ p_act,mfit,micit)
|
||||
use dim_parameter,only: lbfgs
|
||||
use marq_mod,only: mrqmin
|
||||
use lbfgsb_mod,only: lbfgs_driver
|
||||
#ifndef mpi_version
|
||||
use omp_lib
|
||||
#else
|
||||
use mpi
|
||||
integer ierror,my_rank
|
||||
integer workernum
|
||||
#endif
|
||||
! Input variables
|
||||
integer lauf !number of the current macroiteration
|
||||
integer nset !number of parameter sets
|
||||
integer npar !number of parameters
|
||||
|
||||
!Input / output variables
|
||||
double precision par(npar,nset) !< parameters
|
||||
double precision rms(nset) !< array that contains rms of all parameter sets
|
||||
|
||||
! Input variables (necessary solely for mrqmin)
|
||||
integer p_act(npar) !< array that contains info if a parameter is active or not == equivalent to ma in mrqmin
|
||||
integer mfit !< number of active parameters
|
||||
integer micit ! number of microiterations
|
||||
|
||||
! Internal variables in parallel section
|
||||
double precision lrms !< rms for one parameter set
|
||||
double precision lpar(npar) !array for one parameter set !Fabian 31.03.2022: New test to reduce sice of parameters
|
||||
integer i,j
|
||||
|
||||
! Internal variables for OpenMP
|
||||
double precision startzeit,endzeit,start_totzeit,end_totzeit
|
||||
integer thread_num
|
||||
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
||||
|
||||
|
||||
!> ATTENTION: THIS IS THE PARALLIZED SECTION !!!
|
||||
|
||||
!> Perform non-linear least squares fit for each parameter set:
|
||||
#ifdef mpi_version
|
||||
! write(*,*) 'mpi_version'
|
||||
start_totzeit=MPI_Wtime()
|
||||
call MPI_Comm_size(MPI_COMM_WORLD, workernum, ierror)
|
||||
call workshare(workernum, par, rms, npar, nset)
|
||||
end_totzeit=MPI_Wtime()
|
||||
#else
|
||||
start_totzeit=omp_get_wtime()
|
||||
!$omp parallel do schedule(dynamic)
|
||||
!$omp& default(shared)
|
||||
!$omp& private(i,j,lpar,lrms,thread_num,startzeit,endzeit)
|
||||
do i=lauf,nset
|
||||
! > Fabian 15.03.2022: Variable for timing the duration of optimizing one parameter set
|
||||
startzeit=omp_get_wtime() !Fabian
|
||||
|
||||
!> Write the parameters and the initial rms for this set onto private variables
|
||||
lpar(1:npar)=par(1:npar,i)
|
||||
lrms=rms(i)
|
||||
|
||||
!Fabian 05.04.2022: Here I could separate the active and inactive parameters and perform the LM optimization purely with the active params
|
||||
!Fabian 05.04.2022: However, this would require to store the inactive parameter and the vector that decides if a variable is active onto a module since I need it in funcs then!
|
||||
|
||||
|
||||
!> Levenberg-Marquardt-Optimization of the current parameter set
|
||||
!Fabian 16.03.2022: This version might be MPI compatible since it contains purely of private variables
|
||||
!Fabian 16.03.2022: Use this instead of the above, if the data is declared global via a module and pst is only then used when necessary!
|
||||
|
||||
if(lbfgs) then
|
||||
call lbfgs_driver(lpar,npar,p_act,mfit,
|
||||
& lrms,micit,i)
|
||||
else
|
||||
call mrqmin(lpar,npar,p_act,mfit,
|
||||
& lrms,micit,i)
|
||||
endif
|
||||
|
||||
!> Write the optimized parameters and the optimized rms back onto the arrays that collect all parameters and rms
|
||||
par(1:npar,i)=lpar(1:npar)
|
||||
rms(i)=lrms
|
||||
|
||||
!> Fabian 15.03.2022: Some output for timing the duration of optimizing one parameter set
|
||||
thread_num = omp_get_thread_num()
|
||||
endzeit=omp_get_wtime()
|
||||
write(6,*) 'Thread', thread_num ,'Time:', endzeit-startzeit
|
||||
|
||||
!> Write output for the spezific set of parameters
|
||||
write(6,99) i, rms(i), rms(i)*219474.69d0
|
||||
99 format('Set:',i5,5x,'RMS:',g16.6,3x,'(',f16.6,' cm-1)')
|
||||
|
||||
enddo
|
||||
!$omp end parallel do
|
||||
end_totzeit=omp_get_wtime()
|
||||
#endif
|
||||
write(6,*) 'Total time for Macroiteration: '
|
||||
> ,end_totzeit-start_totzeit
|
||||
|
||||
write(6,*) 'Finished parallel fit for Iteration', lauf
|
||||
|
||||
end subroutine
|
||||
|
||||
|
||||
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
C% SUBROUTINE PARENTS(...)
|
||||
C%
|
||||
C% subroutine to select the parent parameter sets according to their
|
||||
C% RMS error
|
||||
C%
|
||||
C % variables:
|
||||
C % par: parameter vector (double[npar,nset])
|
||||
C % rms: error for each set (double[nset])
|
||||
C % difper:
|
||||
C % npar: number of parameters (int)
|
||||
C % idx: sorted indeces according to rms(1..nset) (int[nset])
|
||||
C % nset: number of sets
|
||||
C % nsel: number of selected parents
|
||||
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
subroutine parents(par,rms,difper,npar,idx,nset,nsel,p_act,mfit
|
||||
$ ,enough_parents)
|
||||
implicit none
|
||||
integer i, j, k, nset, idx(nset), npar, nsel, p_act(npar), mfit
|
||||
double precision par(npar,nset), dum(npar,nset), rms(nset), last
|
||||
double precision thr
|
||||
double precision difper, drms(nset)
|
||||
integer dum_idx(nset), rank_parent(nsel)
|
||||
! logical difchk
|
||||
logical enough_parents
|
||||
|
||||
thr=1.d-8
|
||||
dum=0.d0
|
||||
dum_idx = 0
|
||||
rank_parent = 0
|
||||
drms=0.d0
|
||||
|
||||
c write the best parameter set on the dummy
|
||||
dum(1:npar,1)=par(1:npar,1)
|
||||
dum_idx(1)=idx(1)
|
||||
rank_parent(1) = 1
|
||||
!Choose exactly (beside the best parameter set) nsel-1 parameter sets as new parents and write them on dum
|
||||
!These parents are selected according to the lowest possible rms AND sufficient dissimilarity
|
||||
!to the overall best parameter sets
|
||||
last=1.d14
|
||||
k=1
|
||||
do i=1,nset
|
||||
if (difchk(dum,par(1:npar,i),difper,k,npar,p_act,mfit,nset))
|
||||
> then
|
||||
k=k+1
|
||||
dum(1:npar,k)=par(1:npar,i)
|
||||
drms(k)=rms(i)
|
||||
dum_idx(k) = idx(i)
|
||||
rank_parent(k) = i
|
||||
endif
|
||||
if (k.eq.nsel) exit
|
||||
enddo
|
||||
|
||||
!Terminate programm if too few parents are found
|
||||
enough_parents=.true.
|
||||
if(k.lt.nsel) then
|
||||
enough_parents=.false.
|
||||
endif
|
||||
|
||||
!Copy the selected parent parameter sets back to the array par
|
||||
do i=2,nsel
|
||||
par(1:npar,i)=dum(1:npar,i)
|
||||
rms(i)=drms(i)
|
||||
enddo
|
||||
|
||||
!Write out some information on the chosen parent parameter sets
|
||||
write(6,*) 'nsel:', nsel
|
||||
write(6,*)
|
||||
write(6,*) 'Selected parents:'
|
||||
do j=1,nsel
|
||||
write(6,201) rank_parent(j), rms(j), dum_idx(j)
|
||||
write(6,200) (par(k,j), k=1,npar)
|
||||
enddo
|
||||
200 format('Par:',6g16.7)
|
||||
201 format('>>> Rank:',i5,' RMS:' ,g14.4,' set:',i5,' <<<' )
|
||||
|
||||
! call flush
|
||||
! flush(6)
|
||||
|
||||
end subroutine
|
||||
|
||||
!----------------------------------------------------------------------
|
||||
! function to check whether new parameter set is sufficiently different
|
||||
! from already selected sets:
|
||||
logical function difchk(dum,par,difper,k,npar,p_act,mfit,nset)
|
||||
implicit none
|
||||
integer i, j, k, npar, p_act(npar), mfit,nset
|
||||
double precision dum(npar,nset), par(npar), per, thr, difper
|
||||
double precision epsilon
|
||||
parameter(epsilon=1d-8)
|
||||
|
||||
!.. this threshold specifies that parameter set must have an average
|
||||
! difference of at least 1% with respect to any other selected set.
|
||||
thr=1.d0-difper
|
||||
if (thr.gt.0.99d0) thr=0.99d0 !avoids no difference
|
||||
difchk=.true.
|
||||
do i=1,k
|
||||
per=0.d0
|
||||
!Calculate relative difference between between current set (par) and the already selected sets (dum)
|
||||
do j=1,npar
|
||||
if (p_act(j).ge.1) then !Added flexible value for p_act; Nicole 15.12.2022; only active parameters are counted
|
||||
per=per+(min(dum(j,i),par(j))+epsilon)
|
||||
$ /(max(dum(j,i),par(j))+epsilon)
|
||||
endif
|
||||
enddo
|
||||
per=per/mfit !Modified Version that only active parameters are counted; Fabian 14.12.2021
|
||||
!Discard the current set if it is too similar to one already selected
|
||||
if (per.gt.thr) then
|
||||
difchk=.false.
|
||||
return
|
||||
endif
|
||||
enddo
|
||||
|
||||
end function
|
||||
|
||||
!--------------------------------------------------------------------
|
||||
! subroutine to create the baby sets of parameters from the selected
|
||||
! parent sets
|
||||
subroutine babies(par,p_spread,mut,npar,mfit,nset,nsel,iact,
|
||||
$ seed,gtype)
|
||||
implicit none
|
||||
|
||||
c functions
|
||||
double precision rn !gets one random number
|
||||
|
||||
integer i, j, k, npar, nset, nsel, mfit, iact(npar)
|
||||
double precision par(npar,nset), p_spread(npar), mut, dum
|
||||
|
||||
integer seed,gtype
|
||||
|
||||
!loop over all dieing sets (only the nsel parent sets survive)
|
||||
do i=nsel+1,nset
|
||||
!loop over all active parameters
|
||||
do j=1,mfit
|
||||
!picking a random parameter set of the first nsel parent sets !(Fabian 16.03.2022: Add feature, to ensure that at least one baby is generated from each parent?)
|
||||
k=int(rn(seed,gtype,0)*nsel)+1 !Fabian 08.04.2022: Even though seed isnt passed here, the rn call is dependent on the earlier initialized seed
|
||||
!writing the j'th parameter of the selected parent set onto the j'th parameter of the i'th of the remaining sets (only the active parameters are copied)
|
||||
!(Fabian 16.03.2022: This way, I recombinate a number of parents to new babies. However, recombination might not be good, if these parent sets are relatively distinct; maybe use only two parent sets for recombination?)
|
||||
par(iact(j),i)=par(iact(j),k)
|
||||
!select whether the j'th parameter of this new set is mutated !(Fabian 16.03.2022: Add feature, to ensure that at least one parameter is mutated?)
|
||||
if (rn(seed,gtype,0).lt.mut) then
|
||||
dum=rn(seed,gtype,0) - 0.5d0
|
||||
dum=dum*p_spread(iact(j))
|
||||
par(iact(j),i)=par(iact(j),i)*(1.d0+dum)
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
end subroutine
|
||||
|
||||
!-----------------------------------------------------------------------
|
||||
! check convergence of genetic algorithm
|
||||
function conver(old,rms,idx,nsel)
|
||||
implicit none
|
||||
integer i, j, nsel, idx(*), baby
|
||||
double precision rms(*), new, old, thresh, percent, thrper
|
||||
logical conver
|
||||
|
||||
!Thresholds and initializiation
|
||||
conver=.false.
|
||||
thresh=old*1.d-3
|
||||
thrper=0.2d0
|
||||
|
||||
! Lets use all values in the selected subset:
|
||||
j=nsel
|
||||
baby=0
|
||||
|
||||
! Calculate average error for the nsel best parameter sets
|
||||
new=0.d0
|
||||
do i=1,j
|
||||
new=new+rms(i)
|
||||
enddo
|
||||
new=new/dble(j)
|
||||
|
||||
! calculate the number of selected parent sets that were originally babies in the previous iteration
|
||||
do i=1,nsel
|
||||
if (idx(i).gt.nsel) baby=baby+1
|
||||
enddo
|
||||
! calculate the percentage
|
||||
percent=dble(baby)/dble(nsel)
|
||||
|
||||
! some output
|
||||
write(6,100) baby
|
||||
write(6,101) new, j
|
||||
write(6,*)
|
||||
100 format('Number of babies in chosen subsets:', i3)
|
||||
101 format('Average RMS error of chosen subsets:', g12.4,
|
||||
$ ' / averaged values:', i4)
|
||||
|
||||
write(6,110) percent*100.d0
|
||||
write(6,111) old, new, old-new
|
||||
110 format('Percent babies:',f6.1)
|
||||
111 format('Old RMS:',d12.4,' New RMS:',d12.4,' Diff:',d12.4)
|
||||
|
||||
!Set convergence to true if
|
||||
!1. too few previous babies are among the new parents
|
||||
!2. or the average rms of the selected parents between the current & previous macro iteration is sufficiently small
|
||||
conver=(percent.le.thrper).and.(abs(new-old).lt.thresh)
|
||||
write(6,*) 'Convergence:', conver
|
||||
|
||||
!Set average rms of this iteration to the comparison variable old for the next iteration
|
||||
old=new
|
||||
|
||||
end function
|
||||
|
||||
end module fit_mod
|
||||
|
|
@ -0,0 +1,132 @@
|
|||
module funcs_mod
|
||||
implicit none
|
||||
logical,parameter:: dbg =.false.
|
||||
double precision, parameter:: thr_grad_diff = 1.d-3
|
||||
contains
|
||||
|
||||
subroutine funcs(n,p,ymod,dymod,npar,p_act,skip)
|
||||
! use dim_parameter,only:ntot,ndiab,anagrad
|
||||
use dim_parameter,only:ntot,ndiab,anagrad,nstat,nci !Fabian
|
||||
use data_module,only: x1_m
|
||||
use adia_mod,only: adia
|
||||
! In variables
|
||||
integer n, npar, p_act(npar)
|
||||
double precision ymod(ntot)
|
||||
double precision p(npar)
|
||||
logical skip
|
||||
! out variables
|
||||
double precision dymod(ntot,npar)
|
||||
double precision dum_dymod(ntot,npar)
|
||||
logical diff(ntot,npar)
|
||||
! internal varibales
|
||||
double precision ew(ndiab),ev(ndiab,ndiab) ! eigenvalues(ew) and eigenvectors(ev)
|
||||
integer i,j
|
||||
logical,parameter:: dbg =.false.
|
||||
|
||||
skip=.false.
|
||||
diff=.false.
|
||||
! get adiabatic energies:
|
||||
call adia(n,p,npar,ymod,ew,ev,skip)
|
||||
if(skip) return
|
||||
|
||||
if(eigchk(ew,nci)) then !Fabian: since pseudo-inverse is only calculated for first nci eigenvalues and their ci-vectors, if changed the check to nci
|
||||
dymod = 0.d0
|
||||
if(dbg) write(6,*)'funcs skipping point,n: ',n
|
||||
return
|
||||
endif
|
||||
! compute gradient with respect to parameter vector:
|
||||
if(anagrad) then
|
||||
write(6,*) 'ERROR: NOT SUPPORTED.'
|
||||
stop
|
||||
else
|
||||
! compute gradients numerically
|
||||
call num_grad(dymod,n,p,npar,p_act,skip)
|
||||
endif
|
||||
end subroutine
|
||||
|
||||
!----------------------------------------------------------------------
|
||||
! compute gradient of adiabatic energies nummerically with respect to parameters:
|
||||
subroutine num_grad(dymod,n,p,npar,p_act,skip)
|
||||
use dim_parameter,only: ntot,ndiab
|
||||
use adia_mod,only: adia
|
||||
integer n, i, j, npar
|
||||
integer p_act(npar)
|
||||
double precision ymod(ntot), dymod(ntot,npar), p(npar)
|
||||
double precision dp(npar)
|
||||
logical skip
|
||||
double precision ew(ndiab),ev(ndiab,ndiab)
|
||||
! determine finite differences for each parameter:
|
||||
call pdiff(p,dp,npar)
|
||||
|
||||
! generate numerical gradients for all parameters individually
|
||||
do i=1,npar
|
||||
|
||||
do j=1,ntot
|
||||
dymod(j,i)=0.d0
|
||||
enddo
|
||||
|
||||
! calculate gradient for active parameter, for inactive parameter gradient is always zero
|
||||
! Nicole: added flexible value of p_act
|
||||
if (p_act(i).ge.1) then
|
||||
|
||||
! change parameter in forward direction
|
||||
p(i)=p(i)+dp(i)
|
||||
call adia(n,p,npar,ymod,ew,ev,skip)
|
||||
if (skip) then
|
||||
p(i)=p(i)-dp(i)
|
||||
return
|
||||
endif
|
||||
do j=1,ntot
|
||||
dymod(j,i)=ymod(j)
|
||||
enddo
|
||||
|
||||
! change parameter in backward direction
|
||||
p(i)=p(i)-2.d0*dp(i)
|
||||
call adia(n,p,npar,ymod,ew,ev,skip)
|
||||
if (skip) then
|
||||
p(i)=p(i)+2.d0*dp(i)
|
||||
return
|
||||
endif
|
||||
do j=1,ntot
|
||||
dymod(j,i)=(dymod(j,i)-ymod(j))/(2.d0*dp(i)) !Form symmetric difference quotient
|
||||
enddo
|
||||
|
||||
! restore original parameter
|
||||
p(i)=p(i)+dp(i)
|
||||
endif
|
||||
enddo
|
||||
end subroutine num_grad
|
||||
!----------------------------------------------------------------------
|
||||
! determine appropriate finite differences for each parameter:
|
||||
subroutine pdiff(p,dp,npar)
|
||||
integer i, npar
|
||||
double precision p(npar), dp(npar)
|
||||
! double precision, parameter :: d = 1.d-4
|
||||
double precision, parameter :: d = 1.d-6 !Standard
|
||||
! double precision, parameter :: d = 1.d-8
|
||||
double precision, parameter :: thr = 1.d-12
|
||||
do i=1,npar
|
||||
dp(i)=abs(p(i)*d)
|
||||
if (dp(i).lt.thr) dp(i)=thr
|
||||
enddo
|
||||
end subroutine pdiff
|
||||
|
||||
!--------------------------------------------------------------------------------------
|
||||
!.. check vector of eigenvalues for (near) degeneragies
|
||||
logical function eigchk(v,n)
|
||||
!.. on input:
|
||||
integer n
|
||||
double precision v(n)
|
||||
!.. local variables:
|
||||
double precision thr
|
||||
parameter (thr=1.d-8) !threshold for degeneracy
|
||||
integer j
|
||||
eigchk=.false.
|
||||
do j=1,n-1
|
||||
if (abs((v(j+1)-v(j))).lt.thr) then
|
||||
eigchk=.true.
|
||||
return
|
||||
endif
|
||||
enddo
|
||||
end function eigchk
|
||||
end module funcs_mod
|
||||
|
|
@ -0,0 +1,163 @@
|
|||
program genetic
|
||||
! module for dimensioning parameters
|
||||
use dim_parameter,only: qn,ntot,numdatpt,dealloc_dim
|
||||
!data module
|
||||
use data_module, only: init_data, dealloc_data
|
||||
! parser module
|
||||
use parser, only: les
|
||||
! matrix derivatives module
|
||||
! use matrix_derivatives, only: dealloc_dw_ptr
|
||||
! monome module
|
||||
! use monome_module, only: dealloc_vwzprec
|
||||
! diab3D precalculate module
|
||||
! use diab3D_precalculate, only: dealloc_diab3D
|
||||
! parameter initialization module
|
||||
use init_mod,only: rinit,pinit
|
||||
! fitting module
|
||||
use fit_mod,only: fit
|
||||
! writing module
|
||||
use write_mod,only: write_output
|
||||
! MPI module
|
||||
#ifdef mpi_version
|
||||
use mpi
|
||||
#endif
|
||||
|
||||
implicit none
|
||||
|
||||
! Declare Variables
|
||||
! MPI variables
|
||||
#ifdef mpi_version
|
||||
integer my_rank,ierror,threadnum,stopnum,ping(8),i
|
||||
#endif
|
||||
! Data variables
|
||||
double precision, allocatable :: q_in(:,:),x1_in(:,:),x2_in(:,:)
|
||||
double precision, allocatable :: y_in(:,:),wt_in(:,:)
|
||||
! Fiting Model Parameters
|
||||
double precision, allocatable :: p(:),par(:,:) !< vector(npar) for the values of read parameters
|
||||
integer, allocatable :: p_act(:) !< vector(npar) containing 0 or 1 defining if corresponding parameters are activ in Fit
|
||||
double precision, allocatable :: p_spread(:),prange(:,:) !< vector(npar) for the spread values for each parameter
|
||||
integer npar !< read length of parameter arrays
|
||||
! Fit control Parameters
|
||||
integer seed !< Seed for RNG
|
||||
integer nset !< number of diffrent parameter sets
|
||||
logical freeze !< determines if parameters are active
|
||||
double precision mut, difper !< percentage of selected Parents, number of mutations in parents, minimum diffrence between selected parents
|
||||
integer nsel !< number of selected parameter sets for parents
|
||||
integer gtype !< type of RNG used
|
||||
integer maxit, micit !<maximum makro and micro iterations for the genetic program
|
||||
! -----------------------------
|
||||
! Fabian
|
||||
integer iter
|
||||
double precision rms,old
|
||||
character(len=80) filename
|
||||
character(len=80) chkpnt
|
||||
|
||||
! -----------------------------
|
||||
|
||||
#ifdef mpi_version
|
||||
call MPI_Init(ierror)
|
||||
call MPI_Comm_rank(MPI_COMM_WORLD,my_rank,ierror)
|
||||
call MPI_Comm_size(MPI_COMM_WORLD,threadnum,ierror)
|
||||
if(threadnum.lt.2) then
|
||||
write(*,*) 'USING MPI VERSION WITH 1 THREAD: ABORTING'
|
||||
stop
|
||||
endif
|
||||
#endif
|
||||
|
||||
! -----------------------------
|
||||
nsel=0
|
||||
mut=0.d0
|
||||
difper=0.d0
|
||||
call les(q_in,y_in,wt_in,p,p_act,p_spread,npar,
|
||||
> seed,gtype,nset,maxit,micit,nsel,mut,difper,freeze)
|
||||
|
||||
allocate(par(npar,nset),prange(2,npar))
|
||||
allocate(x1_in(qn,numdatpt),x2_in(qn,numdatpt))
|
||||
|
||||
call rinit(p,prange,p_spread,p_act,npar)
|
||||
par=0.d0
|
||||
par(1:npar,1)=p(1:npar)
|
||||
call pinit(par,prange,npar,nset,seed,gtype)
|
||||
|
||||
|
||||
!-------------------------------------------------
|
||||
call data_transform(q_in,x1_in,x2_in,y_in,wt_in,p,npar,p_act)
|
||||
!Fabian: Read data into module
|
||||
call init_data(numdatpt,q_in,x1_in,x2_in,y_in,wt_in,y_in)
|
||||
|
||||
!-------------------------------------------------
|
||||
#ifdef mpi_version
|
||||
if(my_rank.eq.0) then
|
||||
#endif
|
||||
call write_output(q_in,x1_in,x2_in,y_in,wt_in,par,p_act,p_spread,
|
||||
> nset,npar,0,0)
|
||||
#ifdef mpi_version
|
||||
endif
|
||||
#endif
|
||||
|
||||
!-------------------------------------------------
|
||||
|
||||
!Fabian: THIS IS THE PLACE WHERE MY ROUTINES START THERE EXECUTION
|
||||
!Fabian: We should either include these into Maiks routines or remove it from the fitting routines
|
||||
chkpnt='test'
|
||||
filename='test2'
|
||||
old=1.e+5
|
||||
iter=1
|
||||
|
||||
|
||||
#ifdef mpi_version
|
||||
if(my_rank.eq.0) then
|
||||
#endif
|
||||
if(.not.freeze) then
|
||||
call fit(q_in,x1_in,x2_in,y_in,rms,difper,wt_in,
|
||||
$ par,p_spread,mut,npar,p_act,
|
||||
$ seed,gtype,nset,nsel,chkpnt,old,iter,
|
||||
$ maxit,micit,y_in,
|
||||
$ filename)
|
||||
endif
|
||||
#ifdef mpi_version
|
||||
else
|
||||
call mpi_rest_control(micit,npar)
|
||||
endif
|
||||
#endif
|
||||
|
||||
#ifdef mpi_version
|
||||
if(my_rank.eq.0) then
|
||||
#endif
|
||||
call write_output(q_in,x1_in,x2_in,y_in,wt_in,par,p_act,p_spread,
|
||||
> nset,npar,1,iter)
|
||||
#ifdef mpi_version
|
||||
endif
|
||||
#endif
|
||||
|
||||
! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
! Final cleanup of programm (quit MPI, deallocate data, etc.)
|
||||
|
||||
#ifdef mpi_version
|
||||
if(my_rank.eq.0) then
|
||||
call MPI_Comm_size(MPI_COMM_WORLD,threadnum,ierror)
|
||||
stopnum = 0
|
||||
do i = 1,threadnum-1
|
||||
call MPI_Send(stopnum, 1, MPI_INTEGER,
|
||||
$ i, 69, MPI_COMM_WORLD, ping, ierror)
|
||||
enddo
|
||||
call MPI_Barrier(MPI_COMM_WORLD, ierror)
|
||||
endif
|
||||
#endif
|
||||
|
||||
deallocate(q_in,x1_in,x2_in,y_in,wt_in,
|
||||
$ p,par,p_act,p_spread,prange)
|
||||
call dealloc_data
|
||||
call dealloc_dim
|
||||
! call dealloc_dw_ptr
|
||||
! call dealloc_vwzprec
|
||||
! call dealloc_diab3D
|
||||
|
||||
#ifdef mpi_version
|
||||
call MPI_Barrier(MPI_COMM_WORLD, ierror)
|
||||
call MPI_Finalize(ierror)
|
||||
#endif
|
||||
|
||||
|
||||
end program
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
module idxsrt_mod
|
||||
implicit none
|
||||
contains
|
||||
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
! % SUBROUTINE IDXSRT(...)
|
||||
! %
|
||||
! % indices are sorted by ascending values of x, that means if you go
|
||||
! % throug x(idx(1..n)) from one to n, you will get an list of growing
|
||||
! % values
|
||||
! %
|
||||
! % variables:
|
||||
! % idx: indeces which are going to be sorted(int[n])
|
||||
! % n: number of indices (int)
|
||||
! % x: array of values (real[n]))
|
||||
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
subroutine idxsrt(x,idx,n)
|
||||
integer i, j, k, n, idx(n)
|
||||
double precision x(n), dum
|
||||
do i=1,n
|
||||
idx(i)=i
|
||||
enddo
|
||||
do i=1,n
|
||||
do j=i+1,n
|
||||
if (x(j).lt.x(i)) then
|
||||
dum=x(i)
|
||||
x(i)=x(j)
|
||||
x(j)=dum
|
||||
k=idx(i)
|
||||
idx(i)=idx(j)
|
||||
idx(j)=k
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
end subroutine idxsrt
|
||||
end module idxsrt_mod
|
||||
|
|
@ -0,0 +1,107 @@
|
|||
module init_mod
|
||||
implicit none
|
||||
contains
|
||||
|
||||
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
!% SUBROUTINE RINIT
|
||||
!%
|
||||
!% Subroutine to define the allowed range for each parameter:
|
||||
!% for the moment this is a distribution around zero with a given width
|
||||
!% for each parameter
|
||||
!%
|
||||
!% Input variables:
|
||||
!% par: Parameter vectot (double[])
|
||||
!% spread: Spread of each parameter (double[])
|
||||
!% ma: Active cards for every parameter (int[])
|
||||
!% npar: Number of Parameters
|
||||
!%
|
||||
!% Output variables
|
||||
!% prange: Spread interval vector (double[])
|
||||
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
subroutine rinit(par,prange,p_spread,p_act,npar)
|
||||
implicit none
|
||||
integer i,npar,p_act(npar)
|
||||
double precision par(npar), prange(2,npar), p_spread(npar),de,dum
|
||||
!minimum absolute spread
|
||||
double precision minspread
|
||||
parameter(minspread=1.d-4)
|
||||
|
||||
do i=1,npar
|
||||
if (abs(p_act(i)).eq.0) p_spread(i)=0.d0
|
||||
dum=par(i)
|
||||
if (abs(dum).lt.1.d-6) dum=minspread
|
||||
de=abs(dum*p_spread(i)/2.d0)
|
||||
prange(1,i)=par(i)-de
|
||||
prange(2,i)=par(i)+de
|
||||
enddo
|
||||
|
||||
end subroutine
|
||||
|
||||
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
!% SUBROUTINE PINIT(...)
|
||||
!%
|
||||
!% subroutine to initialize the nset parameter sets with random
|
||||
!% numbers in the range defined by prange
|
||||
!%
|
||||
!% Input Variables:
|
||||
!% par: parameter vector (double[])
|
||||
!% prange: Spread interval vector (double[])
|
||||
!% npar: number of parameters (int)
|
||||
!% nset: number of sets (int)
|
||||
!% seed: seed for random.f (int)
|
||||
!% gtype: selects random number generator (int)
|
||||
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
subroutine pinit(par,prange,npar,nset,seed,gtype)
|
||||
implicit none
|
||||
|
||||
integer i, j, npar, nset, seed, gtype,cont
|
||||
double precision par(npar,nset), prange(2,npar), rn, dum
|
||||
|
||||
!.. initialize new random number stream:
|
||||
cont=1
|
||||
dum=rn(seed,gtype,cont)
|
||||
|
||||
!.. create all the parameter sets by random numbers
|
||||
!continue with the initialized random number stream
|
||||
cont=0
|
||||
do i=2,nset
|
||||
do j=1,npar
|
||||
par(j,i)=prange(1,j)+rn(seed,gtype,cont) *
|
||||
$ (prange(2,j)-prange(1,j))
|
||||
enddo
|
||||
enddo
|
||||
end subroutine
|
||||
|
||||
|
||||
|
||||
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
!% SUBROUTINE ACTINIT(...)
|
||||
!%
|
||||
!% subroutine to select the active parameters and assign their indices
|
||||
!%
|
||||
!% Input Variables:
|
||||
!% p_act: vector of active cards
|
||||
!% npar: total number of parameters
|
||||
!%
|
||||
!% Output Variables:
|
||||
!% iact: list of active parameters
|
||||
!% mfit: number of active parameters
|
||||
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
subroutine actinit(p_act,iact,mfit,npar)
|
||||
implicit none
|
||||
|
||||
integer i, npar, p_act(npar), iact(npar), mfit
|
||||
|
||||
mfit=0
|
||||
iact=0
|
||||
do i=1,npar
|
||||
! Nicole: added flexible value of p_act
|
||||
if (p_act(i).ge.1) then
|
||||
mfit=mfit+1
|
||||
iact(mfit)=i
|
||||
endif
|
||||
enddo
|
||||
|
||||
end subroutine
|
||||
|
||||
end module init_mod
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,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,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])
|
||||
!**************************************************************************
|
||||
|
|
@ -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
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
@ -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
|
||||
|
|
@ -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])
|
||||
!**************************************************************************
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1,203 @@
|
|||
#ifdef mpi_version
|
||||
subroutine mpi_rest_control(micit,npar)
|
||||
use mpi
|
||||
implicit none
|
||||
! global permanent data (only transferred once)
|
||||
integer npar
|
||||
integer mfit
|
||||
integer micit
|
||||
integer ma(npar)
|
||||
integer ierror
|
||||
integer i
|
||||
integer mode
|
||||
logical runner
|
||||
integer status(MPI_STATUS_SIZE)
|
||||
|
||||
! do loop around this, checking for next fit or finish
|
||||
call bcastact(ma,npar)
|
||||
call MPI_Bcast(mfit, 1, MPI_INT, 0, MPI_COMM_WORLD,ierror)
|
||||
|
||||
runner=.true.
|
||||
do while(runner)
|
||||
|
||||
call MPI_Recv(mode, 1, MPI_INTEGER, 0, 69, MPI_COMM_WORLD,
|
||||
$ status,ierror)
|
||||
|
||||
if(mode.ne.0) then
|
||||
call mpi_fit_single_set(npar,mfit,micit,ma,mode)
|
||||
else
|
||||
runner=.false.
|
||||
endif
|
||||
end do
|
||||
call MPI_Barrier(MPI_COMM_WORLD, ierror)
|
||||
end
|
||||
|
||||
!-----------------------------------------------
|
||||
|
||||
c this does a single crunch of data
|
||||
subroutine mpi_fit_single_set(npar,mfit,micit,ma,nset)
|
||||
use mpi
|
||||
use dim_parameter, only: lbfgs
|
||||
use marq_mod,only: mrqmin
|
||||
use lbfgsb_mod,only: lbfgs_driver
|
||||
implicit none
|
||||
integer npar,mfit,micit,ierror,ma(*)
|
||||
integer status(MPI_STATUS_SIZE), nset, my_rank
|
||||
double precision par(npar), rms, startzeit, endzeit
|
||||
|
||||
startzeit = MPI_Wtime()
|
||||
|
||||
! receive data via blocking receive
|
||||
call MPI_Recv(par, npar, MPI_DOUBLE_PRECISION, 0, 13,
|
||||
$ MPI_COMM_WORLD, status, ierror)
|
||||
call MPI_Recv(rms, 1, MPI_DOUBLE_PRECISION, 0, 14,
|
||||
$ MPI_COMM_WORLD, status, ierror)
|
||||
|
||||
if(lbfgs) then
|
||||
call lbfgs_driver(par,npar,ma,mfit,
|
||||
& rms,micit,nset)
|
||||
else
|
||||
call mrqmin(par,npar,ma,mfit,
|
||||
& rms,micit,nset)
|
||||
endif
|
||||
|
||||
call MPI_Comm_rank(MPI_COMM_WORLD, my_rank, ierror)
|
||||
|
||||
! send back data via blocking send
|
||||
call MPI_Send(par, npar, MPI_DOUBLE_PRECISION, 0, 23,
|
||||
$ MPI_COMM_WORLD, ierror)
|
||||
call MPI_Send(rms, 1, MPI_DOUBLE_PRECISION, 0, 24, MPI_COMM_WORLD,
|
||||
$ ierror)
|
||||
|
||||
|
||||
endzeit = MPI_Wtime()
|
||||
|
||||
write(6,*) 'Thread', my_rank ,'Zeit:', endzeit-startzeit
|
||||
|
||||
!> Write output for the spezific set of parameters
|
||||
write(6,99) nset, rms, rms*219474.69d0
|
||||
99 format('Set:',i5,5x,'RMS:',g16.6,3x,'(',f16.6,' cm-1)')
|
||||
|
||||
end
|
||||
|
||||
!-----------------------------------------------
|
||||
|
||||
subroutine bcastact(act,len)
|
||||
use mpi
|
||||
implicit none
|
||||
integer len
|
||||
integer act(len)
|
||||
integer ierror
|
||||
|
||||
call MPI_Bcast(act, len, MPI_INT, 0, MPI_COMM_WORLD,ierror)
|
||||
|
||||
end
|
||||
|
||||
!-----------------------------------------------
|
||||
|
||||
subroutine workshare(numthreads, par, rms, npar, nset)
|
||||
use mpi
|
||||
implicit none
|
||||
integer numthreads,ierror,nset,npar
|
||||
double precision, asynchronous :: par(npar,nset),rms(nset)
|
||||
logical working(numthreads-1)
|
||||
logical sent,received_rms,received_par,received
|
||||
integer request_par(8,numthreads-1)
|
||||
integer request_rms(8,numthreads-1)
|
||||
integer ping(8)
|
||||
integer nextworker
|
||||
integer i,j,k
|
||||
integer worksignal
|
||||
integer status(MPI_STATUS_SIZE)
|
||||
integer (kind=MPI_ADDRESS_KIND) :: iadummy
|
||||
|
||||
! init working array
|
||||
do i = 1,numthreads
|
||||
working(i) = .false.
|
||||
enddo
|
||||
|
||||
do i = 1,nset
|
||||
|
||||
! do a round of sending
|
||||
sent=.false.
|
||||
do while(.not.sent)
|
||||
|
||||
do j = 1,numthreads-1
|
||||
if(.not.working(j)) then
|
||||
working(j)=.true.
|
||||
nextworker = j
|
||||
sent=.true.
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
|
||||
if(sent) then
|
||||
call MPI_Issend(i, 1, MPI_INTEGER,
|
||||
$ nextworker, 69, MPI_COMM_WORLD, ping(1), ierror)
|
||||
call MPI_Issend(par(1,i), npar, MPI_DOUBLE_PRECISION,
|
||||
$ nextworker, 13, MPI_COMM_WORLD, request_par(1
|
||||
$ ,nextworker), ierror)
|
||||
call MPI_Issend(rms(i), 1, MPI_DOUBLE_PRECISION,
|
||||
$ nextworker, 14, MPI_COMM_WORLD, request_rms(1
|
||||
$ ,nextworker), ierror)
|
||||
|
||||
! wait for Issend to finish (Hannes initial position for these statements --> runs parallel)
|
||||
call MPI_Wait(ping(1), status, ierror)
|
||||
call MPI_Wait(request_par(1,nextworker), status, ierror)
|
||||
call MPI_Wait(request_rms(1,nextworker), status, ierror)
|
||||
|
||||
call MPI_Irecv(par(1,i), npar, MPI_DOUBLE_PRECISION,
|
||||
$ nextworker, 23, MPI_COMM_WORLD, request_par(1
|
||||
$ ,nextworker) , ierror)
|
||||
|
||||
call MPI_Irecv(rms(i), 1, MPI_DOUBLE_PRECISION,
|
||||
$ nextworker, 24, MPI_COMM_WORLD, request_rms(1
|
||||
$ ,nextworker), ierror)
|
||||
|
||||
endif
|
||||
|
||||
! check finished workers
|
||||
do j = 1,numthreads-1
|
||||
if(working(j)) then
|
||||
received_rms=.false.
|
||||
received_par=.false.
|
||||
call MPI_Test(request_par(1,j), received_rms,
|
||||
$ status, ierror)
|
||||
call MPI_Test(request_rms(1,j), received_par,
|
||||
$ status, ierror)
|
||||
if(received_par.and.received_rms) then
|
||||
working(j) = .false.
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
|
||||
enddo
|
||||
|
||||
enddo
|
||||
|
||||
received = .false.
|
||||
do while(.not.received)
|
||||
do j = 1,numthreads-1
|
||||
if(working(j)) then
|
||||
received_rms=.false.
|
||||
received_par=.false.
|
||||
call MPI_Test(request_par(1,j), received_rms,
|
||||
$ MPI_STATUS_IGNORE, ierror)
|
||||
call MPI_Test(request_rms(1,j), received_par,
|
||||
$ MPI_STATUS_IGNORE, ierror)
|
||||
if(received_par.and.received_rms) then
|
||||
working(j) = .false.
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
received=.true.
|
||||
do j = 1,numthreads-1
|
||||
if(working(j)) then
|
||||
received = .false.
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end
|
||||
#endif
|
||||
|
|
@ -0,0 +1,32 @@
|
|||
**** ERROR CATALOGUE -- this defines what kind of errors parse.f throws
|
||||
|
||||
|
||||
! 1 32 64
|
||||
! v v v
|
||||
! '................................................................'
|
||||
errcat( 1)='ILLOGICALLY SMALL VALUE'
|
||||
errcat( 2)='VALUE EXCEEDS SET MAXIMUM'
|
||||
errcat( 3)='GIVEN DATA STRUCTURE SIZE INCONSISTENT WITH'
|
||||
> // ' PREVIOUS DECLARATION'
|
||||
errcat( 4)='VALUE GREATER THAN SET MAXIMUM'
|
||||
errcat( 5)='VALUE LESS THAN SET MINIMUM'
|
||||
errcat( 6)='IMPLIED DATA POINT NUMBER INCONSISTENT WITH NPAT'
|
||||
errcat( 7)='PERCENTAGE NOT WITHIN MEANINGFUL RANGE (0.0-100.0)'
|
||||
errcat( 8)='MISSING KEY CLASHES WITH PREVIOUS DECLARATION'
|
||||
errcat( 9)='MAXIMUM IDENTICAL TO MINIMUM'
|
||||
errcat(10)='DEPRECATED COMMAND: FEATURE HAS BEEN REMOVED, '
|
||||
> // 'SEE PARSER.'
|
||||
errcat(11)='TOO MANY ARGUMENTS'
|
||||
! errcat(12)=
|
||||
! errcat(13)=
|
||||
! errcat(14)=
|
||||
! errcat(15)=
|
||||
! errcat(16)=
|
||||
! errcat(17)=
|
||||
! errcat(18)=
|
||||
! errcat(19)=
|
||||
! errcat(20)=
|
||||
! errcat(21)=
|
||||
! errcat(22)=
|
||||
! errcat(23)=
|
||||
! errcat(24)=
|
||||
|
|
@ -0,0 +1,55 @@
|
|||
module io_parameters
|
||||
implicit none
|
||||
! ******************************************************************************
|
||||
! **** I/O-Parameters
|
||||
! ***
|
||||
! *** dnlen: maximum char length of data file path
|
||||
! *** maxlines: maximum input file length
|
||||
! *** llen: character maximum per line
|
||||
! *** maxdat: maximum number of input data values of one kind
|
||||
! *** (e.g. integer values) excluding DATA: block
|
||||
! *** clen: max. character length of string data
|
||||
! *** klen: maximum length of key or typestring
|
||||
! *** maxkeys: max. number of keys
|
||||
! *** maxerrors: max. number of pre-defined error messages.
|
||||
|
||||
integer, parameter :: dnlen = 8192
|
||||
integer, parameter :: maxlines = 3000000,llen = 750
|
||||
integer, parameter :: klen=20,maxkeys=200
|
||||
integer, parameter :: maxdat=2000,clen=1024
|
||||
integer, parameter :: maxerrors=100
|
||||
! Declarations for general Keylist and error massages
|
||||
integer :: keynum !< keynum number of general keys
|
||||
integer :: datpos(3,maxdat) !< datpos Pointer to type, data adress and length for each general key
|
||||
character(len=klen) :: keylist(2,maxkeys) !< list of general program keys for programm control and parameter initialisation defined in keylist.incl
|
||||
character(len=64) :: errcat(maxerrors) !< list of generic error Messages defined in errcat.incl
|
||||
|
||||
! parameter key declaration
|
||||
integer, parameter :: maxpar_keys=400 !<maximum number of parameter keys
|
||||
character(len=klen) :: key(4,maxpar_keys) !<list of parameter keys (1-4: number,value,active?,spread)
|
||||
integer :: parkeynum !< actual number of parameterkeys specified
|
||||
integer :: parkeylen !< lenght of longest parameterkey string
|
||||
|
||||
!**********************************************************
|
||||
!**** Error Codes
|
||||
!*** Codes should be powers of 2. Binary representation of return value
|
||||
!*** should correspond to all exceptions invoked. ec_error should never
|
||||
!*** be invoked with any other.
|
||||
!***
|
||||
!*** ec_error: generic error (catch-all, avoid!)
|
||||
!*** ec_read: parsing error during les()
|
||||
!*** ec_dim: dimensioning error
|
||||
!*** ec_log: logic error
|
||||
!***
|
||||
!**** Inferred error codes
|
||||
!*** ec_dimrd: ec_dim+ec_read
|
||||
|
||||
|
||||
integer, parameter :: ec_error=1, ec_read=2, ec_dim=4, ec_log=8
|
||||
integer, parameter :: ec_dimrd=ec_dim+ec_read
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
end module
|
||||
|
|
@ -0,0 +1,301 @@
|
|||
**** KEYLIST -- this defines what kind of keys genANN is able to process syntactially
|
||||
|
||||
keylist=' '
|
||||
|
||||
! The only "special" key in the sense that it terminates input
|
||||
keylist(1, 1)='DATA:'
|
||||
keylist(2, 1)='E!'
|
||||
|
||||
keylist(1, 2)='SEED:'
|
||||
keylist(2, 2)='I1'
|
||||
|
||||
keylist(1, 3)='NSET:'
|
||||
keylist(2, 3)='+I1'
|
||||
|
||||
keylist(1, 4)='FREEZE:'
|
||||
keylist(2, 4)='E'
|
||||
|
||||
keylist(1, 5)='NSTAT:'
|
||||
keylist(2, 5)='+I1!'
|
||||
|
||||
keylist(1, 6)='NCI:'
|
||||
keylist(2, 6)='+I1'
|
||||
|
||||
keylist(1, 7)='NDIAB:'
|
||||
keylist(2, 7)='+I1'
|
||||
|
||||
keylist(1, 8)='HYBRID:'
|
||||
keylist(2, 8)='E'
|
||||
|
||||
keylist(1, 9)='SEL:'
|
||||
keylist(2, 9)='+D1'
|
||||
|
||||
keylist(1,10)='MUT:'
|
||||
keylist(2,10)='+D1'
|
||||
|
||||
keylist(1,11)='DIFPER:'
|
||||
keylist(2,11)='+D1'
|
||||
|
||||
keylist(1,12)='GTYPE:'
|
||||
keylist(2,12)='+I1'
|
||||
|
||||
keylist(1,13)='MAXIT:'
|
||||
keylist(2,13)='+I1'
|
||||
|
||||
keylist(1,14)='MICIT:'
|
||||
keylist(2,14)='+I1'
|
||||
|
||||
keylist(1,15)='GSPREAD:'
|
||||
keylist(2,15)='+D1'
|
||||
|
||||
keylist(1,16)='SETS:'
|
||||
keylist(2,16)='+IN!'
|
||||
|
||||
keylist(1,17)='INPUTS:'
|
||||
keylist(2,17)='+IN!'
|
||||
|
||||
keylist(1,18)='ENCIRATIO:'
|
||||
keylist(2,18)='+D1'
|
||||
|
||||
keylist(1,19)='WTEN:'
|
||||
keylist(2,19)='+DN'
|
||||
|
||||
keylist(1,20)='WTCI:'
|
||||
keylist(2,20)='+DN'
|
||||
|
||||
keylist(1,21)='NPOINTS:'
|
||||
keylist(2,21)='+IN!'
|
||||
|
||||
keylist(1,22)='NTOT:'
|
||||
keylist(2,22)='+I1'
|
||||
|
||||
keylist(1,23)='RMSTHR:'
|
||||
keylist(2,23)='+DN'
|
||||
|
||||
keylist(1,24)='ANAGRAD:'
|
||||
keylist(2,24)='E'
|
||||
|
||||
keylist(1,25)='LBFGS:'
|
||||
keylist(2,25)='E'
|
||||
|
||||
keylist(1,26)='LBFGSCORR:'
|
||||
keylist(2,26)='+I1'
|
||||
|
||||
keylist(1,27)='FACSPREAD:'
|
||||
keylist(2,27)='+D1'
|
||||
|
||||
keylist(1,28)='LOGCONVERGENCE:'
|
||||
keylist(2,28)='E'
|
||||
|
||||
keylist(1,29)='COORD:'
|
||||
keylist(2,29)='IN'
|
||||
|
||||
! keylist(1,30)=
|
||||
! keylist(2,30)=
|
||||
!
|
||||
! keylist(1,31)=
|
||||
! keylist(2,31)=
|
||||
!
|
||||
! keylist(1,32)=
|
||||
! keylist(2,32)=
|
||||
!
|
||||
! keylist(1,33)=
|
||||
! keylist(2,33)=
|
||||
!
|
||||
! keylist(1,34)=
|
||||
! keylist(2,34)=
|
||||
!
|
||||
! keylist(1,35)=
|
||||
! keylist(2,35)=
|
||||
!
|
||||
! keylist(1,36)=
|
||||
! keylist(2,36)=
|
||||
!
|
||||
! keylist(1,37)=
|
||||
! keylist(2,37)=
|
||||
!
|
||||
! keylist(1,38)=
|
||||
! keylist(2,38)=
|
||||
!
|
||||
! keylist(1,39)=
|
||||
! keylist(2,39)=
|
||||
!
|
||||
! keylist(1,40)=
|
||||
! keylist(2,40)=
|
||||
!
|
||||
! keylist(1,41)=
|
||||
! keylist(2,41)=
|
||||
!
|
||||
! keylist(1,42)=
|
||||
! keylist(2,42)=
|
||||
!
|
||||
! keylist(1,43)=
|
||||
! keylist(2,43)=
|
||||
!
|
||||
! keylist(1,44)=
|
||||
! keylist(2,44)=
|
||||
!
|
||||
! keylist(1,45)=
|
||||
! keylist(2,45)=
|
||||
!
|
||||
! keylist(1,46)=
|
||||
! keylist(2,46)=
|
||||
!
|
||||
! keylist(1,47)=
|
||||
! keylist(2,47)=
|
||||
!
|
||||
! keylist(1,48)=
|
||||
! keylist(2,48)=
|
||||
!
|
||||
! keylist(1,49)=
|
||||
! keylist(2,49)=
|
||||
!
|
||||
! keylist(1,50)=
|
||||
! keylist(2,50)=
|
||||
!
|
||||
! keylist(1,51)=
|
||||
! keylist(2,51)=
|
||||
!
|
||||
! keylist(1,52)=
|
||||
! keylist(2,52)=
|
||||
!
|
||||
! keylist(1,53)=
|
||||
! keylist(2,53)=
|
||||
!
|
||||
! keylist(1,54)=
|
||||
! keylist(2,54)=
|
||||
!
|
||||
! keylist(1,55)=
|
||||
! keylist(2,55)=
|
||||
!
|
||||
! keylist(1,56)=
|
||||
! keylist(2,56)=
|
||||
!
|
||||
! keylist(1,57)=
|
||||
! keylist(2,57)=
|
||||
!
|
||||
! keylist(1,58)=
|
||||
! keylist(2,58)=
|
||||
!
|
||||
! keylist(1,59)=
|
||||
! keylist(2,59)=
|
||||
!
|
||||
! keylist(1,60)=
|
||||
! keylist(2,60)=
|
||||
|
||||
! keylist(1,61)=
|
||||
! keylist(2,61)=
|
||||
!
|
||||
! keylist(1,62)=
|
||||
! keylist(2,62)=
|
||||
!
|
||||
! keylist(1,63)=
|
||||
! keylist(2,63)=
|
||||
!
|
||||
! keylist(1,64)=
|
||||
! keylist(2,64)=
|
||||
!
|
||||
! keylist(1,65)=
|
||||
! keylist(2,65)=
|
||||
!
|
||||
! keylist(1,66)=
|
||||
! keylist(2,66)=
|
||||
!
|
||||
! keylist(1,67)=
|
||||
! keylist(2,67)=
|
||||
!
|
||||
! keylist(1,68)=
|
||||
! keylist(2,68)=
|
||||
!
|
||||
! keylist(1,69)=
|
||||
! keylist(2,69)=
|
||||
!
|
||||
! keylist(1,70)=
|
||||
! keylist(2,70)=
|
||||
!
|
||||
! keylist(1,71)=
|
||||
! keylist(2,71)=
|
||||
!
|
||||
! keylist(1,72)=
|
||||
! keylist(2,72)=
|
||||
!
|
||||
! keylist(1,73)=
|
||||
! keylist(2,73)=
|
||||
!
|
||||
! keylist(1,74)=
|
||||
! keylist(2,74)=
|
||||
!
|
||||
! keylist(1,75)=
|
||||
! keylist(2,75)=
|
||||
!
|
||||
! keylist(1,76)=
|
||||
! keylist(2,76)=
|
||||
!
|
||||
! keylist(1,77)=
|
||||
! keylist(2,77)=
|
||||
!
|
||||
! keylist(1,78)=
|
||||
! keylist(2,78)=
|
||||
!
|
||||
! keylist(1,79)=
|
||||
! keylist(2,79)=
|
||||
!
|
||||
! keylist(1,80)=
|
||||
! keylist(2,80)=
|
||||
!
|
||||
! keylist(1,81)=
|
||||
! keylist(2,81)=
|
||||
!
|
||||
! keylist(1,82)=
|
||||
! keylist(2,82)=
|
||||
!
|
||||
! keylist(1,83)=
|
||||
! keylist(2,83)=
|
||||
!
|
||||
! keylist(1,84)=
|
||||
! keylist(2,84)=
|
||||
!
|
||||
! keylist(1,85)=
|
||||
! keylist(2,85)=
|
||||
!
|
||||
! keylist(1,86)=
|
||||
! keylist(2,86)=
|
||||
!
|
||||
! keylist(1,87)=
|
||||
! keylist(2,87)=
|
||||
!
|
||||
! keylist(1,88)=
|
||||
! keylist(2,88)=
|
||||
!
|
||||
! keylist(1,89)=
|
||||
! keylist(2,89)=
|
||||
!
|
||||
! keylist(1,90)=
|
||||
! keylist(2,90)=
|
||||
!
|
||||
! keylist(1,91)=
|
||||
! keylist(2,91)=
|
||||
!
|
||||
! keylist(1,92)=
|
||||
! keylist(2,92)=
|
||||
!
|
||||
! keylist(1,93)=
|
||||
! keylist(2,93)=
|
||||
!
|
||||
! keylist(1,94)=
|
||||
! keylist(2,94)=
|
||||
!
|
||||
! keylist(1,95)=
|
||||
! keylist(2,95)=
|
||||
!
|
||||
! keylist(1,96)=
|
||||
! keylist(2,96)=
|
||||
!
|
||||
! keylist(1,97)=
|
||||
! keylist(2,97)=
|
||||
!
|
||||
! keylist(1,98)=
|
||||
! keylist(2,98)=
|
||||
!
|
||||
! keylist(1,99)=
|
||||
! keylist(2,99)=
|
||||
|
|
@ -0,0 +1 @@
|
|||
../model/keys.f90
|
||||
|
|
@ -0,0 +1,148 @@
|
|||
module fileread_mod
|
||||
contains
|
||||
!-------------------------------------------------------------------
|
||||
|
||||
subroutine get_datfile(datnam,dnlen)
|
||||
implicit none
|
||||
! Get name of input data file DATNAM either from the program's first
|
||||
! command line argument or ask the user.
|
||||
|
||||
integer dnlen
|
||||
character(len=dnlen) datnam
|
||||
|
||||
integer argcount
|
||||
|
||||
argcount=iargc()
|
||||
if (argcount.gt.0) then
|
||||
call getarg(1,datnam)
|
||||
else
|
||||
write(6,'(A)') 'Specify input file:'
|
||||
read(*,*) datnam
|
||||
endif
|
||||
|
||||
if (len_trim(datnam).eq.dnlen) then
|
||||
write(6,'(A)') 'ERROR: TRUNCATED FILENAME'
|
||||
write(6,'(A)') '"' // datnam // '"'
|
||||
endif
|
||||
|
||||
end subroutine get_datfile
|
||||
|
||||
!-------------------------------------------------------------------
|
||||
|
||||
subroutine internalize_datfile(datnam,infile,linenum,llen,
|
||||
> maxlines,dnlen)
|
||||
use strings_mod,only:write_oneline,int2string
|
||||
implicit none
|
||||
|
||||
! Read input file located at DATNAM, skipping comments and blank lines.
|
||||
integer dnlen,llen,maxlines
|
||||
integer linenum
|
||||
character(len=dnlen) datnam
|
||||
character(len=llen) infile(maxlines)
|
||||
|
||||
character(len=llen) line
|
||||
|
||||
!character*16 int2string
|
||||
|
||||
integer j
|
||||
|
||||
!Fabian
|
||||
character(len=llen) fmt,fmt2
|
||||
integer,parameter :: std_out = 6
|
||||
integer,parameter :: funit = 10
|
||||
write(fmt,'(A)') 'Reading file ''' // trim(datnam) // ''' ...'
|
||||
call write_oneline(fmt,std_out)
|
||||
|
||||
open(unit=funit,file=datnam)
|
||||
linenum=0
|
||||
do j=1,maxlines
|
||||
!read(funit,fmt='(A<llen>)',end=20) line !<var> works only for ifort, not for gfortran or mpif90
|
||||
write(fmt2,'("(A",I3,")")') llen !Fabian
|
||||
read(funit,fmt=fmt2,end=20) line !Fabian
|
||||
if (line(1:3).eq.'---') then
|
||||
write(fmt,'(A)') 'EOF-mark "---" found at line'
|
||||
> // trim(int2string(j))
|
||||
call write_oneline(fmt,std_out)
|
||||
exit
|
||||
endif
|
||||
call internalize_line(linenum,infile,line,llen,maxlines)
|
||||
enddo
|
||||
20 close(funit)
|
||||
|
||||
if (j.ge.maxlines) then
|
||||
write(6,'(A)') 'ERROR: FILE LENGTH EXCEEDING MAXLINES.'
|
||||
stop 1
|
||||
endif
|
||||
|
||||
write(fmt,'(A)') 'File read successfully ('
|
||||
> // trim(int2string(linenum)) // ' lines).'
|
||||
call write_oneline(fmt,std_out)
|
||||
|
||||
end subroutine internalize_datfile
|
||||
|
||||
!-------------------------------------------------------------------
|
||||
|
||||
subroutine internalize_line(linenum,infile,line,llen,maxlines)
|
||||
use strings_mod,only: strip_string,upcase
|
||||
implicit none
|
||||
! Parse a single line of input. Ignore comments ("!..") and blank
|
||||
! lines, and turn all input to uppercase.
|
||||
!
|
||||
! infile: data file's internalized form
|
||||
! line: single verbatim line read from physical file
|
||||
! linenum: current number of non-commentlines read
|
||||
! increased by 1 if read line is not a comment
|
||||
! llen: maximum character length of a single line
|
||||
! maxlines: maximum number of lines in infile
|
||||
|
||||
integer llen,maxlines
|
||||
integer linenum
|
||||
character(len=llen) infile(maxlines)
|
||||
character(len=llen) line
|
||||
|
||||
character(len=llen) strip
|
||||
integer line_pos,text_end
|
||||
|
||||
integer j
|
||||
|
||||
line_pos=linenum+1
|
||||
|
||||
! ignore empty lines
|
||||
if (len_trim(line).eq.0) then
|
||||
return
|
||||
endif
|
||||
|
||||
! strip needless whitespace
|
||||
call strip_string(line,strip,llen)
|
||||
|
||||
! determine EOL
|
||||
! ignore comments
|
||||
text_end=0
|
||||
do j=1,len_trim(strip)
|
||||
if (strip(j:j).eq.'!') then
|
||||
exit
|
||||
endif
|
||||
text_end=text_end+1
|
||||
enddo
|
||||
|
||||
if (text_end.eq.llen) then
|
||||
write(6,'(A,I6)') 'WARNING: POTENTIALLY TRUNCATED LINE:'
|
||||
write(6,'(A)') '"' // strip(1:60) // '"...'
|
||||
endif
|
||||
|
||||
! skip if line is a comment
|
||||
if (text_end.eq.0) then
|
||||
return
|
||||
endif
|
||||
|
||||
infile(line_pos)=' '
|
||||
|
||||
! turn string to uppercase and write to infile, ignoring comments
|
||||
call upcase(strip,infile(line_pos),text_end)
|
||||
|
||||
! increment line number
|
||||
linenum=linenum+1
|
||||
|
||||
end subroutine internalize_line
|
||||
|
||||
end module
|
||||
|
|
@ -0,0 +1,274 @@
|
|||
module keyread_mod
|
||||
contains
|
||||
|
||||
subroutine keyread(keylist,infile,keynum,idat,ddat,cdat,datpos,
|
||||
> klen,llen,clen,linenum,maxdat)
|
||||
use long_keyread_mod,only:long_intkey,long_realkey,long_strkey
|
||||
use strings_mod,only:int2string,dble2string
|
||||
implicit none
|
||||
! Read all keys from KEYLIST from INFILE and write their associated
|
||||
! data to the corresponding data block. Memory management is
|
||||
! handled by DATPOS.
|
||||
!
|
||||
! keylist: Registry of keys containing the name of the key
|
||||
! and it's type information.
|
||||
! keylist(N,1): keyname. It should be in all-caps.
|
||||
! keylist(N,2): type string of the form "X#"
|
||||
!
|
||||
! Note: Key 1 (keylist(1,1)) has the special property that all
|
||||
! lines of the input file after it's first occurence will be
|
||||
! ignored. This allows for long input files holding non-key
|
||||
! information.
|
||||
!
|
||||
! typestring syntax:
|
||||
! X should be I (Integer), +I (Int >= 0), D (double precision),
|
||||
! C (character string), +D (real >= 0.0d0)
|
||||
! or E (checks whether key exists).
|
||||
! X! (e.g. +I!, D!,..) makes a key non-optional.
|
||||
! E!, while absurd, is a valid option.
|
||||
! # should be either N (meaning variable length) or an integer >0.
|
||||
! it encodes the expected number of read values
|
||||
!
|
||||
! note: the E-type has no associated *dat-array, instead
|
||||
! datpos(2,N) is either -1 or it's last occurence in infile,
|
||||
! depending on whether the key was found. Furthermore,
|
||||
! E-type keys accept no arguments.
|
||||
!
|
||||
! *dat: data arrays for respective items
|
||||
! klen: length of key/typestring
|
||||
! llen: line length of infile
|
||||
! clen: length of read strings
|
||||
! keynum: number of keys
|
||||
! linenum: number of lines the file has
|
||||
! maxdat: maximum number of total input values read
|
||||
! infile: input file
|
||||
! datpos: integer array assigning read values to the keys
|
||||
! datpos(1,N): internalized type (0: I, 1: +I, 2: D, 3: +D,
|
||||
! 4: C, 5: E)
|
||||
! datpos(2,N): starting pos. in respective data array
|
||||
! datpos(3,N): length of data block
|
||||
!
|
||||
|
||||
!? WARNING: *dat() MAY BE WRITTEN BEYOND THEIR LENGTH FOR BAD DIMENSIONS.
|
||||
!? CATCH THIS!
|
||||
|
||||
integer klen, llen, clen
|
||||
integer keynum, linenum, maxdat
|
||||
character(len=klen) keylist(2,keynum)
|
||||
character(len=llen) infile(linenum)
|
||||
integer datpos(3,maxdat)
|
||||
|
||||
integer idat(maxdat)
|
||||
double precision ddat(maxdat)
|
||||
character(len=clen) cdat(maxdat)
|
||||
character(len=klen) key
|
||||
character(len=64) errmsg
|
||||
|
||||
integer intype,inlen,readlen
|
||||
integer cstart,istart,dstart
|
||||
integer key_end
|
||||
integer datnum,inpos,datlen
|
||||
integer file_stop
|
||||
logical optional2
|
||||
|
||||
integer j,k
|
||||
|
||||
cstart=1
|
||||
istart=1
|
||||
dstart=1
|
||||
datnum=0
|
||||
|
||||
file_stop=linenum
|
||||
key=keylist(1,1)
|
||||
key_end=len_trim(key)
|
||||
if (key_end.ne.0) then
|
||||
do k=1,linenum
|
||||
if (infile(k)(1:key_end).eq.trim(key)) then
|
||||
file_stop=k
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
|
||||
do j=1,keynum
|
||||
key=keylist(1,j)
|
||||
|
||||
! get information needed to read key
|
||||
call get_key_kind(keylist(:,j),intype,optional2,inlen,klen)
|
||||
datpos(1,j)=intype
|
||||
key_end=len_trim(key)
|
||||
|
||||
! find last invocation of key (if present)
|
||||
inpos=0
|
||||
do k=1,file_stop
|
||||
if (infile(k)(1:key_end).eq.trim(key)) then
|
||||
inpos=k
|
||||
endif
|
||||
enddo
|
||||
|
||||
if (inpos.eq.0) then
|
||||
if (.not.optional2) then
|
||||
errmsg='MISSING, NON-OPTIONAL KEY'
|
||||
call signal_key_error(key,errmsg,klen)
|
||||
endif
|
||||
datpos(2,j)=-1
|
||||
datpos(3,j)=0
|
||||
cycle
|
||||
endif
|
||||
|
||||
! read from last occurence of key
|
||||
readlen=0
|
||||
if (intype.le.1) then
|
||||
datlen=maxdat-istart+1
|
||||
call long_intkey(infile,inpos,key_end,
|
||||
> idat,istart,readlen,llen,maxdat,linenum)
|
||||
else if (intype.le.3) then
|
||||
datlen=maxdat-dstart+1
|
||||
call long_realkey(infile,inpos,key_end,
|
||||
> ddat,dstart,readlen,llen,maxdat,linenum)
|
||||
else if (intype.eq.4) then
|
||||
call long_strkey(infile,inpos,key_end,
|
||||
> cdat,cstart,readlen,llen,maxdat,linenum,clen)
|
||||
else if (intype.eq.5) then
|
||||
! since datpos already encodes whether the key was found,
|
||||
! there is no need to save anything
|
||||
readlen=0
|
||||
else
|
||||
write(6,*) 'ERROR: ENCOUNTERED FAULTY TYPE SPEC.'
|
||||
stop 1
|
||||
endif
|
||||
|
||||
! check validity of input length
|
||||
if (inlen.eq.-1) then
|
||||
inlen=readlen
|
||||
else if (inlen.ne.readlen) then
|
||||
errmsg='WRONG NUMBER OF ARGUMENTS'
|
||||
call signal_key_error(key,errmsg,klen)
|
||||
endif
|
||||
|
||||
! check sign of +X types
|
||||
if (intype.eq.1) then
|
||||
do k=1,inlen
|
||||
if (idat(istart-1+k).lt.0) then
|
||||
errmsg='UNEXPECTED NEGATIVE INTEGER: '
|
||||
> // trim(int2string(idat(istart-1+k)))
|
||||
call signal_key_error(key,errmsg,klen)
|
||||
endif
|
||||
enddo
|
||||
else if (intype.eq.3) then
|
||||
do k=1,inlen
|
||||
if (ddat(dstart-1+k).lt.0.0d0) then
|
||||
errmsg='UNEXPECTED NEGATIVE REAL: '
|
||||
> // trim(dble2string(ddat(dstart-1+k)))
|
||||
call signal_key_error(key,errmsg,klen)
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
|
||||
if (intype.le.1) then
|
||||
datpos(2,j)=istart
|
||||
istart=istart+inlen
|
||||
else if (intype.le.3) then
|
||||
datpos(2,j)=dstart
|
||||
dstart=dstart+inlen
|
||||
else if (intype.eq.4) then
|
||||
datpos(2,j)=cstart
|
||||
dstart=cstart+inlen
|
||||
else if (intype.eq.5) then
|
||||
! remember where you last found the key in infile
|
||||
datpos(2,j)=inpos
|
||||
endif
|
||||
|
||||
datpos(3,j)=inlen
|
||||
|
||||
enddo
|
||||
end subroutine keyread
|
||||
|
||||
|
||||
subroutine get_key_kind(kentry,dattype,optional2,datlen,klen)
|
||||
use strings_mod,only:trimnum,nth_word
|
||||
implicit none
|
||||
! Read typestring from a keylist entry KENTRY and extract the
|
||||
! specific type and expected length of KEYs input.
|
||||
!
|
||||
! dattype: type of the data, encoded as int
|
||||
! optional: true if key does not need to be present
|
||||
! datlen: number of values expected
|
||||
! klen: length of keys
|
||||
|
||||
include 'typedef.incl'
|
||||
|
||||
integer klen
|
||||
integer dattype,datlen
|
||||
character(len=klen) kentry(2)
|
||||
logical optional2
|
||||
|
||||
character(len=klen) typestr,key,tmp,numstr
|
||||
character(len=64) errmsg
|
||||
integer strpos,typelen
|
||||
|
||||
integer j
|
||||
|
||||
key=kentry(1)
|
||||
typestr=kentry(2)
|
||||
strpos=0
|
||||
dattype=-1
|
||||
! check type declaration against defined types in typedef.incl
|
||||
do j=1,typenum
|
||||
typelen=len_trim(types(j))
|
||||
if (typestr(1:typelen).eq.trim(types(j))) then
|
||||
dattype=j-1
|
||||
strpos=typelen+1
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
|
||||
if (dattype.eq.-1) then
|
||||
errmsg='INVALID TYPE SPEC: '//'"'//typestr(1:maxtypelen)//'"'
|
||||
call signal_key_error(key,errmsg,klen)
|
||||
endif
|
||||
|
||||
! Any type followed by ! makes the card non-optional, crashing the
|
||||
! program if it is missing.
|
||||
optional2=(typestr(strpos:strpos).ne.'!')
|
||||
if (.not.optional2) then
|
||||
strpos=strpos+1
|
||||
endif
|
||||
|
||||
if (dattype.eq.5) then
|
||||
! since only the key's presence is checked, there is no need to
|
||||
! read beyond the key
|
||||
datlen=0
|
||||
else if (typestr(strpos:strpos).eq.'N') then
|
||||
datlen=-1
|
||||
else
|
||||
call trimnum(typestr,tmp,klen)
|
||||
call nth_word(tmp,numstr,1,klen)
|
||||
! crash gracefully if the expected number of values is neither
|
||||
! int nor "N" (hackey version, but i can't think of a cleaner one)
|
||||
do j=1,1
|
||||
read(numstr,*,err=600,end=600) datlen
|
||||
cycle
|
||||
600 errmsg='CORRUPTED NUMBER OF VALUES: '
|
||||
> //'"'//trim(typestr)//'"'
|
||||
call signal_key_error(key,errmsg,klen)
|
||||
enddo
|
||||
if (datlen.le.0) then
|
||||
errmsg='INVALID TYPE SPEC: '//'"'//trim(typestr)//'"'
|
||||
call signal_key_error(key,errmsg,klen)
|
||||
endif
|
||||
endif
|
||||
|
||||
end subroutine get_key_kind
|
||||
|
||||
|
||||
subroutine signal_key_error(key,msg,klen)
|
||||
implicit none
|
||||
integer klen
|
||||
character(len=klen) key
|
||||
character(len=*) msg
|
||||
write(6,'(A)') 'ERROR: ' // trim(key) // ' ' // trim(msg)
|
||||
stop 1
|
||||
end subroutine signal_key_error
|
||||
|
||||
end module
|
||||
|
|
@ -0,0 +1,601 @@
|
|||
module long_keyread_mod
|
||||
contains
|
||||
|
||||
! NOTE: all routines other than long_intkey and long_intline are
|
||||
! copy-pasted versions of different types.
|
||||
! replacements:
|
||||
! idat -> *dat
|
||||
! ipos -> *pos
|
||||
! istart -> *start
|
||||
! LONG_INT -> LONG_*
|
||||
|
||||
!---------------------------------------------------------------------------
|
||||
|
||||
subroutine long_intkey(infile,inpos,key_end,idat,istart,
|
||||
> readlen,linelen,maxdat,maxlines)
|
||||
implicit none
|
||||
! Read an arbitrary number of integers for a single key from infile
|
||||
! and write to idat.
|
||||
!
|
||||
! Data in infile is expected to have the general format
|
||||
!
|
||||
! KEY: ... ... ... ... &
|
||||
! .... ... ... ... ... &
|
||||
! .... ... ... ... ...
|
||||
!
|
||||
! Lines can be continued using the continuation marker arbitrarily
|
||||
! often. A continuation marker at the last line causes the program
|
||||
! to read undefined data following below. If that data is not a
|
||||
! valid line of integers, the program breaks appropiately.
|
||||
!
|
||||
! idat: vector to write read data on
|
||||
! istart: current position in vector idat (first empty entry)
|
||||
! maxdat: length of idat
|
||||
! readlen: the number of read integers for current key
|
||||
!
|
||||
! infile: string vector containing the read input file linewise
|
||||
! key_end: length of key, expected at the first line read
|
||||
! inpos: current position in infile
|
||||
! linelen: max. character length of a single line
|
||||
! maxlines: length of infile
|
||||
!
|
||||
! broken: if true, assume read data to be corrupt
|
||||
! continued: if true, the next input line should continue
|
||||
! the current data block.
|
||||
|
||||
|
||||
integer maxlines,linelen,maxdat
|
||||
integer key_end
|
||||
integer istart,inpos,readlen
|
||||
integer idat(maxdat)
|
||||
character(len=linelen) infile(maxlines)
|
||||
logical continued, broken
|
||||
|
||||
|
||||
integer line_start,ipos
|
||||
character(len=linelen) key
|
||||
|
||||
integer n
|
||||
|
||||
ipos=istart
|
||||
readlen=0
|
||||
|
||||
key=' '
|
||||
key=infile(inpos)(1:key_end)
|
||||
|
||||
! skip key on first line
|
||||
line_start=key_end+1
|
||||
|
||||
call long_intline(infile(inpos),linelen,line_start,
|
||||
> idat,ipos,maxdat,readlen,
|
||||
> continued,broken)
|
||||
|
||||
line_start=1
|
||||
do n=inpos+1,maxlines
|
||||
if (broken) then
|
||||
continued=.false.
|
||||
exit
|
||||
endif
|
||||
if (.not.continued) then
|
||||
exit
|
||||
endif
|
||||
call long_intline(infile(n),linelen,line_start,
|
||||
> idat,ipos,maxdat,readlen,
|
||||
> continued,broken)
|
||||
enddo
|
||||
|
||||
if (continued) then
|
||||
write(6,'(A)') 'ERROR: LONG_INTKEY: '
|
||||
> // trim(key) //' CONTINUATION PAST EOF'
|
||||
write(6,'(A,I5.5)') 'LINE #',n
|
||||
endif
|
||||
if (broken) then
|
||||
write(6,'(A)') 'ERROR: LONG_INTKEY: '
|
||||
> // trim(key) //' BROKEN INPUT.'
|
||||
write(6,'(A,I5.5)') 'LINE #',n
|
||||
write(6,'(A,I5.5,A)') 'AFTER ', n-inpos-1, ' CONTINUATIONS'
|
||||
stop 1
|
||||
endif
|
||||
|
||||
|
||||
end subroutine long_intkey
|
||||
|
||||
!---------------------------------------------------------------------------
|
||||
|
||||
subroutine long_intline(inline,linelen,line_start,
|
||||
> idat,ipos,maxdat,readlen,
|
||||
> continued,broken)
|
||||
use strings_mod,only: count_words,nth_word
|
||||
implicit none
|
||||
! Read a single line of string input INLINE encoding integers.
|
||||
!
|
||||
! idat: vector to write read data on
|
||||
! ipos: current position in vector idat (first empty entry)
|
||||
! maxdat: length of idat
|
||||
! inline: string containing line from read input file
|
||||
! linelen: max. character length of a single line
|
||||
! broken: if true, assume read data to be corrupt
|
||||
! continued: if true, the next input line should continue
|
||||
! the current data block.
|
||||
! readlen: increment counting the number of read ints
|
||||
! ASSUMED TO BE INITIALIZED.
|
||||
|
||||
integer linelen,maxdat
|
||||
integer line_start,ipos
|
||||
integer idat(maxdat)
|
||||
integer readlen
|
||||
! character(len=linelen) inline
|
||||
character(len=linelen) inline
|
||||
logical continued, broken
|
||||
|
||||
integer line_end, wordcount
|
||||
character(len=linelen) workline, word
|
||||
|
||||
integer n
|
||||
|
||||
line_end=len_trim(inline)
|
||||
broken=.false.
|
||||
|
||||
! check whether line will be continued
|
||||
if (inline(line_end:line_end).eq.'&') then
|
||||
continued=.true.
|
||||
line_end=line_end-1
|
||||
else
|
||||
continued=.false.
|
||||
endif
|
||||
|
||||
! create working copy of line
|
||||
workline=' '
|
||||
workline=inline(line_start:line_end)
|
||||
|
||||
! check the number of wordcount on line
|
||||
call count_words(workline,wordcount,linelen)
|
||||
|
||||
! if the number of entries exceeds the length of idat, break
|
||||
if ((wordcount+ipos-1).gt.maxdat) then
|
||||
write(6,'(A)') 'ERROR: LONG_INTLINE: PARSER OUT OF MEMORY '
|
||||
> // 'ON READ'
|
||||
write(6,'(A)') 'CURRENT LINE:'
|
||||
write(6,'(A)') trim(inline)
|
||||
broken=.true.
|
||||
return
|
||||
endif
|
||||
|
||||
do n=1,wordcount
|
||||
call nth_word(workline,word,n,linelen)
|
||||
read(word,fmt=*,err=600,end=600) idat(ipos)
|
||||
readlen=readlen+1
|
||||
ipos=ipos+1
|
||||
cycle
|
||||
! avoid segfault in parser at all costs, throw error instead
|
||||
600 write(6,'(A,I4.4)') 'ERROR: LONG_INTLINE: '
|
||||
> // 'A FATAL ERROR OCCURED ON ENTRY #',
|
||||
> n
|
||||
write(6,'(A)') 'CURRENT LINE:'
|
||||
write(6,'(A)') trim(inline)
|
||||
broken=.true.
|
||||
return
|
||||
enddo
|
||||
|
||||
end subroutine long_intline
|
||||
|
||||
!---------------------------------------------------------------------------
|
||||
|
||||
subroutine long_realkey(infile,inpos,key_end,ddat,dstart,
|
||||
> readlen,linelen,maxdat,maxlines)
|
||||
implicit none
|
||||
! Read an arbitrary number of double precisions for a single key from infile
|
||||
! and write to ddat.
|
||||
!
|
||||
! Data in infile is expected to have the general format
|
||||
!
|
||||
! KEY: ... ... ... ... &
|
||||
! .... ... ... ... ... &
|
||||
! .... ... ... ... ...
|
||||
!
|
||||
! Lines can be continued using the continuation marker arbitrarily
|
||||
! often. A continuation marker at the last line causes the program
|
||||
! to read undefined data following below. If that data is not a
|
||||
! valid line of integers, the program breaks appropiately.
|
||||
!
|
||||
! ddat: vector to write read data on
|
||||
! dstart: current position in vector ddat (first empty entry)
|
||||
! maxdat: length of ddat
|
||||
! readlen: the number of read integers for current key
|
||||
!
|
||||
! infile: string vector containing the read input file linewise
|
||||
! key_end: length of key, expected at the first line read
|
||||
! inpos: current position in infile
|
||||
! linelen: max. character length of a single line
|
||||
! maxlines: length of infile
|
||||
!
|
||||
! broken: if true, assume read data to be corrupt
|
||||
! continued: if true, the next input line should continue
|
||||
! the current data block.
|
||||
|
||||
|
||||
integer maxlines,linelen,maxdat
|
||||
integer key_end
|
||||
integer dstart,inpos,readlen
|
||||
double precision ddat(maxdat)
|
||||
character(len=linelen) infile(maxlines)
|
||||
logical continued, broken
|
||||
|
||||
|
||||
integer line_start,dpos
|
||||
character(len=linelen) key
|
||||
|
||||
integer n
|
||||
|
||||
dpos=dstart
|
||||
readlen=0
|
||||
|
||||
key=' '
|
||||
key=infile(inpos)(1:key_end)
|
||||
|
||||
! skip key on first line
|
||||
line_start=key_end+1
|
||||
|
||||
call long_realline(infile(inpos),linelen,line_start,
|
||||
> ddat,dpos,maxdat,readlen,
|
||||
> continued,broken)
|
||||
|
||||
line_start=1
|
||||
do n=inpos+1,maxlines
|
||||
if (broken) then
|
||||
continued=.false.
|
||||
exit
|
||||
endif
|
||||
if (.not.continued) then
|
||||
exit
|
||||
endif
|
||||
call long_realline(infile(n),linelen,line_start,
|
||||
> ddat,dpos,maxdat,readlen,
|
||||
> continued,broken)
|
||||
enddo
|
||||
|
||||
if (continued) then
|
||||
write(6,'(A)') 'ERROR: LONG_REALKEY: '
|
||||
> // trim(key) //' CONTINUATION PAST EOF'
|
||||
write(6,'(A,I5.5)') 'LINE #',n
|
||||
endif
|
||||
if (broken) then
|
||||
write(6,'(A)') 'ERROR: LONG_REALKEY: '
|
||||
> // trim(key) //' BROKEN INPUT.'
|
||||
write(6,'(A,I5.5)') 'LINE #',n
|
||||
write(6,'(A,I5.5,A)') 'AFTER ', n-inpos-1, ' CONTINUATIONS'
|
||||
stop 1
|
||||
endif
|
||||
|
||||
|
||||
end subroutine long_realkey
|
||||
|
||||
!---------------------------------------------------------------------------
|
||||
|
||||
subroutine long_realline(inline,linelen,line_start,
|
||||
> ddat,dpos,maxdat,readlen,
|
||||
> continued,broken)
|
||||
use strings_mod,only: count_words,nth_word
|
||||
implicit none
|
||||
! Read a single line of string input INLINE encoding double precisions.
|
||||
!
|
||||
! ddat: vector to write read data on
|
||||
! dpos: current position in vector ddat (first empty entry)
|
||||
! maxdat: length of ddat
|
||||
! inline: string containing line from read input file
|
||||
! linelen: max. character length of a single line
|
||||
! broken: if true, assume read data to be corrupt
|
||||
! continued: if true, the next input line should continue
|
||||
! the current data block.
|
||||
! readlen: increment counting the number of read ints
|
||||
! ASSUMED TO BE INITIALIZED.
|
||||
|
||||
|
||||
integer linelen,maxdat
|
||||
integer line_start,dpos
|
||||
integer readlen
|
||||
double precision ddat(maxdat)
|
||||
character(len=linelen) inline
|
||||
logical continued, broken
|
||||
|
||||
integer line_end, wordcount
|
||||
character(len=linelen) workline, word
|
||||
|
||||
integer n
|
||||
|
||||
line_end=len_trim(inline)
|
||||
broken=.false.
|
||||
|
||||
! check whether line will be continued
|
||||
if (inline(line_end:line_end).eq.'&') then
|
||||
continued=.true.
|
||||
line_end=line_end-1
|
||||
else
|
||||
continued=.false.
|
||||
endif
|
||||
|
||||
! create working copy of line
|
||||
workline=' '
|
||||
workline=inline(line_start:line_end)
|
||||
|
||||
! check the number of wordcount on line
|
||||
call count_words(workline,wordcount,linelen)
|
||||
|
||||
! if the number of entries exceeds the length of ddat, break
|
||||
if ((wordcount+dpos-1).gt.maxdat) then
|
||||
write(6,'(A)') 'ERROR: LONG_REALLINE: PARSER OUT OF MEMORY '
|
||||
> // 'ON READ'
|
||||
write(6,'(A)') 'CURRENT LINE:'
|
||||
write(6,'(A)') trim(inline)
|
||||
write(6,*) 'wordcount',wordcount
|
||||
write(6,*) 'dpos',dpos
|
||||
write(6,*) 'maxdat',maxdat
|
||||
write(6,*) 'ddat',ddat(1:maxdat)
|
||||
broken=.true.
|
||||
return
|
||||
endif
|
||||
|
||||
do n=1,wordcount
|
||||
call nth_word(workline,word,n,linelen)
|
||||
read(word,fmt=*,err=600,end=600) ddat(dpos)
|
||||
readlen=readlen+1
|
||||
dpos=dpos+1
|
||||
cycle
|
||||
! avoid segfault in parser at all costs, throw error instead
|
||||
600 write(6,'(A,I4.4)') 'ERROR: LONG_REALLINE: '
|
||||
> // 'A FATAL ERROR OCCURED ON ENTRY #',
|
||||
> n
|
||||
write(6,'(A)') 'CURRENT LINE:'
|
||||
write(6,'(A)') trim(inline)
|
||||
broken=.true.
|
||||
return
|
||||
enddo
|
||||
|
||||
end subroutine long_realline
|
||||
|
||||
!---------------------------------------------------------------------------
|
||||
|
||||
subroutine long_strkey(infile,inpos,key_end,cdat,cstart,
|
||||
> readlen,linelen,datlen,maxlines,clen)
|
||||
implicit none
|
||||
! Read an arbitrary number of strings for a single key from infile
|
||||
! and write to idat.
|
||||
!
|
||||
! Data in infile is expected to have the general format
|
||||
!
|
||||
! KEY: ... ... ... ... &
|
||||
! .... ... ... ... ... &
|
||||
! .... ... ... ... ...
|
||||
!
|
||||
! Lines can be continued using the continuation marker arbitrarily
|
||||
! often. A continuation marker at the last line causes the program
|
||||
! to read undefined data following below. If that data is not a
|
||||
! valid line of strings, the program breaks appropiately.
|
||||
!
|
||||
! cdat: vector to write read data on
|
||||
! cstart: current position in vector idat (first empty entry)
|
||||
! datlen: length of idat
|
||||
! readlen: the number of read integers for current key
|
||||
!
|
||||
! infile: string vector containing the read input file linewise
|
||||
! key_end: length of key, expected at the first line read
|
||||
! inpos: current position in infile
|
||||
! linelen: max. character length of a single line
|
||||
! maxlines: length of infile
|
||||
! clen: maximum length of a given string
|
||||
!
|
||||
! broken: if true, assume read data to be corrupt
|
||||
! continued: if true, the next input line should continue
|
||||
! the current data block.
|
||||
! append: if true, continue appending to an existing string.
|
||||
|
||||
|
||||
integer maxlines,linelen,datlen,clen
|
||||
integer key_end
|
||||
integer cstart,inpos,readlen
|
||||
character(len=linelen) infile(maxlines)
|
||||
character(len=clen) cdat(datlen)
|
||||
|
||||
|
||||
integer line_start,cpos
|
||||
integer strpos
|
||||
character(len=linelen) key
|
||||
logical continued, broken
|
||||
|
||||
integer n
|
||||
|
||||
cpos=cstart
|
||||
readlen=0
|
||||
|
||||
key=' '
|
||||
key=infile(inpos)(1:key_end)
|
||||
|
||||
! skip key on first line
|
||||
line_start=key_end+1
|
||||
|
||||
strpos=0
|
||||
|
||||
call long_strline(infile(inpos),linelen,line_start,
|
||||
> cdat,cpos,datlen,readlen,clen,
|
||||
> continued,broken,strpos)
|
||||
|
||||
line_start=1
|
||||
do n=inpos+1,maxlines
|
||||
if (broken) then
|
||||
continued=.false.
|
||||
exit
|
||||
endif
|
||||
if (.not.continued) then
|
||||
exit
|
||||
endif
|
||||
call long_strline(infile(n),linelen,line_start,
|
||||
> cdat,cpos,datlen,readlen,clen,
|
||||
> continued,broken,strpos)
|
||||
enddo
|
||||
|
||||
if (continued) then
|
||||
write(6,'(A)') 'ERROR: LONG_STRKEY: '
|
||||
> // trim(key) //' CONTINUATION PAST EOF'
|
||||
write(6,'(A,I5.5)') 'LINE #',n
|
||||
endif
|
||||
if (broken) then
|
||||
write(6,'(A)') 'ERROR: LONG_STRKEY: '
|
||||
> // trim(key) //' BROKEN INPUT.'
|
||||
write(6,'(A,I5.5)') 'LINE #',n
|
||||
write(6,'(A,I5.5,A)') 'AFTER ', n-inpos-1, ' CONTINUATIONS'
|
||||
stop 1
|
||||
endif
|
||||
|
||||
|
||||
end subroutine long_strkey
|
||||
|
||||
|
||||
!---------------------------------------------------------------------------
|
||||
|
||||
subroutine long_strline(inline,linelen,line_start,
|
||||
> cdat,cpos,datlen,readlen,clen,
|
||||
> continued,broken,strpos)
|
||||
use strings_mod,only:iswhitespace, downcase
|
||||
implicit none
|
||||
! Read a single line of string input INLINE encoding integers.
|
||||
!
|
||||
! cdat: vector to write read data on
|
||||
! cpos: current position in vector cdat (first empty/incomplete entry)
|
||||
! datlen: length of idat
|
||||
! inline: string containing line from read input file
|
||||
! linelen: max. character length of a single line
|
||||
! broken: if true, assume read data to be corrupt
|
||||
! continued: if true, the next input line should continue
|
||||
! the current data block.
|
||||
! readlen: increment counting the number of read strings
|
||||
! ASSUMED TO BE INITIALIZED.
|
||||
! strpos: if 0, create new string. Otherwise, append to string of assumed
|
||||
! length strpos.
|
||||
|
||||
integer :: linelen,datlen,clen
|
||||
integer :: line_start,cpos,strpos
|
||||
integer :: readlen
|
||||
character(len=linelen) :: inline
|
||||
character(len=clen) :: cdat(datlen)
|
||||
logical :: continued, broken
|
||||
|
||||
character,parameter :: esc = ACHAR(92) ! "\"
|
||||
|
||||
integer :: line_end
|
||||
character(len=linelen) :: workline
|
||||
character(len=1) :: char, tmp_char
|
||||
|
||||
logical :: cont_string, escaped
|
||||
|
||||
integer :: j
|
||||
|
||||
! logical :: iswhitespace
|
||||
|
||||
broken=.false.
|
||||
continued=.false.
|
||||
cont_string=.false.
|
||||
escaped=.false.
|
||||
|
||||
! create working copy of line
|
||||
workline=' '
|
||||
workline=inline(line_start:len_trim(inline))
|
||||
line_end=len_trim(workline)
|
||||
|
||||
! If needed, initialize working position in cdat
|
||||
if (strpos.eq.0) then
|
||||
cdat(cpos)=' '
|
||||
endif
|
||||
|
||||
! iterate over characters in line
|
||||
do j=1,line_end
|
||||
char=workline(j:j)
|
||||
if (escaped) then
|
||||
! Insert escaped character and proceed.
|
||||
escaped=.false.
|
||||
! Special escape sequences
|
||||
if (char.eq.'.') then
|
||||
! \. = !
|
||||
char='!'
|
||||
endif
|
||||
else if (char.eq.esc) then
|
||||
! Consider next character escaped, skip char.
|
||||
escaped=.true.
|
||||
cycle
|
||||
else if (char.eq.'&') then
|
||||
continued=.true.
|
||||
if (j.eq.line_end) then
|
||||
exit
|
||||
endif
|
||||
! Deal with unusual continuations, look at char after "&"
|
||||
char=workline(j+1:j+1)
|
||||
if (char.eq.'&') then
|
||||
! "&&" allows multi-line strings
|
||||
cont_string=.true.
|
||||
if (j+1.eq.line_end) then
|
||||
exit
|
||||
endif
|
||||
endif
|
||||
write(6,'(A)') 'WARNING: LONG_STRLINE: IGNORED'
|
||||
> // ' JUNK CHARACTER(S) FOLLOWING'
|
||||
> // ' CONTINUATION CHARACTER.'
|
||||
exit
|
||||
else if (iswhitespace(char)) then
|
||||
! Whitespace separates strings; skip char.
|
||||
if (strpos.gt.0) then
|
||||
! Begin a new string unless the current one is empty.
|
||||
strpos=0
|
||||
cpos=cpos+1
|
||||
cdat(cpos)=' '
|
||||
endif
|
||||
cycle
|
||||
else
|
||||
! assume char to be meant as a downcase char
|
||||
call downcase(char,tmp_char,1)
|
||||
char=tmp_char
|
||||
endif
|
||||
|
||||
! Incorporate new char into string
|
||||
strpos=strpos+1
|
||||
|
||||
! Break if a boundary exception occurs
|
||||
if (cpos.gt.datlen) then
|
||||
write(6,'(A)') 'ERROR: LONG_STRLINE: PARSER OUT OF MEMORY'
|
||||
> // ' ON READ'
|
||||
write(6,'(A)') 'CURRENT LINE:'
|
||||
write(6,'(A)') trim(inline)
|
||||
broken=.true.
|
||||
return
|
||||
else if (strpos.gt.clen) then
|
||||
write(6,'(A)') 'ERROR: LONG_STRLINE: PARSER OUT OF MEMORY'
|
||||
> // ' ON READ: STRING ARGUMENT EXCEEDS CLEN'
|
||||
write(6,'(A)') 'CURRENT LINE:'
|
||||
write(6,'(A)') trim(inline)
|
||||
broken=.true.
|
||||
return
|
||||
endif
|
||||
|
||||
! insert character
|
||||
cdat(cpos)(strpos:strpos)=char
|
||||
if (strpos.eq.1) then
|
||||
readlen=readlen+1
|
||||
endif
|
||||
enddo
|
||||
|
||||
! Fix incomplete escape sequences and deal with continuation
|
||||
if (escaped) then
|
||||
write(6,'(A)') 'WARNING: LONG_STRLINE: ENCOUNTERED ESCAPE'
|
||||
> // ' CHARACTER AT EOL. IGNORED.'
|
||||
endif
|
||||
|
||||
! Unless the line ended with "&&", consider the current, non-empty
|
||||
! string complete.
|
||||
if ((cont_string).or.(strpos.eq.0)) then
|
||||
return
|
||||
else
|
||||
cpos=cpos+1
|
||||
strpos=0
|
||||
endif
|
||||
|
||||
end subroutine long_strline
|
||||
|
||||
end module
|
||||
|
|
@ -0,0 +1,505 @@
|
|||
module strings_mod
|
||||
implicit none
|
||||
contains
|
||||
|
||||
!----------------------------------------------------------------------------
|
||||
subroutine capital(in,str,lauf,mmax,sl)
|
||||
integer mmax,lauf,i,j,sl
|
||||
character in(mmax)*(*), str*(*)
|
||||
|
||||
if (str.eq.'') return
|
||||
|
||||
j=0
|
||||
do i=1,sl
|
||||
if (str(i:i).ne.' ') then
|
||||
j=i-1
|
||||
goto 10
|
||||
endif
|
||||
enddo
|
||||
10 do i=1,sl-j
|
||||
str(i:i)=str(i+j:i+j)
|
||||
enddo
|
||||
do i=sl-j+1,sl
|
||||
str(i:i)=' '
|
||||
enddo
|
||||
|
||||
if (str(1:1).eq.'!') return
|
||||
|
||||
lauf=lauf+1
|
||||
do i=1,sl
|
||||
in(lauf)(i:i)=str(i:i)
|
||||
if (str(i:i).eq.'a') in(lauf)(i:i)='A'
|
||||
if (str(i:i).eq.'b') in(lauf)(i:i)='B'
|
||||
if (str(i:i).eq.'c') in(lauf)(i:i)='C'
|
||||
if (str(i:i).eq.'d') in(lauf)(i:i)='D'
|
||||
if (str(i:i).eq.'e') in(lauf)(i:i)='E'
|
||||
if (str(i:i).eq.'f') in(lauf)(i:i)='F'
|
||||
if (str(i:i).eq.'g') in(lauf)(i:i)='G'
|
||||
if (str(i:i).eq.'h') in(lauf)(i:i)='H'
|
||||
if (str(i:i).eq.'i') in(lauf)(i:i)='I'
|
||||
if (str(i:i).eq.'j') in(lauf)(i:i)='J'
|
||||
if (str(i:i).eq.'k') in(lauf)(i:i)='K'
|
||||
if (str(i:i).eq.'l') in(lauf)(i:i)='L'
|
||||
if (str(i:i).eq.'m') in(lauf)(i:i)='M'
|
||||
if (str(i:i).eq.'n') in(lauf)(i:i)='N'
|
||||
if (str(i:i).eq.'o') in(lauf)(i:i)='O'
|
||||
if (str(i:i).eq.'p') in(lauf)(i:i)='P'
|
||||
if (str(i:i).eq.'q') in(lauf)(i:i)='Q'
|
||||
if (str(i:i).eq.'r') in(lauf)(i:i)='R'
|
||||
if (str(i:i).eq.'s') in(lauf)(i:i)='S'
|
||||
if (str(i:i).eq.'t') in(lauf)(i:i)='T'
|
||||
if (str(i:i).eq.'u') in(lauf)(i:i)='U'
|
||||
if (str(i:i).eq.'v') in(lauf)(i:i)='V'
|
||||
if (str(i:i).eq.'w') in(lauf)(i:i)='W'
|
||||
if (str(i:i).eq.'x') in(lauf)(i:i)='X'
|
||||
if (str(i:i).eq.'y') in(lauf)(i:i)='Y'
|
||||
if (str(i:i).eq.'z') in(lauf)(i:i)='Z'
|
||||
C..... Addition of the first if-loop
|
||||
if (i-3.gt.0) then
|
||||
if (in(lauf)(i-3:i).eq.'CHK:') then
|
||||
in(lauf)(i+1:sl)=str(i+1:sl)
|
||||
return
|
||||
endif
|
||||
endif
|
||||
! if (i+3.le.sl) then
|
||||
! if (in(lauf)(i:i+3).eq.'CHK:') then
|
||||
! in(lauf)(i+1:sl)=str(i+1:sl)
|
||||
! return
|
||||
! endif
|
||||
! endif
|
||||
enddo
|
||||
|
||||
end subroutine capital
|
||||
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine lcap(str,n)
|
||||
integer i, n
|
||||
character str*(*), dum*750
|
||||
|
||||
dum=''
|
||||
do i=1,n
|
||||
dum(i:i)=str(i:i)
|
||||
if (str(i:i).eq.'a') dum(i:i)='A'
|
||||
if (str(i:i).eq.'b') dum(i:i)='B'
|
||||
if (str(i:i).eq.'c') dum(i:i)='C'
|
||||
if (str(i:i).eq.'d') dum(i:i)='D'
|
||||
if (str(i:i).eq.'e') dum(i:i)='E'
|
||||
if (str(i:i).eq.'f') dum(i:i)='F'
|
||||
if (str(i:i).eq.'g') dum(i:i)='G'
|
||||
if (str(i:i).eq.'h') dum(i:i)='H'
|
||||
if (str(i:i).eq.'i') dum(i:i)='I'
|
||||
if (str(i:i).eq.'j') dum(i:i)='J'
|
||||
if (str(i:i).eq.'k') dum(i:i)='K'
|
||||
if (str(i:i).eq.'l') dum(i:i)='L'
|
||||
if (str(i:i).eq.'m') dum(i:i)='M'
|
||||
if (str(i:i).eq.'n') dum(i:i)='N'
|
||||
if (str(i:i).eq.'o') dum(i:i)='O'
|
||||
if (str(i:i).eq.'p') dum(i:i)='P'
|
||||
if (str(i:i).eq.'q') dum(i:i)='Q'
|
||||
if (str(i:i).eq.'r') dum(i:i)='R'
|
||||
if (str(i:i).eq.'s') dum(i:i)='S'
|
||||
if (str(i:i).eq.'t') dum(i:i)='T'
|
||||
if (str(i:i).eq.'u') dum(i:i)='U'
|
||||
if (str(i:i).eq.'v') dum(i:i)='V'
|
||||
if (str(i:i).eq.'w') dum(i:i)='W'
|
||||
if (str(i:i).eq.'x') dum(i:i)='X'
|
||||
if (str(i:i).eq.'y') dum(i:i)='Y'
|
||||
if (str(i:i).eq.'z') dum(i:i)='Z'
|
||||
enddo
|
||||
str(1:n)=dum(1:n)
|
||||
|
||||
end subroutine lcap
|
||||
|
||||
!--------------------------------------------------------------------------
|
||||
! function to test how many entries are on one line:
|
||||
function clen(str,sl)
|
||||
integer clen, i, j, sl
|
||||
character str*(sl)
|
||||
|
||||
clen=0
|
||||
j=0
|
||||
do i=sl,1,-1
|
||||
if ((str(i:i).ne.' ').and.(j.eq.0)) then
|
||||
clen=clen+1
|
||||
j=1
|
||||
endif
|
||||
if (str(i:i).eq.' ') j=0
|
||||
enddo
|
||||
|
||||
end function clen
|
||||
|
||||
!--------------------------------------------------------------------------
|
||||
|
||||
logical function isnumeral(char)
|
||||
! Check whether character CHAR is a numeral.
|
||||
|
||||
character char
|
||||
|
||||
character numerals(10)
|
||||
parameter (numerals = ['0','1','2','3','4','5','6','7','8','9'])
|
||||
|
||||
isnumeral=any(numerals.eq.char)
|
||||
|
||||
end function isnumeral
|
||||
|
||||
!--------------------------------------------------------------------------
|
||||
|
||||
logical function iswhitespace(char)
|
||||
! Check whether CHAR is tab or spc character
|
||||
|
||||
character char
|
||||
|
||||
character whitespace(2)
|
||||
parameter (whitespace = [' ', ' '])
|
||||
|
||||
iswhitespace=any(whitespace.eq.char)
|
||||
|
||||
end function iswhitespace
|
||||
|
||||
!--------------------------------------------------------------------------
|
||||
|
||||
subroutine trimnum(string,outstr,str_len)
|
||||
! Extract numbers in STRING as a space separated list in OUTSTR.
|
||||
integer str_len
|
||||
character(len=str_len) string
|
||||
character(len=str_len) outstr
|
||||
|
||||
integer length
|
||||
logical foundnum
|
||||
|
||||
integer k
|
||||
|
||||
! logical isnumeral
|
||||
|
||||
length=len_trim(string)
|
||||
foundnum=.false.
|
||||
|
||||
outstr=' '
|
||||
|
||||
do k=1,length
|
||||
if (isnumeral(string(k:k))) then
|
||||
if (foundnum) then
|
||||
outstr = trim(outstr) // string(k:k)
|
||||
else if (len_trim(outstr).ne.0) then
|
||||
outstr = trim(outstr) // ' ' // string(k:k)
|
||||
foundnum=.true.
|
||||
else
|
||||
outstr = trim(outstr) // string(k:k)
|
||||
foundnum=.true.
|
||||
endif
|
||||
else
|
||||
foundnum=.false.
|
||||
endif
|
||||
enddo
|
||||
|
||||
end subroutine trimnum
|
||||
|
||||
!--------------------------------------------------------------------------
|
||||
|
||||
subroutine strip_string(string,stripped,str_len)
|
||||
! Strip lefthand whitespace of STRING as well as excessive
|
||||
! whitespace and save to STRIPPED.
|
||||
! Example:
|
||||
! " the quick brown fox" -> "the quick brown fox"
|
||||
|
||||
integer str_len
|
||||
character(len=str_len) string,stripped
|
||||
|
||||
character char
|
||||
logical spaced
|
||||
|
||||
! logical iswhitespace
|
||||
|
||||
integer k, trimpos
|
||||
|
||||
stripped=' '
|
||||
trimpos=1
|
||||
|
||||
! spaced indicates whether if a space is found it is the first
|
||||
! (separating the word from the next) or redundant
|
||||
spaced=.true.
|
||||
|
||||
do k=1,len_trim(string)
|
||||
char=string(k:k)
|
||||
if (.not.iswhitespace(char)) then
|
||||
spaced=.false.
|
||||
else if (.not.spaced) then
|
||||
! replace TAB characters if present
|
||||
char=' '
|
||||
spaced=.true.
|
||||
else
|
||||
! ignore redundant spaces
|
||||
cycle
|
||||
endif
|
||||
stripped(trimpos:trimpos)=char
|
||||
trimpos=trimpos+1
|
||||
enddo
|
||||
|
||||
|
||||
end subroutine strip_string
|
||||
|
||||
!--------------------------------------------------------------------------
|
||||
|
||||
subroutine nth_word(string,word,n,str_len)
|
||||
! If STRING is a space separated list of words, return the Nth word.
|
||||
|
||||
integer str_len
|
||||
character(len=str_len) string,word
|
||||
integer n
|
||||
|
||||
character(len=str_len) strip
|
||||
integer wc
|
||||
|
||||
! logical iswhitespace
|
||||
|
||||
integer k,j
|
||||
|
||||
call strip_string(string,strip,str_len)
|
||||
|
||||
word=' '
|
||||
wc=1
|
||||
|
||||
! find the word
|
||||
do k=1,len_trim(strip)
|
||||
if (wc.eq.n) exit
|
||||
if (iswhitespace(strip(k:k))) then
|
||||
wc=wc+1
|
||||
endif
|
||||
enddo
|
||||
do j=k,len_trim(strip)
|
||||
if (iswhitespace(strip(j:j))) exit
|
||||
word = trim(word) // strip(j:j)
|
||||
enddo
|
||||
|
||||
end subroutine nth_word
|
||||
|
||||
!--------------------------------------------------------------------------
|
||||
|
||||
subroutine count_words(string,wordcount,str_len)
|
||||
! If STRING is a space separated list of words, return the Nth word.
|
||||
|
||||
integer str_len
|
||||
character(len=str_len) string
|
||||
integer wordcount
|
||||
|
||||
character(len=str_len) strip
|
||||
integer wc
|
||||
|
||||
! logical iswhitespace
|
||||
|
||||
integer k
|
||||
|
||||
call strip_string(string,strip,str_len)
|
||||
|
||||
if (len_trim(strip).gt.0) then
|
||||
wc=1
|
||||
else
|
||||
wordcount=0
|
||||
return
|
||||
endif
|
||||
|
||||
! find the word
|
||||
do k=1,len_trim(strip)
|
||||
if (iswhitespace(strip(k:k))) then
|
||||
wc=wc+1
|
||||
endif
|
||||
enddo
|
||||
wordcount=wc
|
||||
|
||||
end subroutine count_words
|
||||
|
||||
!--------------------------------------------------------------------------
|
||||
|
||||
subroutine upcase(string,upstring,str_len)
|
||||
! Transform arbitrary string to uppercase and save to upstring
|
||||
|
||||
integer str_len
|
||||
character(len=str_len) string,upstring
|
||||
|
||||
integer j
|
||||
|
||||
upstring=' '
|
||||
|
||||
do j=1,len_trim(string)
|
||||
select case (string(j:j))
|
||||
case ('a')
|
||||
upstring(j:j)= 'A'
|
||||
case ('b')
|
||||
upstring(j:j)= 'B'
|
||||
case ('c')
|
||||
upstring(j:j)= 'C'
|
||||
case ('d')
|
||||
upstring(j:j)= 'D'
|
||||
case ('e')
|
||||
upstring(j:j)= 'E'
|
||||
case ('f')
|
||||
upstring(j:j)= 'F'
|
||||
case ('g')
|
||||
upstring(j:j)= 'G'
|
||||
case ('h')
|
||||
upstring(j:j)= 'H'
|
||||
case ('i')
|
||||
upstring(j:j)= 'I'
|
||||
case ('j')
|
||||
upstring(j:j)= 'J'
|
||||
case ('k')
|
||||
upstring(j:j)= 'K'
|
||||
case ('l')
|
||||
upstring(j:j)= 'L'
|
||||
case ('m')
|
||||
upstring(j:j)= 'M'
|
||||
case ('n')
|
||||
upstring(j:j)= 'N'
|
||||
case ('o')
|
||||
upstring(j:j)= 'O'
|
||||
case ('p')
|
||||
upstring(j:j)= 'P'
|
||||
case ('q')
|
||||
upstring(j:j)= 'Q'
|
||||
case ('r')
|
||||
upstring(j:j)= 'R'
|
||||
case ('s')
|
||||
upstring(j:j)= 'S'
|
||||
case ('t')
|
||||
upstring(j:j)= 'T'
|
||||
case ('u')
|
||||
upstring(j:j)= 'U'
|
||||
case ('v')
|
||||
upstring(j:j)= 'V'
|
||||
case ('w')
|
||||
upstring(j:j)= 'W'
|
||||
case ('x')
|
||||
upstring(j:j)= 'X'
|
||||
case ('y')
|
||||
upstring(j:j)= 'Y'
|
||||
case ('z')
|
||||
upstring(j:j)= 'Z'
|
||||
case default
|
||||
upstring(j:j)=string(j:j)
|
||||
end select
|
||||
enddo
|
||||
|
||||
end subroutine upcase
|
||||
|
||||
!--------------------------------------------------------------------------
|
||||
|
||||
subroutine downcase(string,downstring,str_len)
|
||||
! Transform arbitrary string to downcase and save to downstring
|
||||
|
||||
integer str_len
|
||||
character(len=str_len) string,downstring
|
||||
|
||||
integer j
|
||||
|
||||
downstring=' '
|
||||
|
||||
do j=1,len_trim(string)
|
||||
select case (string(j:j))
|
||||
case ('A')
|
||||
downstring(j:j)= 'a'
|
||||
case ('B')
|
||||
downstring(j:j)= 'b'
|
||||
case ('C')
|
||||
downstring(j:j)= 'c'
|
||||
case ('D')
|
||||
downstring(j:j)= 'd'
|
||||
case ('E')
|
||||
downstring(j:j)= 'e'
|
||||
case ('F')
|
||||
downstring(j:j)= 'f'
|
||||
case ('G')
|
||||
downstring(j:j)= 'g'
|
||||
case ('H')
|
||||
downstring(j:j)= 'h'
|
||||
case ('I')
|
||||
downstring(j:j)= 'i'
|
||||
case ('J')
|
||||
downstring(j:j)= 'j'
|
||||
case ('K')
|
||||
downstring(j:j)= 'k'
|
||||
case ('L')
|
||||
downstring(j:j)= 'l'
|
||||
case ('M')
|
||||
downstring(j:j)= 'm'
|
||||
case ('N')
|
||||
downstring(j:j)= 'n'
|
||||
case ('O')
|
||||
downstring(j:j)= 'o'
|
||||
case ('P')
|
||||
downstring(j:j)= 'p'
|
||||
case ('Q')
|
||||
downstring(j:j)= 'q'
|
||||
case ('R')
|
||||
downstring(j:j)= 'r'
|
||||
case ('S')
|
||||
downstring(j:j)= 's'
|
||||
case ('T')
|
||||
downstring(j:j)= 't'
|
||||
case ('U')
|
||||
downstring(j:j)= 'u'
|
||||
case ('V')
|
||||
downstring(j:j)= 'v'
|
||||
case ('W')
|
||||
downstring(j:j)= 'w'
|
||||
case ('X')
|
||||
downstring(j:j)= 'x'
|
||||
case ('Y')
|
||||
downstring(j:j)= 'y'
|
||||
case ('Z')
|
||||
downstring(j:j)= 'z'
|
||||
case default
|
||||
downstring(j:j)=string(j:j)
|
||||
end select
|
||||
enddo
|
||||
|
||||
end subroutine downcase
|
||||
|
||||
!--------------------------------------------------------------------------
|
||||
pure function int2string(int) result(string)
|
||||
character(len=:), allocatable :: string
|
||||
integer, intent(in) :: int
|
||||
character(len=100) :: str
|
||||
write(str,'(i0)') int
|
||||
string = trim(adjustl(str))
|
||||
end function int2string
|
||||
!--------------------------------------------------------------------------
|
||||
pure function dble2string(dble) result(string)
|
||||
character(len=:), allocatable :: string
|
||||
double precision, intent(in) :: dble
|
||||
character(len=100) :: str
|
||||
write(str,'(ES16.9)') dble
|
||||
string = trim(adjustl(str))
|
||||
end function dble2string
|
||||
!--------------------------------------------------------------------------
|
||||
pure function shortdble2string(dble) result(string)
|
||||
character(len=:), allocatable :: string
|
||||
double precision, intent(in) :: dble
|
||||
character(len=100) :: str
|
||||
write(str,'(ES11.2)') dble
|
||||
string = trim(adjustl(str))
|
||||
end function shortdble2string
|
||||
!----------------------------------------------------------------------------------
|
||||
subroutine write_oneline(string,id_print)
|
||||
#ifdef mpi_version
|
||||
use mpi
|
||||
#endif
|
||||
integer,intent(in) :: id_print
|
||||
character(len=*) string
|
||||
|
||||
#ifdef mpi_version
|
||||
integer my_rank,ierror
|
||||
call MPI_Comm_rank(MPI_COMM_WORLD, my_rank, ierror)
|
||||
#endif
|
||||
|
||||
#ifdef mpi_version
|
||||
if (my_rank.eq.0) then
|
||||
#endif
|
||||
write(id_print,'(A)') adjustl(trim(string))
|
||||
|
||||
#ifdef mpi_version
|
||||
endif
|
||||
#endif
|
||||
|
||||
end subroutine write_oneline
|
||||
|
||||
end module
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
|
||||
integer typenum,maxtypelen
|
||||
parameter (typenum=6,maxtypelen=2)
|
||||
character(len=maxtypelen) types(typenum)
|
||||
! parameter (types=['I', '+I', 'D', '+D', 'C', 'E'])
|
||||
parameter (types=['I ', '+I', 'D ', '+D', 'C ', 'E ']) !Fabian
|
||||
|
|
@ -0,0 +1,103 @@
|
|||
************************************************************************
|
||||
*** long_write
|
||||
*** writing genetic's long input format
|
||||
***
|
||||
************************************************************************
|
||||
module long_write
|
||||
implicit none
|
||||
contains
|
||||
|
||||
subroutine write_longint(f_unit,params,plen,intfmt,maxvals)
|
||||
implicit none
|
||||
! Routine writing long integer output of the form
|
||||
! x1 x2 x3 .... xN &
|
||||
! ... &
|
||||
!
|
||||
! f_unit: UNIT to be written on, directly passed to write
|
||||
! params: integer vector to be written out
|
||||
! plen: number of elements to be printed
|
||||
! maxvals: (maximum) number of values per line
|
||||
! intfmt: format of a single interger, e.g. '(I6)'
|
||||
|
||||
integer f_unit
|
||||
integer params(*)
|
||||
integer plen,maxvals
|
||||
character*16 intfmt
|
||||
|
||||
integer pcount
|
||||
|
||||
integer j,k
|
||||
|
||||
pcount=0 ! count parameters written so far
|
||||
|
||||
! write all values that fill entire lines.
|
||||
do k=1,(plen/maxvals)
|
||||
do j=1,maxvals
|
||||
write(unit=f_unit,fmt=intfmt,advance='NO') params(pcount+j)
|
||||
enddo
|
||||
pcount=pcount+maxvals
|
||||
if (pcount.lt.plen) then
|
||||
write(unit=f_unit,fmt='(A)') ' &'
|
||||
endif
|
||||
enddo
|
||||
|
||||
pcount=pcount+1
|
||||
|
||||
! write remaining few
|
||||
do k=pcount,plen
|
||||
write(unit=f_unit,fmt=intfmt,advance='NO') params(k)
|
||||
enddo
|
||||
|
||||
write(f_unit,'(A)') ''
|
||||
|
||||
end subroutine
|
||||
|
||||
!----------------------------------------------------------------------------
|
||||
|
||||
subroutine write_longreal(f_unit,params,plen,dfmt,maxvals)
|
||||
implicit none
|
||||
! Routine writing long real(*8) output of the form
|
||||
! x1 x2 x3 .... xN &
|
||||
! ... &
|
||||
!
|
||||
! f_unit: UNIT to be written on, directly passed to write
|
||||
! params: integer vector to be written out
|
||||
! plen: number of elements to be printed
|
||||
! maxvals: (maximum) number of values per line
|
||||
! dfmt: format of a single real, e.g. '(ES23.15)'
|
||||
|
||||
real*8 params(*)
|
||||
integer f_unit
|
||||
integer plen,maxvals
|
||||
character*16 dfmt
|
||||
|
||||
integer pcount
|
||||
|
||||
integer j,k
|
||||
|
||||
pcount=0 ! count parameters written so far
|
||||
|
||||
! write all values that fill entire lines.
|
||||
do k=1,(plen/maxvals)
|
||||
do j=1,maxvals
|
||||
write(unit=f_unit,fmt=dfmt,advance='NO') params(pcount+j)
|
||||
enddo
|
||||
pcount=pcount+maxvals
|
||||
if (pcount.lt.plen) then
|
||||
write(unit=f_unit,fmt='(A)') ' &'
|
||||
endif
|
||||
enddo
|
||||
|
||||
pcount=pcount+1
|
||||
|
||||
! write remaining few
|
||||
do k=pcount,plen
|
||||
write(unit=f_unit,fmt=dfmt,advance='NO') params(k)
|
||||
enddo
|
||||
|
||||
write(f_unit,'(A)') ''
|
||||
|
||||
end subroutine
|
||||
|
||||
|
||||
end module
|
||||
|
|
@ -0,0 +1,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
|
||||
|
|
@ -0,0 +1,117 @@
|
|||
module parse_errors
|
||||
use io_parameters, only:
|
||||
> keylist, errcat, ec_dim, ec_log, ec_read, ec_error
|
||||
implicit none
|
||||
|
||||
contains
|
||||
|
||||
!--------------------------------------------------------------------------------
|
||||
|
||||
subroutine signal_p_error(key_id,msg)
|
||||
! Signal generic error with user-defined message MSG.
|
||||
integer key_id
|
||||
character(len=*) msg
|
||||
|
||||
write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id))
|
||||
> // ' ' // trim(msg)
|
||||
stop ec_error
|
||||
|
||||
end subroutine
|
||||
|
||||
!--------------------------------------------------------------------------------
|
||||
|
||||
subroutine signal_dim_error(key_id,msg_code,value,expval)
|
||||
use strings_mod,only:int2string
|
||||
! Signals errors where one specific dimensioning value is ill-set.
|
||||
! If the optional parameter EXPVAL is given, return it as expected
|
||||
! dimensioning value.
|
||||
integer key_id, value
|
||||
integer, optional :: expval
|
||||
integer msg_code
|
||||
write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id))
|
||||
> // ' ' // trim(errcat(msg_code))
|
||||
write(6,'(A)') 'OFFENDING VALUE: ' // trim(int2string(value))
|
||||
if (present(expval)) then
|
||||
write(6,'(A)') 'EXPECTED: ' // trim(int2string(expval))
|
||||
endif
|
||||
stop ec_dim
|
||||
|
||||
end subroutine
|
||||
|
||||
!--------------------------------------------------------------------------------
|
||||
|
||||
subroutine signal_log_error(key_id,msg_code,alt_key)
|
||||
! Signals errors where contradictory settings are provided which
|
||||
! the program cannot resolve. If the optional parameter ALT_KEY
|
||||
! is given, name the explicit key current settings clash with.
|
||||
integer key_id
|
||||
integer, optional :: alt_key
|
||||
integer msg_code
|
||||
|
||||
write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id))
|
||||
> // ' ' // trim(errcat(msg_code))
|
||||
if (present(alt_key)) then
|
||||
write(6,'(A)') 'OFFENDING KEY: ' // trim(keylist(1,alt_key))
|
||||
endif
|
||||
|
||||
stop ec_log
|
||||
|
||||
end subroutine
|
||||
|
||||
!--------------------------------------------------------------------------------
|
||||
|
||||
subroutine signal_val_error(key_id,msg_code,value,expval)
|
||||
use strings_mod,only:int2string
|
||||
! Signals errors where a given value makes no sense in it's given context.
|
||||
! If the optional parameter EXPVAL is given, return it as expected
|
||||
! dimensioning value.
|
||||
integer key_id, value
|
||||
integer, optional :: expval
|
||||
integer msg_code
|
||||
write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id))
|
||||
> // ' ' // trim(errcat(msg_code))
|
||||
write(6,'(A)') 'OFFENDING VALUE: ' // trim(int2string(value))
|
||||
if (present(expval)) then
|
||||
write(6,'(A)') 'EXPECTED: ' // trim(int2string(expval))
|
||||
endif
|
||||
stop ec_read
|
||||
|
||||
end subroutine
|
||||
|
||||
!--------------------------------------------------------------------------------
|
||||
|
||||
subroutine signal_dval_error(key_id,msg_code,value,expval)
|
||||
use strings_mod,only: shortdble2string
|
||||
! Signals errors where a given value makes no sense in it's given context.
|
||||
! If the optional parameter EXPVAL is given, return it as expected
|
||||
! dimensioning value.
|
||||
integer key_id
|
||||
double precision value
|
||||
double precision, optional :: expval
|
||||
integer msg_code
|
||||
write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id))
|
||||
> // ' ' // trim(errcat(msg_code))
|
||||
write(6,'(A)') 'OFFENDING VALUE: '
|
||||
> // trim(shortdble2string(value))
|
||||
if (present(expval)) then
|
||||
write(6,'(A)') 'EXPECTED: ' // trim(shortdble2string(expval))
|
||||
endif
|
||||
stop ec_read
|
||||
|
||||
end subroutine
|
||||
|
||||
|
||||
!--------------------------------------------------------------------------------
|
||||
|
||||
subroutine signal_meta_error(key_id,msg_code)
|
||||
! Signals errors where a key (or key combinations) is/are not
|
||||
! supported or maintained for reasons outside of the program's
|
||||
! scope (e.g.: deprecation).
|
||||
integer key_id,msg_code
|
||||
|
||||
write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id))
|
||||
> // ' ' // trim(errcat(msg_code))
|
||||
stop ec_read
|
||||
|
||||
end subroutine
|
||||
end module
|
||||
|
|
@ -0,0 +1,875 @@
|
|||
|
||||
! >Module Containing Subroutines relevant for reading cards and information from an inputfile
|
||||
|
||||
module parser
|
||||
use io_parameters
|
||||
use dim_parameter
|
||||
use parse_errors
|
||||
use parameterkeys, only: parameterkey_read
|
||||
use long_write
|
||||
implicit none
|
||||
contains
|
||||
!--------------------------------------------------------------------------------------------------------------------------------------
|
||||
! >Reads Cards and Data from Inputfile
|
||||
! !@param datname name of input file that is readed
|
||||
! !@param infile internalized input file
|
||||
! !@param linenum linenumber of internalized input file
|
||||
! !@param idat
|
||||
subroutine les(x,y,wt,p,p_act,p_spread,npar,
|
||||
> seed,gtype,nset,maxit,micit,nsel,mut,difper,freeze)
|
||||
use strings_mod,only:write_oneline
|
||||
use fileread_mod,only:get_datfile,internalize_datfile
|
||||
use keyread_mod,only:keyread
|
||||
! implicit none
|
||||
! Include Files for needed dimension parameters
|
||||
|
||||
! Declare OUT Variables
|
||||
! Data variables
|
||||
double precision, allocatable :: x(:,:) , y(:,:), wt(:,:)
|
||||
! Fiting Model Parameters
|
||||
double precision, allocatable :: p(:) !< vector(npar) for the values of read parameters
|
||||
integer, allocatable :: p_act(:) !< vector(npar) containing 0 or 1 defining if corresponding parameters are activ in Fit
|
||||
double precision, allocatable :: p_spread(:) !< vector(npar) for the spread values for each parameter
|
||||
integer npar !< read length of parameter arrays
|
||||
! Fit control Parameters
|
||||
integer seed !< Seed for RNG
|
||||
integer nset !< number of diffrent parameter sets
|
||||
logical freeze !< determines if parameters are active
|
||||
double precision mut, difper !< percentage of selected Parents, number of mutations in parents, minimum diffrence between selected parents
|
||||
double precision psel !< percantage of selected parents
|
||||
integer nsel !< number of selected parents , generated from psel and nset by rounding to nearest integer
|
||||
integer gtype !< type of RNG used
|
||||
integer maxit, micit !<maximum makro and micro iterations for the genetic program
|
||||
! weighting parameters
|
||||
|
||||
! Declare INTERNAL variables
|
||||
character(len=dnlen) :: datname, dbgdatname !< name of the input File
|
||||
character(len=llen), dimension(:), allocatable :: infile !< internalized array of capitalized input file without comments, blanklines
|
||||
integer linenum !< linenumber in infile
|
||||
double precision gspread
|
||||
! data arrays
|
||||
integer idat(maxdat)
|
||||
double precision ddat(maxdat)
|
||||
character(len=clen) cdat(maxdat)
|
||||
! minimum ntot (inferred from ndiab etc)
|
||||
integer min_ntot
|
||||
|
||||
|
||||
! running index
|
||||
integer j !< running index
|
||||
|
||||
! general key variables
|
||||
integer key_id !< integer identifying a key from keylist.incl
|
||||
logical legacy_wt
|
||||
|
||||
! length or position variables
|
||||
integer dat_start !< linenumber in infile where DATA: Block starts
|
||||
|
||||
! Fabian
|
||||
character(len=llen) :: fmt,fmt2
|
||||
integer, parameter :: id_internal = 10 ! hardcoded until queue is ready for modern features
|
||||
integer, parameter :: std_out = 6
|
||||
|
||||
! allocate relevant arrays
|
||||
allocate(infile(maxlines))
|
||||
|
||||
! define Error Messages
|
||||
include 'errcat.incl'
|
||||
|
||||
! include general keylist
|
||||
include 'keylist.incl'
|
||||
do j=1,maxkeys
|
||||
if (keylist(1,j)(1:1).eq.' ') then
|
||||
keynum=j-1
|
||||
write(fmt,'("Number of accepted input keys: ",I3)') keynum
|
||||
call write_oneline(fmt,std_out)
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
|
||||
!############################################################
|
||||
! Read input file
|
||||
!############################################################
|
||||
|
||||
call get_datfile(datname,dnlen)
|
||||
call internalize_datfile
|
||||
> (datname,infile,linenum,llen,maxlines,dnlen)
|
||||
dbgdatname='.internal_input'
|
||||
#ifndef mpi_version
|
||||
write(6,'(A)') 'Writing internalized version of input to '''
|
||||
> // trim(dbgdatname) // '''..'
|
||||
open(unit=id_internal,file=trim(dbgdatname))
|
||||
do j=1,linenum
|
||||
write(id_internal,'(A)') trim(infile(j))
|
||||
enddo
|
||||
close(id_internal)
|
||||
#endif
|
||||
write(fmt,'("Parsing Keys..")')
|
||||
call write_oneline(fmt,std_out)
|
||||
|
||||
call keyread(keylist,infile,keynum,idat,ddat,cdat,datpos,
|
||||
> klen,llen,clen,linenum,maxdat)
|
||||
|
||||
!############################################################
|
||||
! Read Individual keys for Program Control
|
||||
!############################################################
|
||||
|
||||
!************************************************************************
|
||||
! DATA:
|
||||
!************************************************************************
|
||||
! This card separates the data to be fitted from the rest of the
|
||||
! file.
|
||||
!************************************************************************
|
||||
key_id=1
|
||||
! Find where in the input file the DATA:-block begins and
|
||||
! exclude the line of the card itself
|
||||
dat_start=datIdx(2,key_id)
|
||||
|
||||
!************************************************************************
|
||||
! SEED:
|
||||
!************************************************************************
|
||||
! Random seed for the RNG.
|
||||
!************************************************************************
|
||||
key_id=2
|
||||
seed=8236475
|
||||
|
||||
if (is_present(key_id)) then
|
||||
seed=idat(datIdx(1,key_id))
|
||||
else
|
||||
write(fmt,76) seed
|
||||
call write_oneline(fmt,std_out)
|
||||
endif
|
||||
76 format('No random seed specified; seed set to',i12)
|
||||
|
||||
if (abs(seed).lt.10**5) then
|
||||
call signal_val_error(key_id,5,seed)
|
||||
endif
|
||||
|
||||
write(fmt,'("Random seed set to: ",I12)') seed
|
||||
call write_oneline(fmt,std_out)
|
||||
|
||||
seed=-iabs(seed)
|
||||
|
||||
!************************************************************************
|
||||
! NSET:
|
||||
!************************************************************************
|
||||
! Number of diffrent Parameter sets.
|
||||
!************************************************************************
|
||||
key_id=3
|
||||
nset=1
|
||||
if (is_present(key_id)) then
|
||||
nset=idat(datIdx(1,key_id))
|
||||
if (nset.le.0)
|
||||
> call signal_val_error(key_id,5,nset)
|
||||
else
|
||||
write(fmt,77) nset
|
||||
call write_oneline(fmt,std_out)
|
||||
endif
|
||||
77 format('No number of Parametersets specified; nset set to',i9)
|
||||
|
||||
write(fmt,'("Number of Parametersets set to: ",I9)') nset
|
||||
call write_oneline(fmt,std_out)
|
||||
|
||||
!************************************************************************
|
||||
! FREEZE:
|
||||
!************************************************************************
|
||||
! Determines if All parameters are nonactive if present.
|
||||
!************************************************************************
|
||||
key_id=4
|
||||
freeze=is_present(key_id)
|
||||
|
||||
!************************************************************************
|
||||
! NSTAT:
|
||||
!************************************************************************
|
||||
! Number of Energievalues in y for each Point
|
||||
!************************************************************************
|
||||
key_id=5
|
||||
nstat = idat(datIdx(1,key_id))
|
||||
|
||||
write(fmt,'("Number of Energie values set to: ",I9 )') nstat
|
||||
call write_oneline(fmt,std_out)
|
||||
|
||||
!************************************************************************
|
||||
! NCI:
|
||||
!************************************************************************
|
||||
! Number of CI vectors in y for each Geometry
|
||||
!************************************************************************
|
||||
key_id=6
|
||||
nci = 0
|
||||
if(is_present(key_id)) then
|
||||
nci =idat(datIdx(1,key_id))
|
||||
endif
|
||||
write(fmt,'("Number of CI vectors set to: ",I9 )') nci
|
||||
call write_oneline(fmt,std_out)
|
||||
|
||||
!************************************************************************
|
||||
! NDIAB:
|
||||
!************************************************************************
|
||||
! Size of diabatic space = lenght of ci vectors
|
||||
!************************************************************************
|
||||
key_id=7
|
||||
ndiab=nstat
|
||||
if(is_present(key_id)) then
|
||||
ndiab = idat(datIdx(1,key_id))
|
||||
endif
|
||||
|
||||
write(fmt,'("Setting ndiab to:",I9)') ndiab
|
||||
call write_oneline(fmt,std_out)
|
||||
|
||||
!************************************************************************
|
||||
|
||||
min_ntot= nstat + (nci*ndiab)
|
||||
if(min_ntot.gt.max_ntot) then
|
||||
write(6,*)'ERROR: ntot exceeds set Maximum: ',min_ntot,max_ntot
|
||||
stop
|
||||
endif
|
||||
|
||||
!************************************************************************
|
||||
! HYBRID:
|
||||
!************************************************************************
|
||||
! If present then CI vectors are used in Fit
|
||||
!************************************************************************
|
||||
key_id=8
|
||||
hybrid=is_present(key_id)
|
||||
if(hybrid.and.(nci.le.0)) then
|
||||
write(6,*) 'Cant do Hybrid Fit without ci vectors, nci: ',nci
|
||||
stop ec_log
|
||||
endif
|
||||
|
||||
!************************************************************************
|
||||
! SEL:
|
||||
!************************************************************************
|
||||
! Percentage of selected Parameter sets as Parents
|
||||
!************************************************************************
|
||||
key_id=9
|
||||
psel=0.15d0
|
||||
|
||||
if(is_present(key_id)) then
|
||||
psel = ddat(datIdx(1,key_id))
|
||||
if (psel.gt.1.d0) call signal_dval_error(key_id,7,psel*100)
|
||||
endif
|
||||
nsel=max(int(psel*nset),1)
|
||||
|
||||
write(fmt,79) psel*100, nsel
|
||||
call write_oneline(fmt,std_out)
|
||||
|
||||
79 format(f5.1,'%(#',i5,')of Parameters will be selected as parents')
|
||||
|
||||
!************************************************************************
|
||||
! MUT:
|
||||
!************************************************************************
|
||||
! Percentage of how many mutations happen in parameters
|
||||
!************************************************************************
|
||||
key_id=10
|
||||
mut=0.d0
|
||||
if(is_present(key_id)) then
|
||||
mut = ddat(datIdx(1,key_id))
|
||||
if (mut.gt.1.d0) call signal_dval_error(key_id,7,mut*100.d0)
|
||||
endif
|
||||
|
||||
write(fmt,80) mut
|
||||
call write_oneline(fmt,std_out)
|
||||
|
||||
80 format('MUTATION set to: ',g9.1)
|
||||
|
||||
!************************************************************************
|
||||
! DIFPER:
|
||||
!************************************************************************
|
||||
! minimum Percentage of diffrence between selected parents
|
||||
!************************************************************************
|
||||
key_id=11
|
||||
difper=0.05d0
|
||||
if(is_present(key_id)) then
|
||||
difper = ddat(datIdx(1,key_id))
|
||||
if (difper.gt.1.d0) then
|
||||
call signal_dval_error(key_id,7,difper*100.d0)
|
||||
endif
|
||||
endif
|
||||
|
||||
write(fmt,81) difper
|
||||
call write_oneline(fmt,std_out)
|
||||
|
||||
81 format('DIFPER set to: ',g9.1)
|
||||
|
||||
!************************************************************************
|
||||
! GTYPE:
|
||||
!************************************************************************
|
||||
! Type of used RNG
|
||||
!************************************************************************
|
||||
key_id=12
|
||||
gtype=2
|
||||
if(is_present(key_id)) then
|
||||
gtype = idat(datIdx(1,key_id))
|
||||
endif
|
||||
|
||||
write(fmt,'("GTYPE set to: ",i9)') gtype
|
||||
call write_oneline(fmt,std_out)
|
||||
|
||||
!************************************************************************
|
||||
! MAXIT:
|
||||
!************************************************************************
|
||||
! number of maximum makro Iterations
|
||||
!************************************************************************
|
||||
key_id=13
|
||||
maxit=5
|
||||
if(is_present(key_id)) then
|
||||
maxit=idat(datIdx(1,key_id))
|
||||
endif
|
||||
|
||||
write(fmt,'("max. number of makro iterations set to: ",i9)') maxit
|
||||
call write_oneline(fmt,std_out)
|
||||
|
||||
!************************************************************************
|
||||
! MICIT:
|
||||
!************************************************************************
|
||||
! number of maximum micro Iterations
|
||||
!************************************************************************
|
||||
key_id=14
|
||||
micit=1000
|
||||
if(is_present(key_id)) then
|
||||
micit=idat(datIdx(1,key_id))
|
||||
endif
|
||||
|
||||
write(fmt,'("max. number of micro iterations set to: ",i9)') micit
|
||||
call write_oneline(fmt,std_out)
|
||||
|
||||
!************************************************************************
|
||||
! GSPREAD:
|
||||
!************************************************************************
|
||||
! read general Spread for Parameter keys
|
||||
!************************************************************************
|
||||
key_id=15
|
||||
gspread=1.d0
|
||||
if(is_present(key_id)) then
|
||||
gspread = ddat(datIdx(1,key_id))
|
||||
endif
|
||||
|
||||
write(fmt,'("General Parameterspread set to: ",f5.2)') gspread
|
||||
call write_oneline(fmt,std_out)
|
||||
|
||||
!************************************************************************
|
||||
! SETS:
|
||||
!************************************************************************
|
||||
! Number of seperatly grouped geometries.
|
||||
! With more than one argument, total sets = sum of all entries.
|
||||
!************************************************************************
|
||||
key_id=16
|
||||
sets=-1
|
||||
sets=idat(datIdx(1,key_id))
|
||||
do j=2,datlen(key_id)
|
||||
sets=sets+idat(datIdx(j,key_id))
|
||||
enddo
|
||||
|
||||
if(sets.eq.0) call signal_val_error(key_id,5,sets,1)
|
||||
|
||||
write(fmt,'("Number of Data Sets set to: ",i9)') sets
|
||||
call write_oneline(fmt,std_out)
|
||||
|
||||
!************************************************************************
|
||||
! INPUTS:
|
||||
!************************************************************************
|
||||
! Dimension of input values.
|
||||
! INPUTS: D [d]
|
||||
! If given the optional second argument d, read d<D coordinates off
|
||||
! the DATA: block.
|
||||
!************************************************************************
|
||||
key_id=17
|
||||
qn=-1
|
||||
qn=idat(datIdx(1,key_id))
|
||||
if (datlen(key_id).eq.1) then
|
||||
qn_read=qn
|
||||
else if (datlen(key_id).eq.2) then
|
||||
qn_read=idat(datIdx(2,key_id))
|
||||
if (qn_read.gt.qn) then
|
||||
call signal_val_error(key_id,4,qn_read,qn)
|
||||
else if (qn_read.le.0) then
|
||||
call signal_val_error(key_id,5,qn_read,1)
|
||||
endif
|
||||
else if (datlen(key_id).gt.2) then
|
||||
call signal_dim_error(key_id,11,datlen(key_id),2)
|
||||
endif
|
||||
|
||||
if(qn.le.0) call signal_val_error(key_id,5,qn,1)
|
||||
|
||||
!************************************************************************
|
||||
! ENCIRATIO
|
||||
!************************************************************************
|
||||
! parameter used for weighting ratio between energies and CI vectors
|
||||
!************************************************************************
|
||||
key_id=18
|
||||
if(nci.gt.0) then
|
||||
wt_en2ci=1./(ndiab+0.d0)
|
||||
else
|
||||
wt_en2ci=1.d0
|
||||
endif
|
||||
|
||||
if(is_present(key_id)) then
|
||||
wt_en2ci=ddat(datIdx(1,key_id))
|
||||
endif
|
||||
|
||||
write(fmt,82) wt_en2ci
|
||||
call write_oneline(fmt,std_out)
|
||||
|
||||
82 format('Setting Ratio between Energie and CI Weights to:',g9.1)
|
||||
|
||||
!************************************************************************
|
||||
! WTEN:
|
||||
!************************************************************************
|
||||
! parameter used for weighting states independent
|
||||
!************************************************************************
|
||||
key_id=19
|
||||
allocate(wt_en(nstat))
|
||||
wt_en=1.d0
|
||||
|
||||
if(is_present(key_id)) then
|
||||
if(datlen(key_id).ne.nstat)
|
||||
> call signal_dim_error(key_id,3,datlen(key_id),nstat)
|
||||
do j=1,nstat
|
||||
wt_en(j)=ddat(datIdx(j,key_id))
|
||||
enddo
|
||||
endif
|
||||
|
||||
!************************************************************************
|
||||
! WTCI:
|
||||
!************************************************************************
|
||||
! parameter used for weighting CI vectors independent
|
||||
!************************************************************************
|
||||
key_id=20
|
||||
allocate(wt_ci(nci))
|
||||
wt_ci=1.d0
|
||||
|
||||
if(is_present(key_id)) then
|
||||
if(datlen(key_id).ne.nstat)
|
||||
> call signal_dim_error(key_id,3,datlen(key_id),nci)
|
||||
do j=1,nci
|
||||
wt_ci(j)=ddat(datIdx(j,key_id))
|
||||
enddo
|
||||
endif
|
||||
|
||||
!************************************************************************
|
||||
! RMSTHR:
|
||||
!************************************************************************
|
||||
! Threshhold for RMSE calculation for cutting above the given threshold
|
||||
! one or nstat real expected for each energie one threshold or one for all
|
||||
!************************************************************************
|
||||
key_id=23
|
||||
allocate(rms_thr(nstat))
|
||||
rms_thr = 0.d0
|
||||
|
||||
if(is_present(key_id)) then
|
||||
if(datlen(key_id).eq.nstat) then
|
||||
do j=1,nstat
|
||||
rms_thr(j)=ddat(datIdx(j,key_id))
|
||||
enddo
|
||||
! write(6,'("Setting RMS Threshold for individual States to: ",
|
||||
! ><nstat>g12.4)') rms_thr(1:nstat) !<var> works only for ifort, not for gfortran or mpif90
|
||||
|
||||
write(fmt2,'("(A,",I2,"g12.4)")') nstat
|
||||
write(fmt,fmt2)
|
||||
$ "Set RMS Threshold for individual states to:",
|
||||
$ rms_thr(1:nstat)
|
||||
call write_oneline(fmt,std_out)
|
||||
|
||||
else if (datlen(key_id).eq.1) then
|
||||
rms_thr = ddat(datIdx(1,key_id))
|
||||
! write(6,'("Setting RMS Threshold for all States to: ",
|
||||
! ><nstat>g12.4)') rms_thr !<var> works only for ifort, not for gfortran or mpif90
|
||||
write(fmt2,'("(A,",I2,"g12.4)")') nstat
|
||||
write(fmt,fmt2)
|
||||
$ "Set RMS Threshold for individual states to:",
|
||||
$ rms_thr(1:nstat)
|
||||
call write_oneline(fmt,std_out)
|
||||
|
||||
else
|
||||
call signal_dim_error(key_id,3,datlen(key_id),nstat)
|
||||
endif
|
||||
endif
|
||||
|
||||
|
||||
!************************************************************************
|
||||
! NPOINTS:
|
||||
!************************************************************************
|
||||
! Number of geometries for each set
|
||||
!************************************************************************
|
||||
key_id=21
|
||||
allocate(ndata(sets))
|
||||
ndata=0
|
||||
|
||||
if (is_present(key_id)) then
|
||||
if (datlen(key_id).ne.sets) then
|
||||
call signal_dim_error(key_id,3,datlen(key_id),sets)
|
||||
endif
|
||||
do j=1,sets
|
||||
ndata(j)=idat(datIdx(j,key_id))
|
||||
enddo
|
||||
numdatpt=sum(ndata(1:sets))
|
||||
else
|
||||
write(*,*)'WARNING: NO NPOINTS CARD GIVEN'
|
||||
endif
|
||||
|
||||
!************************************************************************
|
||||
! NTOT:
|
||||
!************************************************************************
|
||||
! Total number of output values.
|
||||
!************************************************************************
|
||||
key_id=22
|
||||
ntot=min_ntot
|
||||
if (is_present(key_id)) then
|
||||
ntot=idat(datIdx(1,key_id))
|
||||
if(ntot.lt.min_ntot) then
|
||||
write(6,*)'ERROR: ntot less than set Minimum: ',
|
||||
> ntot,min_ntot
|
||||
stop
|
||||
elseif(ntot.gt.max_ntot) then
|
||||
write(6,*)'ERROR: ntot exceeds set Maximum: ',ntot,max_ntot
|
||||
stop
|
||||
endif
|
||||
endif
|
||||
|
||||
|
||||
!************************************************************************
|
||||
! ANAGRAD:
|
||||
!************************************************************************
|
||||
! if present analytical gradients are used for eigenvalues and vectors
|
||||
!************************************************************************
|
||||
key_id=24
|
||||
anagrad=is_present(key_id)
|
||||
if(anagrad) then
|
||||
write(fmt,'(A)') 'Using Analytical gradients.'
|
||||
call write_oneline(fmt,std_out)
|
||||
endif
|
||||
|
||||
!************************************************************************
|
||||
! LBFGS:
|
||||
!************************************************************************
|
||||
! if present the LBFGS-B algorithm of Nocedal and Wright is used
|
||||
! instead of the default Levenberg-Marquard algorithm
|
||||
!************************************************************************
|
||||
key_id=25
|
||||
lbfgs=is_present(key_id)
|
||||
if(lbfgs) then
|
||||
write(fmt,'(A)') 'Using LBFGS-B algorithm for fit'
|
||||
call write_oneline(fmt,std_out)
|
||||
endif
|
||||
|
||||
key_id=26
|
||||
lbfgs_corr=10 !Standard value
|
||||
if (lbfgs) then
|
||||
if(is_present(key_id)) then
|
||||
lbfgs_corr=idat(datIdx(1,key_id))
|
||||
endif
|
||||
if(lbfgs_corr.eq.0)
|
||||
$ call signal_val_error(key_id,5,lbfgs_corr,1)
|
||||
write(fmt,'("Number of LBFGS corrections set to: ",i9)')
|
||||
$ lbfgs_corr
|
||||
call write_oneline(fmt,std_out)
|
||||
endif
|
||||
|
||||
!************************************************************************
|
||||
! FACSPREAD:
|
||||
!************************************************************************
|
||||
! read multiplicative factor for spreads of all parameters
|
||||
!************************************************************************
|
||||
key_id=27
|
||||
facspread=1.d0
|
||||
if(is_present(key_id)) then
|
||||
facspread = ddat(datIdx(1,key_id))
|
||||
if(facspread.le.0.d0) then
|
||||
write(6,*) 'ERROR: facspread <= 0'
|
||||
stop
|
||||
endif
|
||||
endif
|
||||
|
||||
write(fmt,'("Multiplicative factor for parameter spread: ",f5.2)')
|
||||
$ facspread
|
||||
call write_oneline(fmt,std_out)
|
||||
|
||||
!************************************************************************
|
||||
! LOGCONVERGENCE:
|
||||
!************************************************************************
|
||||
! If present logging files for convergence are printed
|
||||
!************************************************************************
|
||||
key_id=28
|
||||
log_convergence=is_present(key_id)
|
||||
|
||||
!************************************************************************
|
||||
! COORD:
|
||||
!************************************************************************
|
||||
! For each set, specify a coord number N, where
|
||||
! N=0 (default) computes a walk coordinate on q mapped to [0:1]
|
||||
! N>0 plot against q(N)
|
||||
!
|
||||
!************************************************************************
|
||||
key_id=29
|
||||
allocate(plot_coord(sets))
|
||||
plot_coord=0
|
||||
if (is_present(key_id)) then
|
||||
if (datlen(key_id).ne.sets) then
|
||||
call signal_dim_error(key_id,3,datlen(key_id),sets)
|
||||
endif
|
||||
do j=1,sets
|
||||
plot_coord(j)=idat(datIdx(j,key_id))
|
||||
enddo
|
||||
fmt='COORD: Scan file(s) will use the following coordinates:'
|
||||
call write_oneline(fmt,std_out)
|
||||
fmt='(I3)'
|
||||
call write_longint(std_out,plot_coord,datlen(key_id),
|
||||
> fmt,16)
|
||||
endif
|
||||
|
||||
!************************************************************************
|
||||
! PARMETER KEYS:
|
||||
!************************************************************************
|
||||
! read the parameter keys defined in keys.incl
|
||||
!************************************************************************
|
||||
|
||||
call parameterkey_read
|
||||
> (infile,linenum,p,p_act,p_spread,npar,gspread,facspread)
|
||||
|
||||
if (all(p_act.eq.0)) then
|
||||
write(std_out,'(A)') 'WARNING: No active parameters. '
|
||||
> // 'Setting FREEZE:'
|
||||
freeze=.true.
|
||||
endif
|
||||
|
||||
|
||||
!************************************************************************
|
||||
! DATA:
|
||||
!************************************************************************
|
||||
! reading x an y values in the datablock after DATA: card
|
||||
!************************************************************************
|
||||
legacy_wt=.true. !< @TODO consider implementing card for ANN weighting format
|
||||
call read_data(infile,x,y,wt,
|
||||
> legacy_wt,dat_start,linenum,ntot,qn,
|
||||
> qn_read,numdatpt)
|
||||
|
||||
|
||||
deallocate(infile)
|
||||
end subroutine
|
||||
|
||||
!************************************************************************
|
||||
subroutine read_data(in,x,y,wt,
|
||||
> legacy_wt,st,lauf,y_dim,x_dim,
|
||||
> x_read,ndatapoints)
|
||||
! Routine reading DATA-block.
|
||||
! If ndatapoints is nonzero, only the first ndatapoints pattern pairs are read.
|
||||
!
|
||||
! in: input file as string vector
|
||||
! in(n) nth line of input file
|
||||
! lauf: number of lines in input file
|
||||
! st: starting position of DATA-block
|
||||
!
|
||||
!.....Splitting variables
|
||||
! ndatapoints: number of given pattern pairs
|
||||
! nref: number of reference patterns
|
||||
!.....Data arrays containing the read out and in values
|
||||
! wterr: weight factors for each element of the error vector e
|
||||
! x: input patterns
|
||||
! y: desired output patterns
|
||||
! x/y(i,N): value of ith in-/output neuron for pattern N
|
||||
! x_dim: physical dimension of x(:,N)
|
||||
! x_read: number of read coordinates (rest is 0)
|
||||
!
|
||||
! expected format (for one pattern pair):
|
||||
!.. y1 x1 x2 x3 ... xM
|
||||
!.. y2 x1 x2 x3 ... xM
|
||||
!.. .. .. .. .. ... ..
|
||||
!.. yN x1 x2 x3 ... xM
|
||||
!..
|
||||
!.. WT: w1 w2 ... wN
|
||||
!
|
||||
!... wt-legacy mode format:
|
||||
!.. y1 x1 x2 x3 ... xM
|
||||
!.. WT: w1
|
||||
!.. y2 x1 x2 x3 ... xM
|
||||
!.. WT: w2
|
||||
!.. .. .. .. .. ... ..
|
||||
!.. yN x1 x2 x3 ... xM
|
||||
!.. WT: wN
|
||||
!
|
||||
! where N=inp_out and M=inp_in
|
||||
|
||||
double precision, allocatable :: x(:,:),y(:,:)
|
||||
double precision, allocatable :: wt(:,:)
|
||||
! actual relevant Dimensions
|
||||
integer ndatapoints,st,lauf,y_dim,x_dim
|
||||
integer x_read
|
||||
character(len=llen) in(lauf)
|
||||
logical legacy_wt
|
||||
integer pat_count,line
|
||||
|
||||
integer k
|
||||
|
||||
! allocate arrays
|
||||
allocate(x(x_dim,ndatapoints),y(y_dim,ndatapoints),
|
||||
> wt(y_dim,ndatapoints))
|
||||
|
||||
|
||||
pat_count=0
|
||||
line=st !count lines
|
||||
|
||||
do while (line.le.lauf)
|
||||
if (in(line)(1:3).eq.'WT:') then
|
||||
|
||||
if (legacy_wt .or. (pat_count.eq.0)) then
|
||||
write(6,419) 1
|
||||
write(6,'(A)') '(preceding WT-block)'
|
||||
stop ec_read
|
||||
endif
|
||||
|
||||
read(in(line)(4:llen),*,err=511,end=508)
|
||||
> wt(1:y_dim,pat_count)
|
||||
|
||||
line=line+1
|
||||
|
||||
if (pat_count.eq.ndatapoints) exit
|
||||
|
||||
cycle
|
||||
508 write(6,419) pat_count
|
||||
write(6,'(A)') '(broken WT: input)'
|
||||
stop ec_read
|
||||
511 write(6,418) pat_count
|
||||
write(6,'(A)') 'LINE DUMP:'
|
||||
write(6,'(A)') trim(in(line)(4:llen))
|
||||
stop ec_read
|
||||
else
|
||||
! stop reading if desired number of patterns is read
|
||||
if ((ndatapoints.gt.0).and.(pat_count.eq.ndatapoints)) exit
|
||||
|
||||
! new input set begins
|
||||
pat_count=pat_count+1
|
||||
wt(1:y_dim,pat_count)=1.0D0
|
||||
x(:,pat_count)=0.d0
|
||||
read(in(line)(1:llen),*,err=513,end=510) y(1,pat_count),
|
||||
> x(1:x_read,pat_count)
|
||||
line=line+1
|
||||
! wt-legacy-mode: read single weight
|
||||
if (legacy_wt .and. (in(line)(1:3).eq.'WT:')) then
|
||||
read(in(line)(4:llen),*,err=515,end=514)
|
||||
> wt(1:1,pat_count)
|
||||
line=line+1
|
||||
endif
|
||||
|
||||
do k=2,y_dim
|
||||
! read y(k,pat_count) and copy x-vector for comparison
|
||||
read(in(line)(1:llen),*,err=512,end=509)
|
||||
> y(k,pat_count)
|
||||
|
||||
if (line.lt.lauf) then
|
||||
line=line+1
|
||||
if (legacy_wt .and. (in(line)(1:3).eq.'WT:')) then
|
||||
read(in(line)(4:llen),*,err=515,end=514)
|
||||
> wt(k:k,pat_count)
|
||||
line=line+1
|
||||
endif
|
||||
cycle
|
||||
else if (k.eq.y_dim) then
|
||||
exit
|
||||
endif
|
||||
509 write(6,419) pat_count
|
||||
write(6,'(A)') '(reached EOF before completion)'
|
||||
stop ec_read
|
||||
512 write(6,421) pat_count, line
|
||||
write(6,'(A)') 'LINE DUMP:'
|
||||
write(6,'(A)') trim(in(line)(1:llen))
|
||||
stop ec_read
|
||||
enddo
|
||||
|
||||
cycle
|
||||
510 write(6,419) pat_count
|
||||
stop ec_read
|
||||
513 write(6,421) pat_count, line
|
||||
write(6,'(A)') 'LINE DUMP:'
|
||||
write(6,'(A)') trim(in(line)(1:llen))
|
||||
stop ec_read
|
||||
514 write(6,419) pat_count
|
||||
write(6,'(A)') '(broken WT: input)'
|
||||
stop ec_read
|
||||
515 write(6,418) pat_count
|
||||
write(6,'(A)') 'LINE DUMP:'
|
||||
write(6,'(A)') trim(in(line)(4:llen))
|
||||
stop ec_read
|
||||
endif
|
||||
enddo
|
||||
! pat_count is now actual number of patterns
|
||||
|
||||
if (pat_count.le.0) then
|
||||
write(6,419) 1
|
||||
stop ec_read
|
||||
else if (ndatapoints.ne.pat_count) then
|
||||
write(6,420) ndatapoints,pat_count
|
||||
stop ec_read
|
||||
endif
|
||||
|
||||
|
||||
! 417 format('ERROR: CORRUPTED WEIGHT INPUT (SET #',I9,')')
|
||||
418 format('ERROR: NUMDATPT EXCEEDING MAX_NUMDATPT(',I9,' vs.',I9,')')
|
||||
419 format('ERROR: INCOMPLETE OR MISSING DATA SET. SET #',I9)
|
||||
420 format('ERROR: NUMBER OF DATA POINTS INCONSISTENT
|
||||
> WITH NDATAPOINTS',
|
||||
> '(',I9,' vs.',I9,')')
|
||||
421 format('ERROR: CORRUPTED DATA POINT INPUT (SET #',I9,', LINE,',
|
||||
> I9,')')
|
||||
|
||||
end subroutine
|
||||
|
||||
!--------------------------------------------------------------------------------
|
||||
! Here follow convenience functions defined for this modul only.
|
||||
|
||||
integer function datIdx(j,key_id)
|
||||
! Locate Jth value of KEY_IDth data block on *dat vector(s).
|
||||
|
||||
integer j,key_id
|
||||
|
||||
datIdx=IdxShift(j,datpos(2,key_id))
|
||||
end function
|
||||
|
||||
!--------------------------------------------------------------------------
|
||||
|
||||
integer function IdxShift(j,start)
|
||||
! Map linear index of a logical vector which is embedded in a memory
|
||||
! vector and begins at START.
|
||||
|
||||
integer j,start
|
||||
|
||||
IdxShift=start-1+j
|
||||
|
||||
end function
|
||||
|
||||
!--------------------------------------------------------------------------------
|
||||
|
||||
logical function is_present(key_id,quiet)
|
||||
use strings_mod,only:write_oneline
|
||||
implicit none
|
||||
! Checks whether optional key has been given in input file.
|
||||
! If optional argument QUIET is true, do not print a message
|
||||
! if the key wasn't found.
|
||||
|
||||
integer key_id
|
||||
logical quiet
|
||||
optional quiet
|
||||
|
||||
character(len=llen) fmt
|
||||
integer,parameter :: std_out = 6
|
||||
|
||||
is_present=(datpos(2,key_id).ne.-1)
|
||||
|
||||
if (present(quiet)) then
|
||||
if (quiet) then
|
||||
return
|
||||
endif
|
||||
else if (.not.is_present) then
|
||||
write(fmt,'(A)') 'No '//trim(keylist(1,key_id))//' card found.'
|
||||
call write_oneline(fmt,std_out)
|
||||
endif
|
||||
|
||||
end function
|
||||
|
||||
!----------------------------------------------------------------------------------
|
||||
integer function datlen(key_id)
|
||||
implicit none
|
||||
integer key_id
|
||||
datlen=datpos(3,key_id)
|
||||
end function
|
||||
|
||||
end module
|
||||
|
|
@ -0,0 +1,71 @@
|
|||
module ptr_structure
|
||||
use dim_parameter,only: pst,numdatpt,ndiab,qn
|
||||
implicit none
|
||||
public
|
||||
|
||||
type, public :: value_loc_ptr
|
||||
!number of non-zero-elements
|
||||
integer :: nnz=0
|
||||
!row position of non-zero values
|
||||
integer, allocatable :: rowPtr(:)
|
||||
!column position of non-zero values
|
||||
integer, allocatable :: colPtr(:)
|
||||
!holds non-zero values
|
||||
double precision, allocatable :: values(:,:)
|
||||
end type value_loc_ptr
|
||||
|
||||
contains
|
||||
|
||||
|
||||
subroutine init_ptr(ptr,occupation)
|
||||
|
||||
type(value_loc_ptr) :: ptr
|
||||
logical, intent(in) :: occupation(ndiab,ndiab)
|
||||
|
||||
integer :: i,j,k
|
||||
integer :: m,n,nnz
|
||||
|
||||
! Get occupation size for first and second index
|
||||
m = size(occupation,1)
|
||||
n = size(occupation,2)
|
||||
|
||||
!Count number of non-zero occupation elements
|
||||
nnz = count(occupation .eqv. .true.)
|
||||
ptr%nnz = nnz
|
||||
|
||||
!Allocate data for pointer arrays and value array
|
||||
allocate(ptr%rowPtr(nnz),ptr%colPtr(nnz),ptr%values(nnz,numdatpt))
|
||||
|
||||
!Get all non-zero elements of occupation
|
||||
!Write values on values, write positions on rowPtr and colPtr
|
||||
k=1
|
||||
!Loop over rows
|
||||
do i=1,m
|
||||
!Loop over columns
|
||||
do j=1,n
|
||||
!Get non-zero elements and write their values on values & write their positions on rowPtr and colPtr
|
||||
if(occupation(i,j)) then
|
||||
ptr%rowPtr(k)=i
|
||||
ptr%colPtr(k)=j
|
||||
!Increase counter
|
||||
k=k+1
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end subroutine init_ptr
|
||||
|
||||
subroutine init_values(ptr,matrix,pt)
|
||||
|
||||
type(value_loc_ptr) :: ptr
|
||||
double precision matrix(ndiab,ndiab)
|
||||
integer pt
|
||||
integer l
|
||||
|
||||
do l=1,ptr%nnz
|
||||
ptr%values(l,pt)=matrix(ptr%rowPtr(l),ptr%colPtr(l))
|
||||
enddo
|
||||
|
||||
end subroutine init_values
|
||||
|
||||
end module ptr_structure
|
||||
|
|
@ -0,0 +1,362 @@
|
|||
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
||||
c interface for genetic to call random generator
|
||||
|
||||
c seed = initialization seed: large integer
|
||||
c ierr=6 : output for error [only for Marius Lewerenz random number generator)
|
||||
c gtype = choose which random number generator is invoked
|
||||
|
||||
c gtype = 1 is the DEFAULT behavior if the GTYPE card is not set within the input file
|
||||
|
||||
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
||||
function rn(seed,gtype,cont)
|
||||
implicit none
|
||||
|
||||
!INPUT
|
||||
integer seed !seed to initialize random number stream
|
||||
integer gtype !choose which RNG is used (1="standard" genetic version,2=RANLUX)
|
||||
integer cont !initialize random number stream (1) or continue with already initialited stream (0)
|
||||
|
||||
!LOCAL VARIABLES ("standard" genetic)
|
||||
integer ierr,iseed
|
||||
double precision rand
|
||||
save ierr
|
||||
|
||||
!LOCAL VARIABLES (RANLUX)
|
||||
integer lux
|
||||
integer length
|
||||
parameter (length=1)
|
||||
real random_vec(length)
|
||||
|
||||
!OUTPUT VARIABLE
|
||||
double precision rn
|
||||
|
||||
if (gtype.eq.1) then
|
||||
write(6,*) 'ERROR: 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
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
c---------------------------- ranlfg.inc -------------------------------
|
||||
c---+----|----+----|----+----|----+----|----+----|----+----|----+----|--
|
||||
c
|
||||
c parameters for lagged fibonacci generators and common block with
|
||||
c generator state
|
||||
c
|
||||
c-----------------------------------------------------------------------
|
||||
c
|
||||
c possible (np,nq) values, (np,np-nq) is also valid:
|
||||
c (17,5), (250,103), (521,158), (1279,418),
|
||||
c (2281,715), (4423,1393), (1279,1063)
|
||||
c ref.: Bhanot et al., phys. rev b 33, 7841 (1986);
|
||||
c Zierler, inf. control 15, 67 (1961)
|
||||
c
|
||||
c mersenne prime primitive trinomials:
|
||||
c (heringa et al. int.j.mod.phys.c 3, 561 (1992))
|
||||
c
|
||||
c (89,38)
|
||||
c (127,1), (127,7), (127,15), (127,30), (127,63)
|
||||
c (521,32), (521,48), (521,158), (521,168)
|
||||
c (607,105), (607,147), (607, 273)
|
||||
c (1279,216), (1279,418)
|
||||
c (2281,715), (2281,915), (2281,1029)
|
||||
c (3217,67), (3217,576)
|
||||
c (4423,271), (4423,369), (4423,370), (4423,649), (4424,1393),
|
||||
c (4423,1419), (4423,2098)
|
||||
c (9689,84), (9689,471), (9689,1836), (9689,2444), (9689,4187)
|
||||
c (19937,881), (19937,7083), (19937,9842)
|
||||
c (23209,1530), (23209,6619), (23209,9739)
|
||||
c (44497,8575), (44497,21034)
|
||||
c (110503,25230), (110503,53719)
|
||||
c (132049,7000), (132049,33912), (132049,41469), (132049,52549),
|
||||
c (132049,54454)
|
||||
c
|
||||
c another pair from brent92 who recommends q=0.618p : (258,175)
|
||||
c brent's ranu4 uses (132049,79500)
|
||||
c
|
||||
c-----------------------------------------------------------------------
|
||||
c parameter (np=250,nq=103)
|
||||
integer np,nq
|
||||
parameter (np=1279,nq=418)
|
||||
c parameter (np=2281,nq=715)
|
||||
c parameter (np=274674,nq=67874)
|
||||
integer init
|
||||
integer last
|
||||
double precision x(np) !???
|
||||
save /xrandf/
|
||||
common /xrandf/ x,last,init
|
||||
c---+----|----+----|----+----|----+----|----+----|----+----|----+----|--
|
||||
c----------------------------- last line -------------------------------
|
||||
Loading…
Reference in New Issue