jnshuti
/
ANN-my-version
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

First commit

This commit is contained in:
Jean Paul Nshuti 2026-06-15 15:28:22 +02:00
commit d40633e1e8
61 changed files with 20030 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
src/README Normal file
View File

@ -0,0 +1,50 @@
makepar.sh
here the input is used to generate and save the parameters for the NN
The program should run well with:
valgrind --main-stacksize=100000000 --max-stackframe=150000000
(sizes may vary)
used directories:
.
../bin
../nnfits
../logs
../scans
./: the source directory
../bin/:
Directory in which binaries are stored and executed. Input files
are copied here.
../nnfits/:
Directory in which a copy of the program outout is stored, as well as
fitted parameters of the best (fit_pars.in) and 10th percentile
(fit_10p.in) network.
../logs/:
Directory in which the convergence of the different networks is logged
and summarized in performance.log.
../scans/:
Fitting results of the particular scans are dumped as functions of a
progression parameter t.
input file nomenclature:
diab_* : fit against diabatic energies
*_ci_* : include CI information
*_en_* : exclude CI information (energies only)
gen_* : input generation file
*_minmodel_* : use minimal model of only 2 basis matrices
*_tmcs_* : use tmc coordinates
*_small_* : within a small coordinate range (~0.5-2.5)

7
src/accuracy_constants.f90 Normal file
View File

@ -0,0 +1,7 @@
module accuracy_constants
use iso_fortran_env
implicit none
integer, parameter :: dp = real64
integer, parameter :: idp = int32
!real(dp), parameter :: pi = acos(-1.0_dp)
end module

9
src/ann_inc.f90 Normal file
View File

@ -0,0 +1,9 @@
module ann_inc
use accuracy_constants
use nn_params, only: maxlay,maxtypes,wbcap
implicit none
integer(idp):: laystr(3,maxlay),typop(maxtypes,maxlay)
integer(idp):: weistr(2,maxlay,2)
integer(idp):: nlay
real(dp):: netpars(wbcap)
end module

316
src/axel.f Normal file
View File

@ -0,0 +1,316 @@
************************************************************************
*** aXel
*** convergence accelerators for ANN's Marquardt-Levenberg
***
************************************************************************
module axel
implicit none
contains
subroutine mqlimstep(wbsteps,wbnorm,gradnorm,fails,lambda,
> mqfact,weistr,nlay)
use nn_params
use nncommons
use nndbg_mod
implicit none
! Rescales step if stepsize restrictions are violated.
!
! Depending on the size of each parameter, this subroutine
! establishes a maximum allowed size for the parameter's
! corresponding step. This maximum size is absolute for small
! parameter sizes (below the given threshold), but scales relatively
! to the current parameter value for larger ones. The entire step
! vector is normalized in such a way that the largest offending
! stepsize is reduced to it's maximum allowed value. Additionally,
! if the total length of the step vector exceeds a certain trust
! radius, it is renormalized as well.
!
! wei_end: position of last defined weight in W-vector
! lay_end: position of last defined bias in B-vector
! len_in: number of input-neurons. Since they have no biases
! B(1:len_in) is meaningless.
! large_rel: number of relative threshold violations in step
! large_abs: number of absolute threshold violations in step
!
!
! W: weight matrix vector
! B: bias vector
! wbsteps: steps for weights and biases, same order as a single
! jacobian-row.
!
! stepsize-control parameters for WEIghts and BIases
!
! wb_arad: maximal length of a single step through the entire parameter space,
! aka the trust radius
! *_alim: threshold for switching from relative to absolute scaling
! *_ascale: multiplicative factor by which parameter size is multiplied
! to determine relative maximum step size
! *_amax: hard step limit for small parameter values
double precision wbsteps(wbcap)
double precision lambda,wbnorm,gradnorm
double precision mqfact
integer weistr(2,maxlay,2),nlay
integer fails
double precision scale
integer jac_end
jac_end=weistr(2,nlay,2)
write(6,*) 'CHECKNORM'
write(6,*) wbnorm,gradnorm
if (wbnorm.gt.gradnorm*unit_con) then !? does that make sense???
write(6,*) 'FIXING..'
scale=gradnorm*unit_con/wbnorm
wbsteps(1:jac_end)=wbsteps(1:jac_end)*scale
wbnorm=sqrt(dot_product(wbsteps(1:jac_end),wbsteps(1:jac_end)))
! undo whatever happened in the last step to lambda
if (fails.eq.0) then
lambda=lambda*mqfact
else
lambda=lambda/mqfact
endif
endif
write(6,*) wbnorm
end subroutine
!--------------------------------------------------------------------------------------
subroutine renorm_input(pat_in,npat,preserve,par,
> laystr,weistr)
use nn_params
use nncommons
use io_parameters
use nndbg_mod
implicit none
! Evaluate average and standard deviation of input set and generate
! shifts and normalization factors such that they are normalized to
! an average of 0 and a variance of 1, respectively. If an input is
! constant, do not normalize the variance.
!
! If preserve is true, the network which is assumed to already have
! been fitted will be manipulated such that, given the initial
! values of fact_in and shift_in, it will yield the same output as
! before.
!
! This works as follows: Let u,v be differently normalized versions
! of x and f(u) a function fitted using the data set {u}.
! u and v are given by
!
! u = D1^-1 (x - x1) and
! v = D2^-1 (x - x2).
!
! Since v(x) is invertible we can transform f(u) into an equivalent
! g(v) using f(u(x)) = f(u(v^-1(v(x)))) =: g(v(x))
!
! x = D2 v + x2
! => u(v) = D1^-1 (D2 v + x2 - x1)
! u(v) = D1^-1 D2( v + D2^-1 (x2 - x1))
! = D12 (v - x12)
!
! A transformation of that form can easily be pulled into the ANN
! parameters using the routine unnorm_input.
double precision par(wbcap)
double precision pat_in(maxnin,maxpats)
integer laystr(3,maxlay), weistr(2,maxlay,2)
integer npat
logical preserve
double precision old_shift(maxnin), old_fact(maxnin)
double precision diff_shift(maxnin),diff_fact(maxnin)
integer j
if (preserve) then
old_shift=shift_in
old_fact=fact_in
endif
! get mean for input data
call safe_average(pat_in,shift_in,len_in,maxnin,npat)
! get variance for input data
call safe_variance(pat_in,shift_in,fact_in,len_in,maxnin,npat)
! generate actual norms
do j=1,len_in
fact_in(j)=dsqrt(fact_in(j))
if (dbg) then
write(6,'(A,I3.3,A,ES14.4)') "Computed factor #", j,
> ": ",fact_in(j)
endif
if (fact_in(j).le.zero) then
write(6,'(A,I3.3,A,ES10.2)') "WARNING: Nigh-constant"
> // " coordinate #",j,": ",fact_in(j)
if (vbs) then
write(6,'(A,I3.3)') "Skipping normalization "
> // "of coordinate #", j
endif
fact_in(j) = 1.0d0
endif
enddo
if (preserve) then
! Compute shift displacement x12
do j=1,len_in
diff_shift(j)=(old_shift(j)-shift_in(j))/fact_in(j)
enddo
! Compute factor change D12
do j=1,len_in
diff_fact(j)=old_fact(j)/fact_in(j)
enddo
write(6,'("Absorbing coordinate scaling factors into ANN: ")')
call printvec_full(diff_fact,'(ES12.4)',8,len_in,5)
write(6,'("Absorbing coordinate shift into ANN: ")')
call printvec_full(diff_shift,'(ES12.4)',8,len_in,5)
if (all(abs(diff_shift(1:len_in)).le.zero)
> .and. all(abs(diff_fact(1:len_in)-1.d0).le.zero)) then
write(6,'("REMARK: Shifts and scaling factors'
> // ' near identical to data set.")')
endif
! integrate differences into network
call unnorm_input(par,laystr,diff_shift,diff_fact,weistr)
endif
end subroutine
!--------------------------------------------------------------------------------------
subroutine init_input(lay_in,pat_in,shift,norm,len_in)
! Initialize input layer with optimized coordinates.
!
! Ideally, each coordinate should be normalized such that it has an
! average of 0 and a variance of 1.
use nn_params
use nndbg_mod
implicit none
integer len_in
double precision lay_in(len_in),pat_in(maxnin)
double precision shift(maxnin),norm(maxnin)
integer k
do k=1,len_in
lay_in(k)=(pat_in(k)-shift(k))/norm(k)
enddo
end subroutine
!--------------------------------------------------------------------------------------
subroutine unnorm_input(par,laystr,shift_in,fact_in,weistr,
> preserve)
use nn_params
use io_parameters
use nndbg_mod
implicit none
! Transfer factors and shifts from input normalization to first
! weight matrix and bias, respectively. The equations read as
! follows:
!
! For any un-normalized input vector x we can find a normalized
! counterpart
!
! v = D^-1 (x - <x>),
!
! where D is a diagonal matrix of the standard deviations of the
! respective input coordinate (input layer entry) and <x> is a
! vector of the input layer averages. A feed-forward network fitted
! against the input set {v} hence initially calculates
!
! a = W v + B = W D^-1 (x - <x>) + B
! = (W D^-1) x + (B - W D^-1 <x>)
!
! W,B being the weights matrix and bias vector of the first layer.
! It follows easily that transforming W and B to W' and B' using
!
! W' = W D^-1
! B' = B - W' <x>
!
! we yield a re-parametrized network taking the original coordinates
! x as input.
!
! If preserve is true, this routine acts non-destructively on
! shift_in, fact_in. Absent is equivalent to false.
integer laystr(3,maxlay)
integer weistr(2,maxlay,2)
double precision par(wbcap)
double precision shift_in(maxnin),fact_in(maxnin)
logical, intent(in), optional :: preserve
integer len_in
double precision norm_in(maxnin),new_shift(maxneu)
integer j
len_in=laystr(1,1)
do j=1,len_in
norm_in(j)=1.0d0/fact_in(j)
enddo
! rescale weights:
call rescalemat_in(par(weistr(1,1,1)),norm_in,
> len_in,laystr(1,2))
call dmatvec(par(weistr(1,1,1)),shift_in,new_shift,
> len_in,laystr(1,2))
new_shift=-new_shift
! shift biases:
call shiftmat(par(weistr(1,2,2)),new_shift,laystr(1,2),1)
if ((.not.present(preserve)).or.(.not.preserve)) then
fact_in=1.0d0
shift_in=0.0d0
endif
end subroutine
!--------------------------------------------------------------------------------------
double precision function sim_score(x,y,zero)
! Function to measure similarity between two values, giving them a
! score between 1 (identical) and 0 (opposing/far apart).
!
! If both values are small enough that their abs. values are below
! the threshold argument zero, they are treated as identical
! regardless of actual value. In any other case, values which
! differ by sign are considered opposite, yielding 0.
implicit none
double precision zero,x,y
double precision sgn,maxpar,minpar
! Check whether x and y have the same sign
sgn=sign(1.0d0,x)*sign(1.0d0,y)
maxpar=max(dabs(x),dabs(y))
if (maxpar.le.zero) then
! penalize numerical zeros
sim_score=1.0d0
else if (sgn.le.0.0d0) then
sim_score=0.0d0
else
minpar=min(dabs(x),dabs(y))
sim_score=minpar/maxpar
endif
end function
end module

105
src/backprop.f Normal file
View File

@ -0,0 +1,105 @@
!--------------------------------------------------------------------------------------
subroutine backprop(del,W,deriv,laystr,nlay)
use nn_params
use nndbg_mod
implicit none
! Backpropagates full FF-NN with given output-errors.
! nlay: number of given layers
! nprop: number of single-layer propagations
! neu_io: number of neurons in giv./prev. layer
! neu_oi: number of neurons in prev./giv. layer
! poslay: starting position of layer in L- and B-vector
! poswei: starting position of Weight-Matrix in W-vector
!
! del: Neuron Error Vector
! deriv: Activation function derivatives
! W: Weight Matrix Vector
! laystr: Layer Structure Matrix
!
! laystr(1,N): number of neurons in layer N
! laystr(2,N): starting pos. for layer N
! laystr(3,N): starting pos. for Weight Matrix from layer N to N+1
integer nlay,laystr(3,maxlay)
double precision del(neucap),deriv(neucap)
double precision W(maxwei)
integer poslay,poswei,nprop,neu_io,neu_oi
integer k
nprop=nlay-1
! evaluate deltas
neu_io=laystr(1,nlay) !number of input neurons
do k=nprop,2,-2
neu_oi=laystr(1,k) !number of output neurons
poslay=laystr(2,k)
poswei=laystr(3,k)
call backlay(neu_io,neu_oi,del(poslay),W(poswei),
> deriv(poslay))
neu_io=laystr(1,k-1) !new number of output neurons
poslay=laystr(2,k-1)
poswei=laystr(3,k-1)
! former output neurons are now input, _io and _oi switch places!
! (done for efficiency)
call backlay(neu_oi,neu_io,del(poslay),W(poswei),
> deriv(poslay))
enddo
do k=1,mod(nprop,2) !for odd nprop one iteration is left
neu_oi=laystr(1,1)
poslay=laystr(2,1)
poswei=laystr(3,1)
call backlay(neu_oi,neu_io,del(poslay),W(poswei),
> deriv(poslay))
enddo
end
!--------------------------------------------------------------------------------------
subroutine backlay(neu_in,neu_out,del,W,deriv)
use nn_params
use nndbg_mod
implicit none
! Backpropagates given layer in FF-NN.
! neu_in: number of neurons in layer N+1
! neu_out: number of neurons in layer N
!
!
! del: Neuron Error Vector
! W: Weight Matrix (layer N to layer N+1)
! deriv: Derivative Vector (beginning at layer N)
!
integer neu_in,neu_out
double precision del(neu_out+neu_in),deriv(neu_out)
double precision W(neu_out,neu_in)
integer j,k
do j=1,neu_out
del(j)=0.0D0
enddo
do k=1,neu_in
do j=1,neu_out
del(j)=del(j)+del(neu_out+k)*W(j,k)
enddo
enddo
do k=1,neu_out
del(k)=del(k)*deriv(k)
enddo
end

61
src/common_inc.f90 Normal file
View File

@ -0,0 +1,61 @@
module common
use accuracy_constants, only: idp, dp
use nn_params, only: maxoutp
implicit none
!.. npar: number of parameters
!.. pst: starting addresses and lengths of parameter blocks
integer(idp):: npar, pst(2,100)
!common /parnum/ npar, pst
!******************************************************************************
!**** Syntactic & Parsing parameters
!***
!*** 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#"
!*** keynum: actual number of keys on keylist
!*** 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
integer(idp):: keynum,datpos(3,maxdat)
character(len=klen):: keylist(2,maxkeys)
character(len=klen):: errcat(maxerrors)
!common /synt/ datpos,keynum,keylist,errcat
!******************************************************************************
!**** Misc. fit modifiers
!***
!*** zero_par: set all fitting parameters to zero
!*** legacy_wt: WT:-cards are expected for each output component
!*** individually
!*** walk_scan: if true, map scans to the unit interval [0,1]
!*** otherwise, dump full coordinate vector instead.
logical:: zero_par, legacy_wt
logical:: walk_scan
!common /fitmisc/ zero_par, legacy_wt, walk_scan
!******************************************************************************
!**** Generic error analysis parameters
!***
!*** cutoff: maximal value to be considered for each output in the
!*** context of an unweighted error
!*** showcut: if true, calculate unweighted errors with cutoff thresholds
real(dp):: cutoff(maxoutp),cutwei(maxoutp)
logical:: showcut
!common /eval/ cutoff, cutwei, showcut
END Module

530
src/dmatrix.f Normal file
View File

@ -0,0 +1,530 @@
************************************************************************
*** dmatrix
*** generic double precision matrix operations
***
************************************************************************
subroutine permutemat(oldmat,newmat,perm_row,perm_col,nrow,ncol)
implicit none
! Allows to perform arbitrary permutations of row- and column
! entries of the matrix (corresponding to permutations of the
! underlying basis sets).
!
! Permutations are symbolized as integer vectors. They should
! contain each number from 1 to nrow/ncol in the desired new order,
! 1 meaning the originally first entry etc.
!
! (1,2,3,..) -Permutation-> (P(1),P(2),...)
!
! oldmat: matrix to be modified
! newmat: generated matrix
! nrow: dimension of row-vectors
! ncol: dimension of column vectors
! perm_*: permutation applied to row or column
!
integer nrow,ncol
integer perm_row(nrow),perm_col(ncol)
double precision oldmat(nrow,ncol),newmat(nrow,ncol)
integer j,k
! check validity of permutations (pidgeonhole principle)
do j=1,nrow
if (.not.any(perm_row.eq.j)) then
write(6,'(A)') 'ERROR: INVALID PERMUTATION'
> // ' VECTOR (permutemat)'
stop 1
endif
enddo
do j=1,ncol
if (.not.any(perm_col.eq.j)) then
write(6,'(A)') 'ERROR: INVALID PERMUTATION'
> // ' VECTOR (permutemat)'
stop 1
endif
enddo
do j=1,ncol
do k=1,nrow
newmat(k,j)=oldmat(perm_row(k),perm_col(j))
enddo
enddo
end
!--------------------------------------------------------------------------
subroutine rescalemat_out(mat,factors,nrow,ncol)
implicit none
! Rescale output of matrix mat in each dimension with the
! corresponding entry in factors. This is equivalent to multiplying
! an appropriate diagonal matrix from the lefthand side. The
! original matrix is destroyed in the process.
!
! mat: matrix to be scaled
! nrow_*: dimension of row-vector in matrix *mat (matrix input)
! ncol_*: dimension of column-vector in matrix *mat (matrix output)
integer nrow,ncol
double precision mat(nrow,ncol), factors(ncol)
integer j,k
do j=1,ncol
do k=1,nrow
mat(k,j)=mat(k,j)*factors(j)
enddo
enddo
end
!--------------------------------------------------------------------------
subroutine rescalemat_in(mat,factors,nrow,ncol)
implicit none
! Rescale input of matrix mat in each dimension with the
! corresponding entry in factors. This is equivalent to multiplying
! an appropriate diagonal matrix from the righthand side. The
! original matrix is destroyed in the process.
!
! mat: matrix to be scaled
! nrow_*: dimension of row-vector in matrix *mat (matrix input)
! ncol_*: dimension of column-vector in matrix *mat (matrix output)
integer nrow,ncol
double precision mat(nrow,ncol), factors(nrow)
integer j,k
do j=1,ncol
do k=1,nrow
mat(k,j)=mat(k,j)*factors(k)
enddo
enddo
end
!--------------------------------------------------------------------------
subroutine dmatvec(mat,vec_in,vec_out,nrow,ncol)
implicit none
! Multiply matrix vec with compatible vector vec_in, yielding
! vec_out.
!
! mat: matrix to be scaled
! vec_*: vectors as describe above
! nrow_*: dimension of row-vector in matrix *mat (matrix input)
! ncol_*: dimension of column-vector in matrix *mat (matrix output)
integer nrow,ncol
double precision mat(nrow,ncol), vec_in(nrow), vec_out(ncol)
integer j,k
vec_out=0.0d0
do j=1,ncol
do k=1,nrow
vec_out(j)=vec_out(j) + mat(k,j)*vec_in(k)
enddo
enddo
end
!--------------------------------------------------------------------------
subroutine shiftmat(mat,shift,nrow,ncol)
implicit none
! Add two identically dimensioned matrices mat and shift,
! overwriting mat.
!
! mat: matrix to which shift is added
! shift: addend
! nrow_*: dimension of row-vector in matrix *mat (matrix input)
! ncol_*: dimension of column-vector in matrix *mat (matrix output)
integer nrow,ncol
double precision mat(nrow,ncol), shift(nrow,ncol)
integer j,k
do j=1,ncol
do k=1,nrow
mat(k,j)=mat(k,j)+shift(k,j)
enddo
enddo
end
!--------------------------------------------------------------------------
subroutine phaselock_maxpos(vectors,vecdim,nvec,maxdim)
implicit none
! Normalizes phases of an array of vectors according to molpro standard,
! meaning that the value furthest from 0 is positive in each vector.
!
! vectors: matrix containing all vectors.
! vecdim: dimension of vectors
! nvec: number of vectors
! maxdim: physical vector dimension
integer vecdim,nvec,maxdim
double precision vectors(maxdim,nvec)
double precision maxelem,minelem
integer j
do j=1,nvec
maxelem=maxval(vectors(1:vecdim,j))
minelem=minval(vectors(1:vecdim,j))
if (dabs(minelem).gt.maxelem) then
vectors(1:vecdim,j)=-vectors(1:vecdim,j)
endif
enddo
end
!--------------------------------------------------------------------------
subroutine orderlock_maxolap(vectors,ref_vectors,vecdim,
> nvec,maxdim)
implicit none
! Normalizes the order of an array of vectors such that
! similar vectors appear in similar positions.
! The first reference vector takes priority over the second,
! the 2nd over the 3rd etc.
! vectors: matrix containing all vectors.
! ref_vectors: reference vector set
! vecdim: dimension of vectors
! nvec: number of vectors
! maxdim: physical vector dimension
integer vecdim,nvec,maxdim
double precision vectors(maxdim,nvec),ref_vectors(maxdim,nvec)
double precision olap, maxolap
double precision swap(maxdim)
integer best
integer j,k
do j=1,nvec
! find the vector most similar to reference, using scalar products
maxolap=0.0D0
best=j
do k=j,nvec
! calculate overlap
olap=dabs(dot_product(vectors(1:vecdim,k),
> ref_vectors(1:vecdim,j)))
if (olap.gt.maxolap) then
! update best overlap and mark vector
maxolap=olap
best=k
endif
enddo
! swap places of vectors accordingly
swap=vectors(:,j)
vectors(:,j)=vectors(:,best)
vectors(:,best)=swap
enddo
end
!--------------------------------------------------------------------------
subroutine phaselock_maxolap(vectors,ref_vectors,vecdim,
> nvec,maxdim)
implicit none
! Normalizes phases of an array of vectors such that scalar products
! of corresponding reference vectors are always non-negative.
! vectors: matrix containing all vectors.
! ref_vectors: reference vector set
! vecdim: dimension of vectors
! nvec: number of vectors
! maxdim: physical vector dimension
integer vecdim,nvec,maxdim
double precision vectors(maxdim,nvec),ref_vectors(maxdim,nvec)
double precision olap
integer j
do j=1,nvec
! calculate overlap
olap=dot_product(vectors(1:vecdim,j),
> ref_vectors(1:vecdim,j))
if (olap.lt.0.0D0) then
vectors(1:vecdim,j) = -1.0D0*vectors(1:vecdim,j)
endif
enddo
end
!--------------------------------------------------------------------------
subroutine safe_average(points,avrg,dim,maxdim,npoints)
implicit none
! Generates the average over a set of dim-dimensional vectors in a
! safe fashion using Kahan Summation.
!
! maxdim: physical dimension of vectors
! dim: actual dimension of vectors
! npoints: number of vectors
! points: array of vectors of length (max)dim.
! avrg: final mean vector
!
integer maxdim
integer dim,npoints
double precision points(maxdim,*), avrg(maxdim)
double precision tmp(maxdim)
double precision norm
integer j,k
norm=dble(npoints)
tmp=0.0d0
avrg=0.0d0
do j=1,npoints
do k=1,dim
call KahanAdd(points(k,j),avrg(k),tmp(k))
enddo
enddo
do k=1,dim
avrg(k)=avrg(k)/norm
enddo
end
!--------------------------------------------------------------------------
subroutine safe_variance(points,avrg,var,dim,maxdim,npoints)
implicit none
! Generates the variance over a set of dim-dimensional vectors in a
! safe fashion using Kahan Summation.
!
! maxdim: physical dimension of vectors
! dim: actual dimension of vectors
! npoints: number of vectors
! points: array of vectors of length (max)dim.
! avrg: mean vector
! var: final variance vector
!
integer maxdim
integer dim,npoints
double precision points(maxdim,*), avrg(maxdim), var(maxdim)
double precision tmp(maxdim)
double precision norm
integer j,k
norm=dble(npoints)
tmp=0.0d0
var=0.0d0
do j=1,npoints
do k=1,dim
call KahanAdd((points(k,j)-avrg(k))**2,var(k),tmp(k))
enddo
enddo
do k=1,dim
var(k)=var(k)/norm
enddo
end
!--------------------------------------------------------------------------
subroutine KahanSum(terms,nterms,sum)
implicit none
! Sums over all nterms entries in the vector terms using Kahan Summation.
! It utilizes an algorithm recovering low-order digits of added terms
! Taken from Wikipedia.
! Algebraically, the variable corr should always be zero. Beware
! overly-aggressive optimizing compilers.
integer nterms
double precision terms(nterms)
double precision sum
double precision corr,tmp,newsum
integer j
sum=0.0d0
corr=0.0d0 ! A running compensation for lost low-order bits.
do j=1,nterms
tmp = terms(j) - corr ! try to add collected lost lower digit summations to sum
newsum = sum + tmp ! low-order digits of tmp are lost to summation
! cancels high-order part of tmp
! subtracting tmp recovers low part of the term
corr = (newsum - sum) - tmp
sum = newsum
enddo
end
!--------------------------------------------------------------------------
subroutine KahanAdd(term,sum,corr)
implicit none
! Add term to sum using Kahan Summation.
! It utilizes an algorithm recovering low-order digits of added terms
! Taken from Wikipedia.
! Algebraically, the variable corr should always be zero. Beware
! overly-aggressive optimizing compilers.
double precision term,sum,corr
double precision tmp,newsum
tmp = term - corr ! try to add collected lost lower digit summations to sum
newsum = sum + tmp ! low-order digits of tmp are lost to summation
! cancels high-order part of tmp
! subtracting tmp recovers low part of the term
corr = (newsum - sum) - tmp
sum = newsum
end
!--------------------------------------------------------------------------
subroutine writemat(funit,mat,matfmt,flen,nrow,ncol,
> nrow_print,ncol_print)
implicit none
! Write (submatrix of) matrix mat using format matfmt on each
! individual value to file unit funit.
!
! flen: length of format string
! mat: matrix to be printed
! nrow: dimension of row-vector in matrix mat (matrix input)
! ncol: dimension of column-vector in matrix mat (matrix output)
! *_print: dimensions of submatrix to be printed
integer flen,funit
integer nrow,ncol
integer nrow_print,ncol_print
double precision mat(nrow,ncol)
character*(flen) matfmt
integer j,k
if (nrow_print.gt.nrow) then
write(6,'(A)') 'ERROR: CANNOT PRINT BEYOND MATRIX WIDTH'
> // ' (printmat)'
stop 1
else if (ncol_print.gt.ncol) then
write(6,'(A)') 'ERROR: CANNOT PRINT BEYOND MATRIX HEIGHT'
> // ' (printmat)'
stop 1
endif
do j=1,ncol_print
do k=1,nrow_print
write(unit=funit,fmt=matfmt,advance='NO') mat(k,j)
enddo
write(funit,'()')
enddo
end
!--------------------------------------------------------------------------
subroutine printmat_full(mat,matfmt,flen,nrow,ncol)
implicit none
! Print matrix mat using format matfmt on each
! individual value.
!
! flen: length of format string
! mat: matrix to be printed
! nrow: dimension of row-vector in matrix mat (matrix input)
! ncol: dimension of column-vector in matrix mat (matrix output)
! *_print: dimensions of submatrix to be printed
integer flen
integer nrow,ncol
double precision mat(nrow,ncol)
character*(flen) matfmt
integer stdin
parameter (stdin=6)
call writemat(stdin,mat,matfmt,flen,nrow,ncol,nrow,ncol)
end
!--------------------------------------------------------------------------
subroutine writevec(funit,vec,vecfmt,flen,len,wraplen)
implicit none
! Write vector vec of length len in blocks of length wraplen.
!
! flen: length of format string
! mat: matrix to be printed
! nrow: dimension of row-vector in matrix mat (matrix input)
! ncol: dimension of column-vector in matrix mat (matrix output)
! *_print: dimensions of submatrix to be printed
integer flen,funit
integer len,wraplen
double precision vec(len)
character*(flen) vecfmt
integer wordcount
integer j
wordcount=0
do while (wordcount.lt.len)
do j=1,min(wraplen,len-wordcount)
wordcount=wordcount+1
write(unit=funit,fmt=vecfmt,advance='NO') vec(wordcount)
enddo
write(funit,'()')
enddo
end
!--------------------------------------------------------------------------
subroutine printvec_full(vec,vecfmt,flen,len,wraplen)
implicit none
! Print vector vec of length len in blocks of length wraplen.
!
! flen: length of format string
! mat: matrix to be printed
! nrow: dimension of row-vector in matrix mat (matrix input)
! ncol: dimension of column-vector in matrix mat (matrix output)
! *_print: dimensions of submatrix to be printed
integer flen
integer len,wraplen
double precision vec(len)
character*(flen) vecfmt
integer stdin
parameter (stdin=6)
call writevec(stdin,vec,vecfmt,flen,len,wraplen)
end

199
src/error.f Normal file
View File

@ -0,0 +1,199 @@
*** Define subroutine to generate output layer error for one pattern,
*** as well as the derivate of the error in respect to the neuronal output
***
***
***
****Conventions:
***
*** Most of the data structures are larger than declared;
*** however, only their relevant subsection is passed to the
*** subroutine and hence considered.
***
*** nnerror: subroutine evaluating the output layer's error.
***
*** nnweight: system specific weight adaptions for fit
***
*** pat_err: segment of the total error vector for one pattern.
***
*** len_in: Actual number of input neurons
*** len_out: Actual number of output neurons
***
*** pat_in: Input pattern
*** pat_in(i): value of ith input neuron for given pattern
***
*** pat_out: Desired output pattern
*** pat_out(i): desired value of ith output neuron for given pattern
***
*** L: Final layer, starting at the first neuron
***************************************************************************
****Note:
*** neu_in and neu_out, if needed, should ideally not be hardcoded.
*** Instead they should be passed by the main program to ensure
*** matching dimensionalities.
***
***************************************************************************
subroutine nnerror(pat_err,pat_in,pat_out,nn_out)
use nn_params
use nncommons
use nndbg_mod
implicit none
! Generate error vector from adiabatic model.
!
! nn_out: output from neural network
! pat_err: error vector for single pattern
!
double precision nn_out(maxnout)
double precision pat_in(maxnin),pat_out(maxpout),pat_err(maxpout)
double precision adiaoutp(maxpout)
integer j
call nnadia(pat_in,nn_out,adiaoutp)
do j=1,inp_out
pat_err(j) = pat_out(j) - adiaoutp(j)
enddo
end
!--------------------------------------------------------------------------------------
subroutine nnweight(wterr,pat_out,npat)
use nn_params
use nncommons
use io_parameters
implicit none
! Evaluate system specific weighting for 1 pattern.
!include 'JTmod.incl'
double precision wterr(maxpout,npat),pat_out(maxpout,npat)
integer npat
integer i,j, ii,k
ii =0
do k =1,sets
do j = 1,ndata(k)
ii = ii +1
do i =5, inp_out
if (wterr (i,ii) .gt. 0.0d0) then
wterr( i,ii) = 1.0d-4
endif
enddo
enddo
enddo
! check whether npat equals the number of point in each set
if (npat .ne. ii ) then
write(6,*)" Error in the weight. not consistent npat", npat
stop
endif
pat_out=pat_out
contains
double precision function wdamp(dE)
use nn_params
implicit none
double precision dE
! Weight decay rate
double precision, parameter :: unit=eV2hart
! ln(3)/2 = artanh(1/2)
! double precision, parameter :: alpha=0.5d0*log(3.d0)/unit
! (1+tanh(-x))/2 ~ exp(-2x)
! double precision, parameter :: alpha=0.5d0*log(2.d0)/unit
!
double precision, parameter :: alpha=log(10.d0)/unit
! cutoff
double precision, parameter :: minweight=1.d-4
! asymptotically,
! wdamp=(1.d0+tanh(-alpha*dE))*0.5d0 + minweight
wdamp=1.0d0
if (dE.lt.0) then
wdamp=1.d0
else if (dE.lt.(4*eV2hart)) then
wdamp=exp(-alpha*dE)+minweight
else
wdamp=0
endif
end function wdamp
end subroutine
!--------------------------------------------------------------------------------------
subroutine nnoutgrad(ad_grads,pat_in,nn_out)
use nn_params
use nncommons
use nndbg_mod
implicit none
! Compute the derivative of each output value (i.e. adiab. energies)
! with respect to the Neural Network output-neurons.
!
! nn_out: output from neural network
! ad_grads: derivatives as described above
! ad_grads(:,i): gradient of energy i
! eps: finite differences for derivatives
! eps(i): finite difference for output neuron i
! dis_out: ANN output displaced by finite differences
! dis_out(:,1): equivalent to L + eps
! dis_out(:,2): equivalent to L - eps
! dis_ad: yielded adiabatic output for current displacements
!
! ddelta: factor used to determine eps.
double precision nn_out(maxnout)
double precision pat_in(maxnin)
double precision ad_grads(maxnout,maxpout)
double precision eps(maxnout),dis_out(maxnout,2)
double precision dis_ad(maxpout,2)
double precision ddelta
integer n,j,k
parameter (ddelta = 1.0D-2) !reduce again if appropriate
! determine appropriate finite differences for each parameter:
do k=1,len_out
eps(k)=abs(nn_out(k))*ddelta
if (eps(k).lt.zero) then
eps(k)=zero
endif
enddo
do n=1,len_out
do k=1,2
! copy ANN-output
do j=1,len_out
dis_out(j,k) = nn_out(j)
enddo
enddo
! apply finite difference for output-neuron n
dis_out(n,1) = dis_out(n,1) + eps(n)
dis_out(n,2) = dis_out(n,2) - eps(n)
do k=1,2
! get energies and ci-values
call nnadia(pat_in,dis_out(1,k),dis_ad(1,k))
enddo
! apply finite differences to generate numerical gradient
do k=1,inp_out
ad_grads(n,k) = (dis_ad(k,1)-dis_ad(k,2))/(2.0d0*eps(n))
enddo
enddo
end

153
src/ff_neunet.f Normal file
View File

@ -0,0 +1,153 @@
!--------------------------------------------------------------------------------------
subroutine propagate(W,B,L,deriv,typop,laystr,nlay)
use nn_params
use nndbg_mod
implicit none
! Propagates full FF-NN.
! nlay: number of given layers
! nprop: number of single-layer propagations
! neu_io: number of neurons in giv./prev. layer
! neu_oi: number of neurons in prev./giv. layer
! poslay: starting position of layer in L- and B-vector
! poswei: starting position of Weight-Matrix in W-vector
!
! W: Weight Matrix Vector
! B: Bias Vector
! L: Layer Vector
! deriv: Activation function derivatives
! typop: Type Population Matrix
! laystr: Layer Structure Matrix
!
! laystr(1,N): number of neurons in layer N
! laystr(2,N): starting pos. for layer N
! laystr(3,N): starting pos. for Weight Matrix from layer N to N+1
!
integer nlay,laystr(3,maxlay),typop(maxtypes,maxlay)
double precision W(maxwei),B(neucap),L(neucap),deriv(neucap)
integer poslay,poswei,nprop,neu_io,neu_oi
integer k
nprop=nlay-1
neu_io=laystr(1,1) !number of input neurons
poslay=laystr(2,1)
poswei=laystr(3,1)
do k=2,2*(nprop/2),2
neu_oi=laystr(1,k) !number of output neurons
call proplay(neu_io,neu_oi,W(poswei),B(poslay),L(poslay),
> deriv(poslay),typop(1,k))
poslay=laystr(2,k)
poswei=laystr(3,k)
neu_io=laystr(1,k+1) !new number of output neurons
! former output neurons are now input, _io and _oi switch places!
! (done for efficiency)
call proplay(neu_oi,neu_io,W(poswei),B(poslay),L(poslay),
> deriv(poslay),typop(1,k+1))
poslay=laystr(2,k+1)
poswei=laystr(3,k+1)
enddo
do k=1,mod(nprop,2) !for odd nprop one iteration is left
neu_oi=laystr(1,nlay)
call proplay(neu_io,neu_oi,W(poswei),B(poslay),L(poslay),
> deriv(poslay),typop(1,nlay))
enddo
end
!--------------------------------------------------------------------------------------
subroutine proplay(neu_in,neu_out,W,B,L,deriv,typop)
use nn_params
use nndbg_mod
implicit none
! Evaluates given layer in FF-NN.
!
! neu_in: number of neurons in previous Layer
! neu_out: number of neurons in given Layer
!
! W: Weight Matrix Vector
! B: Bias Vector (beginning at prev. layer)
! L: Layer Vector (beginning at prev. layer)
! deriv: Activation function derivatives
! typop: Type Population Matrix (beginning at curr. layer)
integer neu_in,neu_out,typop(maxtypes)
double precision L(neu_in+neu_out),deriv(neu_in+neu_out)
double precision W(neu_in,neu_out),B(neu_in+neu_out)
integer neu_tot,pos_out
integer j,k
neu_tot=neu_in+neu_out !total number of neurons in both layers
pos_out=neu_in+1 !pos. of current layer's first element
do j=pos_out,neu_tot
L(j)=B(j) !add bias
do k=1,neu_in
L(j)=L(j)+W(k,j-neu_in)*L(k) !matrix x vector
enddo
enddo
! apply nonlin. functions to vector elements
call neurons(neu_out,L(pos_out),deriv(pos_out),typop)
end
!--------------------------------------------------------------------------------------
subroutine neurons(neu_out,L,deriv,typop)
use nn_params
use nndbg_mod
implicit none
! Applies non-linear activation functions to given layer.
! type-unspecified neurons have the activation function f(x)=x.
!
! ni: Number of neurons of type i in given layer.
!
! L: Layer Vector containing accumulated neuronal input
! deriv: Activation function derivatives
! typop: Type Population Matrix
integer neu_out
double precision L(neu_out),deriv(neu_out)
integer typop(maxtypes)
integer n1,n2!,n3
integer j
n1=typop(1)
n2=typop(2)
! n3=typop(3)
call deriv1(L(1),deriv(1),n1)
call neuron1(L(1),n1)
! type 2 is as of now type 0 synonym
do j=n1+1,neu_out
deriv(j)=1.0D0
enddo
! terrible idea to do deriv(n1+1), it can (and will) overstep boundaries by 1
! call deriv2(deriv(n1+1),n2) !deriv2 is L-independent
! call neuron2(L(n1+1),n2)
! call deriv3(L(n1+n2+1),deriv(n1+n2+1),n3)
! call neuron3(L(n1+n2+1),n3)
end

277
src/geNNetic.f Normal file
View File

@ -0,0 +1,277 @@
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
! c
! PROGRAM GENETIC c
! c
! A program for non-linear fitting in multiple dimensions based on a c
! Marquardt-Levenberg non-linear least-squares fit and parameter c
! selection by a genetic algorithm c
! c
! Written by Wolfgang Eisfeld, Dec. 2002 c
! c
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
! c
! Version 1.0 c
! c
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!*****************************************************************************
!** ***
!** nstat: number of states ***
!** maxpout: maximum number of output values ***
! ***
!** pat_in: ***
!** pat_out: ***
! ***
!** wterr: Vector containing the individual weights of data points ***
!** par: Matrix containing the parameter vectors ***
!** npar: actual number of parameters ***
!** num: actual number of data points y ***
!** act: vector that selects which parameters are active ***
!** seed: integer to select random seed ***
!** nset: number of parameter sets ***
!** sets: number of data sets for plotting ***
!** ndata: contains the number of data points for each block for plot ***
!** par_spread: factor by which each parameter spreads around its centre ***
!** ***
!** Special UNIT values ***
!** 8xxx and above: automatically generated. DO NOT ASSIGN MANUALLY. ***
!*****************************************************************************
!** Structural ANN constants:
!**
!** laystr: layer structure matrix
!** laystr(1,N): number of neurons in layer N
!** laystr(2,N): starting pos. for layer N
!** laystr(3,N): starting pos. for weight matrix from layer N to N+1
!**
!** weistr: weight structure matrix
!** weistr(1,N,1): starting pos. of weight matrix N in memory (layer N to N+1)
! identical to laystr(3,N)
!** weistr(2,N,1): end pos. of weight matrix N in memory
!** weistr(1,N,2): starting pos. of bias vector of layer N in memory
!** weistr(2,N,2): end pos. of bias vector of layer N in memory
!**
!** typop: type population matrix
!**
!** nlay: number of given layers
!*****************************************************************************
program genetic
!use
use axel, only: renorm_input,unnorm_input
!use data_transf_mod, only: data_transform
use print_error, only: print_ErrorSummary
use nn_params
use nncommons
use io_parameters
use nndbg_mod
implicit none
!number of states and modes
!.....Genetic-specific variables
double precision, dimension(:,:), allocatable :: par
double precision, dimension(:), allocatable :: par_spread
double precision, dimension(:), allocatable :: rms,ref_rms
double precision, dimension(:,:), allocatable :: wterr
integer, dimension(:), allocatable :: act
integer seed, nset
logical freeze
logical lrnd
!.....ANN-specific variables
double precision, dimension(:,:), allocatable :: pat_in,pat_out
integer, dimension(:,:), allocatable :: laystr,typop
integer, dimension(:,:,:), allocatable :: weistr
integer nlay
!.....validation set for convergence testing
double precision, dimension(:,:), allocatable :: ref_in,ref_out
double precision rmsopt,mingrad,minwbstep
integer npat,nref
logical dry_run
integer init_rtype
integer tenptile
integer ntot
integer j
!include 'keylist.incl' !this defines all special input keys
!include 'errcat.incl' !this defines generic parser error messages
!.....(manual) allocation of all large arrays (prevents stack overflow)
allocate(par(wbcap,maxset))
allocate(par_spread(wbcap),rms(maxset), ref_rms(maxset))
allocate(wterr(maxpout,maxpats))
allocate(act(wbcap))
allocate(pat_in(maxnin,maxpats),pat_out(maxpout,maxpats))
allocate(laystr(3,maxlay),typop(maxtypes,maxlay))
allocate(weistr(2,maxlay,2))
allocate(ref_in(maxnin,maxpats),ref_out(maxpout,maxpats))
freeze=.false.
call nninit_mod()
if (dbg) write(6,'(A)') 'Reading input...'
!.. read input file and initialize data structures:
call read_input(wterr,par,act,seed,nset,
> par_spread,lrnd,dry_run,npat,nref,
> pat_in,pat_out,ref_in,ref_out,
> typop,laystr,weistr,nlay,
> rmsopt,mingrad,minwbstep,freeze)
if (dbg) write(6,'(A)') 'Input file read: OK'
!.. transform input
ntot=npat+nref
call trans_in(pat_in)
! NOTE: create API trans_out
!.. copy reference part
do j=1,nref
ref_in(:,j)=pat_in(:,npat+j)
enddo
! transform the data y
! call data_transform(pat_out,ref_out,ntot)
!.. generate normalization factors for network inputs
if (norm_inp) then
! If scales and shifts are given, preserve them, if not, generate
! new.
call renorm_input(pat_in,npat,pres_inp,
> par,laystr,weistr)
endif
if (freeze) then
write(6,'(A)') 'Parameters frozen. Skipping fit.'
endif
if (use_record.and.((record_state.eq.record_read)
> .or.(record_state.eq.record_update))) then
! instead of random parameter sets, use the record.
call read_record(par,weistr,nlay,nset)
else if (lrnd) then
! create initial nset random parameter sets:
write(6,'(A)') 'Generating initial parameter sets..'
if (freeze) then
init_rtype=3
else if (any(act(1:npar).eq.0)) then
write(6,'(A)') 'Inactive Parameters found, '
> // 'skipping parameter normalization.'
init_rtype=0
write(6,'(A)') 'ERROR: Individual freezing of parameters '
> // 'not implemented.'
stop 1
else
init_rtype=3
endif
do j=1,nset
call mkpars(par(1,j),par_spread,laystr,typop,weistr,
> nlay,init_rtype)
enddo
if (dbg) write(6,*) 'done.'
endif
if (dry_run) then
! DRYRUN:
write(6,'(A)') 'Running model...'
call NNerr(par,pat_in,pat_out,ref_in,ref_out,
> wterr,typop,laystr,weistr,nlay,
> rms(1),ref_rms(1),npat,nref)
write(6,'(A)') 'Done. Exiting..'
else if (.not.freeze) then
!.. train ANNs and move the best to the top.
call traiNNsets(nset,npat,nref,par,act,rms,ref_rms,
> pat_in,pat_out,ref_in,ref_out,
> wterr,
> typop,laystr,weistr,nlay,
> rmsopt,mingrad,minwbstep)
write(6,'(A)') 'Writing best parameters to ''' //
> trim(nnparfile) // ''' ...'
call punch_net(0,nnparfile,par,
> typop,laystr,weistr,nlay,.false.,.false.)
if (nset.gt.10) then
! evaluate 10th percentile position
tenptile=ceiling(0.1D0*dble(nset))
write(6,'(A)') 'Writing 10th percentile parameters to '''
> // trim(nnp10file) // ''' ...'
call punch_net(0,nnp10file,par(1,tenptile),
> typop,laystr,weistr,nlay,
> .false.,.false.)
endif
! generate plotfiles for the best result
call punch_fitscans(par,pat_in,pat_out,wterr,
> typop,laystr,weistr,
> nlay,walk_scan)
else
! RANDOM: and FREEZE: or
! FREEZE: only
if (dbg) then
write(6,asline)
write(6,'(A)') 'NEUPOP:'
write(6,miform) laystr(1,1:nlay)
write(6,'(A)') 'INSHIFT:'
write(6,mform) shift_in(1:laystr(1,1))
write(6,'(A)') 'INSCALE:'
write(6,mform) fact_in(1:laystr(1,1))
write(6,'(A)') 'FINAL W:'
write(6,mform) par(weistr(1,1,1):weistr(2,nlay-1,1),1)
write(6,'(A)') 'FINAL B:'
write(6,mform) par(weistr(1,2,2):weistr(2,nlay,2),1)
write(6,asline)
endif
call NNerr(par,pat_in,pat_out,ref_in,ref_out,
> wterr,typop,laystr,weistr,nlay,
> rms(1),ref_rms(1),npat,nref)
call NNstat(1,npat,nref,par,rms,ref_rms,
> pat_in,pat_out,ref_in,ref_out,
> typop,laystr,weistr,nlay,nntag)
call punch_fitscans(par,pat_in,pat_out,wterr,
> typop,laystr,weistr,
> nlay,walk_scan)
call punch_fitpoints(par,pat_in,pat_out,
> typop,laystr,weistr,nlay,npat,nndmpfile)
call punch_net(0,nnparfile,par,
> typop,laystr,weistr,nlay,.false.,.false.)
call punch_netdistrib(nnfdir,par,pat_in,typop,laystr,weistr,
> nlay,npat,nntag)
call print_ErrorSummary(par,pat_in,pat_out,ref_in,ref_out,
> wterr,typop,laystr,weistr,nlay,
> npat,nref)
endif
write(6,'(A)') 'Writing successful.'
deallocate(par)
deallocate(par_spread,rms, ref_rms)
deallocate(wterr)
deallocate(act)
deallocate(pat_in,pat_out)
deallocate(laystr,typop)
deallocate(weistr)
deallocate(ref_in,ref_out)
end

973
src/iNNterface.f Normal file
View File

@ -0,0 +1,973 @@
******************************************************************************
*** iNNterface
*** connecting ANN with genetic
*** by David Williams
*** & Jerome Collet
***
*** name(s) [synonyms or equivalents]
*** wertnum [npat]
*** q,x1 [pat_in]
*** y [pat_out]
*** par [W,B]
*** num [npat]
***
***
***
******************************************************************************
subroutine NNmin(npat,nref,par,act,rms,ref_rms,pat_in,pat_out,
> ref_in,ref_out,wterr,
> typop,laystr,weistr,nlay,rmsopt,
> mingrad,minwbstep,fit_id,skip)
use nn_params
use nncommons
use io_parameters
use nndbg_mod
implicit none
! Non-linear least-squares fitting using feed forward NN and
! Marquardt-Levenberg learning.
!
! fit_id: unique identifying integer for a given fit
!
! parnum: number of parameters
! par: Parameter vector containing all weights and biases
! (weights first, biases second). Weights are in the
! natural order of the memory:
! W1(1,1) W1(2,1) ... W1(1,2) ... W2(1,1) ...
! ... B1(1) B1(2) ... B2(1) ...
! these may be followed by further parameters
! *not* used by ANN.
! act: vector, indicating the active parameters
! rms: (weighted) root mean square
! ref_rms: rms of reference data
! skip: failure state on exit
!
!
! name [ANN-synonym]
!******************************************************************
! npat: number of given pattern pairs
! nref: number of reference patterns
! rms: (weighted) root mean square error
! rmsopt: error threshold
! mingrad: error gradient threshold
! minwbstep: threshold for wbnorm
!
! pat_in: input patterns
! pat_out: desired output patterns
! pat_*(i,N): value of ith in-/output neuron for pattern N
! ref_*: in analogy to pat_in/out for reference data
! (convergence tests)
!
! wterr: weight factors for each element of the error vector e
!
! wbsteps: Steps for weights and biases, same order as a single jacobian-row.
! mqpar: initial parameter (lambda) for Marquard-Levenberg
! mqfact: factor by which lambda is multiplied/divided after each iteration
!
! par [W]: weight matrix vector
! par [B]: bias vector
!
! common-block /ann/
!******************************************************************
! nlay: number of given layers
! typop: type population matrix
! laystr: layer structure matrix
! laystr(1,N): number of neurons in layer N
! laystr(2,N): starting pos. for layer N
! laystr(3,N): starting pos. for weight matrix from layer N to N+1
double precision par(wbcap)
double precision pat_in(maxnin,*),pat_out(maxpout,*)
double precision ref_in(maxnin,*),ref_out(maxnout,*)
double precision wterr(maxpout,maxpats)
double precision rms,ref_rms,rmsopt
double precision mingrad,minwbstep
integer laystr(3,maxlay),typop(maxtypes,maxlay)
integer weistr(2,maxlay,2)
integer nlay
integer npat,nref
integer act(wbcap)
integer fit_id
logical skip
double precision mqpar,mqfact
integer pos_out,inact_num
integer lay_end,wei_end,bi_pos,bi_end
integer funit
character*32 fname
integer k
pos_out=laystr(2,nlay)-1 !increment leading to output layer pos.
! total number of neurons / W-matrix elements
lay_end=pos_out+len_out
! total number of neurons / W-matrix elements in vector par
wei_end=weistr(2,nlay-1,1)
! starting position and end position of Bias vector in par
bi_pos=weistr(1,1,2)
bi_end=weistr(2,nlay,2)
if (dbg) write(6,*) 'NNmin entered'
if (dbg) write(6,*) 'NPAT:', npat
rms=infty
! initialize MQL-factor and parameter
mqpar=lambda_initial
mqfact=mqfact_default
! fits currently pattern pairs (x1,y)
if (all(act(1:bi_end).eq.0)) then
write(6,'(A)') 'Parameters frozen, skip to output'
return
else if (any(act(1:bi_end).eq.0)) then
write(6,'(A)') 'Some parameters set inactive'
inact_num=0
do k=1,bi_end
if (act(k).eq.0) then
inact_num=inact_num+1
endif
enddo
write(6,'(A,I5.5)') "Total inactive: ",inact_num
endif
if (ldbg) then
write(6,sline)
write(6,'(A)') 'W:'
write(6,mform) par(1:wei_end)
write(6,sline)
write(6,'(A)') 'B:'
write(6,mform) par(bi_pos:bi_end)
write(6,sline)
write(6,'(A)') 'TYPOP:'
do k=1,nlay
write(6,'(2I6,:)') typop(1:2,k)
enddo
write(6,sline)
write(6,*)
write(6,'(A)') 'X,Y'
do k=1,npat
write(unit=6,advance='no',fmt='(A2,1000(ES14.6,:))') 'X:',
> pat_in(1:len_in,k)
write(6,'(A3,1000(ES14.6,:))') ' Y:', pat_out(1:inp_out,k)
enddo
write(6,asline)
write(6,'(A)') 'Entering nnmqo..'
endif
! W , B
call nnmarq(rms,ref_rms,mqpar,mqfact,par,par(bi_pos),act,
> wterr,pat_in,pat_out,ref_in,ref_out,
> typop,laystr,weistr,nlay,
> rmsopt,npat,nref,mingrad,minwbstep,fit_id,skip)
if (rats) then
funit=fitunit+fit_id
fname=trim(nnfdir) // '.fit_'
write(fname,'(A,I5.5)') trim(fname), fit_id
call punch_net(funit,fname,par,
> typop,laystr,weistr,nlay,.false.,.true.)
endif
end subroutine
!--------------------------------------------------------------------------------------
subroutine neunet(x,y,par,typop,laystr,weistr,nlay)
use axel, only: init_input
use nn_params
use nncommons
implicit none
! Wrapper for ANN's propagate
!
! y: neural network output value(s)
! x: input coordinate set
! par: Parameter vector containing all weights and biases
! (weights first, biases second). Weights are in the
! natural order of the memory:
! W1(1,1) W1(2,1) ... W1(1,2) ... W2(1,1) ...
!
! nlay: number of given layers (in common block /ann/)
!
! L: layer vector
! deriv: activation function derivatives (currently discarded)
! typop: type population matrix (in common black /ann/)
! laystr: layer structure matrix (in common block /ann/)
!
! laystr(1,N): number of neurons in layer N
! laystr(2,N): starting pos. for layer N
! laystr(3,N): starting pos. for Weight Matrix from layer N to N+1
double precision y(maxnout),x(maxnin),par(wbcap)
integer laystr(3,maxlay),typop(maxtypes,maxlay)
integer weistr(2,maxlay,2)
integer nlay
double precision L(neucap)
double precision deriv(neucap)
integer wei_end,lay_end
integer pos_out
integer bi_pos,bi_end
pos_out=laystr(2,nlay)-1 !increment leading to output layer pos.
! total number of neurons / W-matrix elements
lay_end=pos_out+len_out
wei_end=weistr(2,nlay-1,1)
! starting position and end position of Bias vector in par
bi_pos=weistr(1,1,2)
bi_end=weistr(2,nlay,2)
! write coordinate values on input neurons
call init_input(L,x,shift_in,fact_in,len_in)
call propagate(par(1),par(bi_pos),L,deriv,typop,laystr,nlay)
! write output on y
y(1:len_out)=L(pos_out+1:pos_out+len_out)
end subroutine
!--------------------------------------------------------------------------------------
subroutine neunet_full(x,L,deriv,par,typop,laystr,weistr,nlay)
use axel, only: init_input
use nn_params
use nncommons
implicit none
! Wrapper for ANN's propagate, containing all outputs
!
! x: input coordinate set
! par: Parameter vector containing all weights and biases
! (weights first, biases second). Weights are in the
! natural order of the memory:
! W1(1,1) W1(2,1) ... W1(1,2) ... W2(1,1) ...
!
! nlay: number of given layers (in common block /ann/)
!
! L: layer vector
! deriv: activation function derivatives (currently discarded)
! typop: type population matrix (in common black /ann/)
! laystr: layer structure matrix (in common block /ann/)
!
! laystr(1,N): number of neurons in layer N
! laystr(2,N): starting pos. for layer N
! laystr(3,N): starting pos. for Weight Matrix from layer N to N+1
double precision x(maxnin),par(wbcap)
double precision L(neucap)
double precision deriv(neucap)
integer laystr(3,maxlay),typop(maxtypes,maxlay)
integer weistr(2,maxlay,2)
integer nlay
integer wei_end,lay_end
integer pos_out
integer bi_pos,bi_end
pos_out=laystr(2,nlay)-1 !increment leading to output layer pos.
! total number of neurons / W-matrix elements
lay_end=pos_out+len_out
wei_end=weistr(2,nlay-1,1)
! starting position and end position of Bias vector in par
bi_pos=weistr(1,1,2)
bi_end=weistr(2,nlay,2)
! write coordinate values on input neurons
call init_input(L,x,shift_in,fact_in,len_in)
call propagate(par(1),par(bi_pos),L,deriv,typop,laystr,nlay)
end subroutine
!--------------------------------------------------------------------------------------
subroutine traiNNsets(nset,npat,nref,par,act,rms,ref_rms,
> pat_in,pat_out,ref_in,ref_out,
> wterr,
> typop,laystr,weistr,nlay,
> rmsopt,mingrad,minwbstep)
use print_error, only: print_ErrorSummary
use nn_params
use nncommons
use io_parameters
use nndbg_mod
implicit none
! Uses NNmin to train all nset initialized neural networks using NNmin.
! The first parameterset will be overwritten with the ANN yielding the
! smallest rms. Remaining sets will be sorted in ascending order.
!
! par: Parameter vector containing all weights and biases
! (weights first, biases second). Weights are in the
! natural order of the memory:
! W1(1,1) W1(2,1) ... W1(1,2) ... W2(1,1) ...
! ... B1(1) B1(2) ... B2(1) ...
! these may be followed by further parameters
! *not* used by ANN.
! act: vector, indicating the active parameters
! rms: (weighted) root mean square for each parameter set.
! rms(1): best rms achieved, overwrites set #1.
! rms(n): final rms of set #n.
! ref_rms: rms of reference data
!
!
! name [ANN-synonym]
!******************************************************************
! nset: number of ANNs to be optimized.
! npat: number of given pattern pairs
! nref: number of reference patterns
! rms: (weighted) root mean square error
! rmsopt: error threshold
! mingrad: error gradient threshold
! minwbstep: threshold for wbnorm
!
! pat_in: input patterns
! pat_out: desired output patterns
! pat_*(i,N): value of ith in-/output neuron for pattern N
! ref_*: in analogy to pat_in/out for reference data
! (convergence tests)
!
! wterr: weight factors for each element of the error vector e
!
! wbsteps: Steps for weights and biases, same order as a single jacobian-row.
! mqpar: initial parameter (lambda) for Marquard-Levenberg
! mqfact: factor by which lambda is multiplied/divided after each iteration
!
! par [W]: weight matrix vector
! par [B]: bias vector
!
double precision par(wbcap,maxset),rms(maxset),ref_rms(maxset)
double precision wterr(maxpout,maxpats)
double precision pat_in(maxnin,*),pat_out(maxpout,*)
double precision ref_in(maxnin,*),ref_out(maxnout,*)
double precision rmsopt,mingrad,minwbstep
integer laystr(3,maxlay),typop(maxtypes,maxlay)
integer weistr(2,maxlay,2)
integer nlay
integer act(wbcap)
integer nset,nref,npat
integer wei_end, bi_pos, bi_end
double precision loc_par(wbcap),loc_rms,loc_ref_rms
logical loc_skip
integer i,k
if (rats) then
! create logfile
open(unit=perfunit,file=trim(perfile),status='REPLACE')
write(perfunit,'(A)') '# UNIT: ' // trim(unit_string)
write(unit=perfunit,fmt='("#",A9,3A10,A17,A10)') 'RMS',
> 'RMS(REF)', 'WBNORM','GRADNORM', 'UPDATE/IT.',
> 'FIT#'
endif
! total number of neurons / W-matrix elements in vector par
wei_end=weistr(2,nlay-1,1)
! starting position and end position of Bias vector in par
bi_pos=weistr(1,1,2)
bi_end=weistr(2,nlay,2)
if (mprun) write(6,asline)
! initialize rms to impossible value
rms(1:nset)=-1.0d0
ref_rms(1:nset)=-1.0d0
if ((from_fit.gt.1).or.(to_fit.lt.nset)) then
write(6,'(A)') 'Detected continuation.'
write(6,'(A,ES10.2)') 'Setting all undefined RMS values to:',
> infty
do i=1,from_fit-1
rms(i)=infty
ref_rms(i)=infty
enddo
do i=to_fit+1,nset
rms(i)=infty
ref_rms(i)=infty
enddo
endif
!$omp parallel do default(shared) private(i,loc_par,loc_rms,
!$omp& loc_ref_rms,loc_skip)
!$omp& schedule(dynamic)
do i=from_fit, to_fit
if (.not.mprun) write(6,asline)
write(6,'(A,I4.4,A)')'Neural Network #',i,': Start!'
! make a local copy of current parameter set
do k=1,bi_end
loc_par(k)=par(k,i)
enddo
! initialize failure state
loc_skip=.false.
! train ANN with ith parameter set
call NNmin(npat,nref,loc_par,act,loc_rms,loc_ref_rms,pat_in,
> pat_out,ref_in,ref_out,
> wterr,typop,laystr,weistr,nlay,
> rmsopt,mingrad,minwbstep,i,loc_skip)
if (.not.loc_skip) then
write(6,'("Final rms:",ES21.14,X,"Validation rms:",
> ES21.14,X,A,"(#",I4.4,")")')
> loc_rms*unit_con,loc_ref_rms*unit_con,
> unit_string,i
! return optimized values to global data structures.
par(:,i)=loc_par
rms(i)=loc_rms
ref_rms(i)=loc_ref_rms
else
rms=infty
ref_rms=infty
endif
enddo
!$omp end parallel do
if (rats) then
close(unit=perfunit)
endif
if (use_record) then
write(6,sline)
if (record_state.eq.record_write) then
call punch_record(par,weistr,nlay,nset,.true.)
else if (record_state.eq.record_overwrite) then
call punch_record(par,weistr,nlay,nset,.false.)
else if (record_state.eq.record_update) then
call punch_record(par,weistr,nlay,nset,.false.)
endif
endif
write(6,newline)
write(6,asline)
write(6,'(A)') 'Training complete.'
! sort parameter sets
call NNrank(nset,nref,par,rms,ref_rms)
call NNstat(nset,npat,nref,par,rms,ref_rms,
> pat_in,pat_out,ref_in,ref_out,
> typop,laystr,weistr,nlay,nntag)
call print_ErrorSummary(par,pat_in,pat_out,ref_in,ref_out,
> wterr,typop,laystr,weistr,nlay,
> npat,nref)
write(6,'(/,A)') 'Done.'
end subroutine
!--------------------------------------------------------------------------------------
subroutine NNrank(nset,nref,par,rms,ref_rms)
use nn_params
use nncommons
use io_parameters
use nndbg_mod
implicit none
! Sorts the parameter sets from best to worst, as well as the
! corresponding rms and ref_rms values. Prints an excerpt from the
! resulting ranking.
!
! nset: number of optimized ANNs
! nref: number of reference patterns
! rms: (weighted) root mean square errors
! ref_rms: (weighted) root mean square errors of validation set
! tenptile: position of the 10th percentile
double precision par(wbcap,nset),rms(nset),ref_rms(nset)
integer nset,nref
double precision, dimension(:,:), allocatable :: par_copy
double precision rms_copy(nset),ref_copy(nset)
integer rms_pos(nset)
integer tenptile,rank_end
double precision rms_avrg,ref_avrg
integer k
allocate(par_copy(wbcap,nset))
tenptile=ceiling(0.1D0*dble(nset))
rms_copy=0.0d0
! create copy of rms-vector to be sorted
do k=1,nset
par_copy(:,k)=par(:,k)
rms_copy(k)=rms(k)
ref_copy(k)=ref_rms(k)
rms_pos(k)=k
enddo
! rank individual trained NNs by rms error.
write(6,'(A)') 'Searching for best fit..'
call dqsort2(nset,rms_copy,rms_pos)
write(6,'(A,ES21.4,X,A)') 'Best rms found:', rms_copy(1)*unit_con,
> trim(unit_string)
if (nref.gt.0) then
write(6,'(A,ES21.4,X,A)') 'Reference rms: ',
> ref_rms(rms_pos(1))*unit_con,
> trim(unit_string)
! produce easy-to-grep rms summary
write(6,'(A,ES12.4,X,A,X,"(",ES14.4,X,A,")")') 'RESULT:',
> rms_copy(1)*unit_con, trim(unit_string),
> ref_rms(rms_pos(1))*unit_con, trim(unit_string)
else
write(6,'(A,ES12.4,X,A)') 'RESULT:',
> rms_copy(1)*unit_con, trim(unit_string)
endif
write(6,sline)
if (dbg) then
write(6,'(/,A)') 'Ranking errors:'
rank_end=nset
else
write(6,'(/,A,/)') 'Ranking errors (top 10%):'
rank_end=tenptile
endif
write(6,'(A15,2A12)') 'FIT#','RMS ['//trim(unit_string)//']',
> 'REF ['//trim(unit_string)//']'
rms_avrg=0.0D0
ref_avrg=0.0D0
do k=1,rank_end
write(6,'(I15,2ES12.4)') rms_pos(k),
> rms_copy(k)*unit_con, ref_rms(rms_pos(k))*unit_con
rms_avrg=rms_avrg + rms_copy(k)
ref_avrg=ref_avrg + ref_rms(rms_pos(k))
enddo
rms_avrg=rms_avrg/dble(rank_end)
ref_avrg=ref_avrg/dble(rank_end)
if (.not.dbg) then
write(6,hline)
write(6,'(A15,2ES12.4)') 'AVERAGE ['//trim(unit_string)//']:',
> rms_avrg*unit_con,ref_avrg*unit_con
endif
write(6,sline)
do k=1,nset
par(:,k)=par_copy(:,rms_pos(k))
rms(k)=rms_copy(k)
ref_rms(k)=ref_copy(rms_pos(k))
enddo
deallocate(par_copy)
end subroutine
!--------------------------------------------------------------------------------------
subroutine NNstat(nset,npat,nref,par,rms,ref_rms,
> pat_in,pat_out,ref_in,ref_out,
> typop,laystr,weistr,nlay,ftag)
use nn_params
use nncommons
use io_parameters
use nndbg_mod
implicit none
! Writes files presenting the distributions of error for the best
! fits, assuming par has already been sorted.
!
! nset: number of optimized ANNs
! npat: number of given pattern pairs
! npar: number of parameters
! nref: number of reference patterns
! rms: (weighted) root mean square errors
! ref_rms: (weighted) root mean square errors of validation set
! tenptile: position of the 10th percentile
! ftag: infix for generated filenames
!
double precision par(wbcap,maxset),rms(maxset),ref_rms(maxset)
double precision pat_in(maxnin,*),pat_out(maxpout,*)
double precision ref_in(maxnin,*),ref_out(maxnout,*)
integer laystr(3,maxlay),typop(maxtypes,maxlay)
integer weistr(2,maxlay,2)
integer nlay
character*8 ftag
integer nset,npat,nref
double precision, dimension(:), allocatable :: err_vec
double precision, dimension(:), allocatable :: ref_vec
double precision med, med_ref
integer med_pos(2), med_ref_pos(2)
integer tenptile,rank_end
character*64 fname
character*8 unit
integer k
allocate(err_vec(maxpats))
allocate(ref_vec(maxpats))
tenptile=ceiling(0.1D0*dble(nset))
rank_end=min(tenptile,1000)
unit = '[' // trim(unit_string) // ']'
write(6,'(A)') 'Generating error statistic..'
write(6,sline)
write(6,'(A15,6A12)') 'NETWORK#',
> 'RMS ' // trim(unit), 'MED. ' // trim(unit),
> 'MAX ' // trim(unit),
> 'REF ' // trim(unit), 'MED. ' // trim(unit),
> 'MAX ' // trim(unit)
if (1.eq.modulo(npat,2)) then
med_pos = (npat+1)/2
else
med_pos(1) = npat/2
med_pos(2) = med_pos(1) + 1
endif
if (nref.le.1) then
med_ref_pos = 1
else if (1.eq.modulo(nref,2)) then
med_ref_pos = (nref+1)/2
else
med_ref_pos(1) = nref/2
med_ref_pos(2) = med_ref_pos(1) + 1
endif
do k=1,rank_end
write(fname,'(A32)') ''
write(fname,'(I4.4)') k
fname = trim(nnfdir) // 'errors_' // trim(ftag)
> // trim(fname) // '.out'
call punch_fitstat(fname,par(1,k),pat_in,pat_out,err_vec,npat,
> typop,laystr,weistr,nlay,
> .false.)
! get median
med=0.5d0*(err_vec(med_pos(1))+err_vec(med_pos(2)))
if (nref.gt.0) then
open(nnunit,file=trim(fname),status='old',position='append')
write(nnunit,'(A)') ''
write(nnunit,asline)
write(nnunit,'(A)') '# REF:'
close(nnunit)
call punch_fitstat(fname,par(1,k),ref_in,ref_out,
> ref_vec,nref,
> typop,laystr,weistr,nlay,.true.)
else
ref_vec(1)=0.0d0
endif
! get median
if (nref.eq.0) then
med_ref=0.0d0
else
med_ref=0.5d0*(ref_vec(med_ref_pos(1))
> + ref_vec(med_ref_pos(2)))
endif
write(6,'(I15,6ES12.4)') k,
> rms(k)*unit_con, med*unit_con, err_vec(1)*unit_con,
> ref_rms(k)*unit_con, med_ref*unit_con, ref_vec(1)*unit_con
enddo
deallocate(err_vec)
deallocate(ref_vec)
end subroutine
!--------------------------------------------------------------------------------------
subroutine NNerr(par,pat_in,pat_out,ref_in,ref_out,
> wterr,
> typop,laystr,weistr,nlay,rms,ref_rms,npat,nref)
use nn_params
use nncommons
use io_parameters
use nndbg_mod
implicit none
! Evaluates error of given ANN using nnmqo's mkerr subroutine,
! and generates an output file.
double precision par(wbcap),wterr(maxpout,maxpats)
double precision pat_in(maxnin,*),pat_out(maxpout,*)
double precision ref_in(maxnin,*),ref_out(maxpout,*)
double precision rms,ref_rms
integer laystr(3,maxlay),typop(maxtypes,maxlay)
integer weistr(2,maxlay,2)
integer nlay
integer npat,nref
integer wei_end,bi_pos,bi_end
! total number of neurons / W-matrix elements in vector par
wei_end=weistr(2,nlay-1,1)
! starting position and end position of Bias vector in par
bi_pos=weistr(1,1,2)
bi_end=weistr(2,nlay,2)
! W, B
call mkerr(par(1),par(bi_pos),wterr,rms,
> pat_in,pat_out,
> typop,laystr,nlay,npat)
write(6,newline)
write(6,asline)
write(6,400) rms*unit_con, trim(unit_string)
if (nref.gt.0) then
call mkerr(par(1),par(bi_pos),wterr(1,npat+1),ref_rms,
> ref_in,ref_out,
> typop,laystr,nlay,nref)
write(6,401) ref_rms*unit_con, trim(unit_string)
else
write(6,403) rms*unit_con, trim(unit_string)
endif
! produce easy-to-grep rms summary
write(6,402) rms*unit_con, trim(unit_string),
> ref_rms*unit_con, trim(unit_string)
write(6,sline)
400 format('RMS of given data and parameter set:',ES12.4,X,A)
401 format('VALIDATION-RMS:',ES12.4,X,A)
402 format('RESULT:',ES12.4,X,A,X,'(',ES12.4,X,A,')')
403 format('RESULT:',ES12.4,X,A)
if (showcut) then
call NNcuterr(par,pat_in,pat_out,npat,
> typop,laystr,weistr,
> nlay)
endif
end subroutine
!--------------------------------------------------------------------------------------
subroutine NNerrvec(par,pat_err,pat_in,pat_out,
> typop,laystr,weistr,nlay)
use nn_params
use nncommons
use io_parameters
use nndbg_mod
implicit none
! Evaluates error vector of given ANN for a *single* pattern using
! nnmqo's mkerrvec subroutine.
double precision par(wbcap)
double precision pat_in(maxnin,*),pat_out(maxpout,*)
double precision pat_err(maxpout)
integer laystr(3,maxlay),typop(maxtypes,maxlay)
integer weistr(2,maxlay,2)
integer nlay
integer wei_end,bi_pos,bi_end
! total number of neurons / W-matrix elements in vector par
wei_end=weistr(2,nlay-1,1)
! starting position and end position of Bias vector in par
bi_pos=weistr(1,1,2)
bi_end=weistr(2,nlay,2)
! W, B
call mkerrvec(par(1),par(bi_pos),pat_err,pat_in,pat_out,
> typop,laystr,nlay)
end subroutine
!--------------------------------------------------------------------------------------
subroutine NNkeygen(nnkeylist,nnkeynum,nlay,force)
use nn_params
use io_parameters
use nndbg_mod
implicit none
! Automatically generate a key list for parsing ANN parameters.
! Force, if true, will make the W(*,*) and B(*) keys mandatory.
!
!.....Keys generated are:
! W(i,i+1): B(i):
! where i=01,02,...
integer nlay
integer nnkeynum
character*(klen) nnkeylist(2,maxnnkeys)
logical force
integer j
nnkeylist=' '
! To utilize the standard keyread utilities, we need the key
! signalizing the EOF
nnkeylist(1,1)='DATA:'
nnkeylist(2,1)='E!'
nnkeynum=1
! Next, we generate all standard weight and bias keys
! Weights first
do j=1,nlay-1
nnkeynum=nnkeynum+1
! keys for weight matrix elements (layer j->j+1)
write(nnkeylist(1,nnkeynum)(1:10),
> '("W(",I2.2,",",I2.2,"):")') j,j+1
! expects: arbitrary number of reals
if (force) then
nnkeylist(2,nnkeynum)='D!N'
else
nnkeylist(2,nnkeynum)='DN'
endif
enddo
! Biases next
do j=1,nlay-1
nnkeynum=nnkeynum+1
! keys for bias vector (layer j+1)
write(nnkeylist(1,nnkeynum)(1:7),
> '("B(",I2.2,"):")') j+1
! expects: arbitrary number of reals
if (force) then
nnkeylist(2,nnkeynum)='D!N'
else
nnkeylist(2,nnkeynum)='DN'
endif
enddo
! Weight spreads
do j=1,nlay-1
nnkeynum=nnkeynum+1
write(nnkeylist(1,nnkeynum)(1:10),
> '("SW(",I2.2,",",I2.2,"):")') j,j+1
! expects: one positive real
nnkeylist(2,nnkeynum)='+D1'
enddo
! Bias spreads
do j=1,nlay-1
nnkeynum=nnkeynum+1
write(nnkeylist(1,nnkeynum)(1:7),
> '("SB(",I2.2,"):")') j+1
! expects: one positive real
nnkeylist(2,nnkeynum)='+D1'
enddo
end subroutine
!--------------------------------------------------------------------------------------
subroutine NNcuterr(par,pat_in,pat_out,npat,
> typop,laystr,weistr,
> nlay)
use nn_params
use nncommons
use io_parameters
use nndbg_mod
implicit none
! Subroutine providing rms error of all output pattern entries which
! lie below a fixed cutoff threshold provided by common block
! variable cutoff.
!
! pat_in: input patterns
! pat_out: desired output patterns
! npat: number of given pattern pairs
! inp_in: number of coordinates written into input.
! inp_out: number of values written to output
!
integer npat
double precision par(wbcap)
double precision pat_in(maxnin,*),pat_out(maxpout,*)
integer laystr(3,maxlay),typop(maxtypes,maxlay)
integer weistr(2,maxlay,2)
integer nlay
integer fmtlen
parameter (fmtlen=16)
character*(fmtlen) intfmt,dblefmt
parameter (intfmt='(I8)',dblefmt='(ES14.2)')
double precision pat_err(maxpout),rms_vec(maxpout)
double precision cut_rms,cut_norm
integer err_count(maxpout)
integer n,j
rms_vec=0.0d0
cut_rms=0.0d0
cut_norm=0.0d0
err_count=0
write(6,'(A)') 'Calculating cutoff-rms..'
! accumulate errors sorted by corresponding output
do n=1,npat
call NNerrvec(par,pat_err,pat_in(1,n),pat_out(1,n),
> typop,laystr,weistr,nlay)
! count only errors actually contributing to cutoff-rms
do j=1,inp_out
if (pat_out(j,n).le.cutoff(j)) then
rms_vec(j)=rms_vec(j)+pat_err(j)**2
err_count(j)=err_count(j)+1
endif
enddo
enddo
! calculate rms-errors
do j=1,inp_out
if (err_count(j).le.0) then
write(6,'(A,I3.3)') 'WARNING: NO OUTPUT FOUND WITHIN'
> // ' CUTOFF FOR OUTPUT VALUE #',j
rms_vec(j)=-1.0d0
else
cut_rms=cut_rms+rms_vec(j)*cutwei(j)
cut_norm=cut_norm+cutwei(j)*dble(err_count(j))
rms_vec(j)=dsqrt(rms_vec(j)/dble(err_count(j)))*unit_con
endif
enddo
if (all(err_count(1:inp_out).le.0)) then
write(6,'(A)') 'WARNING: NO PATTERN WITHIN CUTOFF RANGE(S).'
else
cut_rms=dsqrt(cut_rms/cut_norm)*unit_con
endif
write(6,'(A)') 'Number of outputs within cutoff range:'
call printivec_full(err_count,intfmt,fmtlen,inp_out,5)
write(6,'(A)') 'Individual unweighted RMS-errors ['//
> trim(unit_string)//']:'
call printvec_full(rms_vec,dblefmt,fmtlen,inp_out,5)
write(6,'(A,ES14.2)') 'Total cutoff-RMS ['
> //trim(unit_string)//']:',cut_rms
write(6,newline)
write(6,'(A)') '((RMS of -1 means undefined value))'
write(6,sline)
end subroutine

15
src/io_parameters.f90 Normal file
View File

@ -0,0 +1,15 @@
module io_parameters
use accuracy_constants, only: dp,idp
implicit none
private :: dp, idp
integer(idp),parameter:: dnlen = 8192,maxlines = 300000
integer(idp),parameter:: llen = 750, klen = 32
integer(idp),parameter:: maxkeys = 200
integer(idp),parameter:: maxdat = 10000, clen = 1024
integer(idp),parameter:: maxerrors=100
logical,parameter:: mprun = .true.
integer(idp),parameter:: nstat = 4,nmeta=20
integer(idp),parameter:: maxoutp = nstat+nmeta
END MODULE

153
src/lib/choldc.f Normal file
View File

@ -0,0 +1,153 @@
*** Implementation of cholesky decomposition as described in
!?*** (Add Book Info!)
subroutine choldcsol(A,b,x,n,np,err_stat)
implicit none
! Minimalistic interface to solve a set of linear equations using
! Cholesky decomposition. Like choldc and cholsl it destroys
! Matrix A in the process.
!
! The linear equation is assumed to have the form
! A x = b
!
! n: logical dimension of A
! np: physical dim. of A
!
! A,p: input matrix and diagonal elements
! b: input vector
! x: solution vector
! err_stat: failure state of choldcsol.
! set to true if fatal error occurs.
!
! dstat: real-valued output status of choldc.
! 1.0D0 if successful.
! dstat < 0.0D0 is a failure state where dstat is
! the found negative squared diagonal element of L.
integer np,n
double precision A(np,np),b(n),x(n)
logical err_stat
double precision dstat
double precision p(n)
! Solve A = L L^T
call choldc(A,n,np,p,dstat)
if (dstat.lt.0.0D0) then
write(6,'(A)') 'ERROR (choldcsol): '
> // 'MATRIX NOT POSITIVE DEFINITE'
write(6,'("OFFENDING VALUE:",ES11.2)') dstat
err_stat=.true.
return
endif
! Solve A x = b
call cholsl(A,n,np,p,b,x)
end
!--------------------------------------------------------------------------------------
subroutine choldc(A,n,np,p,dstat)
implicit none
! Given a positive-definite symmetric matrix A(1:n,1:n) with
! physical dimension np this routine constructs its Cholesky
! decomposition A = L L^T. On input, only the upper triangle
! of A need be given; it is not modified. The Cholesky factor L
! is returned in the lower triangle of A, except for it's
! diagonal elements which are returned in p(1:n).
!
! Pivoting is not required due to the method's numerical stability.
!
! n: logical dimension of A
! np: physical dim. of A
! dstat: real-valued output status on exit
! 1.0D0 if successful.
! dstat < 0.0D0 is a failure state where dstat is
! the found negative squared diagonal element of L.
! (not yet implemented)
!
! A: positive-definite symmetric matrix
! A(j,i): elements to be overwritten with L(j,i) iff j<i
! p: diagonal elements L(i,i)
!
integer np,n
double precision A(np,np),p(n),dstat
double precision zero
double precision sum
integer i,j,k
parameter (zero=1.0D-10)
dstat=1.0D0
do i=1,n
! A is symmetric, only regard j>=i.
do j=i,n
sum=A(i,j)
do k=i-1,1,-1
sum=sum - A(i,k)*A(j,k)
enddo
if (i.eq.j) then
if (sum.le.zero) then
! if A including rounding is not
! positive definite, stop
dstat=sum
return
endif
p(i)=dsqrt(sum)
else
A(j,i)=sum/p(i)
endif
enddo
enddo
end
!--------------------------------------------------------------------------------------
subroutine cholsl(A,n,np,p,b,x)
implicit none
! Solves a set of n linear equations A x = b, where A is
! a positive-definite symmetric matrix with physical dimension np.
! A and p are input as the output of the routine choldc.
! Only the lower triangle of A is accessed. b(1:n) is input as
! the right-hand side vector. The solution vector is returned
! in x(1:n). A,n,np and p are not modified ans can be left in place
! for successive calls with different right-hand sides b.
! b is not modified unless you identify b and x in in the calling
! sequence, which is allowed.
!
! n: logical dimension of A
! np: physical dim. of A
!
! A,p: input matrix and diagonal elements
! b: input vector
! x: solution vector
integer n,np
double precision A(np,np),b(n),p(n),x(n)
integer i,k
double precision sum
! Solve L y = b, storing y in x.
do i=1,n
sum=b(i)
do k=i-1,1,-1
sum=sum - A(i,k)*x(k)
enddo
x(i)=sum/p(i)
enddo
! Solve L^T x = y.
do i=n,1,-1
sum=x(i)
do k=i+1,n
sum=sum - A(k,i)*x(k)
enddo
x(i)=sum/p(i)
enddo
end

102
src/lib/diag.f Normal file
View File

@ -0,0 +1,102 @@
subroutine ddiag(matrix,E,U,pdim,mdim)
implicit none
! Diagonalization wrapper: double precision matrix diagonalization.
!
! Physical dimension of array
integer, intent(in) :: pdim
! Order of the matrix.
integer, intent(in) :: mdim
! Matrix
double precision, intent(in) :: matrix(pdim,mdim)
! Eigenvalues & Eigenvectors
double precision, intent(out) :: E(mdim)
double precision, intent(out) :: U(pdim,mdim)
! lapack variables
integer,parameter :: lwork = 1000 ! ~300x300 matrices
double precision work(lwork)
double precision avrg
integer info
integer j
! Compute barycenter tr(M)/mdim
avrg=0
do j=1,mdim
avrg=avrg+matrix(j,j)
enddo
avrg=avrg/dble(mdim)
U=matrix
do j=1,mdim
U(j,j)=U(j,j)-avrg
enddo
call dsyev('V','U',mdim,U,pdim,E,work,lwork,info)
E=E+avrg
if (info.gt.0) then
write(6,100) info
else if (info.lt.0) then
write(6,101) -info
stop 1
endif
100 format("WARNING: DDIAG: Failed to converge ",I0,
> " diagonal elements")
101 format("ERROR: DDIAG: Invalid argument, argument #",I0)
end subroutine
!-------------------------------------------------------------------------------
subroutine deigen(matrix,E,mdim)
implicit none
! Diagonalization wrapper: double precision matrix diagonalization.
!
! Order of the matrix. Assumed to be physical dimension.
integer, intent(in) :: mdim
! Matrix
double precision, intent(in) :: matrix(mdim,mdim)
! Eigenvalues only
double precision, intent(out) :: E(mdim)
! lapack variables
integer,parameter :: lwork = 1000
double precision work(lwork)
double precision :: U(mdim,mdim)
double precision avrg
integer info
integer j
! Compute barycenter tr(M)/mdim
avrg=0
do j=1,mdim
avrg=avrg+matrix(j,j)
enddo
avrg=avrg/dble(mdim)
U=matrix
do j=1,mdim
U(j,j)=U(j,j)-avrg
enddo
call dsyev('N','U',mdim,U,mdim,E,work,lwork,info)
E=E+avrg
if (info.gt.0) then
write(6,100) info
else if (info.lt.0) then
write(6,101) -info
stop 1
endif
100 format("WARNING: DEIGEN: Failed to converge ",I0,
> " diagonal elements")
101 format("ERROR: DEIGEN: Invalid argument, argument #",I0)
end subroutine

530
src/lib/dmatrix.f Normal file
View File

@ -0,0 +1,530 @@
************************************************************************
*** dmatrix
*** generic double precision matrix operations
***
************************************************************************
subroutine permutemat(oldmat,newmat,perm_row,perm_col,nrow,ncol)
implicit none
! Allows to perform arbitrary permutations of row- and column
! entries of the matrix (corresponding to permutations of the
! underlying basis sets).
!
! Permutations are symbolized as integer vectors. They should
! contain each number from 1 to nrow/ncol in the desired new order,
! 1 meaning the originally first entry etc.
!
! (1,2,3,..) -Permutation-> (P(1),P(2),...)
!
! oldmat: matrix to be modified
! newmat: generated matrix
! nrow: dimension of row-vectors
! ncol: dimension of column vectors
! perm_*: permutation applied to row or column
!
integer nrow,ncol
integer perm_row(nrow),perm_col(ncol)
double precision oldmat(nrow,ncol),newmat(nrow,ncol)
integer j,k
! check validity of permutations (pidgeonhole principle)
do j=1,nrow
if (.not.any(perm_row.eq.j)) then
write(6,'(A)') 'ERROR: INVALID PERMUTATION'
> // ' VECTOR (permutemat)'
stop 1
endif
enddo
do j=1,ncol
if (.not.any(perm_col.eq.j)) then
write(6,'(A)') 'ERROR: INVALID PERMUTATION'
> // ' VECTOR (permutemat)'
stop 1
endif
enddo
do j=1,ncol
do k=1,nrow
newmat(k,j)=oldmat(perm_row(k),perm_col(j))
enddo
enddo
end
!--------------------------------------------------------------------------
subroutine rescalemat_out(mat,factors,nrow,ncol)
implicit none
! Rescale output of matrix mat in each dimension with the
! corresponding entry in factors. This is equivalent to multiplying
! an appropriate diagonal matrix from the lefthand side. The
! original matrix is destroyed in the process.
!
! mat: matrix to be scaled
! nrow_*: dimension of row-vector in matrix *mat (matrix input)
! ncol_*: dimension of column-vector in matrix *mat (matrix output)
integer nrow,ncol
double precision mat(nrow,ncol), factors(ncol)
integer j,k
do j=1,ncol
do k=1,nrow
mat(k,j)=mat(k,j)*factors(j)
enddo
enddo
end
!--------------------------------------------------------------------------
subroutine rescalemat_in(mat,factors,nrow,ncol)
implicit none
! Rescale input of matrix mat in each dimension with the
! corresponding entry in factors. This is equivalent to multiplying
! an appropriate diagonal matrix from the righthand side. The
! original matrix is destroyed in the process.
!
! mat: matrix to be scaled
! nrow_*: dimension of row-vector in matrix *mat (matrix input)
! ncol_*: dimension of column-vector in matrix *mat (matrix output)
integer nrow,ncol
double precision mat(nrow,ncol), factors(nrow)
integer j,k
do j=1,ncol
do k=1,nrow
mat(k,j)=mat(k,j)*factors(k)
enddo
enddo
end
!--------------------------------------------------------------------------
subroutine dmatvec(mat,vec_in,vec_out,nrow,ncol)
implicit none
! Multiply matrix vec with compatible vector vec_in, yielding
! vec_out.
!
! mat: matrix to be scaled
! vec_*: vectors as describe above
! nrow_*: dimension of row-vector in matrix *mat (matrix input)
! ncol_*: dimension of column-vector in matrix *mat (matrix output)
integer nrow,ncol
double precision mat(nrow,ncol), vec_in(nrow), vec_out(ncol)
integer j,k
vec_out=0.0d0
do j=1,ncol
do k=1,nrow
vec_out(j)=vec_out(j) + mat(k,j)*vec_in(k)
enddo
enddo
end
!--------------------------------------------------------------------------
subroutine shiftmat(mat,shift,nrow,ncol)
implicit none
! Add two identically dimensioned matrices mat and shift,
! overwriting mat.
!
! mat: matrix to which shift is added
! shift: addend
! nrow_*: dimension of row-vector in matrix *mat (matrix input)
! ncol_*: dimension of column-vector in matrix *mat (matrix output)
integer nrow,ncol
double precision mat(nrow,ncol), shift(nrow,ncol)
integer j,k
do j=1,ncol
do k=1,nrow
mat(k,j)=mat(k,j)+shift(k,j)
enddo
enddo
end
!--------------------------------------------------------------------------
subroutine phaselock_maxpos(vectors,vecdim,nvec,maxdim)
implicit none
! Normalizes phases of an array of vectors according to molpro standard,
! meaning that the value furthest from 0 is positive in each vector.
!
! vectors: matrix containing all vectors.
! vecdim: dimension of vectors
! nvec: number of vectors
! maxdim: physical vector dimension
integer vecdim,nvec,maxdim
double precision vectors(maxdim,nvec)
double precision maxelem,minelem
integer j
do j=1,nvec
maxelem=maxval(vectors(1:vecdim,j))
minelem=minval(vectors(1:vecdim,j))
if (dabs(minelem).gt.maxelem) then
vectors(1:vecdim,j)=-vectors(1:vecdim,j)
endif
enddo
end
!--------------------------------------------------------------------------
subroutine orderlock_maxolap(vectors,ref_vectors,vecdim,
> nvec,maxdim)
implicit none
! Normalizes the order of an array of vectors such that
! similar vectors appear in similar positions.
! The first reference vector takes priority over the second,
! the 2nd over the 3rd etc.
! vectors: matrix containing all vectors.
! ref_vectors: reference vector set
! vecdim: dimension of vectors
! nvec: number of vectors
! maxdim: physical vector dimension
integer vecdim,nvec,maxdim
double precision vectors(maxdim,nvec),ref_vectors(maxdim,nvec)
double precision olap, maxolap
double precision swap(maxdim)
integer best
integer j,k
do j=1,nvec
! find the vector most similar to reference, using scalar products
maxolap=0.0D0
best=j
do k=j,nvec
! calculate overlap
olap=dabs(dot_product(vectors(1:vecdim,k),
> ref_vectors(1:vecdim,j)))
if (olap.gt.maxolap) then
! update best overlap and mark vector
maxolap=olap
best=k
endif
enddo
! swap places of vectors accordingly
swap=vectors(:,j)
vectors(:,j)=vectors(:,best)
vectors(:,best)=swap
enddo
end
!--------------------------------------------------------------------------
subroutine phaselock_maxolap(vectors,ref_vectors,vecdim,
> nvec,maxdim)
implicit none
! Normalizes phases of an array of vectors such that scalar products
! of corresponding reference vectors are always non-negative.
! vectors: matrix containing all vectors.
! ref_vectors: reference vector set
! vecdim: dimension of vectors
! nvec: number of vectors
! maxdim: physical vector dimension
integer vecdim,nvec,maxdim
double precision vectors(maxdim,nvec),ref_vectors(maxdim,nvec)
double precision olap
integer j
do j=1,nvec
! calculate overlap
olap=dot_product(vectors(1:vecdim,j),
> ref_vectors(1:vecdim,j))
if (olap.lt.0.0D0) then
vectors(1:vecdim,j) = -1.0D0*vectors(1:vecdim,j)
endif
enddo
end
!--------------------------------------------------------------------------
subroutine safe_average(points,avrg,dim,maxdim,npoints)
implicit none
! Generates the average over a set of dim-dimensional vectors in a
! safe fashion using Kahan Summation.
!
! maxdim: physical dimension of vectors
! dim: actual dimension of vectors
! npoints: number of vectors
! points: array of vectors of length (max)dim.
! avrg: final mean vector
!
integer maxdim
integer dim,npoints
double precision points(maxdim,*), avrg(maxdim)
double precision tmp(maxdim)
double precision norm
integer j,k
norm=dble(npoints)
tmp=0.0d0
avrg=0.0d0
do j=1,npoints
do k=1,dim
call KahanAdd(points(k,j),avrg(k),tmp(k))
enddo
enddo
do k=1,dim
avrg(k)=avrg(k)/norm
enddo
end
!--------------------------------------------------------------------------
subroutine safe_variance(points,avrg,var,dim,maxdim,npoints)
implicit none
! Generates the variance over a set of dim-dimensional vectors in a
! safe fashion using Kahan Summation.
!
! maxdim: physical dimension of vectors
! dim: actual dimension of vectors
! npoints: number of vectors
! points: array of vectors of length (max)dim.
! avrg: mean vector
! var: final variance vector
!
integer maxdim
integer dim,npoints
double precision points(maxdim,*), avrg(maxdim), var(maxdim)
double precision tmp(maxdim)
double precision norm
integer j,k
norm=dble(npoints)
tmp=0.0d0
var=0.0d0
do j=1,npoints
do k=1,dim
call KahanAdd((points(k,j)-avrg(k))**2,var(k),tmp(k))
enddo
enddo
do k=1,dim
var(k)=var(k)/norm
enddo
end
!--------------------------------------------------------------------------
subroutine KahanSum(terms,nterms,sum)
implicit none
! Sums over all nterms entries in the vector terms using Kahan Summation.
! It utilizes an algorithm recovering low-order digits of added terms
! Taken from Wikipedia.
! Algebraically, the variable corr should always be zero. Beware
! overly-aggressive optimizing compilers.
integer nterms
double precision terms(nterms)
double precision sum
double precision corr,tmp,newsum
integer j
sum=0.0d0
corr=0.0d0 ! A running compensation for lost low-order bits.
do j=1,nterms
tmp = terms(j) - corr ! try to add collected lost lower digit summations to sum
newsum = sum + tmp ! low-order digits of tmp are lost to summation
! cancels high-order part of tmp
! subtracting tmp recovers low part of the term
corr = (newsum - sum) - tmp
sum = newsum
enddo
end
!--------------------------------------------------------------------------
subroutine KahanAdd(term,sum,corr)
implicit none
! Add term to sum using Kahan Summation.
! It utilizes an algorithm recovering low-order digits of added terms
! Taken from Wikipedia.
! Algebraically, the variable corr should always be zero. Beware
! overly-aggressive optimizing compilers.
double precision term,sum,corr
double precision tmp,newsum
tmp = term - corr ! try to add collected lost lower digit summations to sum
newsum = sum + tmp ! low-order digits of tmp are lost to summation
! cancels high-order part of tmp
! subtracting tmp recovers low part of the term
corr = (newsum - sum) - tmp
sum = newsum
end
!--------------------------------------------------------------------------
subroutine writemat(funit,mat,matfmt,flen,nrow,ncol,
> nrow_print,ncol_print)
implicit none
! Write (submatrix of) matrix mat using format matfmt on each
! individual value to file unit funit.
!
! flen: length of format string
! mat: matrix to be printed
! nrow: dimension of row-vector in matrix mat (matrix input)
! ncol: dimension of column-vector in matrix mat (matrix output)
! *_print: dimensions of submatrix to be printed
integer flen,funit
integer nrow,ncol
integer nrow_print,ncol_print
double precision mat(nrow,ncol)
character*(flen) matfmt
integer j,k
if (nrow_print.gt.nrow) then
write(6,'(A)') 'ERROR: CANNOT PRINT BEYOND MATRIX WIDTH'
> // ' (printmat)'
stop 1
else if (ncol_print.gt.ncol) then
write(6,'(A)') 'ERROR: CANNOT PRINT BEYOND MATRIX HEIGHT'
> // ' (printmat)'
stop 1
endif
do j=1,ncol_print
do k=1,nrow_print
write(unit=funit,fmt=matfmt,advance='NO') mat(k,j)
enddo
write(funit,'()')
enddo
end
!--------------------------------------------------------------------------
subroutine printmat_full(mat,matfmt,flen,nrow,ncol)
implicit none
! Print matrix mat using format matfmt on each
! individual value.
!
! flen: length of format string
! mat: matrix to be printed
! nrow: dimension of row-vector in matrix mat (matrix input)
! ncol: dimension of column-vector in matrix mat (matrix output)
! *_print: dimensions of submatrix to be printed
integer flen
integer nrow,ncol
double precision mat(nrow,ncol)
character*(flen) matfmt
integer stdin
parameter (stdin=6)
call writemat(stdin,mat,matfmt,flen,nrow,ncol,nrow,ncol)
end
!--------------------------------------------------------------------------
subroutine writevec(funit,vec,vecfmt,flen,len,wraplen)
implicit none
! Write vector vec of length len in blocks of length wraplen.
!
! flen: length of format string
! mat: matrix to be printed
! nrow: dimension of row-vector in matrix mat (matrix input)
! ncol: dimension of column-vector in matrix mat (matrix output)
! *_print: dimensions of submatrix to be printed
integer flen,funit
integer len,wraplen
double precision vec(len)
character*(flen) vecfmt
integer wordcount
integer j
wordcount=0
do while (wordcount.lt.len)
do j=1,min(wraplen,len-wordcount)
wordcount=wordcount+1
write(unit=funit,fmt=vecfmt,advance='NO') vec(wordcount)
enddo
write(funit,'()')
enddo
end
!--------------------------------------------------------------------------
subroutine printvec_full(vec,vecfmt,flen,len,wraplen)
implicit none
! Print vector vec of length len in blocks of length wraplen.
!
! flen: length of format string
! mat: matrix to be printed
! nrow: dimension of row-vector in matrix mat (matrix input)
! ncol: dimension of column-vector in matrix mat (matrix output)
! *_print: dimensions of submatrix to be printed
integer flen
integer len,wraplen
double precision vec(len)
character*(flen) vecfmt
integer stdin
parameter (stdin=6)
call writevec(stdin,vec,vecfmt,flen,len,wraplen)
end

530
src/lib/dmatrix.f~ Normal file
View File

@ -0,0 +1,530 @@
************************************************************************
*** dmatrix
*** generic double precision matrix operations
***
************************************************************************
subroutine permutemat(oldmat,newmat,perm_row,perm_col,nrow,ncol)
implicit none
! Allows to perform arbitrary permutations of row- and column
! entries of the matrix (corresponding to permutations of the
! underlying basis sets).
!
! Permutations are symbolized as integer vectors. They should
! contain each number from 1 to nrow/ncol in the desired new order,
! 1 meaning the originally first entry etc.
!
! (1,2,3,..) -Permutation-> (P(1),P(2),...)
!
! oldmat: matrix to be modified
! newmat: generated matrix
! nrow: dimension of row-vectors
! ncol: dimension of column vectors
! perm_*: permutation applied to row or column
!
integer nrow,ncol
integer perm_row(nrow),perm_col(ncol)
double precision oldmat(nrow,ncol),newmat(nrow,ncol)
integer j,k
! check validity of permutations (pidgeonhole principle)
do j=1,nrow
if (.not.any(perm_row.eq.j)) then
write(6,'(A)') 'ERROR: INVALID PERMUTATION'
> // ' VECTOR (permutemat)'
stop 1
endif
enddo
do j=1,ncol
if (.not.any(perm_col.eq.j)) then
write(6,'(A)') 'ERROR: INVALID PERMUTATION'
> // ' VECTOR (permutemat)'
stop 1
endif
enddo
do j=1,ncol
do k=1,nrow
newmat(k,j)=oldmat(perm_row(k),perm_col(j))
enddo
enddo
end
!--------------------------------------------------------------------------
subroutine rescalemat_out(mat,factors,nrow,ncol)
implicit none
! Rescale output of matrix mat in each dimension with the
! corresponding entry in factors. This is equivalent to multiplying
! an appropriate diagonal matrix from the lefthand side. The
! original matrix is destroyed in the process.
!
! mat: matrix to be scaled
! nrow_*: dimension of row-vector in matrix *mat (matrix input)
! ncol_*: dimension of column-vector in matrix *mat (matrix output)
integer nrow,ncol
double precision mat(nrow,ncol), factors(ncol)
integer j,k
do j=1,ncol
do k=1,nrow
mat(k,j)=mat(k,j)*factors(j)
enddo
enddo
end
!--------------------------------------------------------------------------
subroutine rescalemat_in(mat,factors,nrow,ncol)
implicit none
! Rescale input of matrix mat in each dimension with the
! corresponding entry in factors. This is equivalent to multiplying
! an appropriate diagonal matrix from the righthand side. The
! original matrix is destroyed in the process.
!
! mat: matrix to be scaled
! nrow_*: dimension of row-vector in matrix *mat (matrix input)
! ncol_*: dimension of column-vector in matrix *mat (matrix output)
integer nrow,ncol
double precision mat(nrow,ncol), factors(nrow)
integer j,k
do j=1,ncol
do k=1,nrow
mat(k,j)=mat(k,j)*factors(k)
enddo
enddo
end
!--------------------------------------------------------------------------
subroutine dmatvec(mat,vec_in,vec_out,nrow,ncol)
implicit none
! Multiply matrix vec with compatible vector vec_in, yielding
! vec_out.
!
! mat: matrix to be scaled
! vec_*: vectors as describe above
! nrow_*: dimension of row-vector in matrix *mat (matrix input)
! ncol_*: dimension of column-vector in matrix *mat (matrix output)
integer nrow,ncol
double precision mat(nrow,ncol), vec_in(nrow), vec_out(ncol)
integer j,k
vec_out=0.0d0
do j=1,ncol
do k=1,nrow
vec_out(j)=vec_out(j) + mat(k,j)*vec_in(k)
enddo
enddo
end
!--------------------------------------------------------------------------
subroutine shiftmat(mat,shift,nrow,ncol)
implicit none
! Add two identically dimensioned matrices mat and shift,
! overwriting mat.
!
! mat: matrix to which shift is added
! shift: addend
! nrow_*: dimension of row-vector in matrix *mat (matrix input)
! ncol_*: dimension of column-vector in matrix *mat (matrix output)
integer nrow,ncol
double precision mat(nrow,ncol), shift(nrow,ncol)
integer j,k
do j=1,ncol
do k=1,nrow
mat(k,j)=mat(k,j)+shift(k,j)
enddo
enddo
end
!--------------------------------------------------------------------------
subroutine phaselock_maxpos(vectors,vecdim,nvec,maxdim)
implicit none
! Normalizes phases of an array of vectors according to molpro standard,
! meaning that the value furthest from 0 is positive in each vector.
!
! vectors: matrix containing all vectors.
! vecdim: dimension of vectors
! nvec: number of vectors
! maxdim: physical vector dimension
integer vecdim,nvec,maxdim
double precision vectors(maxdim,nvec)
double precision maxelem,minelem
integer j
do j=1,nvec
maxelem=maxval(vectors(1:vecdim,j))
minelem=minval(vectors(1:vecdim,j))
if (dabs(minelem).gt.maxelem) then
vectors(1:vecdim,j)=-vectors(1:vecdim,j)
endif
enddo
end
!--------------------------------------------------------------------------
subroutine orderlock_maxolap(vectors,ref_vectors,vecdim,
> nvec,maxdim)
implicit none
! Normalizes the order of an array of vectors such that
! similar vectors appear in similar positions.
! The first reference vector takes priority over the second,
! the 2nd over the 3rd etc.
! vectors: matrix containing all vectors.
! ref_vectors: reference vector set
! vecdim: dimension of vectors
! nvec: number of vectors
! maxdim: physical vector dimension
integer vecdim,nvec,maxdim
double precision vectors(maxdim,nvec),ref_vectors(maxdim,nvec)
double precision olap, maxolap
double precision swap(maxdim)
integer best
integer j,k
do j=1,nvec
! find the vector most similar to reference, using scalar products
maxolap=0.0D0
best=j
do k=j,nvec
! calculate overlap
olap=dabs(dot_product(vectors(1:vecdim,k),
> ref_vectors(1:vecdim,j)))
if (olap.gt.maxolap) then
! update best overlap and mark vector
maxolap=olap
best=k
endif
enddo
! swap places of vectors accordingly
swap=vectors(:,j)
vectors(:,j)=vectors(:,best)
vectors(:,best)=swap
enddo
end
!--------------------------------------------------------------------------
subroutine phaselock_maxolap(vectors,ref_vectors,vecdim,
> nvec,maxdim)
implicit none
! Normalizes phases of an array of vectors such that scalar products
! of corresponding reference vectors are always non-negative.
! vectors: matrix containing all vectors.
! ref_vectors: reference vector set
! vecdim: dimension of vectors
! nvec: number of vectors
! maxdim: physical vector dimension
integer vecdim,nvec,maxdim
double precision vectors(maxdim,nvec),ref_vectors(maxdim,nvec)
double precision olap
integer j
do j=1,nvec
! calculate overlap
olap=dot_product(vectors(1:vecdim,j),
> ref_vectors(1:vecdim,j))
if (olap.lt.0.0D0) then
vectors(1:vecdim,j) = -1.0D0*vectors(1:vecdim,j)
endif
enddo
end
!--------------------------------------------------------------------------
subroutine safe_average(points,avrg,dim,maxdim,npoints)
implicit none
! Generates the average over a set of dim-dimensional vectors in a
! safe fashion using Kahan Summation.
!
! maxdim: physical dimension of vectors
! dim: actual dimension of vectors
! npoints: number of vectors
! points: array of vectors of length (max)dim.
! avrg: final mean vector
!
integer maxdim
integer dim,npoints
double precision points(maxdim,*), avrg(maxdim)
double precision tmp(maxdim)
double precision norm
integer j,k
norm=dble(npoints)
tmp=0.0d0
avrg=0.0d0
do j=1,npoints
do k=1,dim
call KahanAdd(points(k,j),avrg(k),tmp(k))
enddo
enddo
do k=1,dim
avrg(k)=avrg(k)/norm
enddo
end
!--------------------------------------------------------------------------
subroutine safe_variance(points,avrg,var,dim,maxdim,npoints)
implicit none
! Generates the variance over a set of dim-dimensional vectors in a
! safe fashion using Kahan Summation.
!
! maxdim: physical dimension of vectors
! dim: actual dimension of vectors
! npoints: number of vectors
! points: array of vectors of length (max)dim.
! avrg: mean vector
! var: final variance vector
!
integer maxdim
integer dim,npoints
double precision points(maxdim,*), avrg(maxdim), var(maxdim)
double precision tmp(maxdim)
double precision norm
integer j,k
norm=dble(npoints)
tmp=0.0d0
var=0.0d0
do j=1,npoints
do k=1,dim
call KahanAdd((points(k,j)-avrg(k))**2,var(k),tmp(k))
enddo
enddo
do k=1,dim
var(k)=var(k)/norm
enddo
end
!--------------------------------------------------------------------------
subroutine KahanSum(terms,nterms,sum)
implicit none
! Sums over all nterms entries in the vector terms using Kahan Summation.
! It utilizes an algorithm recovering low-order digits of added terms
! Taken from Wikipedia.
! Algebraically, the variable corr should always be zero. Beware
! overly-aggressive optimizing compilers.
integer nterms
double precision terms(nterms)
double precision sum
double precision corr,tmp,newsum
integer j
sum=0.0d0
corr=0.0d0 ! A running compensation for lost low-order bits.
do j=1,nterms
tmp = terms(j) - corr ! try to add collected lost lower digit summations to sum
newsum = sum + tmp ! low-order digits of tmp are lost to summation
! cancels high-order part of tmp
! subtracting tmp recovers low part of the term
corr = (newsum - sum) - tmp
sum = newsum
enddo
end
!--------------------------------------------------------------------------
subroutine KahanAdd(term,sum,corr)
implicit none
! Add term to sum using Kahan Summation.
! It utilizes an algorithm recovering low-order digits of added terms
! Taken from Wikipedia.
! Algebraically, the variable corr should always be zero. Beware
! overly-aggressive optimizing compilers.
double precision term,sum,corr
double precision tmp,newsum
tmp = term - corr ! try to add collected lost lower digit summations to sum
newsum = sum + tmp ! low-order digits of tmp are lost to summation
! cancels high-order part of tmp
! subtracting tmp recovers low part of the term
corr = (newsum - sum) - tmp
sum = newsum
end
!--------------------------------------------------------------------------
subroutine writemat(funit,mat,matfmt,flen,nrow,ncol,
> nrow_print,ncol_print)
implicit none
! Write (submatrix of) matrix mat using format matfmt on each
! individual value to file unit funit.
!
! flen: length of format string
! mat: matrix to be printed
! nrow: dimension of row-vector in matrix mat (matrix input)
! ncol: dimension of column-vector in matrix mat (matrix output)
! *_print: dimensions of submatrix to be printed
integer flen,funit
integer nrow,ncol
integer nrow_print,ncol_print
double precision mat(nrow,ncol)
character*(flen) matfmt
integer j,k
if (nrow_print.gt.nrow) then
write(6,'(A)') 'ERROR: CANNOT PRINT BEYOND MATRIX WIDTH'
> // ' (printmat)'
stop 1
else if (ncol_print.gt.ncol) then
write(6,'(A)') 'ERROR: CANNOT PRINT BEYOND MATRIX HEIGHT'
> // ' (printmat)'
stop 1
endif
do j=1,ncol_print
do k=1,nrow_print
write(unit=funit,fmt=matfmt,advance='NO') mat(k,j)
enddo
write(funit,'()')
enddo
end
!--------------------------------------------------------------------------
subroutine printmat_full(mat,matfmt,flen,nrow,ncol)
implicit none
! Print matrix mat using format matfmt on each
! individual value.
!
! flen: length of format string
! mat: matrix to be printed
! nrow: dimension of row-vector in matrix mat (matrix input)
! ncol: dimension of column-vector in matrix mat (matrix output)
! *_print: dimensions of submatrix to be printed
integer flen
integer nrow,ncol
double precision mat(nrow,ncol)
character*(flen) matfmt
integer stdin
parameter (stdin=6)
call writemat(stdin,mat,matfmt,flen,nrow,ncol,nrow,ncol)
end
!--------------------------------------------------------------------------
subroutine writevec(funit,vec,vecfmt,flen,len,wraplen)
implicit none
! Write vector vec of length len in blocks of length wraplen.
!
! flen: length of format string
! mat: matrix to be printed
! nrow: dimension of row-vector in matrix mat (matrix input)
! ncol: dimension of column-vector in matrix mat (matrix output)
! *_print: dimensions of submatrix to be printed
integer flen,funit
integer len,wraplen
double precision vec(len)
character*(flen) vecfmt
integer wordcount
integer j
wordcount=0
do while (wordcount.lt.len)
do j=1,min(wraplen,len-wordcount)
wordcount=wordcount+1
write(unit=funit,fmt=vecfmt,advance='NO') vec(j)
enddo
write(funit,'()')
enddo
end
!--------------------------------------------------------------------------
subroutine printvec_full(vec,vecfmt,flen,len,wraplen)
implicit none
! Print vector vec of length len in blocks of length wraplen.
!
! flen: length of format string
! mat: matrix to be printed
! nrow: dimension of row-vector in matrix mat (matrix input)
! ncol: dimension of column-vector in matrix mat (matrix output)
! *_print: dimensions of submatrix to be printed
integer flen
integer len,wraplen
double precision vec(len)
character*(flen) vecfmt
integer stdin
parameter (stdin=6)
call writevec(stdin,vec,vecfmt,flen,len,wraplen)
end

140
src/lib/fileread.f Normal file
View File

@ -0,0 +1,140 @@
!-------------------------------------------------------------------
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*(dnlen) datnam
integer argcount
argcount=iargc()
if (argcount.gt.0) then
call getarg(1,datnam)
else
write(6,'(A)') 'Specify input file:'
write(5,*) datnam
endif
if (len_trim(datnam).eq.dnlen) then
write(6,'(A)') 'ERROR: TRUNCATED FILENAME'
write(6,'(A)') '"' // datnam // '"'
endif
end
!-------------------------------------------------------------------
subroutine internalize_datfile(datnam,infile,linenum,llen,
> maxlines,dnlen)
implicit none
! Read input file located at DATNAM, skipping comments and blank lines.
integer dnlen,llen,maxlines
integer linenum
character*(dnlen) datnam
character*(llen) infile(maxlines)
character*(llen) line
character*32 datfmt
character*16 int2string
integer j
! datfmt=' '
! datfmt = '(' // trim(int2string(llen)) //'A)'
! write(6,"(100('*'))")
!? valgrind has a problem with this. find a fix!
datfmt='(750A)'
write(6,'(A)') 'Reading file ''' // trim(datnam) // ''' ...'
open(600,file=datnam)
linenum=0
do j=1,maxlines
read(600,fmt='(A750)',end=20) line
if (line(1:3).eq.'---') then
write(6,'(A)') 'EOF-mark "---" found at line'
> // trim(int2string(j))
exit
endif
call internalize_line(linenum,infile,line,llen,maxlines)
enddo
20 close(600)
if (j.ge.maxlines) then
write(6,'(A)') 'ERROR: FILE LENGTH EXCEEDING MAXLINES.'
stop 1
endif
write(6,'(A)') 'File read successfully ('
> // trim(int2string(linenum)) // ' lines).'
end
!-------------------------------------------------------------------
subroutine internalize_line(linenum,infile,line,llen,maxlines)
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*(llen) infile(maxlines)
character*(llen) line
character*(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

350
src/lib/imatrix.f Normal file
View File

@ -0,0 +1,350 @@
************************************************************************
*** imatrix
*** generic integer matrix operations
***
************************************************************************
subroutine expandimat(oldmat,newmat,nrow_old,ncol_old,
> nrow_new,ncol_new)
implicit none
! Expands a matrix oldmat to matrix newmat. Matrices are assumed to
! lie densely in memory, meaning physical and actual dimension
! coincides for the row-index. New matrix elements remain uninitialized.
!
! oldmat: matrix to be expanded
! newmat: expanded matrix
! nrow_*: dimension of row-vector in matrix *mat
! ncol_*: dimension of column-vector in matrix *mat
integer nrow_old,ncol_old,nrow_new,ncol_new
integer oldmat(nrow_old,ncol_old),newmat(nrow_new,ncol_new)
integer j,k
if (nrow_new.lt.nrow_old) then
write(6,'(A)') 'ERROR: CANNOT DECREASE MATRIX WIDTH'
> // ' (expandmat)'
stop
else if (ncol_new.lt.ncol_old) then
write(6,'(A)') 'ERROR: CANNOT DECREASE MATRIX HEIGHT'
> // ' (expandmat)'
stop
endif
do j=1,ncol_old
do k=1,nrow_old
newmat(k,j)=oldmat(k,j)
enddo
enddo
end
!--------------------------------------------------------------------------
subroutine permuteimat(oldmat,newmat,perm_row,perm_col,nrow,ncol)
implicit none
! Allows to perform arbitrary permutations of row- and column
! entries of the matrix (corresponding to permutations of the
! underlying basis sets).
!
! Permutations are symbolized as integer vectors. They should
! contain each number from 1 to nrow/ncol in the desired new order,
! 1 meaning the originally first entry etc.
!
! (1,2,3,..) -Permutation-> (P(1),P(2),...)
!
! oldmat: matrix to be modified
! newmat: generated matrix
! nrow: dimension of row-vectors
! ncol: dimension of column vectors
! perm_*: permutation applied to row or column
!
integer nrow,ncol
integer perm_row(nrow),perm_col(ncol)
integer oldmat(nrow,ncol),newmat(nrow,ncol)
integer j,k
! check validity of permutations (pidgeonhole principle)
do j=1,nrow
if (.not.any(perm_row.eq.j)) then
write(6,'(A)') 'ERROR: INVALID PERMUTATION'
> // ' VECTOR (permutemat)'
stop 1
endif
enddo
do j=1,ncol
if (.not.any(perm_col.eq.j)) then
write(6,'(A)') 'ERROR: INVALID PERMUTATION'
> // ' VECTOR (permutemat)'
stop 1
endif
enddo
do j=1,ncol
do k=1,nrow
newmat(k,j)=oldmat(perm_row(k),perm_col(j))
enddo
enddo
end
!--------------------------------------------------------------------------
subroutine shuffled_ilist(list,len)
implicit none
! Generates an integer array of length len cotaining all integers
! form 1 to len in random order using a modification of the
! Fisher-Yates shuffle. Source: Wikipedia.
!
! WARNING: it is assumed that the RNG of random.f has been
! initialized.
!
! list: integer array to be written
! len: length of list meant to be written (not phys. dimension)
integer len
integer list(len)
double precision ran
integer ierr
integer j,n
parameter (ierr=6)
do j=1,len
! generate random real in [0,1)
call vranf(ran,1,0,ierr)
! translate to random int in [1,j]
n = 1 + floor(dble(j)*ran)
list(j)=list(n)
list(n)=j
enddo
end
!--------------------------------------------------------------------------
subroutine random_sample_ilist(list,len,maxval)
implicit none
! Generates a random sample of length len from a (virtual) list of
! integers from 1 to maxval using Algorithm R. Source: Wikipedia.
!
! WARNING: it is assumed that the RNG of random.f has been
! initialized.
!
! list: sample to be generated
! len: length of list meant to be written
! maxval: maximum value allowed in list. Assumed to be > len.
integer len,maxval
integer list(len)
double precision ran
integer ierr
parameter (ierr=6)
integer j,n
do j=1,len
list(j)=j
enddo
do j=len+1,maxval
! generate random real in [0,1)
call vranf(ran,1,0,ierr)
! translate to random int in [1,j]
n = 1 + floor(dble(j)*ran)
if (n.le.len) then
list(n)=j
endif
enddo
end
!--------------------------------------------------------------------------
integer function SIndex2(j,k,rowdim)
implicit none
! Map indices of a matrix lying densely in linear memory, with a
! logical row dimension rowdim. In other words, if M and V are
! besides the number of indices identical then
! M(j,k) == V(SIndex2(j,k,rowdim)) for all 1<=j<=rowdim.
!
integer rowdim
integer j,k
SIndex2 = (k-1)*rowdim + j
end
!--------------------------------------------------------------------------
integer function MIndex2(S,rowdim)
implicit none
! Map super index of a matrix lying densely in linear memory, with a
! logical row dimension rowdim to it's minor indices. In other
! words, if M and V are besides the number of indices identical then
! for all j = MIndex(S,rowdim)
! M(j(1),j(2)) == V(S) for all 1<=S.
!
dimension MIndex2(2)
integer rowdim
integer S
integer j(2)
j(1)=mod(S-1,rowdim)+1
j(2)=(S-1)/rowdim + 1
MIndex2=j(:)
end
!--------------------------------------------------------------------------
subroutine MIndexN(supidx,midx,dimnum,dimlen)
implicit none
! Map super index of some dimnum-dimensional array to linear memory
! according to FORTRAN convention, meaning that if V and M are the
! same array with different index convention then
!
! V(supidx) = M(midx(1),midx(2),midx(3),...,midx(dimnum))
! for all supidx >=1, IF dimlen(j) > 1 for all j
!
integer dimnum
integer midx(dimnum),dimlen(dimnum)
integer supidx
integer blocksize(dimnum)
integer sindex
integer j
! calculate block-size for unit indices (1,0,..),(0,1,0,..),...
! that is: 1,n1,n1*n2,...
blocksize=1
do j=2,dimnum
blocksize(j:dimnum)=blocksize(j:dimnum)*dimlen(j-1)
enddo
! superindex needs to start from 0 for fancy modulo arithmetic
sindex=supidx-1
do j=dimnum,1,-1
midx(j)=sindex/(blocksize(j))
sindex=mod(sindex,blocksize(j))
enddo
! set indices back to range [1..ni]
midx=midx+1
end
!--------------------------------------------------------------------------
subroutine MIndexN_range(maxidx,midx,dimnum,dimlen)
implicit none
! Map range of superindices from 1 to maxidx of some
! dimnum-dimensional array to linear memory according to FORTRAN
! convention, meaning that if V and M are the same array with
! different index convention then
!
! V(k) = M(midx(1,k),midx(2,k),...,midx(dimnum,k))
! for all 1<=k<=maxidx, IF dimlen(j) > 1 for all j
!
integer dimnum,maxidx
integer midx(dimnum,maxidx),dimlen(dimnum)
integer blocksize(dimnum)
integer sindex
integer j,k
! calculate block-size for unit indices (1,0,..),(0,1,0,..),...
! that is: 1,n1,n1*n2,...
blocksize=1
do j=2,dimnum
blocksize(j:dimnum)=blocksize(j:dimnum)*dimlen(j-1)
enddo
do k=1,maxidx
! superindex needs to start from 0 for fancy modulo arithmetic
sindex=k-1
do j=dimnum,1,-1
midx(j,k)=sindex/(blocksize(j)) + 1
sindex=mod(sindex,blocksize(j))
enddo
enddo
end
!--------------------------------------------------------------------------
integer function IdxShift(j,start)
implicit none
! 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
!--------------------------------------------------------------------------
subroutine writeivec(funit,vec,vecfmt,flen,len,wraplen)
implicit none
! Write integer vector vec of length len in blocks of length wraplen.
!
! flen: length of format string
! mat: matrix to be printed
! nrow: dimension of row-vector in matrix mat (matrix input)
! ncol: dimension of column-vector in matrix mat (matrix output)
! *_print: dimensions of submatrix to be printed
integer flen,funit
integer len,wraplen
integer vec(len)
character*(flen) vecfmt
integer wordcount
integer j
wordcount=0
do while (wordcount.lt.len)
do j=1,min(wraplen,len-wordcount)
wordcount=wordcount+1
write(unit=funit,fmt=trim(vecfmt),advance='NO') vec(j)
enddo
write(funit,'()')
enddo
end
!--------------------------------------------------------------------------
subroutine printivec_full(vec,vecfmt,flen,len,wraplen)
implicit none
! Print integer vector vec of length len in blocks of length wraplen.
!
! flen: length of format string
! mat: matrix to be printed
! nrow: dimension of row-vector in matrix mat (matrix input)
! ncol: dimension of column-vector in matrix mat (matrix output)
! *_print: dimensions of submatrix to be printed
integer flen
integer len,wraplen
integer vec(len)
character*(flen) vecfmt
integer stdin
parameter (stdin=6)
call writeivec(stdin,vec,vecfmt,flen,len,wraplen)
end

275
src/lib/keyread.f Normal file
View File

@ -0,0 +1,275 @@
subroutine keyread(keylist,infile,keynum,idat,ddat,cdat,datpos,
> klen,llen,clen,linenum,maxdat)
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*(klen) keylist(2,keynum)
character*(llen) infile(linenum)
integer datpos(3,maxdat)
integer idat(maxdat)
double precision ddat(maxdat)
character*(clen) cdat(maxdat)
character*(klen) key
character*64 errmsg
integer intype,inlen,readlen
integer cstart,istart,dstart
integer key_end
integer datnum,inpos,datlen
integer file_stop
logical optional
character*16 int2string, dble2string
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,optional,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.optional) 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 get_key_kind(kentry,dattype,optional,datlen,klen)
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
integer klen
integer dattype,datlen
character*(klen) kentry(2)
logical optional
character*(klen) typestr,key,tmp,numstr
character*64 errmsg
integer strpos,typelen
integer typenum,maxtypelen
parameter (typenum=6,maxtypelen=2)
character*(maxtypelen) types(typenum)
parameter (types=['I ', '+I', 'D ', '+D', 'C ', 'E '])
integer j
key=kentry(1)
typestr=kentry(2)
dattype=-1
strpos=1
! check type declaration against defined types
! There has got to be a smarter way to do this.
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.
optional=(typestr(strpos:strpos).ne.'!')
if (.not.optional) 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 signal_key_error(key,msg,klen)
implicit none
integer klen
character*(klen) key
character*(*) msg
write(6,'(A)') 'ERROR: ' // trim(key) // ' ' // trim(msg)
stop 1
end

343
src/lib/long_keyread.f Normal file
View File

@ -0,0 +1,343 @@
! 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*(linelen) infile(maxlines)
logical continued, broken
integer line_start,ipos
character*(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_intline(inline,linelen,line_start,
> idat,ipos,maxdat,readlen,
> continued,broken)
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*(linelen) inline
logical continued, broken
integer line_end, wordcount
character*(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).ge.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_realkey(infile,inpos,key_end,ddat,dstart,
> readlen,linelen,maxdat,maxlines)
implicit none
! Read an arbitrary number of double precision reals 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*(linelen) infile(maxlines)
logical continued, broken
integer line_start,dpos
character*(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_realline(inline,linelen,line_start,
> ddat,dpos,maxdat,readlen,
> continued,broken)
implicit none
! Read a single line of string input INLINE encoding double
! precision reals.
!
! 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*(linelen) inline
logical continued, broken
integer line_end, wordcount
character*(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).ge.maxdat) then
write(6,'(A)') 'ERROR: LONG_REALLINE: 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) 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

132
src/lib/misc.f Normal file
View File

@ -0,0 +1,132 @@
**** Generic convenience subroutines and functions
subroutine ibaserep(x,base,rep_x,len)
implicit none
! Subroutine generating the first len digits of
! the standard representation of an integer x
! in the given base, ignoring the sign.
!
! x: Integer to be represented.
! base: Base of the representation.
! bases <= 1 yield an error.
! len: Length of the vector rep_x.
! rep_x: Vector containing the digits
! of the representation, starting
! with the 0th power.
integer len
integer base
integer x, rep_x(len)
integer z
integer k
if (base.le.1) then
stop 'ERROR: ibaserep: Invalid base.'
endif
! create working copy of x
z=iabs(x)
do k=1,len
rep_x(k) = mod(z,base)
z = z/base
enddo
end
!------------------------------------------------------------
subroutine repeatfmt32(fullfmt,unitfmt,rep,ulen)
implicit none
! Generate a 32 character format string repeating the same
! (up to) 16 character format the given number of times.
!
! Ex.: repeatfmt32(fmt,'ES23.15',50,7)
! is equivalent to
! fmt='( 50ES23.15) '
! which is a valid format string equivalent to '(50ES23.15)'.
!
!
! rep: number of repetitions
! ulen: actual length of unitfmt <=16
! fullfmt: output format string
! unitfmt: segment to be repeated rep times
integer ulen,rep
character*32 fullfmt
character unitfmt(16)
character*16 unit_tmp
if (ulen.gt.16) then
stop 'ERROR: repeatfmt32: string unit exceeding size limit'
else if (rep.ge.10**9) then
stop 'ERROR: repeatfmt32: repetition number too large'
endif
! copy desired unit string
unit_tmp=' '
write(unit_tmp,'(16(A1,:))') unitfmt(1:ulen)
write(fullfmt,'("(",I14,A16)') rep, unit_tmp
fullfmt = trim(fullfmt) // ')'
end
!------------------------------------------------------------
logical function ibetween(min,x,max)
implicit none
! Function checking whether the inequation
! min <= x <= max holds true.
integer min,max,x
ibetween=(min.le.x).and.(x.le.max)
end
!------------------------------------------------------------
logical function dbetween(min,x,max)
implicit none
! Function checking whether the inequation
! min <= x <= max holds true.
double precision min,max,x
dbetween=(min.le.x).and.(x.le.max)
end
!------------------------------------------------------------
logical function dveceq(vec1,vec2,len)
implicit none
! Function comparing two vectors of length len
! element by element, only true if all elements are
! equal
double precision vec1(*),vec2(*)
integer len
dveceq=all( vec1(1:len).eq.vec2(1:len) )
end
!------------------------------------------------------------
logical function dvecne(vec1,vec2,len)
implicit none
! Function comparing two vectors of length len
! element by element, only true if at least one
! is different.
double precision vec1(*),vec2(*)
integer len
dvecne=any( vec1(1:len).ne.vec2(1:len) )
end

429
src/lib/qsort.f Normal file
View File

@ -0,0 +1,429 @@
subroutine dqsort2(n,arr,key)
implicit none
! Sorts an array arr(1:n) into ascending order using Quicksort,
! while making the corresponding rearrangement of the array key(1:n)
! Taken from NUMERICAL RECIPES IN FORTRAN 77, 2nd Ed. (p. 324)
!
! arr: Array to be sorted, expects double precision.
! key: key array to be permuted in the same manner as arr.
! usually key is chosen such that key(j)=j for all j
! on input.
! n: actual length of arr.
!
! M: Size of subarrays sorted by straight insertion
! NSTACK: req. auxiliary storage.
! the maximal processable n is given by 2^(NSTACK/2)
integer n,M,NSTACK
double precision arr(n)
integer key(n),pos
parameter (M=7,NSTACK=50)
double precision a,temp
integer b,itemp
integer istack(NSTACK),jstack
integer i,ir,j,k,l
pos=n+1
jstack=0
l=1
ir=n
1 if (ir-l.lt.M) then
! Insertion sort when subarray is small enough
do j=l+1,ir
a=arr(j)
b=key(j)
do i=j-1,l,-1
if (arr(i).le.a) goto 2
arr(i+1)=arr(i)
key(i+1)=key(i)
enddo
i=l-1
2 arr(i+1)=a
key(i+1)=b
enddo
if (jstack.eq.0) return
! Pop stack and begin a new round of partitioning
ir=istack(jstack)
l=istack(jstack-1)
jstack=jstack-2
else
k=(l+ir)/2
temp=arr(k)
arr(k)=arr(l+1)
arr(l+1)=temp
itemp=key(k)
key(k)=key(l+1)
key(l+1)=itemp
if (arr(l).gt.arr(ir)) then
temp=arr(l)
arr(l)=arr(ir)
arr(ir)=temp
itemp=key(l)
key(l)=key(ir)
key(ir)=itemp
endif
if (arr(l+1).gt.arr(ir)) then
temp=arr(l+1)
arr(l+1)=arr(ir)
arr(ir)=temp
itemp=key(l+1)
key(l+1)=key(ir)
key(ir)=itemp
endif
if (arr(l).gt.arr(l+1)) then
temp=arr(l)
arr(l)=arr(l+1)
arr(l+1)=temp
itemp=key(l)
key(l)=key(l+1)
key(l+1)=itemp
endif
i=l+1
j=ir
a=arr(l+1)
b=key(l+1)
3 continue
i=i+1
if (arr(i).lt.a) goto 3
4 continue
j=j-1
if (arr(j).gt.a) goto 4
if (j.lt.i) goto 5
temp=arr(i)
arr(i)=arr(j)
arr(j)=temp
itemp=key(i)
key(i)=key(j)
key(j)=itemp
goto 3
5 arr(l+1)=arr(j)
arr(j)=a
key(l+1)=key(j)
key(j)=b
jstack=jstack+2
if (jstack.gt.NSTACK) then
stop 'ERROR: NSTACK too small in dqsort2'
endif
if (ir-i+1.ge.j-1) then
istack(jstack)=ir
istack(jstack-1)=i
ir=j-1
else
istack(jstack)=j-1
istack(jstack-1)=l
l=i
endif
endif
goto 1
end
subroutine dqsort(n,arr)
implicit none
! Sorts an array arr(1:n) into ascending order using Quicksort.
! Taken from NUMERICAL RECIPES IN FORTRAN 77, 2nd Ed. (p. 324)
!
! arr: Array to be sorted, expects double precision.
! n: actual length of arr.
!
! M: Size of subarrays sorted by straight insertion
! NSTACK: req. auxiliary storage.
! the maximal processable n is given by 2^(NSTACK/2)
integer n,M,NSTACK
double precision arr(n)
integer pos
parameter (M=7,NSTACK=50)
double precision a,temp
integer istack(NSTACK),jstack
integer i,ir,j,k,l
pos=n+1
jstack=0
l=1
ir=n
1 if (ir-l.lt.M) then
! Insertion sort when subarray is small enough
do j=l+1,ir
a=arr(j)
do i=j-1,l,-1
if (arr(i).le.a) goto 2
arr(i+1)=arr(i)
enddo
i=l-1
2 arr(i+1)=a
enddo
if (jstack.eq.0) return
! Pop stack and begin a new round of partitioning
ir=istack(jstack)
l=istack(jstack-1)
jstack=jstack-2
else
k=(l+ir)/2
temp=arr(k)
arr(k)=arr(l+1)
arr(l+1)=temp
if (arr(l).gt.arr(ir)) then
temp=arr(l)
arr(l)=arr(ir)
arr(ir)=temp
endif
if (arr(l+1).gt.arr(ir)) then
temp=arr(l+1)
arr(l+1)=arr(ir)
arr(ir)=temp
endif
if (arr(l).gt.arr(l+1)) then
temp=arr(l)
arr(l)=arr(l+1)
arr(l+1)=temp
endif
i=l+1
j=ir
a=arr(l+1)
3 continue
i=i+1
if (arr(i).lt.a) goto 3
4 continue
j=j-1
if (arr(j).gt.a) goto 4
if (j.lt.i) goto 5
temp=arr(i)
arr(i)=arr(j)
arr(j)=temp
goto 3
5 arr(l+1)=arr(j)
arr(j)=a
jstack=jstack+2
if (jstack.gt.NSTACK) then
stop 'ERROR: NSTACK too small in dqsort2'
endif
if (ir-i+1.ge.j-1) then
istack(jstack)=ir
istack(jstack-1)=i
ir=j-1
else
istack(jstack)=j-1
istack(jstack-1)=l
l=i
endif
endif
goto 1
end
subroutine iqsort(n,arr)
implicit none
! Sorts an array arr(1:n) into ascending order using Quicksort.
! Taken from NUMERICAL RECIPES IN FORTRAN 77, 2nd Ed. (p. 324)
!
! arr: Array to be sorted, expects integer.
! n: actual length of arr.
!
! M: Size of subarrays sorted by straight insertion
! NSTACK: req. auxiliary storage.
! the maximal processable n is given by 2^(NSTACK/2)
integer n,M,NSTACK
integer arr(n)
integer pos
parameter (M=7,NSTACK=50)
integer a,temp
integer istack(NSTACK),jstack
integer i,ir,j,k,l
pos=n+1
jstack=0
l=1
ir=n
1 if (ir-l.lt.M) then
! Insertion sort when subarray is small enough
do j=l+1,ir
a=arr(j)
do i=j-1,l,-1
if (arr(i).le.a) goto 2
arr(i+1)=arr(i)
enddo
i=l-1
2 arr(i+1)=a
enddo
if (jstack.eq.0) return
! Pop stack and begin a new round of partitioning
ir=istack(jstack)
l=istack(jstack-1)
jstack=jstack-2
else
k=(l+ir)/2
temp=arr(k)
arr(k)=arr(l+1)
arr(l+1)=temp
if (arr(l).gt.arr(ir)) then
temp=arr(l)
arr(l)=arr(ir)
arr(ir)=temp
endif
if (arr(l+1).gt.arr(ir)) then
temp=arr(l+1)
arr(l+1)=arr(ir)
arr(ir)=temp
endif
if (arr(l).gt.arr(l+1)) then
temp=arr(l)
arr(l)=arr(l+1)
arr(l+1)=temp
endif
i=l+1
j=ir
a=arr(l+1)
3 continue
i=i+1
if (arr(i).lt.a) goto 3
4 continue
j=j-1
if (arr(j).gt.a) goto 4
if (j.lt.i) goto 5
temp=arr(i)
arr(i)=arr(j)
arr(j)=temp
goto 3
5 arr(l+1)=arr(j)
arr(j)=a
jstack=jstack+2
if (jstack.gt.NSTACK) then
stop 'ERROR: NSTACK too small in dqsort2'
endif
if (ir-i+1.ge.j-1) then
istack(jstack)=ir
istack(jstack-1)=i
ir=j-1
else
istack(jstack)=j-1
istack(jstack-1)=l
l=i
endif
endif
goto 1
end
subroutine reverse_dqsort2(n,arr,key)
implicit none
! Sorts an array arr(1:n) into descending order using Quicksort,
! while making the corresponding rearrangement of the array key(1:n)
! Taken from NUMERICAL RECIPES IN FORTRAN 77, 2nd Ed. (p. 324)
!
! arr: Array to be sorted, expects double precision.
! key: key array to be permuted in the same manner as arr.
! usually key is chosen such that key(j)=j for all j
! on input.
! n: actual length of arr.
!
! M: Size of subarrays sorted by straight insertion
! NSTACK: req. auxiliary storage.
! the maximal processable n is given by 2^(NSTACK/2)
integer n,M,NSTACK
double precision arr(n)
integer key(n),pos
parameter (M=7,NSTACK=50)
double precision a,temp
integer b,itemp
integer istack(NSTACK),jstack
integer i,ir,j,k,l
pos=n+1
jstack=0
l=1
ir=n
1 if (ir-l.lt.M) then
! Insertion sort when subarray is small enough
do j=l+1,ir
a=arr(j)
b=key(j)
do i=j-1,l,-1
if (arr(i).ge.a) goto 2
arr(i+1)=arr(i)
key(i+1)=key(i)
enddo
i=l-1
2 arr(i+1)=a
key(i+1)=b
enddo
if (jstack.eq.0) return
! Pop stack and begin a new round of partitioning
ir=istack(jstack)
l=istack(jstack-1)
jstack=jstack-2
else
k=(l+ir)/2
temp=arr(k)
arr(k)=arr(l+1)
arr(l+1)=temp
itemp=key(k)
key(k)=key(l+1)
key(l+1)=itemp
if (arr(l).lt.arr(ir)) then
temp=arr(l)
arr(l)=arr(ir)
arr(ir)=temp
itemp=key(l)
key(l)=key(ir)
key(ir)=itemp
endif
if (arr(l+1).lt.arr(ir)) then
temp=arr(l+1)
arr(l+1)=arr(ir)
arr(ir)=temp
itemp=key(l+1)
key(l+1)=key(ir)
key(ir)=itemp
endif
if (arr(l).lt.arr(l+1)) then
temp=arr(l)
arr(l)=arr(l+1)
arr(l+1)=temp
itemp=key(l)
key(l)=key(l+1)
key(l+1)=itemp
endif
i=l+1
j=ir
a=arr(l+1)
b=key(l+1)
3 continue
i=i+1
if (arr(i).gt.a) goto 3
4 continue
j=j-1
if (arr(j).lt.a) goto 4
if (j.lt.i) goto 5
temp=arr(i)
arr(i)=arr(j)
arr(j)=temp
itemp=key(i)
key(i)=key(j)
key(j)=itemp
goto 3
5 arr(l+1)=arr(j)
arr(j)=a
key(l+1)=key(j)
key(j)=b
jstack=jstack+2
if (jstack.gt.NSTACK) then
stop 'ERROR: NSTACK too small in dqsort2'
endif
if (ir-i+1.ge.j-1) then
istack(jstack)=ir
istack(jstack-1)=i
ir=j-1
else
istack(jstack)=j-1
istack(jstack-1)=l
l=i
endif
endif
goto 1
end

50
src/lib/ran.f Normal file
View File

@ -0,0 +1,50 @@
double precision function ranget()
! Even shorter rn(), to remove visual clutter
implicit none
double precision rn
ranget=rn(1,1,0)
end
!--------------------------------------------------------------------------------------
double precision function ranget_gauss(sig)
implicit none
! Draw a single value from a gaussian distribution with a standard
! deviation of sig.
double precision sig
double precision gran(1)
integer iout ! standard output
parameter (iout=6)
call gautrg(gran,1,0,iout)
ranget_gauss=gran(1)*dabs(sig)
end
!--------------------------------------------------------------------------------------
integer function ranget_int(max)
implicit none
! Get a random int between 1 and max.
integer max
double precision ranget
ranget_int=floor(dble(max)*ranget())+1
end
!--------------------------------------------------------------------------------------
double precision function ranget_sym(spread)
implicit none
! Get a random real between -spread and spread.
double precision spread
double precision ranget
ranget_sym=(ranget()-0.5D0)*2.0D0*spread
end

133
src/lib/ran_gv.f Normal file
View File

@ -0,0 +1,133 @@
**** Custom extension to random.f
*** NOTE: IF THE RNG HAS BEEN INITIALIZED BY vranf ANYWHERE
*** IN THE CODE, IT IS NOT NECESSARY TO REINITIALIZE.
subroutine granvec(vecs,vdim,nvec,seed)
implicit none
! Generates vectors of dimension vdim. Resulting vectors are
! distributed uniformly for all angles.
! The vector norm is distributed normally (r>0) and centered at the
! origin but limited to an interval
! rmin <= r <= rmax for numerical reasons.
! rmin and rmax scale with sqrt(vdim) due to the progression of
! |(1)|, |(1 1)|, |(1 1 1)| ...
!
! vdim: dimension of a single vector.
! nvec: number of vectors to be stored in vecs
! vecs: random vectors
! seed: seed for RNG
integer vdim,nvec
double precision vecs(vdim,nvec)
integer seed
double precision rmin,rmax
double precision norm
integer iout
integer j,k
parameter (rmin=0.1d0,rmax=1.5,iout=6)
! force seed to be negative integer
seed=-iabs(seed)
! initalize RNG
call gautrg(vecs,0,seed,iout)
do j=1,nvec
norm=-1.0d0
! sort out too large/small vectors
do while ((norm.le.rmin).or.(norm.ge.rmax))
! generate vector
call gautrg(vecs(1,j),vdim,0,iout)
! calculate norm
norm=0.0d0
do k=1,vdim
norm=norm+vecs(k,j)**2
enddo
norm=dsqrt(norm/vdim)
enddo
enddo
end
subroutine nnorm_grv(vecs,vdim,nvec)
implicit none
! Generates vector(s) of dimension vdim. Resulting vectors are
! distributed uniformly for all angles. vranf is assumed
! to be already initialized.
!
! The norm is set to be sqrt(vdim), such that the in case
! of all vector elements being the same size they would be
! 'normalized' to 1.
!
! vdim: dimension of a single vector.
! nvec: number of vectors to be stored in vecs
! vecs: random vectors.
integer vdim,nvec
double precision vecs(vdim,nvec)
integer seed
double precision norm
integer j,k
! generate vectors
seed=0
call granvec(vecs,vdim,nvec,seed)
do j=1,nvec
! calculate norm
norm=0.0d0
do k=1,vdim
norm=norm+vecs(k,j)**2
enddo
! renorm vectors to vdim
norm=dsqrt(vdim/norm)
do k=1,vdim
vecs(k,j)=vecs(k,j)*norm
enddo
enddo
end
subroutine normal_grv(vecs,vdim,nvec)
implicit none
! Generates vector(s) of dimension vdim. Resulting vectors are
! distributed uniformly for all angles. vranf is assumed
! to be already initialized.
!
! The norm is set to be 1.
!
! vdim: dimension of a single vector.
! nvec: number of vectors to be stored in vecs
! vecs: random vectors.
integer vdim,nvec
double precision vecs(vdim,nvec)
integer seed
double precision norm
integer j,k
! generate vectors
seed=0
call granvec(vecs,vdim,nvec,seed)
do j=1,nvec
! calculate norm
norm=0.0d0
do k=1,vdim
norm=norm+vecs(k,j)**2
enddo
! renorm vectors to vdim
norm=dsqrt(1.0d0/norm)
do k=1,vdim
vecs(k,j)=vecs(k,j)*norm
enddo
enddo
end

1365
src/lib/random.f Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
src/lib/random.o Normal file
View File

Binary file not shown.

46
src/lib/ranlfg.inc Normal file
View File

@ -0,0 +1,46 @@
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)
parameter (np=1279,nq=418)
c parameter (np=2281,nq=715)
c parameter (np=4423,nq=1393)
save /xrandf/
common /xrandf/ x(np),last,init
c---+----|----+----|----+----|----+----|----+----|----+----|----+----|--
c----------------------------- last line -------------------------------

526
src/lib/strings.f Normal file
View File

@ -0,0 +1,526 @@
!----------------------------------------------------------------------------
subroutine capital(in,str,lauf,mmax,sl)
implicit none
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 lcap(str,n)
implicit none
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
!--------------------------------------------------------------------------
! function to test how many entries are on one line:
function clen(str,sl)
implicit none
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
!--------------------------------------------------------------------------
logical function isnumeral(char)
implicit none
! 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
!--------------------------------------------------------------------------
logical function iswhitespace(char)
implicit none
! Check whether CHAR is tab or spc character
character char
character whitespace(2)
parameter (whitespace = [' ', ' '])
iswhitespace=any(whitespace.eq.char)
end
!--------------------------------------------------------------------------
subroutine trimnum(string,outstr,str_len)
implicit none
! Extract numbers in STRING as a space separated list in OUTSTR.
integer str_len
character*(str_len) string
character*(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 strip_string(string,stripped,str_len)
implicit none
! 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*(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 nth_word(string,word,n,str_len)
implicit none
! If STRING is a space separated list of words, return the Nth word.
integer str_len
character*(str_len) string,word
integer n
character*(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 count_words(string,wordcount,str_len)
implicit none
! If STRING is a space separated list of words, return the Nth word.
integer str_len
character*(str_len) string
integer wordcount
character*(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 upcase(string,upstring,str_len)
implicit none
! Transform arbitrary string to uppercase and save to upstring
integer str_len
character*(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 downcase(string,downstring,str_len)
implicit none
! Transform arbitrary string to downcase and save to downstring
integer str_len
character*(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
!--------------------------------------------------------------------------
character*16 function int2string(int)
implicit none
! Convert integer to string of length 16.
integer int
character*16 istr
istr=' '
write(istr,*) int
do while (istr(1:1).eq.' ')
istr(1:16) = istr(2:16) // ' '
enddo
int2string=istr
end
!--------------------------------------------------------------------------
character*16 function dble2string(dble)
implicit none
! Convert double precision float to string of length 16.
double precision dble
character*16 dstr
dstr=' '
write(dstr,'(ES16.9)') dble
if (dstr(1:1).eq.' ') then
dstr(1:16) = dstr(2:16) // ' '
endif
dble2string=dstr
end
!--------------------------------------------------------------------------
character*16 function shortdble2string(dble)
implicit none
! Convert double precision float to string of length 16 using a
! shortened format
double precision dble
character*16 dstr
dstr=' '
write(dstr,'(ES11.2)') dble
if (dstr(1:1).eq.' ') then
dstr(1:16) = dstr(2:16) // ' '
endif
shortdble2string=dstr
end

5
src/lib/typedef.incl Normal file
View File

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

343
src/long_io.f Normal file
View File

@ -0,0 +1,343 @@
************************************************************************
*** long_io
*** reading & writing genetic's long input format
***
************************************************************************
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 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)'
double precision 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 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*(linelen) infile(maxlines)
character*(clen) cdat(datlen)
integer line_start,cpos
integer strpos
character*(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_strline(inline,linelen,line_start,
> cdat,cpos,datlen,readlen,clen,
> continued,broken,strpos)
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*(linelen) inline
character*(clen) cdat(datlen)
logical continued, broken
character esc
parameter (esc='\\')
integer line_end
character*(linelen) workline
character*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

429
src/mkNN.f Normal file
View File

@ -0,0 +1,429 @@
subroutine mknet(laystr,weistr,neupop,nlay)
use nn_params
use nndbg_mod
implicit none
! Initialize layer structure matrix exclusively.
!
! nlay: number of given layers
! neupop: neuronal population vector: contains number of neurons for each layer
! laystr: layer structure matrix
! weistr: weight structure matrix
integer laystr(3,maxlay),weistr(2,maxlay,2), neupop(maxlay)
integer nlay
integer neu_tot,wei_tot
integer n
if (dbg) write(6,'(A)') '#INITIALIZING NN....'
neu_tot=0 !number of reserved neurons spaces in memory so far
wei_tot=0 !number of reserved weight matrix element spaces in mem. so far
do n=1,nlay-1
laystr(1,n)=neupop(n) !number of neurons in layer n
laystr(2,n)=neu_tot+1 !starting pos. for layer n
laystr(3,n)=wei_tot+1 !starting pos. for W-matrix
!from layer N to N+1
neu_tot=neu_tot+neupop(n)
wei_tot=wei_tot+neupop(n)*neupop(n+1)
enddo
laystr(1,nlay)=neupop(nlay)
laystr(2,nlay)=neu_tot+1
laystr(3,nlay)=wei_tot+1 !technically oversteps boundary
!of W-vector; practically points to first bias
if (dbg) write(6,'(A)') '#PERFORMING SANITY CHECKS..'
weistr=0
! since there are no input biases, the first entry just points at
! the last few weight matrix elements
weistr(1,1,2)=wei_tot-neupop(1)+1
weistr(2,1,2)=wei_tot
do n=1,nlay-1
weistr(1,n,1)=laystr(3,n)
weistr(2,n,1)=laystr(3,n+1)-1 !end pos. of corresponding W-matrix
weistr(1,n+1,2)=weistr(2,n,2)+1 !starting pos. of bias
weistr(2,n+1,2)=weistr(2,n,2)+neupop(n+1) !end pos. of bias
enddo
if (dbg.or.vbs) write(6,*) '#PERFORMING SANITY CHECKS..'
if (neupop(1).gt.maxnin) then
write(6,'("ERROR: NETWORK INPUT EXCEEDS MAXIMUM.")')
write(6,'(I3.3,"/",I3.3)') neupop(1),maxnin
stop 1
else if (neupop(nlay).gt.maxnout) then
write(6,'("ERROR: NETWORK OUTPUT EXCEEDS MAXIMUM.")')
write(6,'(I3.3,"/",I3.3)') neupop(nlay),maxnout
stop 1
else if (nlay.gt.maxlay) then
write(6,'("ERROR: LAYER COUNT EXCEED MAXIMUM.")')
write(6,'(I2.2,"/",I2.2)') nlay,maxlay
stop 1
endif
do n=2,nlay-1
if (neupop(1).gt.maxnin) then
write(6,'("ERROR: HIDDEN LAYER SIZE EXCEEDS MAXIMUM.")')
write(6,'(I3.3,"/",I3.3)') neupop(n),maxneu
write(6,'("PROBLEM OCCURED IN LAYER #",I2.2)') n
stop 1
endif
enddo
if (dbg) then
write(6,*) '#INIT SUCCESSFUL.'
write(6,'(A10,I6)') '#NEU_TOT =',neu_tot
write(6,'(A10,I6)') '#WEI_TOT =',wei_tot
write(6,'(A10,I6)') '#MAXWEI = ',maxwei
endif
end
!--------------------------------------------------------------------------------------
subroutine mkpars(par,spread,laystr,typop,weistr,nlay,rtype)
use nn_params
use io_parameters
use nndbg_mod
implicit none
! Initialize Weights and Biases exclusively.
!
!
! par: one parameter vector
! spread: factor by which each weight or bias spreads around 0
! nlay: number of given layers
! rtype: type of random distribution:
! 0 -- even distribution
! 1 -- angular uniform distribution,
! vectors normalized to sqrt(wb_end)
! 2 -- even normalized distribution:
! std. deviation of weighted sums is 1.
! Ignores act.
! 3 -- same as 2, but more exact for 2+ hidden layer
! networks
!
! Initialization of the random numbers must have been done before
! call vranf(par(1:1),0,seed,iout) is used for the initialization
double precision par(wbcap),spread(wbcap)
integer laystr(3,maxlay),typop(maxtypes,maxlay)
integer weistr(2,maxlay,2)
integer rtype,nlay
integer wb_end
integer k
! evalute length of entire weight- and bias-vector together
wb_end=weistr(2,nlay,2)
if (rtype.eq.0) then
! generate random numbers within [0,1)
call vranf(par,wb_end,0,iout)
! shift range accordingly
do k=1,wb_end
par(k)=(par(k)-0.5D0)*2.0D0*spread(k)
enddo
else if (rtype.eq.1) then
! generate random numbers
call nnorm_grv(par,wb_end,1)
! shift range accordingly
do k=1,wb_end
par(k)=par(k)*2.0D0*spread(k)
enddo
else if (rtype.eq.2) then
! generate random numbers within [0,1)
call vranf(par,wb_end,0,iout)
! shift range to [-1,1)
do k=1,wb_end
par(k)=(par(k)-0.5D0)*2.0D0
enddo
call normalize_wbvec(par,laystr,weistr,nlay)
else if (rtype.eq.3) then
! generate random numbers within [0,1)
call vranf(par,wb_end,0,iout)
! shift range to [-1,1)
do k=1,wb_end
par(k)=(par(k)-0.5D0)*2.0D0
enddo
call normalize_wbvec_nonlin(par,laystr,weistr,typop,nlay)
par=par*spread
else
stop 'ERROR: INVALID TYPE OF RANDOM NUMBER GENERATION (RTYPE)'
endif
end
!--------------------------------------------------------------------------------------
subroutine normalize_wbvec_nonlin(par,laystr,weistr,typop,nlay)
use nn_params
use nncommons
use io_parameters
use nndbg_mod
implicit none
! Normalizes weights and biases in such a way that the standard
! deviation of a layer's weighted sums is 1, assuming par has been
! initialized with evenly distributed values from -1 to 1.
!
! For ANNs with 1 hidden layer, this routine is exact. For
! multilayered ANNs, this routine approximates distortions from ANN
! activation functions linearly. The "radius" of the even
! distribution is given for a layer k by:
!
! sqrt(3)/sqrt(1+N_eff(k-1)),
!
! where N_eff(k-1) is the effective number of neurons of the
! previous layer. It is given by the sum over all squared
! activation function derivatives at 0 of the previous layer.
! Hence, for f(x)=x for all neurons in a given layer N_eff is the
! actual number of neurons in that layer.
!
double precision par(wbcap)
integer laystr(3,maxlay),typop(maxtypes,maxlay)
integer weistr(2,maxlay,2)
integer nlay
double precision L(maxneu),deriv(maxneu),wbfact(maxlay)
double precision effnum
integer neu_out
integer j,n
! input layer has a trivial activation by def.
wbfact(1)=dsqrt(3.0d0)/dsqrt(dble(laystr(1,1)+1))
do n=2,nlay
L=0
deriv=0
neu_out=laystr(1,n)
! sum over squared derivatives
call neurons(neu_out,L,deriv,typop(1,n))
effnum=0.0d0
do j=1,neu_out
effnum=effnum+deriv(j)**2
enddo
wbfact(n)=dsqrt(3.0d0)/dsqrt(effnum+1.0d0)
enddo
do n=1,nlay-1
do j=weistr(1,n,1),weistr(2,n,1)
par(j)=par(j)*wbfact(n)
enddo
enddo
do n=2,nlay
do j=weistr(1,n,2),weistr(2,n,2)
par(j)=par(j)*wbfact(n-1)
enddo
enddo
end
!--------------------------------------------------------------------------------------
subroutine normalize_wbvec(par,laystr,weistr,nlay)
use nn_params
use nncommons
use io_parameters
use nndbg_mod
implicit none
! Normalizes weights and biases in such a way that the standard
! deviation of a layer's weighted sums is 1, assuming par has been
! initialized with evenly distributed values from -1 to 1.
!
! For ANNs with 1 hidden layer, this routine is exact. For
! multilayered ANNs, this routine neglects distortion effects of the
! activation functions.
double precision par(wbcap)
integer laystr(3,maxlay)
integer weistr(2,maxlay,2)
integer nlay
integer j,n
do n=1,nlay-1
do j=weistr(1,n,1),weistr(2,n,1)
par(j)=par(j)*dsqrt(3.0d0)/dsqrt(dble(laystr(1,n)+1))
enddo
enddo
do n=2,nlay
do j=weistr(1,n,2),weistr(2,n,2)
par(j)=par(j)*dsqrt(3.0d0)
> /dsqrt(dble(laystr(1,n-1)+1))
enddo
enddo
end
!--------------------------------------------------------------------------------------
subroutine mkmodpars(par,act,spread,nlay,thresh)
use nn_params
use nncommons, only: pst
use io_parameters
use nndbg_mod
implicit none
! Assume weights and biases to be mostly initialized and only change
! those that have values that which have an absolute value less than
! thresh. Inactive weights and biases remain untouched.
!
!
! par: one parameter vector
! spread: factor by which each weight or bias spreads around 0
! act: activities for the parameter vector par. Inactive
! parameters remain untouched
! nlay: number of given layers
! thresh: minimum absolute value for a parameter to be
! overwritten. If negative, default to 0.0d0.
! Initialization of the random numbers must have been done before
! call vranf(par(1:1),0,seed,iout) is used for the initialization
double precision par(wbcap),spread(wbcap),thresh
integer act(wbcap)
integer nlay
double precision ranval(2)
double precision minval
integer wb_end
integer k
if (thresh.le.0.0d0) then
minval=0.0d0
else
minval=thresh
endif
! evalute length of entire weight- and bias-vector together
wb_end=pst(1,2*(nlay-1))+pst(2,2*(nlay-1))-1
do k=1,wb_end
! check whether par(k) needs changing.
if ((act(k).ne.0).and.(dabs(par(k)).le.minval)) then
! generate random number within [0,1)
call vranf(ranval,1,0,iout)
! shift range accordingly
par(k)=(ranval(1)-0.5D0)*2.0D0*spread(k)
endif
enddo
end
!--------------------------------------------------------------------------------------
subroutine mkrefset_tail(pat_in,pat_out,ref_in,ref_out,npat,nref)
use nn_params
use nncommons
use nndbg_mod
implicit none
! Split off the nref last pattern pairs and make them reference data.
!
! npat: number of given pattern pairs. Will be reduced by nref.
! nref: number of reference patterns
!
! pat_in: input patterns
! pat_out: desired output patterns
! pat_*(i,N): value of ith in-/output neuron for pattern N
!
! ref_*: in analogy to pat_in/out for reference data (convergence tests)
double precision pat_in(maxnin,maxpats),pat_out(maxpout,maxpats)
double precision ref_in(maxnin,maxpats),ref_out(maxpout,maxpats)
integer npat,nref
integer j,k
if (nref.ge.npat) then
write(6,*) 'ERROR: MKREFSET: NREF TOO LARGE FOR GIVEN NPAT'
stop 1
else if (nref.lt.0) then
write(6,*) 'ERROR: MKREFSET: NEGATIVE NREF'
stop 1
endif
! update npat
npat=npat-nref
! Copy tail to ref-vectors
do j=1,nref
do k=1,maxnin
ref_in(k,j)=pat_in(k,npat+j)
enddo
do k=1,maxpout
ref_out(k,j)=pat_out(k,npat+j)
enddo
enddo
end
!--------------------------------------------------------------------------------------
subroutine mkweights(wterr,npat,pat_out)
use nn_params
use nncommons
use io_parameters
use nndbg_mod
implicit none
! Rescale weights depending on their kind (energy or state
! composition) based on a simplified form of the hybrid
! diabatisation weighting scheme. System specific rescaling is done
! by calling nnweights() for each pattern weight vector.
!
! npat: number of given pattern pairs
! wterr: weight factors for each element of the error vector e
!
! vecnum: number of state vectors in model
integer npat
double precision wterr(maxpout,npat),pat_out(maxpout,npat)
character*32 fname
integer j,n,total,k
fname = trim(nnfdir) // 'weights.out'
write(6,stdfmt) 'Applying weighting scheme..'
open(nnunit,file=trim(fname),status='replace')
write(nnunit,stdfmt) '# This is the established weighting scheme'
> // ' for the present fit.'
write(nnunit,stdfmt) '# Weights appear in the order given by the'
> // 'original input.'
write(nnunit,stdfmt) '# Weights given here are *not* normalized.'
write(nnunit,newline)
!do k=1,npat
call nnweight(wterr,pat_out,npat)
!enddo
!pat_out = pat_out ! to avoid unsed complain durinng compilation
total=0
do k=1,sets
write(nnunit,'(A10,I6.5)') '# Scan Nr.',k
do j=1,ndata(k)
total=total+1
do n=1,inp_out
write(nnunit,'(ES25.15)',advance='NO')
> wterr(n,total)
enddo
write(nnunit,newline)
enddo
enddo
close(nnunit)
write(6,'(A)') 'Error weight generation successful.'
write(6,'(A)') 'Wrote (not normalized) weights to '''
> // trim(fname) // '''.'
end

149
src/model/Phase_correction.f90 Normal file
View File

@ -0,0 +1,149 @@
module Phase_corr
! module for correcting the phase issue in the ab inition dipole data
use iso_fortran_env, only: dp => real64, idp => int32
use nncommons, only: ndiab
implicit none
!integer(idp), parameter:: ndiab = 4
contains
SUBROUTINE build_cluster(m,p)
! subroutine which check the sign of two succesive point
!and correct it if neccessary
! take dipole mx at point i and at point i+1
! update dipole at i+1
implicit none
Real(dp), intent(in):: m(ndiab,ndiab) ! at point i
Real(dp), intent(inout):: p(ndiab,ndiab) ! mx at i+1
!Real(dp), intent(inout):: q(qn)
!Real(dp):: prod2, prod3
! check first the sign of mx0(2,3) if it the same as sign of y(coord)
! q3 is ys
! q5 is yb
! check if the product of the transition element
! of two successive point there is no flip of sign
! check if state 1 need to be flipped
!if (needs_flip(M,P,1)) then
! write(6,*) "state 1 is flipped"
! call flip_e_state(P,1)
!endif
! check if e-state (2) need to be flipped
if (needs_flip(M,P,2)) then
!write(6,*) "state 2 is flipped"
call flip_e_state(P,2)
endif
! check if state (3) need to be flipped
!if (needs_flip(M,P,3)) then
! write(6,*) 'State 3 is flipped '
! call flip_e_state(P,3)
!endif
! check for the last state
!if (needs_flip(M,P,4)) then
! write(6,*) "state 4 is flipped"
! call flip_e_state(P,4)
!endif
END SUBROUTINE build_cluster
SUBROUTINE flip_e_state(A,O)
! the routine which flip the sign of the e-state element
!USE dim_parameter, only: ndiab
!USE accuracy_constants, only: idp, dp
implicit none
real(dp), intent(inout):: A(ndiab,ndiab) ! dipole matrix
integer(idp), intent(in):: O ! the index of the e-state to be flipped
real(dp):: P(ndiab,ndiab)
integer(idp):: i
!logical,save :: first_call =.true.
! the identity matrix will be used to create the transformation matrix P
P = 0.0d0
do i =1,ndiab
P(i,i)=1.0d0
enddo
! flipped the sign of the desired e state
P(o,o) = -1.0d0
! apply P on A
! A' = P**TAP
A=matmul(transpose(P),matmul(A,P))
! write the index of electronic state flipped
END SUBROUTINE
logical function needs_flip(m, p, s)
! Decide whether electronic state s should be flipped
implicit none
real(dp), intent(in) :: m(ndiab, ndiab), p(ndiab, ndiab)
integer(idp), intent(in) :: s
real(dp), parameter:: tol = 1.0d-9,eps_dip =1.0d-6
real(dp) :: m1,m2,p1,p2,m3,p3
needs_flip = .false.
select case (s)
case(1)
m1 = m(1,2) ; p1 = p(1,2)
m2 = m(1,3) ; p2 = p(1,3)
m3 = m(1,4) ; p3 = p(1,4)
if ((abs(m1) < eps_dip) .and. (abs(p1) < eps_dip)) then
m1 = m3
p1 = p3
else if ((abs(m2) < eps_dip) .and. (abs(p2) < eps_dip)) then
m2 = m3
p2 = p3
endif
case (2)
m1 = m(2,3) ; p1 = p(2,3)
m2 = m(2,4) ; p2 = P(2,4)
case (3)
m1 = m(2,3) ; p1 = p(2,3)
m2 = m(3,4) ; p2 = p(3,4)
case(4)
m1 = m(2,4) ; p1 = p(2,4)
m2 = m(3,4) ; p2 = p(3,4)
m3 = m(1,4) ; p3 = p(1,4)
if ((abs(m1) < eps_dip) .and. (abs(p1) < eps_dip)) then
m1 = m3
p1 = p3
else if ((abs(m2) < eps_dip) .and. (abs(p2) < eps_dip)) then
m2 = m3
p2 = p3
endif
case default
return
end select
if (abs(m1*p1) < tol .and. abs(m2*p2) < tol ) return
!if (abs(m2*p2) < tol ) return
!if (m1*p1 < 0.0_dp .and. m2*p2 < 0.0_dp) then
if (m1*p1 < 0.0_dp) then
needs_flip = .true.
end if
end function needs_flip
end module

1843
src/model/all.f90 Normal file
View File

File diff suppressed because it is too large Load Diff

58
src/model/ctrans.f Normal file
View File

@ -0,0 +1,58 @@
! Author: jnshuti
! Created: 2025-10-24 16:44:03
! Last modified: 2026-01-12 11:20:55 jnshuti
subroutine cart2mode(qq)
use invariants_mod, only: invariants
use nn_params
use nncommons
implicit none
double precision, intent(inout):: qq(maxnin)
double precision :: q(12),inv(4)
double precision :: qm(6)
double precision, parameter :: m_N=25526.04237518618d0
double precision, parameter :: m_H=1837.152647439619d0
double precision, parameter :: Ang2Bohr=1.889726124565d0
double precision diff(12), ref_geom(12)
double precision q_mod(12)
! transformation matrix
double precision mode(12,6)
! final internal coord vector
include 'newmodes.f'
ref_geom(1:12)=0.d0
ref_geom( 4 )=1.022871078d0
ref_geom( 7 )=-.5d0*ref_geom(4)
!ref_geom( 8 )=sqrt(1.5d0)*ref_geom(4)
ref_geom( 8)=0.5d0*sqrt(3.0d0)*ref_geom(4)
ref_geom(10 )=-.5d0*ref_geom(4)
!ref_geom(11 )=-sqrt(1.5d0)*ref_geom(4)
ref_geom(11)=-0.5d0*sqrt(3.0d0)*ref_geom(4)
!massN=25526.04237518618
!massH=1837.152647439619
!
q(1:12)=qq(1:12)
q_mod = (1.0d0/Ang2Bohr)*q
! difference vector
diff=q_mod-ref_geom
! mass weighting
diff(1:3)=diff(1:3)*sqrt(m_N)
diff(4:12)=diff(4:12)*sqrt(m_H)
qm=matmul(transpose(mode),diff)
do i =1,6
if ( abs(qm(i)) .lt. 1.0d-6) qm(i) = 0.0d0
enddo
qm(3) = -qm(3)
call invariants(qm(1),qm(2),qm(3),qm(4),qm(5),inv)
qq(1:len_in)=inv(1:len_in)
qq(len_in+1:len_in+5)=qm(2:6)
end subroutine cart2mode

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

@ -0,0 +1,174 @@
! Author: jnshuti
! Created: 2025-10-28 10:05:45
! Last modified: 2026-02-04 10:18:40 jnshuti
! Subroutine which transform the data in any desired format
module data_transf_mod
use iso_fortran_env, only: dp => real64, idp => int32
use nncommons, only: sets, ndata, inp_out,ndiab
use nn_params, only: maxpout,maxpats
use Phase_corr
implicit none
!integer(idp),parameter:: ndiab=4
private
public :: data_transform
contains
SUBROUTINE data_transform(pat_out,npat)
! IN: pat_out: the output patterns
! x1 the input pattern
! the aim it to transform pat_out in any disired form
implicit none
real(dp),intent(inout):: pat_out(maxpout,maxpats)
!real(dp),intent(inout):: ref_out(maxpout,maxpats)
integer(idp), intent(in):: npat ! the total number of point
! internal varibles
integer(idp) i,j,total ,ii,m,n
integer(idp), dimension(sets):: flipped_scan2, flipped_scan3
integer(idp), dimension(sets):: flipped_scan4
Real(dp),allocatable:: mux(:,:,:)
integer(idp):: scn_strt, scn_end,iref
logical, parameter:: flip =.true.
!write(6,*)"The total numbe of points used in data transform =",npat
! allocatable varables
allocate(mux(ndiab,ndiab,npat))
! define the scann need to be flipped
! list of all the scan need to flip the sign depending on the result of the molpro calculation
flipped_scan2 = 0; flipped_scan3 = 0; flipped_scan4 =0
flipped_scan3 = [1,3,4,5,6,7,8,9,10,11, &
12,13,14,15,16,17,18,19,20, &
21,22,24,25,54,55,56, &
58,59,60,61,62,63]
flipped_scan2 = [27,28,29,30,31,32,33,34,35, &
36,37,38,39,40,41,42,43,44, &
45,46,47,48,49,50,51,52,53, &
65,67,68,69,70,71, &
72,73,74]
flipped_scan4 = [23,64]
!flipped_scan2 = [77,80,118,120]
!flipped_scan3 = [56,111]
total=0
do i =1,sets
do j=1,ndata(i)
total = total+1
!pat_out(1:inp_out,total)=pat_out(1:inp_out,total)!-ref_en
! transform the y to matrix form
call Y2mat(pat_out(5:inp_out,total),Mux(:,:,total))
if (flip) then
if (j .gt. 2) call build_cluster(Mux(:,:,total-1),Mux(:,:,total))
endif
enddo
enddo
! flipe the required scan
if (flip) then
scn_end = 0
iref=0
do i =1,sets
if (ndata(i) .eq. 0) cycle
scn_strt = scn_end +1
scn_end = scn_end + ndata(i)
if (any(flipped_scan2 .eq. remap(i) )) then
do j = scn_strt,scn_end
call flip_e_state(Mux(:,:,j),2)
enddo
endif
if (any(flipped_scan3 .eq. remap(i) )) then
do j = scn_strt,scn_end
call flip_e_state(Mux(:,:,j),3)
enddo
endif
if (any(flipped_scan4 .eq. remap(i))) then
do j =scn_strt,scn_end
call flip_e_state(Mux(:,:,j),4)
enddo
endif
ii = 4
do m=1,ndiab
do n = m,ndiab
ii = ii +1
pat_out(ii,scn_strt:scn_end) = &
Mux(m,n,scn_strt:scn_end)
enddo
enddo
enddo
endif
deallocate(Mux)
END SUBROUTINE data_transform
subroutine Y2mat(Y,Mx)
IMPLICIT NONE
Real(dp), intent(in):: y(:)
Real(dp),intent(out):: Mx(ndiab,ndiab)
! internal variables
integer(idp):: ii,i,j
!ntot = ndiab*(ndiab+1)/2
!if (inp_out/2 .ne. ntot) then
! write(6,*)"output not equal ntot", inp_out,ntot
! stop
!endif
ii=1
do i=1,ndiab
do j=i,ndiab
! !mx
mx(i,j)=y(ii)
!
ii=ii+1
enddo
enddo
call copy_2_low(mx)
!call copy_2_low(my)
end subroutine
! ! subroutine which copy the upper matrix to lower
subroutine copy_2_low(m)
implicit none
real(dp), intent(inout) :: m(:,:)
integer(idp) :: i,j
! copy the lower part of the matrix to the upper part
do i=1,size(m,1)
do j=i,size(m,1)
m(j,i) = m(i,j)
enddo
enddo
end subroutine copy_2_low
integer function remap(i)
integer(idp),intent(in):: i
remap = i + 0
end function remap
end module data_transf_mod

411
src/model/dipole_model.f90 Normal file
View File

@ -0,0 +1,411 @@
module diabmodel
use dip_param
use iso_fortran_env, only:dp => real64,idp => int32
use nn_params
use nncommons, only: len_in
implicit none
!integer(idp),parameter:: ndiab=4
!logical :: debug=.false.
private
public:: diab_x
contains
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine diab_x(e,q,nn_out)
real(dp),intent(in) :: q(maxnin)
real(dp),intent(inout) :: nn_out(maxnout)
real(dp),intent(out) :: e(:,:)
integer(idp) id,i,j, ii
real(dp) xs,xb,ys,yb,a,b,ss,sb,v3_vec(8)
real(dp), dimension(16) :: shift,scal
! real(dp),dimension(17):: shi,scalee
real(dp), parameter:: tol = 1.0d-9
!include "shift-scale-70N.incl"
!include "sh-scal-50.incl"
xs=q(len_in+2)
ys=q(len_in+3)
xb=q(len_in+4)
yb=q(len_in+5)
a=q(len_in+1)
b=q(len_in+6)
id = 11
call init_dip_planar_data()
shift =1.0d0
scal = 1.0d0
ii = 5
do i = 28 ,np ! pes parameter key index
if( abs(p(i)) .gt. tol ) then
p(i) = p(i)*(shift(ii)+ scal(ii)*nn_out(ii))
ii = ii + 1
endif
enddo
!write(6,*)" Dipole non-zero", ii-1
ss=xs**2+ys**2 ! totaly symmetric term
sb=xb**2+yb**2
v3_vec( 1) = xs*(xs**2-3*ys**2)
v3_vec( 2) = xb*(xb**2-3*yb**2)
v3_vec( 3) = xb*(xs**2-ys**2) - 2*yb*xs*ys
v3_vec( 4) = xs*(xb**2-yb**2) - 2*ys*xb*yb
v3_vec( 5) = ys*(3*xs**2-ys**2)
v3_vec( 6) = yb*(3*xb**2-yb**2)
v3_vec( 7) = yb*(xs**2-ys**2)+2*xb*xs*ys
v3_vec( 8) = ys*(xb**2-yb**2)+2*xs*xb*yb
e=0.0d0
!id=key !1
! V-term
! order 1
e(1,1)=e(1,1)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb
id=id+1 !2
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
id=id+1 !3
e(4,4)=e(4,4)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb
! order 2
id=id+1 !4
e(1,1)=e(1,1)+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 !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)
! 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
id=id+1 !8
e(2,2)=e(2,2)+p(pst(1,id))*xs*ss+p(pst(1,id)+1)*xb*sb
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
! JAHN TELLER COUPLING W AND Z
! 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))
! order 1
id=id+1 !11
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
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)+p(pst(1,id)+3)*ss+p(pst(1,id)+4)*sb
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)+p(pst(1,id)+3)*ss+p(pst(1,id)+4)*sb)
e(2,3)=e(2,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)
! order 3
id=id+1 !13
do i=1,4
j=i-1
e(2,2)=e(2,2)+(p(pst(1,id)+j)+p(pst(1,id)+j+4))*v3_vec(i)
e(3,3)=e(3,3)-(p(pst(1,id)+j)+p(pst(1,id)+j+4))*v3_vec(i)
e(2,3)=e(2,3)+(-p(pst(1,id)+j)+p(pst(1,id)+j+4))*v3_vec(i+4)
enddo
e(2,2)=e(2,2)+p(pst(1,id)+8)*xs*ss+p(pst(1,id)+9)*xb*sb
e(3,3)=e(3,3)-(p(pst(1,id)+8)*xs*ss+p(pst(1,id)+9)*xb*sb)
e(2,3)=e(2,3)-p(pst(1,id)+8)*ys*ss-p(pst(1,id)+9)*yb*sb
! PSEUDO JAHN TELLER
! A2 ground state coupled with E
! ###################################################
! ###################################################
! order 0
id=id+1 !14
e(1,2)=e(1,2)+b*p(pst(1,id))
! order 1
id=id+1 !15
e(1,2)=e(1,2)+b*(p(pst(1,id))*xs+p(pst(1,id)+1)*xb)
e(1,3)=e(1,3)+b*(p(pst(1,id))*ys+p(pst(1,id)+1)*yb)
! order 2
id=id+1 !16
e(1,2)=e(1,2)+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) + p(pst(1,id)+3)*(xs**2+ys**2))
e(1,3)=e(1,3)-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))
! order 3
id =id+1 ! 17
do i=1,4
e(1,2)=e(1,2)+b*(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3_vec(i)
e(1,3)=e(1,3)+b*(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+3)))*v3_vec(i+4)
enddo
!! THE COUPLING OF A2 WITH A1
!####################################################
!####################################################
! order 1
id=id+1 !18
e(1,4)=e(1,4)+b*(p(pst(1,id))*xs+p(pst(1,id)+1)*xb)
id=id+1 !19
e(1,4)=e(1,4)+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))
!!! THE COUPLING OF A1 WITH E
!!####################################################
!####################################################
! order 0
id=id+1 !20
e(2,4)=e(2,4)+p(pst(1,id))
! order 1
id=id+1 !21
e(2,4)=e(2,4)+p(pst(1,id))*xs + p(pst(1,id)+1)*xb
e(3,4)=e(3,4)+p(pst(1,id))*ys + p(pst(1,id)+1)*yb
! order 2
id=id+1 !22
e(2,4)=e(2,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) +p(pst(1,id)+3)*(xs**2+ys**2)
e(3,4)=e(3,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)
! order 3
id=id+1 !23
do i=1,4
e(2,4)=e(2,4)+(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3_vec(i)
e(3,4)=e(3,4)+(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+3)))*v3_vec(i+4)
enddo
!! End of the model
e(2,1)=e(1,2)
e(3,1)=e(1,3)
e(3,2)=e(2,3)
e(4,1)=e(1,4)
e(4,2)=e(2,4)
e(4,3)=e(3,4)
end subroutine diab_x
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! THE Y COMPONENT OF DIPOLE
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!subroutine diab_y(e,q,nn_out)
! real(dp),intent(in) :: q(maxnin)
! real(dp),intent(inout) :: nn_out(maxnout)
! real(dp),intent(out) :: e(:,:)
! integer(idp) id,i,j, ii
! real(dp) xs,xb,ys,yb,a,b,ss,sb,v3_vec(8)
! real(dp), dimension(23) :: shift,scal
! real(dp), parameter:: tol = 1.0d-9
!
! xs=q(5)
! ys=q(6)
! xb=q(7)
! yb=q(8)
! a=q(4)
! b=q(9)
!
! id = 11
!
! call init_dip_planar_data()
! scal = 1.0d-3
! shift =1.0d0
! ii = 1
! do i = 11 ,np ! pes parameter key index
! if( abs(p(i)) .gt. tol ) then
! p(i) = p(i)*(shift(ii)+ scal(ii)*nn_out(ii))
! ii = ii + 1
! endif
! enddo
!
! id = 11
!
! ss=xs**2+ys**2 ! totaly symmetric term
! sb=xb**2+yb**2
!
! v3_vec( 1) = xs*(xs**2-3*ys**2)
! v3_vec( 2) = xb*(xb**2-3*yb**2)
! v3_vec( 3) = xb*(xs**2-ys**2) - 2*yb*xs*ys
! v3_vec( 4) = xs*(xb**2-yb**2) - 2*ys*xb*yb
! v3_vec( 5) = ys*(3*xs**2-ys**2)
! v3_vec( 6) = yb*(3*xb**2-yb**2)
! v3_vec( 7) = yb*(xs**2-ys**2)+2*xb*xs*ys
! v3_vec( 8) = ys*(xb**2-yb**2)+2*xs*xb*yb
!
!
!
!
!
! e=0.0d0
! ! V-term
! !id=key !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
! ! order 2
! id=id+1 !4
! 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)
! ! 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 !8
! 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 !9
! e(4,4)=e(4,4)+p(pst(1,id))*ys*ss+p(pst(1,id)+1)*yb*sb
!
! ! V- term + totally symmetric coord a
!
! ! JAHN TELLER COUPLING TERM
! ! order 0
! id=id+1 !10
! e(2,3)=e(2,3)+p(pst(1,id))
! ! order 1
!
! id=id+1 !11
! 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
! !id=id+1 !12
! ! order 2
! id=id+1 !12
! 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)
! e(2,3)=e(2,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)+p(pst(1,id)+3)*ss+p(pst(1,id)+4)*sb
! ! order 3
! id=id+1 !13
! do i=1,4
! j=i-1
! e(2,2)=e(2,2)+(p(pst(1,id)+j)-p(pst(1,id)+j+4))*v3_vec(i+4)
! e(3,3)=e(3,3)-(p(pst(1,id)+j)-p(pst(1,id)+j+4))*v3_vec(i+4)
! e(2,3)=e(2,3)+(p(pst(1,id)+j)+p(pst(1,id)+j+4))*v3_vec(i)
! enddo
! e(2,2)=e(2,2)-p(pst(1,id)+8)*ys*ss-p(pst(1,id)+9)*yb*sb
! e(3,3)=e(3,3)+p(pst(1,id)+8)*ys*ss+p(pst(1,id)+9)*yb*sb
! e(2,3)=e(2,3)-p(pst(1,id)+8)*xs*ss-p(pst(1,id)+1)*xb*sb
! ! PSEUDO JAHN TELLER
! ! ORDER 0
! ! THE COUPLING OF A2 GROUND STATE WITH E
! ! ###################################################
! ! ###################################################
! ! order 0
! id=id+1 !14
! e(1,3)=e(1,3)-b*(p(pst(1,id)))
! ! order 1
! id=id+1 !15
! 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 !16
! 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) - p(pst(1,id)+3)*(xs**2+ys**2))
!
! ! order 3
! id = id+1 ! 17
! do i=1,4
! e(1,2)=e(1,2)+b*(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+3)))*v3_vec(i+4)
! e(1,3)=e(1,3)-b*(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3_vec(i)
! enddo
!
!
! ! THE COUPLING OF A2 WITH A1
! !####################################################
! !####################################################
! ! order 1
! id=id+1 !17
! e(1,4)=e(1,4)+b*(p(pst(1,id))*ys+p(pst(1,id)+1)*yb)
! ! order 2
! id=id+1 !18
! e(1,4)=e(1,4)-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))
!
!
! ! THE COUPLING OF A1 WITH E
! !####################################################
! !####################################################
! ! order 0
! id=id+1 !19
! e(3,4)=e(3,4)-p(pst(1,id))
! ! order 1
! id=id+1 !20
! e(2,4)=e(2,4)-p(pst(1,id))*ys-p(pst(1,id)+1)*yb
! e(3,4)=e(3,4)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb
! ! order 2
! id=id+1 !21
! e(2,4)=e(2,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(3,4)=e(3,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) - p(pst(1,id)+3)*(xs**2+ys**2)
!
! id =id+1 ! 23
! ! order 3
! do i=1,4
! e(2,4)=e(2,4)+(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+3)))*v3_vec(i+4)
! e(3,4)=e(3,4)-(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3_vec(i)
! enddo
!
! ! end of the model
! e(2,1)=e(1,2)
! e(3,1)=e(1,3)
! e(3,2)=e(2,3)
! e(4,1)=e(1,4)
! e(4,2)=e(2,4)
! e(4,3)=e(3,4)
! ! change Ex and Ey
!end subroutine diab_y
! potential nh3
! parth
!subroutine copy_2_lower_triangle(mat)
! real(dp), intent(inout) :: mat(:, :)
! integer :: m, n
! write lower triangle of matrix symmetrical
! do n = 2, size(mat, 1)
! do m = 1, n - 1
! mat(n, m) = mat(m, n)
! end do
! end do
! end subroutine copy_2_lower_triangle
end module diabmodel

914
src/model/fit_genetic.f90 Normal file
View File

@ -0,0 +1,914 @@
Module dip_param
IMPLICIT NONE
Integer,parameter :: np=101
Double precision :: p(101)
integer :: pst(2,400)
! Non zero parameters are 17
!$omp threadprivate(p,pst)
contains
SUBROUTINE init_dip_planar_data()
implicit none
p( 1)= -0.561433980D+02
p( 2)= 0.000000000D+00
p( 3)= 0.000000000D+00
p( 4)= -0.558830090D+02
p( 5)= 0.000000000D+00
p( 6)= 0.000000000D+00
p( 7)= -0.557220030D+02
p( 8)= 0.000000000D+00
p( 9)= 0.000000000D+00
p( 10)= 0.000000000D+00
p( 11)= 0.334452655D-02
p( 12)= 0.000000000D+00
p( 13)= 0.000000000D+00
p( 14)= 0.000000000D+00
p( 15)= 0.000000000D+00
p( 16)= 0.000000000D+00
p( 17)= 0.000000000D+00
p( 18)= 0.000000000D+00
p( 19)= 0.000000000D+00
p( 20)= 0.000000000D+00
p( 21)= -0.532590808D-03
p( 22)= 0.000000000D+00
p( 23)= 0.000000000D+00
p( 24)= 0.000000000D+00
p( 25)= 0.000000000D+00
p( 26)= 0.000000000D+00
p( 27)= 0.000000000D+00
p( 28)= -0.226116045D-01
p( 29)= 0.000000000D+00
p( 30)= -0.363599361D-01
p( 31)= 0.000000000D+00
p( 32)= 0.962100323D-01
p( 33)= 0.000000000D+00
p( 34)= 0.111336127D-03
p( 35)= 0.000000000D+00
p( 36)= 0.000000000D+00
p( 37)= -0.433685770D-04
p( 38)= 0.000000000D+00
p( 39)= 0.000000000D+00
p( 40)= -0.548870572D-02
p( 41)= 0.000000000D+00
p( 42)= 0.000000000D+00
p( 43)= 0.000000000D+00
p( 44)= 0.000000000D+00
p( 45)= 0.000000000D+00
p( 46)= 0.000000000D+00
p( 47)= 0.000000000D+00
p( 48)= 0.000000000D+00
p( 49)= 0.217598103D+00
p( 50)= -0.113909871D-01
p( 51)= 0.000000000D+00
p( 52)= -0.123184224D-03
p( 53)= 0.000000000D+00
p( 54)= 0.000000000D+00
p( 55)= 0.000000000D+00
p( 56)= 0.000000000D+00
p( 57)= 0.000000000D+00
p( 58)= 0.000000000D+00
p( 59)= 0.000000000D+00
p( 60)= 0.000000000D+00
p( 61)= 0.000000000D+00
p( 62)= 0.000000000D+00
p( 63)= 0.000000000D+00
p( 64)= 0.000000000D+00
p( 65)= 0.000000000D+00
p( 66)= 0.000000000D+00
p( 67)= 0.000000000D+00
p( 68)= 0.000000000D+00
p( 69)= 0.000000000D+00
p( 70)= 0.000000000D+00
p( 71)= 0.000000000D+00
p( 72)= 0.000000000D+00
p( 73)= 0.000000000D+00
p( 74)= 0.000000000D+00
p( 75)= 0.000000000D+00
p( 76)= 0.000000000D+00
p( 77)= 0.000000000D+00
p( 78)= 0.000000000D+00
p( 79)= 0.000000000D+00
p( 80)= 0.000000000D+00
p( 81)= 0.000000000D+00
p( 82)= 0.000000000D+00
p( 83)= 0.000000000D+00
p( 84)= 0.000000000D+00
p( 85)= 0.000000000D+00
p( 86)= 0.000000000D+00
p( 87)= -0.567206500D-02
p( 88)= -0.613490432D-02
p( 89)= 0.000000000D+00
p( 90)= 0.303022045D-03
p( 91)= 0.000000000D+00
p( 92)= 0.000000000D+00
p( 93)= 0.000000000D+00
p( 94)= 0.000000000D+00
p( 95)= 0.000000000D+00
p( 96)= 0.000000000D+00
p( 97)= 0.000000000D+00
p( 98)= 0.000000000D+00
p( 99)= 0.000000000D+00
p(100)= 0.000000000D+00
p(101)= 0.000000000D+00
pst(1, 1)= 1
pst(2, 1)= 3
pst(1, 2)= 4
pst(2, 2)= 3
pst(1, 3)= 7
pst(2, 3)= 4
pst(1, 4)= 11
pst(2, 4)= 2
pst(1, 5)= 13
pst(2, 5)= 3
pst(1, 6)= 16
pst(2, 6)= 2
pst(1, 7)= 18
pst(2, 7)= 3
pst(1, 8)= 21
pst(2, 8)= 3
pst(1, 9)= 24
pst(2, 9)= 3
pst(1, 10)= 27
pst(2, 10)= 1
pst(1, 11)= 28
pst(2, 11)= 2
pst(1, 12)= 30
pst(2, 12)= 2
pst(1, 13)= 32
pst(2, 13)= 2
pst(1, 14)= 34
pst(2, 14)= 3
pst(1, 15)= 37
pst(2, 15)= 3
pst(1, 16)= 40
pst(2, 16)= 3
pst(1, 17)= 43
pst(2, 17)= 2
pst(1, 18)= 45
pst(2, 18)= 2
pst(1, 19)= 47
pst(2, 19)= 2
pst(1, 20)= 49
pst(2, 20)= 1
pst(1, 21)= 50
pst(2, 21)= 2
pst(1, 22)= 52
pst(2, 22)= 5
pst(1, 23)= 57
pst(2, 23)= 10
pst(1, 24)= 67
pst(2, 24)= 1
pst(1, 25)= 68
pst(2, 25)= 2
pst(1, 26)= 70
pst(2, 26)= 4
pst(1, 27)= 74
pst(2, 27)= 8
pst(1, 28)= 82
pst(2, 28)= 2
pst(1, 29)= 84
pst(2, 29)= 3
pst(1, 30)= 87
pst(2, 30)= 1
pst(1, 31)= 88
pst(2, 31)= 2
pst(1, 32)= 90
pst(2, 32)= 4
pst(1, 33)= 94
pst(2, 33)= 8
pst(1, 34)= 0
pst(2, 34)= 0
pst(1, 35)= 0
pst(2, 35)= 0
pst(1, 36)= 0
pst(2, 36)= 0
pst(1, 37)= 0
pst(2, 37)= 0
pst(1, 38)= 0
pst(2, 38)= 0
pst(1, 39)= 0
pst(2, 39)= 0
pst(1, 40)= 0
pst(2, 40)= 0
pst(1, 41)= 0
pst(2, 41)= 0
pst(1, 42)= 0
pst(2, 42)= 0
pst(1, 43)= 0
pst(2, 43)= 0
pst(1, 44)= 0
pst(2, 44)= 0
pst(1, 45)= 0
pst(2, 45)= 0
pst(1, 46)= 0
pst(2, 46)= 0
pst(1, 47)= 0
pst(2, 47)= 0
pst(1, 48)= 0
pst(2, 48)= 0
pst(1, 49)= 0
pst(2, 49)= 0
pst(1, 50)= 0
pst(2, 50)= 0
pst(1, 51)= 0
pst(2, 51)= 0
pst(1, 52)= 0
pst(2, 52)= 0
pst(1, 53)= 0
pst(2, 53)= 0
pst(1, 54)= 0
pst(2, 54)= 0
pst(1, 55)= 0
pst(2, 55)= 0
pst(1, 56)= 0
pst(2, 56)= 0
pst(1, 57)= 0
pst(2, 57)= 0
pst(1, 58)= 0
pst(2, 58)= 0
pst(1, 59)= 0
pst(2, 59)= 0
pst(1, 60)= 0
pst(2, 60)= 0
pst(1, 61)= 0
pst(2, 61)= 0
pst(1, 62)= 0
pst(2, 62)= 0
pst(1, 63)= 0
pst(2, 63)= 0
pst(1, 64)= 0
pst(2, 64)= 0
pst(1, 65)= 0
pst(2, 65)= 0
pst(1, 66)= 0
pst(2, 66)= 0
pst(1, 67)= 0
pst(2, 67)= 0
pst(1, 68)= 0
pst(2, 68)= 0
pst(1, 69)= 0
pst(2, 69)= 0
pst(1, 70)= 0
pst(2, 70)= 0
pst(1, 71)= 0
pst(2, 71)= 0
pst(1, 72)= 0
pst(2, 72)= 0
pst(1, 73)= 0
pst(2, 73)= 0
pst(1, 74)= 0
pst(2, 74)= 0
pst(1, 75)= 0
pst(2, 75)= 0
pst(1, 76)= 0
pst(2, 76)= 0
pst(1, 77)= 0
pst(2, 77)= 0
pst(1, 78)= 0
pst(2, 78)= 0
pst(1, 79)= 0
pst(2, 79)= 0
pst(1, 80)= 0
pst(2, 80)= 0
pst(1, 81)= 0
pst(2, 81)= 0
pst(1, 82)= 0
pst(2, 82)= 0
pst(1, 83)= 0
pst(2, 83)= 0
pst(1, 84)= 0
pst(2, 84)= 0
pst(1, 85)= 0
pst(2, 85)= 0
pst(1, 86)= 0
pst(2, 86)= 0
pst(1, 87)= 0
pst(2, 87)= 0
pst(1, 88)= 0
pst(2, 88)= 0
pst(1, 89)= 0
pst(2, 89)= 0
pst(1, 90)= 0
pst(2, 90)= 0
pst(1, 91)= 0
pst(2, 91)= 0
pst(1, 92)= 0
pst(2, 92)= 0
pst(1, 93)= 0
pst(2, 93)= 0
pst(1, 94)= 0
pst(2, 94)= 0
pst(1, 95)= 0
pst(2, 95)= 0
pst(1, 96)= 0
pst(2, 96)= 0
pst(1, 97)= 0
pst(2, 97)= 0
pst(1, 98)= 0
pst(2, 98)= 0
pst(1, 99)= 0
pst(2, 99)= 0
pst(1,100)= 0
pst(2,100)= 0
pst(1,101)= 0
pst(2,101)= 0
pst(1,102)= 0
pst(2,102)= 0
pst(1,103)= 0
pst(2,103)= 0
pst(1,104)= 0
pst(2,104)= 0
pst(1,105)= 0
pst(2,105)= 0
pst(1,106)= 0
pst(2,106)= 0
pst(1,107)= 0
pst(2,107)= 0
pst(1,108)= 0
pst(2,108)= 0
pst(1,109)= 0
pst(2,109)= 0
pst(1,110)= 0
pst(2,110)= 0
pst(1,111)= 0
pst(2,111)= 0
pst(1,112)= 0
pst(2,112)= 0
pst(1,113)= 0
pst(2,113)= 0
pst(1,114)= 0
pst(2,114)= 0
pst(1,115)= 0
pst(2,115)= 0
pst(1,116)= 0
pst(2,116)= 0
pst(1,117)= 0
pst(2,117)= 0
pst(1,118)= 0
pst(2,118)= 0
pst(1,119)= 0
pst(2,119)= 0
pst(1,120)= 0
pst(2,120)= 0
pst(1,121)= 0
pst(2,121)= 0
pst(1,122)= 0
pst(2,122)= 0
pst(1,123)= 0
pst(2,123)= 0
pst(1,124)= 0
pst(2,124)= 0
pst(1,125)= 0
pst(2,125)= 0
pst(1,126)= 0
pst(2,126)= 0
pst(1,127)= 0
pst(2,127)= 0
pst(1,128)= 0
pst(2,128)= 0
pst(1,129)= 0
pst(2,129)= 0
pst(1,130)= 0
pst(2,130)= 0
pst(1,131)= 0
pst(2,131)= 0
pst(1,132)= 0
pst(2,132)= 0
pst(1,133)= 0
pst(2,133)= 0
pst(1,134)= 0
pst(2,134)= 0
pst(1,135)= 0
pst(2,135)= 0
pst(1,136)= 0
pst(2,136)= 0
pst(1,137)= 0
pst(2,137)= 0
pst(1,138)= 0
pst(2,138)= 0
pst(1,139)= 0
pst(2,139)= 0
pst(1,140)= 0
pst(2,140)= 0
pst(1,141)= 0
pst(2,141)= 0
pst(1,142)= 0
pst(2,142)= 0
pst(1,143)= 0
pst(2,143)= 0
pst(1,144)= 0
pst(2,144)= 0
pst(1,145)= 0
pst(2,145)= 0
pst(1,146)= 0
pst(2,146)= 0
pst(1,147)= 0
pst(2,147)= 0
pst(1,148)= 0
pst(2,148)= 0
pst(1,149)= 0
pst(2,149)= 0
pst(1,150)= 0
pst(2,150)= 0
pst(1,151)= 0
pst(2,151)= 0
pst(1,152)= 0
pst(2,152)= 0
pst(1,153)= 0
pst(2,153)= 0
pst(1,154)= 0
pst(2,154)= 0
pst(1,155)= 0
pst(2,155)= 0
pst(1,156)= 0
pst(2,156)= 0
pst(1,157)= 0
pst(2,157)= 0
pst(1,158)= 0
pst(2,158)= 0
pst(1,159)= 0
pst(2,159)= 0
pst(1,160)= 0
pst(2,160)= 0
pst(1,161)= 0
pst(2,161)= 0
pst(1,162)= 0
pst(2,162)= 0
pst(1,163)= 0
pst(2,163)= 0
pst(1,164)= 0
pst(2,164)= 0
pst(1,165)= 0
pst(2,165)= 0
pst(1,166)= 0
pst(2,166)= 0
pst(1,167)= 0
pst(2,167)= 0
pst(1,168)= 0
pst(2,168)= 0
pst(1,169)= 0
pst(2,169)= 0
pst(1,170)= 0
pst(2,170)= 0
pst(1,171)= 0
pst(2,171)= 0
pst(1,172)= 0
pst(2,172)= 0
pst(1,173)= 0
pst(2,173)= 0
pst(1,174)= 0
pst(2,174)= 0
pst(1,175)= 0
pst(2,175)= 0
pst(1,176)= 0
pst(2,176)= 0
pst(1,177)= 0
pst(2,177)= 0
pst(1,178)= 0
pst(2,178)= 0
pst(1,179)= 0
pst(2,179)= 0
pst(1,180)= 0
pst(2,180)= 0
pst(1,181)= 0
pst(2,181)= 0
pst(1,182)= 0
pst(2,182)= 0
pst(1,183)= 0
pst(2,183)= 0
pst(1,184)= 0
pst(2,184)= 0
pst(1,185)= 0
pst(2,185)= 0
pst(1,186)= 0
pst(2,186)= 0
pst(1,187)= 0
pst(2,187)= 0
pst(1,188)= 0
pst(2,188)= 0
pst(1,189)= 0
pst(2,189)= 0
pst(1,190)= 0
pst(2,190)= 0
pst(1,191)= 0
pst(2,191)= 0
pst(1,192)= 0
pst(2,192)= 0
pst(1,193)= 0
pst(2,193)= 0
pst(1,194)= 0
pst(2,194)= 0
pst(1,195)= 0
pst(2,195)= 0
pst(1,196)= 0
pst(2,196)= 0
pst(1,197)= 0
pst(2,197)= 0
pst(1,198)= 0
pst(2,198)= 0
pst(1,199)= 0
pst(2,199)= 0
pst(1,200)= 0
pst(2,200)= 0
pst(1,201)= 0
pst(2,201)= 0
pst(1,202)= 0
pst(2,202)= 0
pst(1,203)= 0
pst(2,203)= 0
pst(1,204)= 0
pst(2,204)= 0
pst(1,205)= 0
pst(2,205)= 0
pst(1,206)= 0
pst(2,206)= 0
pst(1,207)= 0
pst(2,207)= 0
pst(1,208)= 0
pst(2,208)= 0
pst(1,209)= 0
pst(2,209)= 0
pst(1,210)= 0
pst(2,210)= 0
pst(1,211)= 0
pst(2,211)= 0
pst(1,212)= 0
pst(2,212)= 0
pst(1,213)= 0
pst(2,213)= 0
pst(1,214)= 0
pst(2,214)= 0
pst(1,215)= 0
pst(2,215)= 0
pst(1,216)= 0
pst(2,216)= 0
pst(1,217)= 0
pst(2,217)= 0
pst(1,218)= 0
pst(2,218)= 0
pst(1,219)= 0
pst(2,219)= 0
pst(1,220)= 0
pst(2,220)= 0
pst(1,221)= 0
pst(2,221)= 0
pst(1,222)= 0
pst(2,222)= 0
pst(1,223)= 0
pst(2,223)= 0
pst(1,224)= 0
pst(2,224)= 0
pst(1,225)= 0
pst(2,225)= 0
pst(1,226)= 0
pst(2,226)= 0
pst(1,227)= 0
pst(2,227)= 0
pst(1,228)= 0
pst(2,228)= 0
pst(1,229)= 0
pst(2,229)= 0
pst(1,230)= 0
pst(2,230)= 0
pst(1,231)= 0
pst(2,231)= 0
pst(1,232)= 0
pst(2,232)= 0
pst(1,233)= 0
pst(2,233)= 0
pst(1,234)= 0
pst(2,234)= 0
pst(1,235)= 0
pst(2,235)= 0
pst(1,236)= 0
pst(2,236)= 0
pst(1,237)= 0
pst(2,237)= 0
pst(1,238)= 0
pst(2,238)= 0
pst(1,239)= 0
pst(2,239)= 0
pst(1,240)= 0
pst(2,240)= 0
pst(1,241)= 0
pst(2,241)= 0
pst(1,242)= 0
pst(2,242)= 0
pst(1,243)= 0
pst(2,243)= 0
pst(1,244)= 0
pst(2,244)= 0
pst(1,245)= 0
pst(2,245)= 0
pst(1,246)= 0
pst(2,246)= 0
pst(1,247)= 0
pst(2,247)= 0
pst(1,248)= 0
pst(2,248)= 0
pst(1,249)= 0
pst(2,249)= 0
pst(1,250)= 0
pst(2,250)= 0
pst(1,251)= 0
pst(2,251)= 0
pst(1,252)= 0
pst(2,252)= 0
pst(1,253)= 0
pst(2,253)= 0
pst(1,254)= 0
pst(2,254)= 0
pst(1,255)= 0
pst(2,255)= 0
pst(1,256)= 0
pst(2,256)= 0
pst(1,257)= 0
pst(2,257)= 0
pst(1,258)= 0
pst(2,258)= 0
pst(1,259)= 0
pst(2,259)= 0
pst(1,260)= 0
pst(2,260)= 0
pst(1,261)= 0
pst(2,261)= 0
pst(1,262)= 0
pst(2,262)= 0
pst(1,263)= 0
pst(2,263)= 0
pst(1,264)= 0
pst(2,264)= 0
pst(1,265)= 0
pst(2,265)= 0
pst(1,266)= 0
pst(2,266)= 0
pst(1,267)= 0
pst(2,267)= 0
pst(1,268)= 0
pst(2,268)= 0
pst(1,269)= 0
pst(2,269)= 0
pst(1,270)= 0
pst(2,270)= 0
pst(1,271)= 0
pst(2,271)= 0
pst(1,272)= 0
pst(2,272)= 0
pst(1,273)= 0
pst(2,273)= 0
pst(1,274)= 0
pst(2,274)= 0
pst(1,275)= 0
pst(2,275)= 0
pst(1,276)= 0
pst(2,276)= 0
pst(1,277)= 0
pst(2,277)= 0
pst(1,278)= 0
pst(2,278)= 0
pst(1,279)= 0
pst(2,279)= 0
pst(1,280)= 0
pst(2,280)= 0
pst(1,281)= 0
pst(2,281)= 0
pst(1,282)= 0
pst(2,282)= 0
pst(1,283)= 0
pst(2,283)= 0
pst(1,284)= 0
pst(2,284)= 0
pst(1,285)= 0
pst(2,285)= 0
pst(1,286)= 0
pst(2,286)= 0
pst(1,287)= 0
pst(2,287)= 0
pst(1,288)= 0
pst(2,288)= 0
pst(1,289)= 0
pst(2,289)= 0
pst(1,290)= 0
pst(2,290)= 0
pst(1,291)= 0
pst(2,291)= 0
pst(1,292)= 0
pst(2,292)= 0
pst(1,293)= 0
pst(2,293)= 0
pst(1,294)= 0
pst(2,294)= 0
pst(1,295)= 0
pst(2,295)= 0
pst(1,296)= 0
pst(2,296)= 0
pst(1,297)= 0
pst(2,297)= 0
pst(1,298)= 0
pst(2,298)= 0
pst(1,299)= 0
pst(2,299)= 0
pst(1,300)= 0
pst(2,300)= 0
pst(1,301)= 0
pst(2,301)= 0
pst(1,302)= 0
pst(2,302)= 0
pst(1,303)= 0
pst(2,303)= 0
pst(1,304)= 0
pst(2,304)= 0
pst(1,305)= 0
pst(2,305)= 0
pst(1,306)= 0
pst(2,306)= 0
pst(1,307)= 0
pst(2,307)= 0
pst(1,308)= 0
pst(2,308)= 0
pst(1,309)= 0
pst(2,309)= 0
pst(1,310)= 0
pst(2,310)= 0
pst(1,311)= 0
pst(2,311)= 0
pst(1,312)= 0
pst(2,312)= 0
pst(1,313)= 0
pst(2,313)= 0
pst(1,314)= 0
pst(2,314)= 0
pst(1,315)= 0
pst(2,315)= 0
pst(1,316)= 0
pst(2,316)= 0
pst(1,317)= 0
pst(2,317)= 0
pst(1,318)= 0
pst(2,318)= 0
pst(1,319)= 0
pst(2,319)= 0
pst(1,320)= 0
pst(2,320)= 0
pst(1,321)= 0
pst(2,321)= 0
pst(1,322)= 0
pst(2,322)= 0
pst(1,323)= 0
pst(2,323)= 0
pst(1,324)= 0
pst(2,324)= 0
pst(1,325)= 0
pst(2,325)= 0
pst(1,326)= 0
pst(2,326)= 0
pst(1,327)= 0
pst(2,327)= 0
pst(1,328)= 0
pst(2,328)= 0
pst(1,329)= 0
pst(2,329)= 0
pst(1,330)= 0
pst(2,330)= 0
pst(1,331)= 0
pst(2,331)= 0
pst(1,332)= 0
pst(2,332)= 0
pst(1,333)= 0
pst(2,333)= 0
pst(1,334)= 0
pst(2,334)= 0
pst(1,335)= 0
pst(2,335)= 0
pst(1,336)= 0
pst(2,336)= 0
pst(1,337)= 0
pst(2,337)= 0
pst(1,338)= 0
pst(2,338)= 0
pst(1,339)= 0
pst(2,339)= 0
pst(1,340)= 0
pst(2,340)= 0
pst(1,341)= 0
pst(2,341)= 0
pst(1,342)= 0
pst(2,342)= 0
pst(1,343)= 0
pst(2,343)= 0
pst(1,344)= 0
pst(2,344)= 0
pst(1,345)= 0
pst(2,345)= 0
pst(1,346)= 0
pst(2,346)= 0
pst(1,347)= 0
pst(2,347)= 0
pst(1,348)= 0
pst(2,348)= 0
pst(1,349)= 0
pst(2,349)= 0
pst(1,350)= 0
pst(2,350)= 0
pst(1,351)= 0
pst(2,351)= 0
pst(1,352)= 0
pst(2,352)= 0
pst(1,353)= 0
pst(2,353)= 0
pst(1,354)= 0
pst(2,354)= 0
pst(1,355)= 0
pst(2,355)= 0
pst(1,356)= 0
pst(2,356)= 0
pst(1,357)= 0
pst(2,357)= 0
pst(1,358)= 0
pst(2,358)= 0
pst(1,359)= 0
pst(2,359)= 0
pst(1,360)= 0
pst(2,360)= 0
pst(1,361)= 0
pst(2,361)= 0
pst(1,362)= 0
pst(2,362)= 0
pst(1,363)= 0
pst(2,363)= 0
pst(1,364)= 0
pst(2,364)= 0
pst(1,365)= 0
pst(2,365)= 0
pst(1,366)= 0
pst(2,366)= 0
pst(1,367)= 0
pst(2,367)= 0
pst(1,368)= 0
pst(2,368)= 0
pst(1,369)= 0
pst(2,369)= 0
pst(1,370)= 0
pst(2,370)= 0
pst(1,371)= 0
pst(2,371)= 0
pst(1,372)= 0
pst(2,372)= 0
pst(1,373)= 0
pst(2,373)= 0
pst(1,374)= 0
pst(2,374)= 0
pst(1,375)= 0
pst(2,375)= 0
pst(1,376)= 0
pst(2,376)= 0
pst(1,377)= 0
pst(2,377)= 0
pst(1,378)= 0
pst(2,378)= 0
pst(1,379)= 0
pst(2,379)= 0
pst(1,380)= 0
pst(2,380)= 0
pst(1,381)= 0
pst(2,381)= 0
pst(1,382)= 0
pst(2,382)= 0
pst(1,383)= 0
pst(2,383)= 0
pst(1,384)= 0
pst(2,384)= 0
pst(1,385)= 0
pst(2,385)= 0
pst(1,386)= 0
pst(2,386)= 0
pst(1,387)= 0
pst(2,387)= 0
pst(1,388)= 0
pst(2,388)= 0
pst(1,389)= 0
pst(2,389)= 0
pst(1,390)= 0
pst(2,390)= 0
pst(1,391)= 0
pst(2,391)= 0
pst(1,392)= 0
pst(2,392)= 0
pst(1,393)= 0
pst(2,393)= 0
pst(1,394)= 0
pst(2,394)= 0
pst(1,395)= 0
pst(2,395)= 0
pst(1,396)= 0
pst(2,396)= 0
pst(1,397)= 0
pst(2,397)= 0
pst(1,398)= 0
pst(2,398)= 0
pst(1,399)= 0
pst(2,399)= 0
pst(1,400)= 0
pst(2,400)= 0
End SUBROUTINE init_dip_planar_data
End Module dip_param

914
src/model/fit_param_dip_pes.f90 Normal file
View File

@ -0,0 +1,914 @@
Module dip_param
IMPLICIT NONE
Integer,parameter :: np=101
Double precision :: p(101)
integer :: pst(2,400)
! Non zero parameters are 16
!$omp threadprivate(p,pst)
contains
SUBROUTINE init_dip_planar_data()
implicit none
p( 1)= -0.561433980D+02
p( 2)= 0.000000000D+00
p( 3)= 0.000000000D+00
p( 4)= -0.558830090D+02
p( 5)= 0.000000000D+00
p( 6)= 0.000000000D+00
p( 7)= -0.557220030D+02
p( 8)= 0.000000000D+00
p( 9)= 0.000000000D+00
p( 10)= 0.000000000D+00
p( 11)= 0.333624014D-02
p( 12)= 0.000000000D+00
p( 13)= 0.000000000D+00
p( 14)= 0.000000000D+00
p( 15)= 0.000000000D+00
p( 16)= 0.000000000D+00
p( 17)= 0.000000000D+00
p( 18)= 0.000000000D+00
p( 19)= 0.000000000D+00
p( 20)= 0.000000000D+00
p( 21)= -0.532590808D-03
p( 22)= 0.000000000D+00
p( 23)= 0.000000000D+00
p( 24)= 0.000000000D+00
p( 25)= 0.000000000D+00
p( 26)= 0.000000000D+00
p( 27)= 0.000000000D+00
p( 28)= -0.226073502D-01
p( 29)= 0.000000000D+00
p( 30)= -0.363395355D-01
p( 31)= 0.000000000D+00
p( 32)= 0.939930347D-01
p( 33)= 0.000000000D+00
p( 34)= 0.111364489D-03
p( 35)= 0.000000000D+00
p( 36)= 0.000000000D+00
p( 37)= 0.000000000D+00
p( 38)= 0.000000000D+00
p( 39)= 0.000000000D+00
p( 40)= -0.545384229D-02
p( 41)= 0.000000000D+00
p( 42)= 0.000000000D+00
p( 43)= 0.000000000D+00
p( 44)= 0.000000000D+00
p( 45)= 0.000000000D+00
p( 46)= 0.000000000D+00
p( 47)= 0.000000000D+00
p( 48)= 0.000000000D+00
p( 49)= 0.217598103D+00
p( 50)= -0.113772250D-01
p( 51)= 0.000000000D+00
p( 52)= -0.122160662D-03
p( 53)= 0.000000000D+00
p( 54)= 0.000000000D+00
p( 55)= 0.000000000D+00
p( 56)= 0.000000000D+00
p( 57)= 0.000000000D+00
p( 58)= 0.000000000D+00
p( 59)= 0.000000000D+00
p( 60)= 0.000000000D+00
p( 61)= 0.000000000D+00
p( 62)= 0.000000000D+00
p( 63)= 0.000000000D+00
p( 64)= 0.000000000D+00
p( 65)= 0.000000000D+00
p( 66)= 0.000000000D+00
p( 67)= 0.000000000D+00
p( 68)= 0.000000000D+00
p( 69)= 0.000000000D+00
p( 70)= 0.000000000D+00
p( 71)= 0.000000000D+00
p( 72)= 0.000000000D+00
p( 73)= 0.000000000D+00
p( 74)= 0.000000000D+00
p( 75)= 0.000000000D+00
p( 76)= 0.000000000D+00
p( 77)= 0.000000000D+00
p( 78)= 0.000000000D+00
p( 79)= 0.000000000D+00
p( 80)= 0.000000000D+00
p( 81)= 0.000000000D+00
p( 82)= 0.000000000D+00
p( 83)= 0.000000000D+00
p( 84)= 0.000000000D+00
p( 85)= 0.000000000D+00
p( 86)= 0.000000000D+00
p( 87)= -0.567206500D-02
p( 88)= -0.565873672D-02
p( 89)= 0.000000000D+00
p( 90)= 0.336524505D-03
p( 91)= 0.000000000D+00
p( 92)= 0.000000000D+00
p( 93)= 0.000000000D+00
p( 94)= 0.000000000D+00
p( 95)= 0.000000000D+00
p( 96)= 0.000000000D+00
p( 97)= 0.000000000D+00
p( 98)= 0.000000000D+00
p( 99)= 0.000000000D+00
p(100)= 0.000000000D+00
p(101)= 0.000000000D+00
pst(1, 1)= 1
pst(2, 1)= 3
pst(1, 2)= 4
pst(2, 2)= 3
pst(1, 3)= 7
pst(2, 3)= 4
pst(1, 4)= 11
pst(2, 4)= 2
pst(1, 5)= 13
pst(2, 5)= 3
pst(1, 6)= 16
pst(2, 6)= 2
pst(1, 7)= 18
pst(2, 7)= 3
pst(1, 8)= 21
pst(2, 8)= 3
pst(1, 9)= 24
pst(2, 9)= 3
pst(1, 10)= 27
pst(2, 10)= 1
pst(1, 11)= 28
pst(2, 11)= 2
pst(1, 12)= 30
pst(2, 12)= 2
pst(1, 13)= 32
pst(2, 13)= 2
pst(1, 14)= 34
pst(2, 14)= 3
pst(1, 15)= 37
pst(2, 15)= 3
pst(1, 16)= 40
pst(2, 16)= 3
pst(1, 17)= 43
pst(2, 17)= 2
pst(1, 18)= 45
pst(2, 18)= 2
pst(1, 19)= 47
pst(2, 19)= 2
pst(1, 20)= 49
pst(2, 20)= 1
pst(1, 21)= 50
pst(2, 21)= 2
pst(1, 22)= 52
pst(2, 22)= 5
pst(1, 23)= 57
pst(2, 23)= 10
pst(1, 24)= 67
pst(2, 24)= 1
pst(1, 25)= 68
pst(2, 25)= 2
pst(1, 26)= 70
pst(2, 26)= 4
pst(1, 27)= 74
pst(2, 27)= 8
pst(1, 28)= 82
pst(2, 28)= 2
pst(1, 29)= 84
pst(2, 29)= 3
pst(1, 30)= 87
pst(2, 30)= 1
pst(1, 31)= 88
pst(2, 31)= 2
pst(1, 32)= 90
pst(2, 32)= 4
pst(1, 33)= 94
pst(2, 33)= 8
pst(1, 34)= 0
pst(2, 34)= 0
pst(1, 35)= 0
pst(2, 35)= 0
pst(1, 36)= 0
pst(2, 36)= 0
pst(1, 37)= 0
pst(2, 37)= 0
pst(1, 38)= 0
pst(2, 38)= 0
pst(1, 39)= 0
pst(2, 39)= 0
pst(1, 40)= 0
pst(2, 40)= 0
pst(1, 41)= 0
pst(2, 41)= 0
pst(1, 42)= 0
pst(2, 42)= 0
pst(1, 43)= 0
pst(2, 43)= 0
pst(1, 44)= 0
pst(2, 44)= 0
pst(1, 45)= 0
pst(2, 45)= 0
pst(1, 46)= 0
pst(2, 46)= 0
pst(1, 47)= 0
pst(2, 47)= 0
pst(1, 48)= 0
pst(2, 48)= 0
pst(1, 49)= 0
pst(2, 49)= 0
pst(1, 50)= 0
pst(2, 50)= 0
pst(1, 51)= 0
pst(2, 51)= 0
pst(1, 52)= 0
pst(2, 52)= 0
pst(1, 53)= 0
pst(2, 53)= 0
pst(1, 54)= 0
pst(2, 54)= 0
pst(1, 55)= 0
pst(2, 55)= 0
pst(1, 56)= 0
pst(2, 56)= 0
pst(1, 57)= 0
pst(2, 57)= 0
pst(1, 58)= 0
pst(2, 58)= 0
pst(1, 59)= 0
pst(2, 59)= 0
pst(1, 60)= 0
pst(2, 60)= 0
pst(1, 61)= 0
pst(2, 61)= 0
pst(1, 62)= 0
pst(2, 62)= 0
pst(1, 63)= 0
pst(2, 63)= 0
pst(1, 64)= 0
pst(2, 64)= 0
pst(1, 65)= 0
pst(2, 65)= 0
pst(1, 66)= 0
pst(2, 66)= 0
pst(1, 67)= 0
pst(2, 67)= 0
pst(1, 68)= 0
pst(2, 68)= 0
pst(1, 69)= 0
pst(2, 69)= 0
pst(1, 70)= 0
pst(2, 70)= 0
pst(1, 71)= 0
pst(2, 71)= 0
pst(1, 72)= 0
pst(2, 72)= 0
pst(1, 73)= 0
pst(2, 73)= 0
pst(1, 74)= 0
pst(2, 74)= 0
pst(1, 75)= 0
pst(2, 75)= 0
pst(1, 76)= 0
pst(2, 76)= 0
pst(1, 77)= 0
pst(2, 77)= 0
pst(1, 78)= 0
pst(2, 78)= 0
pst(1, 79)= 0
pst(2, 79)= 0
pst(1, 80)= 0
pst(2, 80)= 0
pst(1, 81)= 0
pst(2, 81)= 0
pst(1, 82)= 0
pst(2, 82)= 0
pst(1, 83)= 0
pst(2, 83)= 0
pst(1, 84)= 0
pst(2, 84)= 0
pst(1, 85)= 0
pst(2, 85)= 0
pst(1, 86)= 0
pst(2, 86)= 0
pst(1, 87)= 0
pst(2, 87)= 0
pst(1, 88)= 0
pst(2, 88)= 0
pst(1, 89)= 0
pst(2, 89)= 0
pst(1, 90)= 0
pst(2, 90)= 0
pst(1, 91)= 0
pst(2, 91)= 0
pst(1, 92)= 0
pst(2, 92)= 0
pst(1, 93)= 0
pst(2, 93)= 0
pst(1, 94)= 0
pst(2, 94)= 0
pst(1, 95)= 0
pst(2, 95)= 0
pst(1, 96)= 0
pst(2, 96)= 0
pst(1, 97)= 0
pst(2, 97)= 0
pst(1, 98)= 0
pst(2, 98)= 0
pst(1, 99)= 0
pst(2, 99)= 0
pst(1,100)= 0
pst(2,100)= 0
pst(1,101)= 0
pst(2,101)= 0
pst(1,102)= 0
pst(2,102)= 0
pst(1,103)= 0
pst(2,103)= 0
pst(1,104)= 0
pst(2,104)= 0
pst(1,105)= 0
pst(2,105)= 0
pst(1,106)= 0
pst(2,106)= 0
pst(1,107)= 0
pst(2,107)= 0
pst(1,108)= 0
pst(2,108)= 0
pst(1,109)= 0
pst(2,109)= 0
pst(1,110)= 0
pst(2,110)= 0
pst(1,111)= 0
pst(2,111)= 0
pst(1,112)= 0
pst(2,112)= 0
pst(1,113)= 0
pst(2,113)= 0
pst(1,114)= 0
pst(2,114)= 0
pst(1,115)= 0
pst(2,115)= 0
pst(1,116)= 0
pst(2,116)= 0
pst(1,117)= 0
pst(2,117)= 0
pst(1,118)= 0
pst(2,118)= 0
pst(1,119)= 0
pst(2,119)= 0
pst(1,120)= 0
pst(2,120)= 0
pst(1,121)= 0
pst(2,121)= 0
pst(1,122)= 0
pst(2,122)= 0
pst(1,123)= 0
pst(2,123)= 0
pst(1,124)= 0
pst(2,124)= 0
pst(1,125)= 0
pst(2,125)= 0
pst(1,126)= 0
pst(2,126)= 0
pst(1,127)= 0
pst(2,127)= 0
pst(1,128)= 0
pst(2,128)= 0
pst(1,129)= 0
pst(2,129)= 0
pst(1,130)= 0
pst(2,130)= 0
pst(1,131)= 0
pst(2,131)= 0
pst(1,132)= 0
pst(2,132)= 0
pst(1,133)= 0
pst(2,133)= 0
pst(1,134)= 0
pst(2,134)= 0
pst(1,135)= 0
pst(2,135)= 0
pst(1,136)= 0
pst(2,136)= 0
pst(1,137)= 0
pst(2,137)= 0
pst(1,138)= 0
pst(2,138)= 0
pst(1,139)= 0
pst(2,139)= 0
pst(1,140)= 0
pst(2,140)= 0
pst(1,141)= 0
pst(2,141)= 0
pst(1,142)= 0
pst(2,142)= 0
pst(1,143)= 0
pst(2,143)= 0
pst(1,144)= 0
pst(2,144)= 0
pst(1,145)= 0
pst(2,145)= 0
pst(1,146)= 0
pst(2,146)= 0
pst(1,147)= 0
pst(2,147)= 0
pst(1,148)= 0
pst(2,148)= 0
pst(1,149)= 0
pst(2,149)= 0
pst(1,150)= 0
pst(2,150)= 0
pst(1,151)= 0
pst(2,151)= 0
pst(1,152)= 0
pst(2,152)= 0
pst(1,153)= 0
pst(2,153)= 0
pst(1,154)= 0
pst(2,154)= 0
pst(1,155)= 0
pst(2,155)= 0
pst(1,156)= 0
pst(2,156)= 0
pst(1,157)= 0
pst(2,157)= 0
pst(1,158)= 0
pst(2,158)= 0
pst(1,159)= 0
pst(2,159)= 0
pst(1,160)= 0
pst(2,160)= 0
pst(1,161)= 0
pst(2,161)= 0
pst(1,162)= 0
pst(2,162)= 0
pst(1,163)= 0
pst(2,163)= 0
pst(1,164)= 0
pst(2,164)= 0
pst(1,165)= 0
pst(2,165)= 0
pst(1,166)= 0
pst(2,166)= 0
pst(1,167)= 0
pst(2,167)= 0
pst(1,168)= 0
pst(2,168)= 0
pst(1,169)= 0
pst(2,169)= 0
pst(1,170)= 0
pst(2,170)= 0
pst(1,171)= 0
pst(2,171)= 0
pst(1,172)= 0
pst(2,172)= 0
pst(1,173)= 0
pst(2,173)= 0
pst(1,174)= 0
pst(2,174)= 0
pst(1,175)= 0
pst(2,175)= 0
pst(1,176)= 0
pst(2,176)= 0
pst(1,177)= 0
pst(2,177)= 0
pst(1,178)= 0
pst(2,178)= 0
pst(1,179)= 0
pst(2,179)= 0
pst(1,180)= 0
pst(2,180)= 0
pst(1,181)= 0
pst(2,181)= 0
pst(1,182)= 0
pst(2,182)= 0
pst(1,183)= 0
pst(2,183)= 0
pst(1,184)= 0
pst(2,184)= 0
pst(1,185)= 0
pst(2,185)= 0
pst(1,186)= 0
pst(2,186)= 0
pst(1,187)= 0
pst(2,187)= 0
pst(1,188)= 0
pst(2,188)= 0
pst(1,189)= 0
pst(2,189)= 0
pst(1,190)= 0
pst(2,190)= 0
pst(1,191)= 0
pst(2,191)= 0
pst(1,192)= 0
pst(2,192)= 0
pst(1,193)= 0
pst(2,193)= 0
pst(1,194)= 0
pst(2,194)= 0
pst(1,195)= 0
pst(2,195)= 0
pst(1,196)= 0
pst(2,196)= 0
pst(1,197)= 0
pst(2,197)= 0
pst(1,198)= 0
pst(2,198)= 0
pst(1,199)= 0
pst(2,199)= 0
pst(1,200)= 0
pst(2,200)= 0
pst(1,201)= 0
pst(2,201)= 0
pst(1,202)= 0
pst(2,202)= 0
pst(1,203)= 0
pst(2,203)= 0
pst(1,204)= 0
pst(2,204)= 0
pst(1,205)= 0
pst(2,205)= 0
pst(1,206)= 0
pst(2,206)= 0
pst(1,207)= 0
pst(2,207)= 0
pst(1,208)= 0
pst(2,208)= 0
pst(1,209)= 0
pst(2,209)= 0
pst(1,210)= 0
pst(2,210)= 0
pst(1,211)= 0
pst(2,211)= 0
pst(1,212)= 0
pst(2,212)= 0
pst(1,213)= 0
pst(2,213)= 0
pst(1,214)= 0
pst(2,214)= 0
pst(1,215)= 0
pst(2,215)= 0
pst(1,216)= 0
pst(2,216)= 0
pst(1,217)= 0
pst(2,217)= 0
pst(1,218)= 0
pst(2,218)= 0
pst(1,219)= 0
pst(2,219)= 0
pst(1,220)= 0
pst(2,220)= 0
pst(1,221)= 0
pst(2,221)= 0
pst(1,222)= 0
pst(2,222)= 0
pst(1,223)= 0
pst(2,223)= 0
pst(1,224)= 0
pst(2,224)= 0
pst(1,225)= 0
pst(2,225)= 0
pst(1,226)= 0
pst(2,226)= 0
pst(1,227)= 0
pst(2,227)= 0
pst(1,228)= 0
pst(2,228)= 0
pst(1,229)= 0
pst(2,229)= 0
pst(1,230)= 0
pst(2,230)= 0
pst(1,231)= 0
pst(2,231)= 0
pst(1,232)= 0
pst(2,232)= 0
pst(1,233)= 0
pst(2,233)= 0
pst(1,234)= 0
pst(2,234)= 0
pst(1,235)= 0
pst(2,235)= 0
pst(1,236)= 0
pst(2,236)= 0
pst(1,237)= 0
pst(2,237)= 0
pst(1,238)= 0
pst(2,238)= 0
pst(1,239)= 0
pst(2,239)= 0
pst(1,240)= 0
pst(2,240)= 0
pst(1,241)= 0
pst(2,241)= 0
pst(1,242)= 0
pst(2,242)= 0
pst(1,243)= 0
pst(2,243)= 0
pst(1,244)= 0
pst(2,244)= 0
pst(1,245)= 0
pst(2,245)= 0
pst(1,246)= 0
pst(2,246)= 0
pst(1,247)= 0
pst(2,247)= 0
pst(1,248)= 0
pst(2,248)= 0
pst(1,249)= 0
pst(2,249)= 0
pst(1,250)= 0
pst(2,250)= 0
pst(1,251)= 0
pst(2,251)= 0
pst(1,252)= 0
pst(2,252)= 0
pst(1,253)= 0
pst(2,253)= 0
pst(1,254)= 0
pst(2,254)= 0
pst(1,255)= 0
pst(2,255)= 0
pst(1,256)= 0
pst(2,256)= 0
pst(1,257)= 0
pst(2,257)= 0
pst(1,258)= 0
pst(2,258)= 0
pst(1,259)= 0
pst(2,259)= 0
pst(1,260)= 0
pst(2,260)= 0
pst(1,261)= 0
pst(2,261)= 0
pst(1,262)= 0
pst(2,262)= 0
pst(1,263)= 0
pst(2,263)= 0
pst(1,264)= 0
pst(2,264)= 0
pst(1,265)= 0
pst(2,265)= 0
pst(1,266)= 0
pst(2,266)= 0
pst(1,267)= 0
pst(2,267)= 0
pst(1,268)= 0
pst(2,268)= 0
pst(1,269)= 0
pst(2,269)= 0
pst(1,270)= 0
pst(2,270)= 0
pst(1,271)= 0
pst(2,271)= 0
pst(1,272)= 0
pst(2,272)= 0
pst(1,273)= 0
pst(2,273)= 0
pst(1,274)= 0
pst(2,274)= 0
pst(1,275)= 0
pst(2,275)= 0
pst(1,276)= 0
pst(2,276)= 0
pst(1,277)= 0
pst(2,277)= 0
pst(1,278)= 0
pst(2,278)= 0
pst(1,279)= 0
pst(2,279)= 0
pst(1,280)= 0
pst(2,280)= 0
pst(1,281)= 0
pst(2,281)= 0
pst(1,282)= 0
pst(2,282)= 0
pst(1,283)= 0
pst(2,283)= 0
pst(1,284)= 0
pst(2,284)= 0
pst(1,285)= 0
pst(2,285)= 0
pst(1,286)= 0
pst(2,286)= 0
pst(1,287)= 0
pst(2,287)= 0
pst(1,288)= 0
pst(2,288)= 0
pst(1,289)= 0
pst(2,289)= 0
pst(1,290)= 0
pst(2,290)= 0
pst(1,291)= 0
pst(2,291)= 0
pst(1,292)= 0
pst(2,292)= 0
pst(1,293)= 0
pst(2,293)= 0
pst(1,294)= 0
pst(2,294)= 0
pst(1,295)= 0
pst(2,295)= 0
pst(1,296)= 0
pst(2,296)= 0
pst(1,297)= 0
pst(2,297)= 0
pst(1,298)= 0
pst(2,298)= 0
pst(1,299)= 0
pst(2,299)= 0
pst(1,300)= 0
pst(2,300)= 0
pst(1,301)= 0
pst(2,301)= 0
pst(1,302)= 0
pst(2,302)= 0
pst(1,303)= 0
pst(2,303)= 0
pst(1,304)= 0
pst(2,304)= 0
pst(1,305)= 0
pst(2,305)= 0
pst(1,306)= 0
pst(2,306)= 0
pst(1,307)= 0
pst(2,307)= 0
pst(1,308)= 0
pst(2,308)= 0
pst(1,309)= 0
pst(2,309)= 0
pst(1,310)= 0
pst(2,310)= 0
pst(1,311)= 0
pst(2,311)= 0
pst(1,312)= 0
pst(2,312)= 0
pst(1,313)= 0
pst(2,313)= 0
pst(1,314)= 0
pst(2,314)= 0
pst(1,315)= 0
pst(2,315)= 0
pst(1,316)= 0
pst(2,316)= 0
pst(1,317)= 0
pst(2,317)= 0
pst(1,318)= 0
pst(2,318)= 0
pst(1,319)= 0
pst(2,319)= 0
pst(1,320)= 0
pst(2,320)= 0
pst(1,321)= 0
pst(2,321)= 0
pst(1,322)= 0
pst(2,322)= 0
pst(1,323)= 0
pst(2,323)= 0
pst(1,324)= 0
pst(2,324)= 0
pst(1,325)= 0
pst(2,325)= 0
pst(1,326)= 0
pst(2,326)= 0
pst(1,327)= 0
pst(2,327)= 0
pst(1,328)= 0
pst(2,328)= 0
pst(1,329)= 0
pst(2,329)= 0
pst(1,330)= 0
pst(2,330)= 0
pst(1,331)= 0
pst(2,331)= 0
pst(1,332)= 0
pst(2,332)= 0
pst(1,333)= 0
pst(2,333)= 0
pst(1,334)= 0
pst(2,334)= 0
pst(1,335)= 0
pst(2,335)= 0
pst(1,336)= 0
pst(2,336)= 0
pst(1,337)= 0
pst(2,337)= 0
pst(1,338)= 0
pst(2,338)= 0
pst(1,339)= 0
pst(2,339)= 0
pst(1,340)= 0
pst(2,340)= 0
pst(1,341)= 0
pst(2,341)= 0
pst(1,342)= 0
pst(2,342)= 0
pst(1,343)= 0
pst(2,343)= 0
pst(1,344)= 0
pst(2,344)= 0
pst(1,345)= 0
pst(2,345)= 0
pst(1,346)= 0
pst(2,346)= 0
pst(1,347)= 0
pst(2,347)= 0
pst(1,348)= 0
pst(2,348)= 0
pst(1,349)= 0
pst(2,349)= 0
pst(1,350)= 0
pst(2,350)= 0
pst(1,351)= 0
pst(2,351)= 0
pst(1,352)= 0
pst(2,352)= 0
pst(1,353)= 0
pst(2,353)= 0
pst(1,354)= 0
pst(2,354)= 0
pst(1,355)= 0
pst(2,355)= 0
pst(1,356)= 0
pst(2,356)= 0
pst(1,357)= 0
pst(2,357)= 0
pst(1,358)= 0
pst(2,358)= 0
pst(1,359)= 0
pst(2,359)= 0
pst(1,360)= 0
pst(2,360)= 0
pst(1,361)= 0
pst(2,361)= 0
pst(1,362)= 0
pst(2,362)= 0
pst(1,363)= 0
pst(2,363)= 0
pst(1,364)= 0
pst(2,364)= 0
pst(1,365)= 0
pst(2,365)= 0
pst(1,366)= 0
pst(2,366)= 0
pst(1,367)= 0
pst(2,367)= 0
pst(1,368)= 0
pst(2,368)= 0
pst(1,369)= 0
pst(2,369)= 0
pst(1,370)= 0
pst(2,370)= 0
pst(1,371)= 0
pst(2,371)= 0
pst(1,372)= 0
pst(2,372)= 0
pst(1,373)= 0
pst(2,373)= 0
pst(1,374)= 0
pst(2,374)= 0
pst(1,375)= 0
pst(2,375)= 0
pst(1,376)= 0
pst(2,376)= 0
pst(1,377)= 0
pst(2,377)= 0
pst(1,378)= 0
pst(2,378)= 0
pst(1,379)= 0
pst(2,379)= 0
pst(1,380)= 0
pst(2,380)= 0
pst(1,381)= 0
pst(2,381)= 0
pst(1,382)= 0
pst(2,382)= 0
pst(1,383)= 0
pst(2,383)= 0
pst(1,384)= 0
pst(2,384)= 0
pst(1,385)= 0
pst(2,385)= 0
pst(1,386)= 0
pst(2,386)= 0
pst(1,387)= 0
pst(2,387)= 0
pst(1,388)= 0
pst(2,388)= 0
pst(1,389)= 0
pst(2,389)= 0
pst(1,390)= 0
pst(2,390)= 0
pst(1,391)= 0
pst(2,391)= 0
pst(1,392)= 0
pst(2,392)= 0
pst(1,393)= 0
pst(2,393)= 0
pst(1,394)= 0
pst(2,394)= 0
pst(1,395)= 0
pst(2,395)= 0
pst(1,396)= 0
pst(2,396)= 0
pst(1,397)= 0
pst(2,397)= 0
pst(1,398)= 0
pst(2,398)= 0
pst(1,399)= 0
pst(2,399)= 0
pst(1,400)= 0
pst(2,400)= 0
End SUBROUTINE init_dip_planar_data
End Module dip_param

172
src/model/invariants_nh3.f90 Normal file
View File

@ -0,0 +1,172 @@
Module invariants_mod
implicit none
contains
!----------------------------------------------------
subroutine invariants(a,xs,ys,xb,yb,inv)
implicit none
!include "nnparams.incl"
double precision, intent(in) :: a, xs, ys, xb, yb
double precision, intent(out) ::inv(3)
double precision:: invar(23)
!double precision:: invar(24)
complex(8) :: q1, q2
LOGICAL,PARAMETER:: debg =.FALSE.
integer :: i
! express the coordinate in complex
q1 = dcmplx(xs, ys)
q2 = dcmplx(xb, yb)
! compute the invariants
!inv( 4) = a
!inv( 4) = b**2
! INVARIANTS OF KIND II
!------------------------
invar(1) = dreal( q1 * conjg(q1) ) ! r11
invar(2) = dreal( q1 * conjg(q2) ) ! r12
invar(3) = dreal( q2 * conjg(q2) ) ! r22
invar(4) = (dimag(q1 * conjg(q2)) )**2 ! rho 12**2
!INVATIANTS OF KIND III
!------------------------
invar(5) = dreal( q1 * q1 * q1 ) ! r111
invar(6) = dreal( q1 * q1 * q2 ) ! r112
invar(7) = dreal( q1 * q2 * q2 ) ! r122
invar(8) = dreal( q2 * q2 * q2 ) ! r222
invar(9) = (dimag( q1 * q1 * q1 ))**2 ! rho111**2
invar(10) = (dimag( q1 * q1 * q2 ))**2 ! rho112 **2
invar(11) = (dimag( q1 * q2 * q2 ))**2 ! rho122**2
invar(12) = (dimag( q2 * q2 * q2 ))**2 ! rho222
! INVARIANTS OF KIND IV
!-------------------------
invar(13) = (dimag( q1 * conjg(q2)) * dimag( q1 * q1 * q1 ))
invar(14) = (dimag( q1 * conjg(q2)) * dimag( q1 * q1 * q2 ))
invar(15) = (dimag( q1 * conjg(q2)) * dimag( q1 * q2 * q2 ))
invar(16) = (dimag( q1 * conjg(q2)) * dimag( q2 * q2 * q2 ))
! INVARIANTS OF KIND V
!----------------------
invar(17) = (dimag( q1 * q1 * q1 ) * dimag( q1 * q1 * q2 ))
invar(18) = (dimag( q1 * q1 * q1 ) * dimag( q1 * q2 * q2 ))
invar(19) = (dimag( q1 * q1 * q1 ) * dimag( q2 * q2 * q2 ))
invar(20) = (dimag( q1 * q1 * q2 ) * dimag( q1 * q2 * q2 ))
invar(21) = (dimag( q1 * q1 * q2 ) * dimag( q2 * q2 * q2 ))
invar(22) = (dimag( q1 * q2 * q2 ) * dimag( q2 * q2 * q2 ))
invar(23) = a
! the only non zero invariant for bend pure cuts
inv(1) = invar( 1)
inv(2) = invar( 5)
inv(3) = invar( 9)
! inv(4) = invar(1)
! inv(5) = invar(5)
! inv(6) = invar(9)
!inv(17)=invar(18)
!inv(19) = invar()
!inv(2) = invar(5)
!inv(3) = invar(9)
!inv(1:22)=invar(1:22)
!inv(4:8) = invar(5:9)
!inv(9)=invar(12)
if (debg) then
write(14,"(A,*(f10.5))")"Invar II", (invar(i),i=1,4)
write(14,"(A,*(f10.5))") "Invar III", (invar(i),i=5,12)
write(14,"(A,*(f10.5))")"Invar IV", (invar(i),i=13,16)
write(14,"(A,*(f10.5))")"Invar V", (invar(i),i=17,22)
write(14,*)"THE INPUT COORDINATE IN COMPLEX REPRES"
write(14,*)"---------------------------------------"
write(14,*)"xs =",dreal(q1), "ys=",dimag(q1)
endif
! modify the invariants to only consider few of them
!
!invar(13:22)=0.0d0
end subroutine invariants
! subroutine invariants_ch(a, xs, ys, xb, yb, invar)
! implicit none
! double precision, intent(in) :: a, xs, ys, xb, yb
! double precision, intent(out) :: invar(25)
!
! complex(8) :: q1, q2
! double precision :: r11, r22, r12, eta
! double precision :: I1, I2, I3, I4
!
! ! Define complex coordinates
! q1 = dcmplx(xs, ys)
! q2 = dcmplx(xb, yb)
!
! ! Quadratic invariants
! r11 = dreal(q1*conjg(q1))
! r22 = dreal(q2*conjg(q2))
! r12 = dreal(q1*conjg(q2))
! eta = dimag(q1*conjg(q2))
!
! ! Cubic imag parts (used many times)
! I1 = dimag(q1*q1*q1)
! I2 = dimag(q1*q1*q2)
! I3 = dimag(q1*q2*q2)
! I4 = dimag(q2*q2*q2)
! ! the totally symmetric invariant 25
! invar(25) = a
! ! Store invariants
! invar(1) = r11
! invar(2) = r12
! invar(3) = r22
! invar(4) = eta*eta
!
! invar(5) = dreal(q1*q1*q1)
! invar(6) = dreal(q1*q1*q2)
! invar(7) = dreal(q1*q2*q2)
! invar(8) = dreal(q2*q2*q2)
!
! invar(9) = I1*I1
! invar(10) = I2*I2
! invar(11) = I3*I3
! invar(12) = I4*I4
!
! invar(13) = eta * I1
! invar(14) = eta * I2
! invar(15) = eta * I3
! invar(16) = eta * I4
!
! ! Pure quartic invariants
! invar(17) = r11*r11 + r22*r22
! invar(18) = r11*r22 - r12*r12 - eta*eta
!
! ! Cubic-imag bilinear invariants (minimal independent set)
! invar(19) = I1*I2
! invar(20) = I1*I3
! invar(21) = I1*I4
! invar(22) = I2*I3
! invar(23) = I2*I4
!
! ! Odd cubic invariant
! invar(24) = eta**3
!
! if (debg) then
! write(14,"(A,*(f10.5))")"Invar II", (invar(i),i=1,4)
! write(14,"(A,*(f10.5))") "Invar III", (invar(i),i=5,12)
! write(14,"(A,*(f10.5))")"Invar IV", (invar(i),i=13,16)
! write(14,"(A,*(f10.5))")"Invar V", (invar(i),i=17,22)
!
! write(14,*)"THE INPUT COORDINATE IN COMPLEX REPRES"
! write(14,*)"---------------------------------------"
! write(14,*)"xs =",dreal(q1), "ys=",dimag(q1)
! endif
!
! end subroutine
end module invariants_mod

87
src/model/newmodes.f Normal file
View File

@ -0,0 +1,87 @@
! Author: jnshuti
! Created: 2025-10-24 16:45:07
! Last modified: 2025-10-24 16:45:27 jnshuti
! Modes:
! Mode 1
mode( 1, 1) = 0.0000000000d0
mode( 2, 1) = 0.0000000000d0
mode( 3, 1) = 0.0000000000d0
mode( 4, 1) = 0.5773502692d0
mode( 5, 1) = 0.0000000000d0
mode( 6, 1) = 0.0000000000d0
mode( 7, 1) = -0.2886751346d0
mode( 8, 1) = 0.5000000000d0
mode( 9, 1) = 0.0000000000d0
mode(10, 1) = -0.2886751346d0
mode(11, 1) = -0.5000000000d0
mode(12, 1) = 0.0000000000d0
! Mode 2
mode( 1, 2) = 0.3121511560d0
mode( 2, 2) = 0.0000000000d0
mode( 3, 2) = 0.0000000000d0
mode( 4, 2) = -0.7756982471d0
mode( 5, 2) = 0.0000000000d0
mode( 6, 2) = 0.0000000000d0
mode( 7, 2) = -0.1939245618d0
mode( 8, 2) = 0.3358871938d0
mode( 9, 2) = 0.0000000000d0
mode(10, 2) = -0.1939245618d0
mode(11, 2) = -0.3358871938d0
mode(12, 2) = 0.0000000000d0
! Mode 3
mode( 1, 3) = 0.0000000000d0
mode( 2, 3) = 0.3121511560d0
mode( 3, 3) = 0.0000000000d0
mode( 4, 3) = 0.0000000000d0
mode( 5, 3) = 0.0000000000d0
mode( 6, 3) = 0.0000000000d0
mode( 7, 3) = 0.3358871938d0
mode( 8, 3) = -0.5817736853d0
mode( 9, 3) = 0.0000000000d0
mode(10, 3) = -0.3358871938d0
mode(11, 3) = -0.5817736853d0
mode(12, 3) = 0.0000000000d0
! Mode 4
mode( 1, 4) = 0.2830826954d0
mode( 2, 4) = 0.0000000000d0
mode( 3, 4) = 0.0000000000d0
mode( 4, 4) = 0.0759441281d0
mode( 5, 4) = 0.0000000000d0
mode( 6, 4) = 0.0000000000d0
mode( 7, 4) = -0.5655692225d0
mode( 8, 4) = -0.3703779057d0
mode( 9, 4) = 0.0000000000d0
mode(10, 4) = -0.5655692225d0
mode(11, 4) = 0.3703779057d0
mode(12, 4) = 0.0000000000d0
! Mode 5
mode( 1, 5) = 0.0000000000d0
mode( 2, 5) = 0.2830826954d0
mode( 3, 5) = 0.0000000000d0
mode( 4, 5) = 0.0000000000d0
mode( 5, 5) = -0.7794070061d0
mode( 6, 5) = 0.0000000000d0
mode( 7, 5) = -0.3703779057d0
mode( 8, 5) = -0.1378936554d0
mode( 9, 5) = 0.0000000000d0
mode(10, 5) = 0.3703779057d0
mode(11, 5) = -0.1378936554d0
mode(12, 5) = 0.0000000000d0
! Mode 6
mode( 1, 6) = 0.0000000000d0
mode( 2, 6) = 0.0000000000d0
mode( 3, 6) = 0.4213954872d0
mode( 4, 6) = 0.0000000000d0
mode( 5, 6) = 0.0000000000d0
mode( 6, 6) = -0.5235856642d0
mode( 7, 6) = 0.0000000000d0
mode( 8, 6) = 0.0000000000d0
mode( 9, 6) = -0.5235856642d0
mode(10, 6) = 0.0000000000d0
mode(11, 6) = 0.0000000000d0
mode(12, 6) = -0.5235856642d0

87
src/model/nnadia_nh3.f Normal file
View File

@ -0,0 +1,87 @@
subroutine nninit_mod()
use nn_params
implicit none
end subroutine
subroutine nnadia(coords,coeffs,adiaoutp)
USE pesmod, only: potential_nh3_low
Use diabmodel, only: diab_x
use nn_params
use nncommons
implicit none
! returns THE DIABATIC MATRIX UPPER MATRIX OF BOTH X AND Y COMPONENT OF DIPOLE
!
! coords: vector containing symmetry-adapted coordinates.
! coeffs: vector containing coeffs of diab dipole matrix
! adiaoutp: upper diab matrix of dipole
! x component come first and then y component
!
! dmat_x & dmat_y: analytic model of dipole, x and y
!
! matdim: dimension of hamiltoniam matrix
! mkeigen: integer: no eigenvectors if =0
! eigenvs: dummy storage for eigenvectors
!include 'JTmod.incl'
DOUBLE PRECISION,intent(in):: coords(maxnin)
DOUBLE PRECISION,INTENT(INOUT)::coeffs(maxnout)
DOUBLE PRECISION,INTENT(OUT):: adiaoutp(maxpout)
DOUBLE PRECISION, DIMENSION(ndiab,ndiab):: v,U,ex,temp
double precision, dimension(ndiab):: e
Double precision, allocatable:: mat(:,:)
integer i, ij, j, max_row
! variable for lapack
integer,parameter :: lwork = 1000
double precision work(lwork)
integer info
call potential_nh3_low(V,coords,coeffs)
! diagonalize the pes
u=0.0d0
allocate(mat,source=V)
call DSYEV('V','U',ndiab,mat,ndiab,e,work,lwork, info)
if (info .ne. 0) then
write(6,*)"The diagonalizing routine failed", info
stop
end if
U(:,:)= mat(:,:)
deallocate(mat)
do i =1,ndiab
adiaoutp(i)=e(i)
enddo
! Fix the phase of U matrix
! fix phas of U
do i =1,ndiab
max_row=maxloc(abs(U(:,i)),1)
if(U(max_row,i) .lt. 0) then
U(:,i) = -1.0d0*U(:,i)
endif
enddo
call diab_x(ex,coords,coeffs) ! ex is the dipole x component
! transforrm the dipole
temp = matmul(transpose(U),ex)
ex = matmul(temp,U)
ij = 4
do i =1,ndiab
do j = i,ndiab
ij = ij+1
adiaoutp(ij) = ex(i,j)
!adiaoutp(ij) = 0.0d0
enddo
enddo
END SUBROUTINE

91
src/model/nncoords_nh3.f90 Normal file
View File

@ -0,0 +1,91 @@
module trans_coord
implicit none
contains
subroutine cart2mode(qq)
use invariants_mod, only: invariants
use nn_params
use nncommons
implicit none
double precision, intent(inout):: qq(maxnin)
double precision :: q(12),inv(3),qm(6)
double precision, parameter :: m_N=25526.04237518618d0
double precision, parameter :: m_H=1837.152647439619d0
double precision, parameter :: Ang2Bohr=1.889726124565d0
double precision diff(12), ref_geom(12)
double precision q_mod(12)
! transformation matrix
double precision mode(12,6)
integer i
! final internal coord vector
include 'newmodes.f'
ref_geom(1:12)=0.d0
ref_geom( 4 )=1.022871078d0
ref_geom( 7 )=-.5d0*ref_geom(4)
!ref_geom( 8 )=sqrt(1.5d0)*ref_geom(4)
ref_geom( 8)=0.5d0*sqrt(3.0d0)*ref_geom(4)
ref_geom(10 )=-.5d0*ref_geom(4)
!ref_geom(11 )=-sqrt(1.5d0)*ref_geom(4)
ref_geom(11)=-0.5d0*sqrt(3.0d0)*ref_geom(4)
!massN=25526.04237518618
!massH=1837.152647439619
!
q(1:12)=qq(1:12)
q_mod = (1.0d0/Ang2Bohr)*q
! difference vector
diff=q_mod-ref_geom
! mass weighting
diff(1:3)=diff(1:3)*sqrt(m_N)
diff(4:12)=diff(4:12)*sqrt(m_H)
qm=matmul(transpose(mode),diff)
do i =1,size(qm)
if (abs(qm(i)) .lt. 1.0d-6) qm(i)=0.0d0
enddo
!qm(3) = -qm(3)
call invariants(qm(1),qm(2),qm(3),qm(4),qm(5),inv)
qq =0.0d0
qq(1:len_in)=inv(1:len_in)
qq(len_in+1:len_in+6)=qm(1:6)
end subroutine cart2mode
end module trans_coord
!**** Define coordinate transformation applied to the input before fit.
!***
!***
!****Conventions:
!***
!*** ctrans: subroutine transforming a single point in coordinate space
subroutine trans_in(pat_in)
!use ctrans_mod, only: ctrans
use trans_coord, only: cart2mode
use nn_params
use nncommons
implicit none
!include 'nndbg.incl'
double precision pat_in(maxnin,maxpats)
!integer ntot
integer j,i,jj
jj=1
do j=1,sets
!write(62,*)"Scan ",j
do i =1,ndata(j)
call cart2mode(pat_in(:,jj))
! FIRST ELEMENT OF PAT-IN ARE USED BY NEURON NETWORK
!write(62,'(*(ES16.8))') pat_in(:,jj)
jj = jj +1
enddo
enddo
end

172
src/model/pes_model.f90 Normal file
View File

@ -0,0 +1,172 @@
module pesmod
!use dim_parameter,only:qn,ndiab,pst
use iso_fortran_env, only: idp => int32, dp => real64
use dip_param
use nn_params
use nncommons, only: len_in
implicit none
integer(idp),parameter:: ndiab=4
private
public :: potential_nh3_low
contains
subroutine potential_nh3_low(e,q,nn_out)
implicit none
real(dp),intent(in)::q(maxnin)
real(dp),intent(out)::e(:,:)
real(dp),intent(inout):: nn_out(maxnout)
!logical,intent(in):: sym
!integer(idp),intent(in)::key
integer(idp) id,i, ii
real(dp) tmp,xs,xb,ys,yb,a,b,ss,sb
logical, parameter:: switch = .false. ! parameter to switch when you want to know Ex and Ey
logical, parameter:: sym = .false. ! to include r**2 in the Genetic fitting
real(dp),parameter:: tol = 1.0d-9
real(dp),dimension(16):: scal, shift
!real(dp),dimension(17):: shi,scalee
!include "shift-scale-70N.incl"
!include "sh-scal-50.incl"
xs=q(len_in+2)
ys=q(len_in+3)
xb=q(len_in+4)
yb=q(len_in+5)
a=q(len_in+1)
b=q(len_in+6)
ss= xs**2+ys**2
sb= xb**2+yb**2
call init_dip_planar_data()
shift =1.0d0
scal = 1.0d-3
!scal = 1.0d-3
!scal(1:3) = 1.0d-3
ii = 1
do i =1 ,27 ! pes parameter key index
if( abs(p(i)) .gt. tol ) then
p(i) = p(i)*(shift(ii)+ scal(ii)*nn_out(ii))
ii = ii + 1
endif
enddo
!write(6,*)" PES non zero", ii-1
e = 0.0_dp
id = 1 ! 1
! v -term
! oth order only
! A2"
e(1,1) = e(1,1) + p(pst(1,id)) !- p(pst(1,1))
if (sym) then
e(1,1)=e(1,1) + p(pst(1,id)+1)*ss +p(pst(1,id)+2)*sb
endif
id = id +1 !2
! E block
e(2,2) = e(2,2)+ p(pst(1,id))! - p(pst(1,1))
e(3,3) = e(3,3)+ p(pst(1,id))! - p(pst(1,1))
if (sym) then
e(2,2)=e(2,2)+p(pst(1,id)+1)*ss +p(pst(1,id)+2)*ss**2
e(3,3)=e(3,3)+p(pst(1,id)+1)*ss +p(pst(1,id)+2)*ss**2
endif
id = id +1 ! 3
!A1'
e(4,4) = e(4,4) + p(pst(1,id))! - p(pst(1,1))
if (sym) then
e(4,4)=e(4,4) + p(pst(1,id)+1)*ss +p(pst(1,id)+2)*ss**2 &
+ p(pst(1,id)+3)*ss**3
endif
! W and z of JT block
! first order
id = id +1 !4
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 ! 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)
e(2,3) = e(2,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)
! the coupling of A2' and E'
! order 1
id = id +1 !6
e(1,2) = e(1,2) + b*(p(pst(1,id))*xs + p(pst(1,id)+1)*yb)
e(1,3) = e(1,3) - b*(p(pst(1,id))*ys + p(pst(1,id)+1)*yb)
! order 2
id =id +1 ! 7
e(1,2) = e(1,2) +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))
e(1,3) = e(1,3) +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))
! the coupling of A1' and E'
id = id +1 ! 8
e(2,4) = e(2,4) + p(pst(1,id))*xs + p(pst(1,id)+1)*xb
e(3,4) = e(3,4) - p(pst(1,id))*ys - p(pst(1,id)+1)*yb
if (sym) then
e(2,4) = e(2,4)+ p(pst(1,id)+2)*xs*ss
e(3,4) = e(3,4)- p(pst(1,id)+2)*ys*ss
endif
! order 2
id = id +1 ! 9
e(2,4) = e(2,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(3,4) = e(3,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)
! the couplign between A
id = id +1 ! 10
e(1,4) = e(1,4) + b*p(pst(1,id))
!write(*,*) 'Id = ',id
call copy_2_lower_triangle(e)
if (switch) then
write( 6,*)" EX AND EY ARE SWITCHED"
tmp = e(2,2)
e(2,2) = e(3,3)
e(3,3) = tmp
! the coupling
tmp = e(2,4)
e(2,4) = e(3,4)
e(3,4) = tmp
e(4,2) = e(2,4)
e(4,3) = e(3,4)
endif
end subroutine potential_nh3_low
subroutine copy_2_lower_triangle(mat)
real(dp), intent(inout) :: mat(:, :)
integer :: m, n
! write lower triangle of matrix symmetrical
do n = 2, size(mat, 1)
do m = 1, n - 1
mat(n, m) = mat(m, n)
end do
end do
end subroutine copy_2_lower_triangle
end module

72
src/model/red_invariants.f90 Normal file
View File

@ -0,0 +1,72 @@
Module invariants_mod
implicit none
contains
!----------------------------------------------------
subroutine invariants(a,xs,ys,xb,yb,b,invar)
implicit none
double precision, intent(in) :: a, xs, ys, xb, yb, b
double precision, intent(out) :: invar(24)
complex(8) :: q1, q2
LOGICAL,PARAMETER:: debg =.FALSE.
integer :: i
! express the coordinate in complex
q1 = dcmplx(xs, ys)
q2 = dcmplx(xb, yb)
! compute the invariants
invar(24) = a
invar(23) =b**2
! INVARIANTS OF KIND II
!------------------------
invar(1) = dreal( q1 * conjg(q1) ) ! r11
invar(2) = dreal( q1 * conjg(q2) ) ! r12
invar(3) = dreal( q2 * conjg(q2) ) ! r22
invar(4) = (dimag(q1 * conjg(q2)) )**2 ! rho 12**2
!INVATIANTS OF KIND III
!------------------------
invar(5) = dreal( q1 * q1 * q1 ) ! r111
invar(6) = dreal( q1 * q1 * q2 ) ! r112
invar(7) = dreal( q1 * q2 * q2 ) ! r122
invar(8) = dreal( q2 * q2 * q2 ) ! r222
invar(9) = (dimag( q1 * q1 * q1 ))**2 ! rho111**2
invar(10) = (dimag( q1 * q1 * q2 ))**2 ! rho112 **2
invar(11) = (dimag( q1 * q2 * q2 ))**2 ! rho122**2
invar(12) = (dimag( q2 * q2 * q2 ))**2 ! rho222
! INVARIANTS OF KIND IV
!-------------------------
invar(13) = (dimag( q1 * conjg(q2)) * dimag( q1 * q1 * q1 ))
invar(14) = (dimag( q1 * conjg(q2)) * dimag( q1 * q1 * q2 ))
invar(15) = (dimag( q1 * conjg(q2)) * dimag( q1 * q2 * q2 ))
invar(16) = (dimag( q1 * conjg(q2)) * dimag( q2 * q2 * q2 ))
! INVARIANTS OF KIND V
!----------------------
invar(17) = (dimag( q1 * q1 * q1 ) * dimag( q1 * q1 * q2 ))
invar(18) = (dimag( q1 * q1 * q1 ) * dimag( q1 * q2 * q2 ))
invar(19) = (dimag( q1 * q1 * q1 ) * dimag( q2 * q2 * q2 ))
invar(20) = (dimag( q1 * q1 * q2 ) * dimag( q1 * q2 * q2 ))
invar(21) = (dimag( q1 * q1 * q2 ) * dimag( q2 * q2 * q2 ))
invar(22) = (dimag( q1 * q2 * q2 ) * dimag( q2 * q2 * q2 ))
if (debg) then
write(*,"(A,*(f10.5))")"Invar II", (invar(i),i=1,4)
write(*,"(A,*(f10.5))") "Invar III", (invar(i),i=5,12)
write(*,"(A,*(f10.5))")"Invar IV", (invar(i),i=13,16)
write(*,"(A,*(f10.5))")"Invar V", (invar(i),i=17,22)
write(*,*)"THE INPUT COORDINATE IN COMPLEX REPRES"
write(*,*)"---------------------------------------"
write(*,*)"xs =",dreal(q1), "ys=",dimag(q1)
endif
end subroutine invariants
end module invariants_mod

9
src/model/sh-scal-50.incl Normal file
View File

@ -0,0 +1,9 @@
! shift and scale for 70N structrure
! Real(dp),parameter:: scal(17) = 1.0d0 ,shift(17) = 1.0d0
Real(dp),parameter:: scal(17) = &
[0.00434,0.00239,0.00201,4.13538,9.04704,1.07732,0.79253, &
1.86682,1.87266,0.58857,0.90899,2.07755,1.81564,1.31957,1.68503,1.48391,1.79901]
Real(dp),parameter:: shift(17) = &
[-0.00016,-0.00020, 0.00008,-0.04261,13.00281,-0.44002,-0.18611, &
0.73999, 0.34618,-0.44183,-0.06997, 0.39988,-1.42376, 0.77752,-1.23819,-0.22926, 0.82597]

11
src/model/shift-scale-70N.incl Normal file
View File

@ -0,0 +1,11 @@
! shift and scale for 70N structrure
! Real(dp),parameter:: scal(17) = 1.0d0 ,shift(17) = 1.0d0
Real(dp),parameter:: scal(17) = &
[0.00401, 0.00265, 0.00335, 1.19496, 3.79876, 0.32139, 0.46267, &
1.36249, 0.90118, 0.94406, 0.29014, 0.72172, 1.25435, 2.09880, &
0.93696, 1.69131, 0.75050 ]
Real(dp),parameter:: shift(17) = &
[-0.00018,-0.00018,-0.00002,-0.03463,-0.74584, 0.09806, 0.16350, &
-0.96733,-0.62850, 0.57182,-0.00110, 0.10584, 0.29949,-0.82418, &
0.57450, 0.04471, 0.28142 ]

913
src/model/without_symm_dip_pes.f90 Normal file
View File

@ -0,0 +1,913 @@
Module dip_param
IMPLICIT NONE
Integer,parameter :: np=101
Double precision :: p(101)
integer :: pst(2,400)
! Non zero parameters are 20
contains
SUBROUTINE init_dip_planar_data()
implicit none
p( 1)= -0.561433980D+02
p( 2)= 0.000000000D+00
p( 3)= 0.000000000D+00
p( 4)= -0.558830090D+02
p( 5)= 0.000000000D+00
p( 6)= 0.000000000D+00
p( 7)= -0.557220030D+02
p( 8)= 0.000000000D+00
p( 9)= 0.000000000D+00
p( 10)= 0.000000000D+00
p( 11)= 0.346660755D-02
p( 12)= 0.000000000D+00
p( 13)= 0.745842871D-04
p( 14)= 0.000000000D+00
p( 15)= 0.000000000D+00
p( 16)= 0.000000000D+00
p( 17)= 0.000000000D+00
p( 18)= 0.000000000D+00
p( 19)= 0.000000000D+00
p( 20)= 0.000000000D+00
p( 21)= -0.532590808D-03
p( 22)= 0.000000000D+00
p( 23)= 0.000000000D+00
p( 24)= 0.000000000D+00
p( 25)= 0.000000000D+00
p( 26)= 0.000000000D+00
p( 27)= 0.000000000D+00
p( 28)= -0.226326661D-01
p( 29)= 0.000000000D+00
p( 30)= -0.369184193D-01
p( 31)= 0.000000000D+00
p( 32)= 0.107573698D+00
p( 33)= 0.000000000D+00
p( 34)= 0.115472219D-03
p( 35)= 0.000000000D+00
p( 36)= 0.000000000D+00
p( 37)= 0.188753347D-04
p( 38)= 0.000000000D+00
p( 39)= 0.000000000D+00
p( 40)= -0.761215310D-02
p( 41)= 0.000000000D+00
p( 42)= 0.000000000D+00
p( 43)= 0.000000000D+00
p( 44)= 0.000000000D+00
p( 45)= 0.000000000D+00
p( 46)= 0.000000000D+00
p( 47)= 0.000000000D+00
p( 48)= 0.000000000D+00
p( 49)= 0.217598103D+00
p( 50)= -0.107350386D-01
p( 51)= 0.000000000D+00
p( 52)= 0.103908437D-03
p( 53)= 0.000000000D+00
p( 54)= 0.000000000D+00
p( 55)= 0.000000000D+00
p( 56)= 0.000000000D+00
p( 57)= 0.000000000D+00
p( 58)= 0.000000000D+00
p( 59)= 0.000000000D+00
p( 60)= 0.000000000D+00
p( 61)= 0.000000000D+00
p( 62)= 0.000000000D+00
p( 63)= 0.000000000D+00
p( 64)= 0.000000000D+00
p( 65)= 0.000000000D+00
p( 66)= 0.000000000D+00
p( 67)= 0.000000000D+00
p( 68)= 0.000000000D+00
p( 69)= 0.000000000D+00
p( 70)= 0.000000000D+00
p( 71)= 0.000000000D+00
p( 72)= 0.000000000D+00
p( 73)= 0.000000000D+00
p( 74)= 0.000000000D+00
p( 75)= 0.000000000D+00
p( 76)= 0.000000000D+00
p( 77)= 0.000000000D+00
p( 78)= 0.000000000D+00
p( 79)= 0.000000000D+00
p( 80)= 0.000000000D+00
p( 81)= 0.000000000D+00
p( 82)= 0.000000000D+00
p( 83)= 0.000000000D+00
p( 84)= 0.000000000D+00
p( 85)= 0.000000000D+00
p( 86)= 0.000000000D+00
p( 87)= -0.567206500D-02
p( 88)= 0.342983596D-02
p( 89)= 0.000000000D+00
p( 90)= 0.000000000D+00
p( 91)= 0.000000000D+00
p( 92)= 0.000000000D+00
p( 93)= 0.000000000D+00
p( 94)= 0.000000000D+00
p( 95)= 0.000000000D+00
p( 96)= 0.000000000D+00
p( 97)= 0.000000000D+00
p( 98)= 0.000000000D+00
p( 99)= 0.000000000D+00
p(100)= 0.000000000D+00
p(101)= 0.000000000D+00
pst(1, 1)= 1
pst(2, 1)= 3
pst(1, 2)= 4
pst(2, 2)= 3
pst(1, 3)= 7
pst(2, 3)= 4
pst(1, 4)= 11
pst(2, 4)= 2
pst(1, 5)= 13
pst(2, 5)= 3
pst(1, 6)= 16
pst(2, 6)= 2
pst(1, 7)= 18
pst(2, 7)= 3
pst(1, 8)= 21
pst(2, 8)= 3
pst(1, 9)= 24
pst(2, 9)= 3
pst(1, 10)= 27
pst(2, 10)= 1
pst(1, 11)= 28
pst(2, 11)= 2
pst(1, 12)= 30
pst(2, 12)= 2
pst(1, 13)= 32
pst(2, 13)= 2
pst(1, 14)= 34
pst(2, 14)= 3
pst(1, 15)= 37
pst(2, 15)= 3
pst(1, 16)= 40
pst(2, 16)= 3
pst(1, 17)= 43
pst(2, 17)= 2
pst(1, 18)= 45
pst(2, 18)= 2
pst(1, 19)= 47
pst(2, 19)= 2
pst(1, 20)= 49
pst(2, 20)= 1
pst(1, 21)= 50
pst(2, 21)= 2
pst(1, 22)= 52
pst(2, 22)= 5
pst(1, 23)= 57
pst(2, 23)= 10
pst(1, 24)= 67
pst(2, 24)= 1
pst(1, 25)= 68
pst(2, 25)= 2
pst(1, 26)= 70
pst(2, 26)= 4
pst(1, 27)= 74
pst(2, 27)= 8
pst(1, 28)= 82
pst(2, 28)= 2
pst(1, 29)= 84
pst(2, 29)= 3
pst(1, 30)= 87
pst(2, 30)= 1
pst(1, 31)= 88
pst(2, 31)= 2
pst(1, 32)= 90
pst(2, 32)= 4
pst(1, 33)= 94
pst(2, 33)= 8
pst(1, 34)= 0
pst(2, 34)= 0
pst(1, 35)= 0
pst(2, 35)= 0
pst(1, 36)= 0
pst(2, 36)= 0
pst(1, 37)= 0
pst(2, 37)= 0
pst(1, 38)= 0
pst(2, 38)= 0
pst(1, 39)= 0
pst(2, 39)= 0
pst(1, 40)= 0
pst(2, 40)= 0
pst(1, 41)= 0
pst(2, 41)= 0
pst(1, 42)= 0
pst(2, 42)= 0
pst(1, 43)= 0
pst(2, 43)= 0
pst(1, 44)= 0
pst(2, 44)= 0
pst(1, 45)= 0
pst(2, 45)= 0
pst(1, 46)= 0
pst(2, 46)= 0
pst(1, 47)= 0
pst(2, 47)= 0
pst(1, 48)= 0
pst(2, 48)= 0
pst(1, 49)= 0
pst(2, 49)= 0
pst(1, 50)= 0
pst(2, 50)= 0
pst(1, 51)= 0
pst(2, 51)= 0
pst(1, 52)= 0
pst(2, 52)= 0
pst(1, 53)= 0
pst(2, 53)= 0
pst(1, 54)= 0
pst(2, 54)= 0
pst(1, 55)= 0
pst(2, 55)= 0
pst(1, 56)= 0
pst(2, 56)= 0
pst(1, 57)= 0
pst(2, 57)= 0
pst(1, 58)= 0
pst(2, 58)= 0
pst(1, 59)= 0
pst(2, 59)= 0
pst(1, 60)= 0
pst(2, 60)= 0
pst(1, 61)= 0
pst(2, 61)= 0
pst(1, 62)= 0
pst(2, 62)= 0
pst(1, 63)= 0
pst(2, 63)= 0
pst(1, 64)= 0
pst(2, 64)= 0
pst(1, 65)= 0
pst(2, 65)= 0
pst(1, 66)= 0
pst(2, 66)= 0
pst(1, 67)= 0
pst(2, 67)= 0
pst(1, 68)= 0
pst(2, 68)= 0
pst(1, 69)= 0
pst(2, 69)= 0
pst(1, 70)= 0
pst(2, 70)= 0
pst(1, 71)= 0
pst(2, 71)= 0
pst(1, 72)= 0
pst(2, 72)= 0
pst(1, 73)= 0
pst(2, 73)= 0
pst(1, 74)= 0
pst(2, 74)= 0
pst(1, 75)= 0
pst(2, 75)= 0
pst(1, 76)= 0
pst(2, 76)= 0
pst(1, 77)= 0
pst(2, 77)= 0
pst(1, 78)= 0
pst(2, 78)= 0
pst(1, 79)= 0
pst(2, 79)= 0
pst(1, 80)= 0
pst(2, 80)= 0
pst(1, 81)= 0
pst(2, 81)= 0
pst(1, 82)= 0
pst(2, 82)= 0
pst(1, 83)= 0
pst(2, 83)= 0
pst(1, 84)= 0
pst(2, 84)= 0
pst(1, 85)= 0
pst(2, 85)= 0
pst(1, 86)= 0
pst(2, 86)= 0
pst(1, 87)= 0
pst(2, 87)= 0
pst(1, 88)= 0
pst(2, 88)= 0
pst(1, 89)= 0
pst(2, 89)= 0
pst(1, 90)= 0
pst(2, 90)= 0
pst(1, 91)= 0
pst(2, 91)= 0
pst(1, 92)= 0
pst(2, 92)= 0
pst(1, 93)= 0
pst(2, 93)= 0
pst(1, 94)= 0
pst(2, 94)= 0
pst(1, 95)= 0
pst(2, 95)= 0
pst(1, 96)= 0
pst(2, 96)= 0
pst(1, 97)= 0
pst(2, 97)= 0
pst(1, 98)= 0
pst(2, 98)= 0
pst(1, 99)= 0
pst(2, 99)= 0
pst(1,100)= 0
pst(2,100)= 0
pst(1,101)= 0
pst(2,101)= 0
pst(1,102)= 0
pst(2,102)= 0
pst(1,103)= 0
pst(2,103)= 0
pst(1,104)= 0
pst(2,104)= 0
pst(1,105)= 0
pst(2,105)= 0
pst(1,106)= 0
pst(2,106)= 0
pst(1,107)= 0
pst(2,107)= 0
pst(1,108)= 0
pst(2,108)= 0
pst(1,109)= 0
pst(2,109)= 0
pst(1,110)= 0
pst(2,110)= 0
pst(1,111)= 0
pst(2,111)= 0
pst(1,112)= 0
pst(2,112)= 0
pst(1,113)= 0
pst(2,113)= 0
pst(1,114)= 0
pst(2,114)= 0
pst(1,115)= 0
pst(2,115)= 0
pst(1,116)= 0
pst(2,116)= 0
pst(1,117)= 0
pst(2,117)= 0
pst(1,118)= 0
pst(2,118)= 0
pst(1,119)= 0
pst(2,119)= 0
pst(1,120)= 0
pst(2,120)= 0
pst(1,121)= 0
pst(2,121)= 0
pst(1,122)= 0
pst(2,122)= 0
pst(1,123)= 0
pst(2,123)= 0
pst(1,124)= 0
pst(2,124)= 0
pst(1,125)= 0
pst(2,125)= 0
pst(1,126)= 0
pst(2,126)= 0
pst(1,127)= 0
pst(2,127)= 0
pst(1,128)= 0
pst(2,128)= 0
pst(1,129)= 0
pst(2,129)= 0
pst(1,130)= 0
pst(2,130)= 0
pst(1,131)= 0
pst(2,131)= 0
pst(1,132)= 0
pst(2,132)= 0
pst(1,133)= 0
pst(2,133)= 0
pst(1,134)= 0
pst(2,134)= 0
pst(1,135)= 0
pst(2,135)= 0
pst(1,136)= 0
pst(2,136)= 0
pst(1,137)= 0
pst(2,137)= 0
pst(1,138)= 0
pst(2,138)= 0
pst(1,139)= 0
pst(2,139)= 0
pst(1,140)= 0
pst(2,140)= 0
pst(1,141)= 0
pst(2,141)= 0
pst(1,142)= 0
pst(2,142)= 0
pst(1,143)= 0
pst(2,143)= 0
pst(1,144)= 0
pst(2,144)= 0
pst(1,145)= 0
pst(2,145)= 0
pst(1,146)= 0
pst(2,146)= 0
pst(1,147)= 0
pst(2,147)= 0
pst(1,148)= 0
pst(2,148)= 0
pst(1,149)= 0
pst(2,149)= 0
pst(1,150)= 0
pst(2,150)= 0
pst(1,151)= 0
pst(2,151)= 0
pst(1,152)= 0
pst(2,152)= 0
pst(1,153)= 0
pst(2,153)= 0
pst(1,154)= 0
pst(2,154)= 0
pst(1,155)= 0
pst(2,155)= 0
pst(1,156)= 0
pst(2,156)= 0
pst(1,157)= 0
pst(2,157)= 0
pst(1,158)= 0
pst(2,158)= 0
pst(1,159)= 0
pst(2,159)= 0
pst(1,160)= 0
pst(2,160)= 0
pst(1,161)= 0
pst(2,161)= 0
pst(1,162)= 0
pst(2,162)= 0
pst(1,163)= 0
pst(2,163)= 0
pst(1,164)= 0
pst(2,164)= 0
pst(1,165)= 0
pst(2,165)= 0
pst(1,166)= 0
pst(2,166)= 0
pst(1,167)= 0
pst(2,167)= 0
pst(1,168)= 0
pst(2,168)= 0
pst(1,169)= 0
pst(2,169)= 0
pst(1,170)= 0
pst(2,170)= 0
pst(1,171)= 0
pst(2,171)= 0
pst(1,172)= 0
pst(2,172)= 0
pst(1,173)= 0
pst(2,173)= 0
pst(1,174)= 0
pst(2,174)= 0
pst(1,175)= 0
pst(2,175)= 0
pst(1,176)= 0
pst(2,176)= 0
pst(1,177)= 0
pst(2,177)= 0
pst(1,178)= 0
pst(2,178)= 0
pst(1,179)= 0
pst(2,179)= 0
pst(1,180)= 0
pst(2,180)= 0
pst(1,181)= 0
pst(2,181)= 0
pst(1,182)= 0
pst(2,182)= 0
pst(1,183)= 0
pst(2,183)= 0
pst(1,184)= 0
pst(2,184)= 0
pst(1,185)= 0
pst(2,185)= 0
pst(1,186)= 0
pst(2,186)= 0
pst(1,187)= 0
pst(2,187)= 0
pst(1,188)= 0
pst(2,188)= 0
pst(1,189)= 0
pst(2,189)= 0
pst(1,190)= 0
pst(2,190)= 0
pst(1,191)= 0
pst(2,191)= 0
pst(1,192)= 0
pst(2,192)= 0
pst(1,193)= 0
pst(2,193)= 0
pst(1,194)= 0
pst(2,194)= 0
pst(1,195)= 0
pst(2,195)= 0
pst(1,196)= 0
pst(2,196)= 0
pst(1,197)= 0
pst(2,197)= 0
pst(1,198)= 0
pst(2,198)= 0
pst(1,199)= 0
pst(2,199)= 0
pst(1,200)= 0
pst(2,200)= 0
pst(1,201)= 0
pst(2,201)= 0
pst(1,202)= 0
pst(2,202)= 0
pst(1,203)= 0
pst(2,203)= 0
pst(1,204)= 0
pst(2,204)= 0
pst(1,205)= 0
pst(2,205)= 0
pst(1,206)= 0
pst(2,206)= 0
pst(1,207)= 0
pst(2,207)= 0
pst(1,208)= 0
pst(2,208)= 0
pst(1,209)= 0
pst(2,209)= 0
pst(1,210)= 0
pst(2,210)= 0
pst(1,211)= 0
pst(2,211)= 0
pst(1,212)= 0
pst(2,212)= 0
pst(1,213)= 0
pst(2,213)= 0
pst(1,214)= 0
pst(2,214)= 0
pst(1,215)= 0
pst(2,215)= 0
pst(1,216)= 0
pst(2,216)= 0
pst(1,217)= 0
pst(2,217)= 0
pst(1,218)= 0
pst(2,218)= 0
pst(1,219)= 0
pst(2,219)= 0
pst(1,220)= 0
pst(2,220)= 0
pst(1,221)= 0
pst(2,221)= 0
pst(1,222)= 0
pst(2,222)= 0
pst(1,223)= 0
pst(2,223)= 0
pst(1,224)= 0
pst(2,224)= 0
pst(1,225)= 0
pst(2,225)= 0
pst(1,226)= 0
pst(2,226)= 0
pst(1,227)= 0
pst(2,227)= 0
pst(1,228)= 0
pst(2,228)= 0
pst(1,229)= 0
pst(2,229)= 0
pst(1,230)= 0
pst(2,230)= 0
pst(1,231)= 0
pst(2,231)= 0
pst(1,232)= 0
pst(2,232)= 0
pst(1,233)= 0
pst(2,233)= 0
pst(1,234)= 0
pst(2,234)= 0
pst(1,235)= 0
pst(2,235)= 0
pst(1,236)= 0
pst(2,236)= 0
pst(1,237)= 0
pst(2,237)= 0
pst(1,238)= 0
pst(2,238)= 0
pst(1,239)= 0
pst(2,239)= 0
pst(1,240)= 0
pst(2,240)= 0
pst(1,241)= 0
pst(2,241)= 0
pst(1,242)= 0
pst(2,242)= 0
pst(1,243)= 0
pst(2,243)= 0
pst(1,244)= 0
pst(2,244)= 0
pst(1,245)= 0
pst(2,245)= 0
pst(1,246)= 0
pst(2,246)= 0
pst(1,247)= 0
pst(2,247)= 0
pst(1,248)= 0
pst(2,248)= 0
pst(1,249)= 0
pst(2,249)= 0
pst(1,250)= 0
pst(2,250)= 0
pst(1,251)= 0
pst(2,251)= 0
pst(1,252)= 0
pst(2,252)= 0
pst(1,253)= 0
pst(2,253)= 0
pst(1,254)= 0
pst(2,254)= 0
pst(1,255)= 0
pst(2,255)= 0
pst(1,256)= 0
pst(2,256)= 0
pst(1,257)= 0
pst(2,257)= 0
pst(1,258)= 0
pst(2,258)= 0
pst(1,259)= 0
pst(2,259)= 0
pst(1,260)= 0
pst(2,260)= 0
pst(1,261)= 0
pst(2,261)= 0
pst(1,262)= 0
pst(2,262)= 0
pst(1,263)= 0
pst(2,263)= 0
pst(1,264)= 0
pst(2,264)= 0
pst(1,265)= 0
pst(2,265)= 0
pst(1,266)= 0
pst(2,266)= 0
pst(1,267)= 0
pst(2,267)= 0
pst(1,268)= 0
pst(2,268)= 0
pst(1,269)= 0
pst(2,269)= 0
pst(1,270)= 0
pst(2,270)= 0
pst(1,271)= 0
pst(2,271)= 0
pst(1,272)= 0
pst(2,272)= 0
pst(1,273)= 0
pst(2,273)= 0
pst(1,274)= 0
pst(2,274)= 0
pst(1,275)= 0
pst(2,275)= 0
pst(1,276)= 0
pst(2,276)= 0
pst(1,277)= 0
pst(2,277)= 0
pst(1,278)= 0
pst(2,278)= 0
pst(1,279)= 0
pst(2,279)= 0
pst(1,280)= 0
pst(2,280)= 0
pst(1,281)= 0
pst(2,281)= 0
pst(1,282)= 0
pst(2,282)= 0
pst(1,283)= 0
pst(2,283)= 0
pst(1,284)= 0
pst(2,284)= 0
pst(1,285)= 0
pst(2,285)= 0
pst(1,286)= 0
pst(2,286)= 0
pst(1,287)= 0
pst(2,287)= 0
pst(1,288)= 0
pst(2,288)= 0
pst(1,289)= 0
pst(2,289)= 0
pst(1,290)= 0
pst(2,290)= 0
pst(1,291)= 0
pst(2,291)= 0
pst(1,292)= 0
pst(2,292)= 0
pst(1,293)= 0
pst(2,293)= 0
pst(1,294)= 0
pst(2,294)= 0
pst(1,295)= 0
pst(2,295)= 0
pst(1,296)= 0
pst(2,296)= 0
pst(1,297)= 0
pst(2,297)= 0
pst(1,298)= 0
pst(2,298)= 0
pst(1,299)= 0
pst(2,299)= 0
pst(1,300)= 0
pst(2,300)= 0
pst(1,301)= 0
pst(2,301)= 0
pst(1,302)= 0
pst(2,302)= 0
pst(1,303)= 0
pst(2,303)= 0
pst(1,304)= 0
pst(2,304)= 0
pst(1,305)= 0
pst(2,305)= 0
pst(1,306)= 0
pst(2,306)= 0
pst(1,307)= 0
pst(2,307)= 0
pst(1,308)= 0
pst(2,308)= 0
pst(1,309)= 0
pst(2,309)= 0
pst(1,310)= 0
pst(2,310)= 0
pst(1,311)= 0
pst(2,311)= 0
pst(1,312)= 0
pst(2,312)= 0
pst(1,313)= 0
pst(2,313)= 0
pst(1,314)= 0
pst(2,314)= 0
pst(1,315)= 0
pst(2,315)= 0
pst(1,316)= 0
pst(2,316)= 0
pst(1,317)= 0
pst(2,317)= 0
pst(1,318)= 0
pst(2,318)= 0
pst(1,319)= 0
pst(2,319)= 0
pst(1,320)= 0
pst(2,320)= 0
pst(1,321)= 0
pst(2,321)= 0
pst(1,322)= 0
pst(2,322)= 0
pst(1,323)= 0
pst(2,323)= 0
pst(1,324)= 0
pst(2,324)= 0
pst(1,325)= 0
pst(2,325)= 0
pst(1,326)= 0
pst(2,326)= 0
pst(1,327)= 0
pst(2,327)= 0
pst(1,328)= 0
pst(2,328)= 0
pst(1,329)= 0
pst(2,329)= 0
pst(1,330)= 0
pst(2,330)= 0
pst(1,331)= 0
pst(2,331)= 0
pst(1,332)= 0
pst(2,332)= 0
pst(1,333)= 0
pst(2,333)= 0
pst(1,334)= 0
pst(2,334)= 0
pst(1,335)= 0
pst(2,335)= 0
pst(1,336)= 0
pst(2,336)= 0
pst(1,337)= 0
pst(2,337)= 0
pst(1,338)= 0
pst(2,338)= 0
pst(1,339)= 0
pst(2,339)= 0
pst(1,340)= 0
pst(2,340)= 0
pst(1,341)= 0
pst(2,341)= 0
pst(1,342)= 0
pst(2,342)= 0
pst(1,343)= 0
pst(2,343)= 0
pst(1,344)= 0
pst(2,344)= 0
pst(1,345)= 0
pst(2,345)= 0
pst(1,346)= 0
pst(2,346)= 0
pst(1,347)= 0
pst(2,347)= 0
pst(1,348)= 0
pst(2,348)= 0
pst(1,349)= 0
pst(2,349)= 0
pst(1,350)= 0
pst(2,350)= 0
pst(1,351)= 0
pst(2,351)= 0
pst(1,352)= 0
pst(2,352)= 0
pst(1,353)= 0
pst(2,353)= 0
pst(1,354)= 0
pst(2,354)= 0
pst(1,355)= 0
pst(2,355)= 0
pst(1,356)= 0
pst(2,356)= 0
pst(1,357)= 0
pst(2,357)= 0
pst(1,358)= 0
pst(2,358)= 0
pst(1,359)= 0
pst(2,359)= 0
pst(1,360)= 0
pst(2,360)= 0
pst(1,361)= 0
pst(2,361)= 0
pst(1,362)= 0
pst(2,362)= 0
pst(1,363)= 0
pst(2,363)= 0
pst(1,364)= 0
pst(2,364)= 0
pst(1,365)= 0
pst(2,365)= 0
pst(1,366)= 0
pst(2,366)= 0
pst(1,367)= 0
pst(2,367)= 0
pst(1,368)= 0
pst(2,368)= 0
pst(1,369)= 0
pst(2,369)= 0
pst(1,370)= 0
pst(2,370)= 0
pst(1,371)= 0
pst(2,371)= 0
pst(1,372)= 0
pst(2,372)= 0
pst(1,373)= 0
pst(2,373)= 0
pst(1,374)= 0
pst(2,374)= 0
pst(1,375)= 0
pst(2,375)= 0
pst(1,376)= 0
pst(2,376)= 0
pst(1,377)= 0
pst(2,377)= 0
pst(1,378)= 0
pst(2,378)= 0
pst(1,379)= 0
pst(2,379)= 0
pst(1,380)= 0
pst(2,380)= 0
pst(1,381)= 0
pst(2,381)= 0
pst(1,382)= 0
pst(2,382)= 0
pst(1,383)= 0
pst(2,383)= 0
pst(1,384)= 0
pst(2,384)= 0
pst(1,385)= 0
pst(2,385)= 0
pst(1,386)= 0
pst(2,386)= 0
pst(1,387)= 0
pst(2,387)= 0
pst(1,388)= 0
pst(2,388)= 0
pst(1,389)= 0
pst(2,389)= 0
pst(1,390)= 0
pst(2,390)= 0
pst(1,391)= 0
pst(2,391)= 0
pst(1,392)= 0
pst(2,392)= 0
pst(1,393)= 0
pst(2,393)= 0
pst(1,394)= 0
pst(2,394)= 0
pst(1,395)= 0
pst(2,395)= 0
pst(1,396)= 0
pst(2,396)= 0
pst(1,397)= 0
pst(2,397)= 0
pst(1,398)= 0
pst(2,398)= 0
pst(1,399)= 0
pst(2,399)= 0
pst(1,400)= 0
pst(2,400)= 0
End SUBROUTINE init_dip_planar_data
End Module dip_param

235
src/model/write_error.f90 Normal file
View File

@ -0,0 +1,235 @@
module print_error
use iso_fortran_env, only: idp => int32, dp => real64
use nn_params
use nncommons
implicit none
contains
!=======================================================================
! Compute and print error summary (RMS) for PES energies and dipole moments
! Separately for total, weighted, energies (1:4), dipoles (5:inp_out)
!=======================================================================
subroutine print_ErrorSummary(par, pat_in, pat_out,ref_in,ref_out, &
wterr, typop, laystr, weistr, nlay, &
npat, nref)
real(dp), intent(in) :: pat_in(maxnin, maxpats)
real(dp), intent(in) :: pat_out(maxpout, maxpats)
real(dp), intent(in) :: par(wbcap, maxset)
real(dp), intent(in) :: wterr(maxpout, maxpats)
real(dp), intent(in) :: ref_in(maxnin,maxpats), ref_out(maxpout,maxpats)
integer(idp), intent(in) :: laystr(3, maxlay)
integer(idp), intent(in) :: typop(maxtypes, maxlay)
integer(idp), intent(in) :: weistr(2, maxlay, 2)
integer(idp), intent(in) :: nlay, npat, nref
! Local variables
integer(idp) :: pt, k,i
integer(idp) :: ntot
integer(idp),dimension(maxpout) :: cnt_tot,cnt_fit,cnt_val
real(dp), dimension(maxpout) :: total_rms_fit, total_rms_val,wrms_fit,wrms_val
real(dp) :: nnoutp(maxnout)
real(dp) :: ymod(maxpout, maxpats)
real(dp) :: wsum_fit
real(dp) :: rms_total, rms_weight
real(dp) :: en_rms, dip_rms
Real(dp) :: rms_total_fit, rms_w_fit
Real(dp) :: rms_total_val, rms_w_val
Real(dp) :: en_rms_fit,en_rms_val,dip_rms_fit,dip_rms_val
integer(idp), parameter :: std_out = 6
! Total number of points (fitting + validation/reference)
ntot = npat + nref
! keep in mind that npat is the total number of point fit + ref
!write(6,*)"Npat in the error summary", npat,nref
write(11,'(*(ES16.7))')par(:,1)
! Initialize accumulators
cnt_fit = 0
cnt_tot = 0
cnt_val = 0
wsum_fit =0.0_dp
total_rms_fit(:) = 0.0_dp
wrms_fit(:) = 0.0_dp
total_rms_val (:) = 0.0_dp
wrms_val(:) = 0.0_dp
!write(11,'(*(ES18.6))')ref_in(1:3,:)
! Generate model predictions and accumulate squared errors
pt = 0
do pt =1, npat
if (pt > maxpats) then
write(std_out, *) "ERROR: pt exceeds maxpats!"
stop
end if
! Get network output
call neunet(pat_in(:, pt), nnoutp, par,typop, laystr, weistr, nlay)
! Transform to adiabatic representation (energies + dipoles)
call nnadia(pat_in(:, pt), nnoutp, ymod(:, pt))
! Accumulate errors only for components with positive weight
do k = 1, inp_out
if (wterr(k, pt) > 0.0_dp) then
!cnt_tot(k) = cnt_tot(k) + 1
! Fitting / training set
cnt_fit(k) = cnt_fit(k) + 1
total_rms_fit(k) = total_rms_fit(k) + (ymod(k,pt) - pat_out(k,pt))**2
wrms_fit(k) = wrms_fit(k) + ((ymod(k,pt) - pat_out(k,pt))**2 &
* (wterr(k,pt)))
wsum_fit = wsum_fit + wterr(k,pt)
end if
end do
end do
! validation set
do i =1, nref
!if (pt > maxpats) stop "Error pt exceeds maxpats"
pt = npat + i
call neunet(ref_in(:,i),nnoutp,par,typop,laystr,weistr,nlay)
! call the model
call nnadia(ref_in(:,i),nnoutp,ymod(:,pt))
! calculate the errors
do k=1,inp_out
if (wterr(k,pt) > 0.0_dp) then
cnt_val (k) = cnt_val(k) + 1
total_rms_val(k) = total_rms_val(k) + (ymod(k,pt) - ref_out(k,i))**2
wrms_val(k) = wrms_val(k) + ((ymod(k,pt) - ref_out(k,i))**2 * &
(wterr(k,pt)))
!write(6,*)" IN here wter"
endif
enddo
!write(11,'(*(ES18.6))')wterr(:,pt)
enddo
! Safety check: did we process the expected number of points?
! Compute RMS values
! TOTAL FIT +REF
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
rms_total = 0.0_dp
if ((sum(cnt_fit(1:inp_out)) + sum(cnt_val(1:inp_out))) > 0) then
rms_total = dsqrt( sum(total_rms_fit + total_rms_val) / &
real((sum(cnt_fit(1:inp_out))+sum(cnt_val(1:inp_out))), dp) )
end if
rms_weight = 0.0_dp
if (sum(wterr(1:inp_out, 1:npat+nref)) > 1.0e-12_dp) then ! avoid div-by-zero
rms_weight = dsqrt( sum(wrms_fit) + sum(wrms_val)) / sum(wterr(1:inp_out, 1:npat+nref))
!rms_weight = dsqrt(wt_rms /weighted_wt )
end if
en_rms = 0.0_dp
if ((sum(cnt_fit(1:4)) + sum(cnt_val(1:4))) > 0) then
en_rms = sqrt( ( sum(total_rms_fit(1:4)) + sum(total_rms_val(1:4)) ) / &
real(sum(cnt_fit(1:4)) + sum(cnt_val(1:4)), dp) )
end if
dip_rms = 0.0_dp
if ((sum(cnt_fit(5:inp_out)) + sum(cnt_val(5:inp_out)))> 0) then
dip_rms = sqrt( (sum(total_rms_fit(5:inp_out)) + sum(total_rms_val(5:inp_out))) / &
real((sum(cnt_fit(5:inp_out))+sum(cnt_val(5:inp_out))), dp) )
end if
rms_total_fit = 0.0_dp
if (sum(cnt_fit(1:inp_out)) > 0) then
rms_total_fit = dsqrt( sum(total_rms_fit(1:inp_out)) / real(sum(cnt_fit(1:inp_out)), dp) )
endif
rms_w_fit = 0.0_dp
if (wsum_fit > 1.0e-12_dp) then
rms_w_fit = sqrt( sum(wrms_fit(1:inp_out)) / wsum_fit )
endif
! validation
rms_total_val = 0.0_dp
if (sum(cnt_val(1:inp_out)) > 0) then
rms_total_val = sqrt( sum(total_rms_val(1:inp_out)) / real(sum(cnt_val(1:inp_out)), dp) )
endif
rms_w_val = 0.0_dp
if (sum(wterr(1:inp_out,npat+1:npat+nref)) > 1.0e-12_dp) then
rms_w_val = sqrt( sum(wrms_val(1:inp_out)) / sum(wterr(1:inp_out,npat+1:npat+nref)) )
endif
! compute each quantity error
en_rms_fit = merge( sqrt(sum(total_rms_fit(1:4))/real(sum(cnt_fit(1:4)),dp)),&
0.0_dp, sum(cnt_fit(1:4))>0 )
en_rms_val = merge( sqrt(sum(total_rms_val(1:4))/real(sum(cnt_val(1:4)),dp)), &
0.0_dp, sum(cnt_val(1:4))>0 )
dip_rms_fit = merge( sqrt(sum(total_rms_fit(5:inp_out))/real(sum(cnt_fit(5:inp_out)),dp)), &
0.0_dp, sum(cnt_fit(5:inp_out))>0 )
dip_rms_val = merge( sqrt(sum(total_rms_val(5:inp_out))/real(sum(cnt_val(5:inp_out)),dp)), &
0.0_dp, sum(cnt_val(5:inp_out))>0 )
! Output
write(std_out, '(A)') " "
write(std_out, '(A)') "USER DEFINED ERROR METRIC"
write(std_out, '(A)') "######################################"
!write(std_out, '(A,ES18.8,A)') &
! "Total RMS (all fitted components, unweighted) : ", rms_total * unit_con, &
! " [ha]"
!write(std_out, '(A,ES18.8,A)') &
! "Total Weighted RMS (fit + Ref) : ", rms_weight * unit_con
!write(std_out, '(A,ES18.8,A)') &
! "Energy RMS : ", en_rms * unit_con, " [ha] "
!write(std_out, '(A,ES18.8,A)') &
! "Dipole RMS : ", dip_rms * unit_con, " [ha] "
! compute the metric for fit data
write(std_out, '(A)') "FITTING / TRAINING SET"
write(std_out, '(A)') "#############################"
write(std_out,'(A,ES14.6,A)') " Total RMS (unweighted) = ", rms_total_fit * unit_con
write(std_out,'(A,ES14.6,A)') " Weighted RMS = ", rms_w_fit * unit_con
write(std_out,'(A,ES14.6,A)') " Energy RMS = ", en_rms_fit * unit_con
write(std_out,'(A,ES14.6,A)') " Dipole RMS = ", dip_rms_fit * unit_con
write(std_out, '(A)') " "
write(std_out, '(A)') "VALIDATION / REFERENCE SET"
write(std_out, '(A)') "##################################"
write(std_out,'(A,ES14.6,A)') " Total RMS (unweighted) = ", rms_total_val * unit_con
write(std_out,'(A,ES14.6,A)') " Weighted RMS = ", rms_w_val * unit_con
write(std_out,'(A,ES14.6,A)') " Energy RMS = ", en_rms_val * unit_con
write(std_out,'(A,ES14.6,A)') " Dipole RMS = ", dip_rms_val * unit_con
write(std_out, '(A)') " "
write(std_out, '(A)') "COMBINED (FIT + VALIDATION)"
write(std_out, '(A)') "------------------------------"
write(std_out,'(A,ES14.6,A)') " Total RMS (unweighted) = ", rms_total * unit_con
write(std_out,'(A,ES14.6,A)') " Weighted RMS = ", rms_weight * unit_con
write(std_out,'(A,ES14.6,A)') " Energy RMS = ", en_rms * unit_con
write(std_out,'(A,ES14.6,A)') " Dipole RMS = ", dip_rms * unit_con
write(std_out,'(A)')" END OF ERROR SUMMARY"
!write(std_out, '(A)') repeat("-", 70)
! Optional: add more detailed per-component output if desired
! do k = 1, inp_out
! if (cnt(k) > 0) then
! write(std_out,'(A,I0,A,ES12.5)') "Output ",k," RMS = ", &
! sqrt(total_rms(k)/real(cnt(k),dp)) * unit_con
! end if
! end do
end subroutine print_ErrorSummary
end module print_error

115
src/neuron_types.f Normal file
View File

@ -0,0 +1,115 @@
**** Define activation functions for FF-NN propagation.
***
***Conventions:
***neuroni: subroutine for type-i neuron (ex. neuron1)
***derivi: derivative of type-i activation function
***ntype: number of neurons of type i
***L: Layer vector, assumed to begin at the first neuron of type i
***deriv: Derivative vector, assumed to begin at the first neuron of type i
***************************************************************************
****Pattern:
* subroutine neuron0(L,ntype)
* implicit none
* <Description>
*
* include 'nnparams.incl'
*
* double precision L(*)
* integer ntype
*
* integer i
*
* do i=1,ntype
* L(i)= f(L(i))
* enddo
*
* end
***************************************************************************
subroutine neuron1(L,ntype)
use nn_params
implicit none
! logistic sigmoid curve
! f = N*tanh(a*x)
! where a=atanh(1/sqrt(3)) and N=sqrt(3)
! This way, f(1)=1 and f'' maximal at 1.
double precision L(*)
integer ntype
double precision alpha, norm
parameter (norm=dsqrt(3.0d0))
parameter (alpha=(dlog(norm+1.0d0)-dlog(norm-1.0d0))/2.0d0)
integer i
do i=1,ntype
L(i)=norm*dtanh(alpha*L(i))
enddo
end
subroutine deriv1(L,deriv,ntype)
use nn_params
implicit none
! logistic sigmoid curve
! f'(x)=N*(1-tanh^2(a*x))*(a)
! where a=atanh(1/sqrt(3)) and N=sqrt(3)
! This way, f(1)=1 and f'' maximal at 1.
double precision L(*),deriv(*)
integer ntype
double precision alpha, norm
parameter (norm=dsqrt(3.0d0))
parameter (alpha=(dlog(norm+1.0d0)-dlog(norm-1.0d0))/2.0d0)
integer i
do i=1,ntype
deriv(i)=alpha*norm*(1.0D0 - dtanh(alpha*L(i))**2)
enddo
end
**********************
subroutine neuron2(L,ntype)
use nn_params
implicit none
! linear activation function
double precision L(*)
integer ntype
integer i
do i=1,ntype
L(i)=L(i)
enddo
end
subroutine deriv2(deriv,ntype)
use nn_params
implicit none
! linear activation function
integer ntype
double precision deriv(*)
integer i
do i=1,ntype
deriv(i)=1.0D0
enddo
end
**********************

119
src/nn_common_param.f90 Normal file
View File

@ -0,0 +1,119 @@
module nncommons
use accuracy_constants
use nn_params, only: maxnin, maxpats
use io_parameters, only: maxoutp, maxdat, klen, maxkeys, maxerrors
implicit none
private :: dp, idp, maxnin, maxpats
private :: maxoutp, maxdat, klen, maxkeys, maxerrors
! General parameter and parser state formerly declared in common.incl.
integer(idp) :: npar, pst(2,100)
integer(idp) :: keynum, datpos(3,maxdat)
character(len=klen) :: keylist(2,maxkeys)
character(len=64) :: errcat(maxerrors)
!**** Basic data structures and special constants for ANN
!***
!***
!*** /nngene/: fundamental constants for gene manipulation
!***
!*** /nnprop/: basic fitting info (iternation numbers etc.)
!***
!*** /nnio/: constants for translating input variables/function values
!*** into NN input/output
!***
!*** /nnopt/: information for convergence acceleration
!***
!*** /nnunits/: unit transformations for output
!***
!*** /nnplot/: information relevant to plotting
!***
!*** /nnpartial/: information to organize partial runs (e.g. restarts)
!***
!*** maxbpit: max. number of iterations for ML-learning
!*** maxfails: maximum number of failed microiterations
!*** maxref_fails: maximum number of times the reference pattern
!*** set fails to improve
!*** lambda_initial: initial value for Marquardt-Levenberg parameter
!*** mqfact_default: factor by which lambda is changed during MQL-fit
!***
!*** inp_in: number of coordinates in input (not implemented)
!*** inp_out: number of values in output
!*** len_in: number of input neurons
!*** len_out: number of output neurons
!***
!*** unit_string: name of output unit
!*** unit_con: conversion factor from internal to output unit
!***
!*** continued/partial run parameters
!***
!*** from_fit: MQL-fit to start from
!*** to_fit: MQL-fit to end at (instead of nset)
!*** use_record: whether to interact with records at all.
!*** record_state: Whether to read/write from the record (see RECORD: key)
!***
!*** plotting parameters
!***
!*** sets: number of data sets for plotting
!*** ndata: contains the number of data points for each block for plot
!***
!*** genetic parameters
!***
!*** wspread: spread of new, random weights around 0
!*** bspread: spread of new, random biases around 0
!*** ipmut: chance of point mutation per gene on ichrom
!*** dpmut: chance of point mutation per gene on dchrom
!*** ipins: chance of a gene insertion/deletion on ichrom
!*** dpins: chance of a gene insertion/deletion on dchrom
!***
!*** convergence Acceleration parameters
!*** wb_arad: trust radius (maximum allowed total stepsize)
!*** wei_alim: threshold for switching stepsize limit for weights
!*** bi_alim: threshold for switching stepsize limit for biases
!*** wei_amax: absolute maximum step size for |weights| <= wei_alim
!*** bi_amax: absolute maximum step size for |biases| <= bi_alim
!*** wei_ascale: relative maximum step size for |weights| > wei_alim
!*** bi_ascale: relative maximum step size for |biases| > bi_alim
!***
!*** shift_in: mean of the fitting input set
!*** fact_in: standard deviation of the input set
!*** norm_inp: if true, normalize input
!*** pres_inp: if true, preserve shift_in and fact_in from input,
!*** otherwise normalize destructively
!*** nbr_fit_set: number of fiting set
Real(dp):: wei_alim,bi_alim,wei_amax,bi_amax
Real(dp):: wei_ascale,bi_ascale,wb_arad
Real(dp):: shift_in(maxnin),fact_in(maxnin)
Real(dp):: wspread,bspread
Real(dp):: ipmut, dpmut,ipins,dpins
Real(dp):: unit_con
Real(dp):: lambda_initial, mqfact_default
integer(idp):: len_in,len_out,inp_out,inp_in
integer(idp):: maxbpit,maxfails,maxref_fails
integer(idp):: from_fit, to_fit
integer(idp):: npoints(maxpats), ndata(maxpats)
integer(idp):: sets
integer(idp):: record_state
integer(idp):: ndiab
logical:: limstep,pres_inp,norm_inp
logical:: use_record
character(len=4):: unit_string
integer(idp):: nbr_fit_set
!******************************************************************************
!**** Misc. fit modifiers
!***
!*** zero_par: set all fitting parameters to zero
!*** legacy_wt: WT:-cards are expected for each output component
!*** individually
!*** walk_scan: if true, map scans to the unit interval [0,1]
!*** otherwise, dump full coordinate vector instead.
logical :: zero_par, legacy_wt
logical :: walk_scan
real(dp) :: cutoff(maxoutp), cutwei(maxoutp)
logical :: showcut
end module

163
src/nn_params.f90 Normal file
View File

@ -0,0 +1,163 @@
module nn_params
use accuracy_constants
implicit none
private :: dp, idp
! module to hold the parameters
! to replace nnparams.incl
! define all the parameter
!**********************************************************
!**** Parameters
!*** maxneu: max. number of neurons per hidden layer
!*** maxnin: max. number of neurons in input layer
!*** maxnout: max. number of neurons in output layer
!*** maxset: max. number of neural networks to fit
!*** maxpout: max. number of values in output pattern
!*** maxlay: max. number of layers (always >2)
!*** maxtypes: max. number of neuron types
!*** maxtpar: max. number of parameters for each neuron type
!*** maxpats: max. number of learning patterns
!*** maxxrmeta: max. number of metadata-blocks in xranges
!**********************************************************
!**** Inferred Parameters
!*** maxwei: max. total number of weight matrix elements
!*** neucap: max. total number of neurons
!*** wbcap: max. total number of weights and biases
!*** xrcap: max. total number of used dimensions in xranges
!*** WARNING: maxwei may fail for 2-layered networks
!*** if maxnin*maxnout is sufficiently large!
!**********************************************************
!**** Numerical Parameters
!*** infty: largest possible double precision real value.
!*** iinfty: largest possible integer value.
!*** zero: sets what is considered an irrelevant difference
!*** in size. use for comarison of reals, to determine
!*** 'dangerously small' values, etc
!*** scan_res: maximum precision for geometric boundary algorithm
integer(idp),parameter:: maxneu=150,maxlay=3,maxtypes=2,maxtpar=1
integer(idp),parameter:: maxpats=10000
integer(idp),parameter:: maxnin=15,maxnout=25,maxpout=15
integer(idp),parameter:: maxwei=(maxlay-3)*maxneu**2+maxneu*(maxnin+maxnout)
integer(idp),parameter:: neucap=(maxlay-2)*maxneu+maxnin+maxnout
integer(idp),parameter:: wbcap=maxwei+neucap
integer(idp),parameter:: maxset=1000, maxnnkeys=4*maxlay
integer(idp),parameter:: maxxrmeta=3,xrcap=2+maxxrmeta
! NUMERICAL PARAMETER
real(dp),parameter:: pi = acos(-1.0_dp)
real(dp),parameter:: infty=huge(1.0_dp)
integer(idp),parameter:: iinfty=huge(1)
real(dp),parameter:: zero =1.0d-8, scan_res=1.0d-8
! unit conversion parameter
real(dp),parameter:: hart2eV=27.211385d0
real(dp),parameter:: eV2hart=1.0d0/hart2eV
real(dp),parameter:: hart2icm=219474.69d0
real(dp),parameter:: icm2hart=1.0_dp/hart2icm
real(dp),parameter:: eV2icm=hart2icm/hart2eV
real(dp),parameter:: icm2eV=1.0_dp/eV2icm
real(dp),parameter:: deg2rad=pi/180.0_dp, rad2deg=1.0_dp/deg2rad
!**********************************************************
!**** I/O Parameters
!*** iout: standard output for vranf error messages
!*** nnunit: temporary UNIT for misc. output files
!*** nnuit + [0..99] are reserved for futher
!*** unspecific misc. files.
!*** perfunit: UNIT for performance logfile
!*** fitunit: UNIT added to random positive integer
!*** identifying a single core fit UNIQUELY
!***
!*** lrfmt: format for long real output
!*** lifmt: format for long integer output
!***
!*** nndatfile: filename for DATA-files
!*** (without file extension)
!*** nnreffile: filename for reference DATA-blocks
!*** (without file extension)
!*** nnparfile: filename for best fitted parameters to be
!*** written on (without file extension)
!*** nnp10file: filename for the 10th percentile parameters to
!*** be written on (without file extension)
!*** nnexpfile: filename for modified neural network parameters
!*** (without file extension)
!*** sampfile: filename for displaying sampled points in
!*** configuration space
!*** nndmpfile: filename for dumping data point pairs
!*** nnrecfile: filename for writing parameter records.
!*** perfile: filename for logged fitting performances.
!*** nntag: infix for various filenames to mark their origin
!*** program should end with a trailing '_' if nonempty.
!*** prim_tag: tag added to the '***' line of primitive par-files
!*** nnfdir: directory for dumping fit files
!*** nnsdir: directory for dumping scans.
!*** nnldir: directory for dumping logfiles for each fit
character(len=32),parameter:: nndatfile='DATA_ANN'
character(len=32),parameter:: nnreffile='REF_ANN'
character(len=32),parameter:: nnparfile='../nnfits/fit_pars'
character(len=32),parameter:: nnp10file='../nnfits/fit_10p'
character(len=32),parameter:: nnexpfile='../nnfits/exp_pars'
character(len=32),parameter:: nndmpfile='../nnfits/fit_dump.dat'
character(len=32),parameter:: sampfile='../scans/samples.dat'
character(len=32),parameter:: perfile='../logs/performance.log'
character(len=32),parameter:: nnrecfile='../nnfits/record'
character(len=16),parameter:: nnfdir='../nnfits/',nnsdir='../scans/'
character(len=8), parameter:: nnldir='../logs/'
character(len=8), parameter::nntag=''
character(len=16),parameter:: prim_tag=' Time-stamp: " "'
character(len=16),parameter:: lrfmt='(ES20.12)',lifmt='(I12)'
integer(idp),parameter :: iout=6,perfunit=700,nnunit=800,fitunit=8000
!**********************************************************
!**** Debugging Parameters
!*** sline: separation line
!*** asline: alternative sep. line
!*** hline: simple horizontal line
!*** newline: a single blank line
!*** mform: standard form for matrix output
!*** miform: standard form for integer matrix output
!*** smform: shortened form for matrix output
!*** stdfmt: standard format for strings
character(len=16),parameter:: sline='(75("*"))',asline='(75("#"))'
character(len=16),parameter:: hline='(75("-"))'
character(len=2) ,parameter:: newline='()'
character(len=16),parameter:: mform='(5ES12.4)',smform='(5ES10.2)'
character(len=16),parameter:: miform='(5I12)'
character(len=8) ,parameter:: stdfmt='(A)'
!**********************************************************
!**** Continuation Parameters
!*** record_*: Various possible values for the common block variable
!*** record_state. See the parser for more.
integer(idp),parameter :: record_read=0,record_write=1,record_overwrite=-1
integer(idp),parameter :: record_update=-2
!**********************************************************
!**** 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(idp),parameter:: ec_error=1,ec_read=2,ec_dim=4,ec_log=8
integer(idp),parameter:: ec_dimrd=ec_dim+ec_read
END module nn_params

30
src/nndbg.f90 Normal file
View File

@ -0,0 +1,30 @@
module nndbg_mod
implicit none
!**** Parameters
!*** dbg: enables debugging features.
!*** vbs: enables verbose mode
!*** rats: enables mass calculation mode
!*** conlog: enables convergence logs
!***
!logical,parameter:: (dbg=.false.,vbs=.false.,rats=.false.)
!logical,parameter:: (dbg=.false.,vbs=.false.,rats=.true.)
!logical,parameter:: (dbg=.false.,vbs=.true.,rats=.false.)
!logical,parameter:: (dbg=.true.,vbs=.false.,rats=.false.)
!logical,parameter:: (dbg=.true.,vbs=.true.,rats=.false.)
!logical,parameter:: (dbg=.true.,vbs=.false.,rats=.true.)
logical,parameter:: dbg=.false.,vbs=.true.,rats=.true.
logical,parameter:: conlog=.true.
! logical,parame nlog=.fals
!**** Inferred Parameters
!*** ldbg: "long dbg": enables massive information
!*** dumps if rats is not present. Best for
!*** small data sets.
logical,parameter:: ldbg=(dbg.and.(.not.rats))
END MODULE

982
src/nnmqo.f Normal file
View File

@ -0,0 +1,982 @@
!--------------------------------------------------------------------------------------
subroutine nnmarq(rms,ref_rms,mqpar,mqfact,W,B,act,wterr,
> pat_in,pat_out,ref_in,ref_out,
> typop,laystr,weistr,nlay,
> rmsopt,npat,nref,mingrad,minwbstep,fit_id,skip)
use nn_params
use nncommons
use nndbg_mod
implicit none
! Optimizes weights and biases using least squares errors
! and Marquard Levenberg
!
! fit_id: unique identifying integer for a given fit
! log_unit: unique file unit for given fit
!
! nlay: number of given layers
! npat: number of given pattern pairs
! nref: number of reference patterns
! rms: (weighted) root mean square error
! ref_rms: rms of reference data
! gradnorm: norm of error gradient
! wbnorm: norm of steps
! last: rms of prev. iteration
! rmsopt: error threshold
! mingrad: error gradient threshold
! minwbstep: threshold for wbnorm
! update: Decides whether or not jsquare and grad need to be reevaluated.
! ref_conv: true if reference set seized improving despite fit
! grad_conv: true if gradient converged
! step_conv: true if stepsize converged
! fails: number of unsuccessful steps
! skip: indicates fatal error having occured
! act: decides which weights and biases are actually updated
! macroit: number of J-updates
!
! pat_in: input patterns
! pat_out: desired output patterns
! pat_*(i,N): value of ith in-/output neuron for pattern N
! ref_*: in analogy to pat_in/out for reference data
! (convergence tests)
!
! wterr: weight factors for each element of the error vector e
!
! J: Jacobian matrix. A single row consists of matrix elements
! corresponding to all Weights as they are kept in memory (W),
! followed by all Biases. It is never fully kept in memory.
! Instead, required matrix elements are generated when needed.
!
! e: Error vector. It consists of the differences between the NN's
! output-vector and the desired output patterns, for all patterns.
! Like J it is never really kept in memory.
!
! jsquare: J^T J
! wbsteps: Steps for weights and biases, same order as a single jacobian-row.
! mqpar: initial parameter (lambda) for Marquard-Levenberg
! mqfact: factor by which lambda is multiplied/divided after each iteration
! wsave: saves W with best outcome
! bsave: saves B with best outcome
! skip: indicates whether fit is broken and needs to be ignored.
!
! grad: total error vector transformed by transposed jacobian
! W: weight matrix vector
! B: bias vector
! typop: type population matrix
! laystr: layer structure matrix
integer npat,nref
integer fit_id
double precision W(maxwei),B(neucap)
double precision pat_in(maxnin,maxpats),pat_out(maxpout,maxpats)
double precision ref_in(maxnin,maxpats),ref_out(maxpout,maxpats)
double precision wterr(maxpout,maxpats)
double precision rms,ref_rms
double precision rmsopt,mqfact,mqpar,mingrad,minwbstep
integer laystr(3,maxlay),typop(maxtypes,maxlay)
integer weistr(2,maxlay,2)
integer nlay
integer act(wbcap)
logical skip
double precision wsave(maxwei),bsave(neucap),wbsteps(wbcap)
double precision wsave_ref(maxwei),bsave_ref(neucap)
double precision grad(wbcap)
double precision jsquare
allocatable jsquare(:,:)
double precision lambda,last,ref_last,gradnorm,wbnorm,wbnorm_old
integer pos_out,len_err
integer lay_end,wei_end,jac_end
integer fails,macroit
integer ref_fails
integer log_unit
character*32 nnlogfile
logical ref_conv,grad_conv,step_conv
logical update
integer j
! Initialize values
lambda=mqpar
allocate(jsquare(wbcap,wbcap))
pos_out=laystr(2,nlay)-1 !increment leading to output layer pos.
! position of last defined neuron/W-matrix element
lay_end=pos_out+len_out
wei_end=weistr(2,nlay-1,1)
len_err=npat*len_out !length of error vector
jac_end=wei_end+lay_end-len_in !width of jacobian matrix
! evaluate initial jsquare and gradient, initialize last
if (dbg) then
write(iout,'(A)') 'Building first Jacobian..'
endif
call mkjsq(W,B,wterr,jsquare,last,grad,gradnorm,
> jac_end,pat_in,pat_out,wei_end,
> typop,laystr,nlay,npat)
if (dbg) then
write(iout,'(A)') 'done.'
write(iout,asline)
write(iout,'(A)') 'INITIAL WEIGHTS:'
write(iout,mform) W(1:wei_end)
write(iout,'(A)') 'INITIAL BIASES:'
write(iout,mform) B(len_in+1:lay_end)
endif
call mkerr(W,B,wterr(1,npat+1),ref_rms,ref_in,ref_out,
> typop,laystr,nlay,nref)
rms=last
ref_last=ref_rms
wsave(1:wei_end)=W(1:wei_end)
bsave(1:lay_end)=B(1:lay_end)
fails=0
ref_fails=0
macroit=0
wbnorm=-1.0d0
update=.true.
ref_conv=.false.
grad_conv=.false.
step_conv=.false.
if (conlog) then
! generate file displaying convergence behavior.
log_unit=fitunit+fit_id
nnlogfile=trim(nnldir) // 'convergence_'
write(nnlogfile,'(A,I4.4,".log")') trim(nnlogfile),fit_id
if (dbg.or.vbs) then
write(iout,'(A)') 'logging convergence in '''
> // trim(nnlogfile) // '''...'
endif
open(log_unit,file=trim(nnlogfile),status='replace')
write(log_unit,'(A)') '# UNIT: ' // trim(unit_string)
write(log_unit,'(A1,A8,6A15,1A18)') '#','ITER','RMS',
> 'RMS(REF)','GRADNORM','STEP','LAMBDA','{ORIGSTEP}'
write(unit=log_unit,fmt='(I9,4ES15.3)') 0, rms*unit_con,
> ref_rms*unit_con, gradnorm*unit_con, lambda
else if (vbs) then
write(iout,'(A)') '#UNITS: '//trim(unit_string)
write(iout,'(A1,A8,5A15)') '#','ITER','RMS','RMS(REF)',
> 'GRADNORM','WBNORM','LAMBDA'
write(iout,'(I9,4ES15.3,ES15.2)') 0, rms*unit_con,
> ref_rms*unit_con, gradnorm*unit_con,
> wbnorm, lambda
endif
! Iterates up to a maximum number of allowed microiterations
! (backpropagations)
do j=1,maxbpit
! evaluate step
call marqstep(jsquare,wbsteps,lambda,jac_end,grad,wbnorm,skip)
if (skip) then
exit
endif
! copy old step norm
wbnorm_old=wbnorm
! apply changes
call mqupdate(W,B,wbsteps,act,lay_end,wei_end)
! TODO: consider pulling this into check_mqstep.
! check for improvement
call mkerr(W,B,wterr,rms,pat_in,pat_out,
> typop,laystr,nlay,npat)
if (conlog.and.rats) then
write(log_unit,'(I9,5ES15.3)',advance='no') j, rms*unit_con,
> ref_rms*unit_con, gradnorm*unit_con, wbnorm, lambda
if (limstep) then
write(log_unit,'(ES15.3,2I6)',advance='no') wbnorm_old
endif
else if (vbs) then
write(iout,'(I9,3ES15.3,2ES15.2)') j, rms*unit_con,
> ref_rms*unit_con, gradnorm*unit_con,
> wbnorm, lambda
endif
if (dbg) then
write(iout,sline)
write(iout,*) 'LAST:',last,'RMS:',rms
write(iout,*) 'LAMBDA:', lambda
write(iout,*) 'GRADNORM:', gradnorm
write(iout,*) 'WBNORM:', wbnorm
endif
call check_mqstep(W,B,wterr,rms,ref_rms,last,ref_last,
> wsave,bsave,wsave_ref,bsave_ref,
> fails,ref_fails,lambda,update,ref_conv,
> mqfact,ref_in,ref_out,wei_end,
> typop,laystr,weistr,
> nlay,npat,nref)
! check for convergence
step_conv=(wbnorm <= minwbstep)
grad_conv=(gradnorm <= mingrad)
if (step_conv.or.grad_conv) then
exit
endif
if (rmsopt.gt.0.0d0) then
! if considered relevant, check absolute error
if (rms <= rmsopt) exit
endif
if (fails > maxfails) then
if (dbg) write(iout,'(A)') 'MAXFAILS REACHED, GIVE UP'
exit
else if (ref_conv) then
if (dbg) write(iout,'(A)') 'MAXREFFAILS REACHED, GIVE UP'
exit
endif
if (conlog) then
if (update) then
write(log_unit,'(3X,A)') '#ACCEPTED'
else
write(log_unit,'(3X,A,ES12.3)') '#WORSE: ΔRMS=',
> (rms-last)*unit_con
endif
endif
if (update) then
! reevaluate jacobian
last=rms
macroit=macroit+1
call mkjsq(W,B,wterr,jsquare,rms,grad,gradnorm,
> jac_end,pat_in,pat_out,wei_end,
> typop,laystr,nlay,npat)
endif
if (dbg) then
write(iout,'(A)') 'WEIGHTS:'
write(iout,mform) W(1:wei_end)
write(iout,'(A)') 'BIASES:'
write(iout,mform) B(len_in+1:lay_end)
endif
enddo
! overwrite rms with best result
rms=last
ref_rms=ref_last
if (skip) then
if (dbg.or.vbs) then
write(iout,'(A)') '#CONVERGENCE ERROR: '
> // 'FATAL ERROR OCCURED.'
endif
if (rats) then
write(unit=perfunit,fmt=400) rms*unit_con, ref_rms*unit_con,
> wbnorm, gradnorm*unit_con, macroit, j-1, fit_id,
> '#CRASHED'
endif
else if (j >= maxbpit) then
if (dbg.or.vbs) then
write(iout,'(A)') '#CONVERGENCE ERROR: '
> // 'ITERATIONS EXCEEDED MAXBPIT'
endif
if (rats) then
write(unit=perfunit,fmt=401) rms*unit_con, ref_rms*unit_con,
> wbnorm, gradnorm*unit_con, macroit,j-1, fit_id
endif
else if (fails > maxfails) then
if (dbg) then
write(iout,'(A)') '#CONVERGENCE ERROR: MAXFAILS REACHED.'
endif
if (rats) then
write(unit=perfunit,fmt=400) rms*unit_con, ref_rms*unit_con,
> wbnorm, gradnorm*unit_con, macroit, j-1, fit_id,
> '#FAILED'
endif
else
if (vbs) then
if (ref_conv) then
write(iout,'(A)') '#CONVERGED VALIDATION SET.'
endif
if (wbnorm <= minwbstep) then
if (gradnorm <= mingrad) then
write(iout,'(A)') '#CONVERGENCE REACHED.'
> // ' (GRADIENT & STEP)'
endif
write(iout,'(A)') '#CONVERGED STEPSIZE ONLY.'
else if (gradnorm <= mingrad) then
write(iout,'(A)') '#CONVERGED GRADIENT ONLY.'
endif
endif
if (rats) then
write(unit=perfunit,fmt=400,advance='no')
> rms*unit_con,
> ref_rms*unit_con, wbnorm,
> gradnorm*unit_con, macroit, j-1, fit_id,
> '#CONVERGED'
if (ref_conv) then
write(perfunit,'(A)') ' [REF]'
else if (grad_conv.and.step_conv) then
write(perfunit,'(A)') ' [GRAD & STEP]'
else if (grad_conv) then
write(perfunit,'(A)') ' [GRAD]'
else if (step_conv) then
write(perfunit,'(A)') ' [STEP]'
else
write(unit=perfunit,fmt=newline)
endif
endif
endif
400 format(4ES10.2,4X,I6,"/",I6,I8,4X,A)
401 format(4ES10.2,4X,I6,"/",I6,I8)
if (conlog) then
close(log_unit)
endif
deallocate(jsquare)
if (dbg) then
j=j-1
write(iout,asline)
write(iout,'(A)') 'OPT END.'
write(iout,'(A12,I9)') 'ITERATIONS:',j
write(iout,'(A9,I12)') 'MACROIT:', macroit
write(iout,'(A26,3(I6,'' :''),F6.2,''%'')')
> 'SAVED:UNDONE:TOTAL:%SAVED',
> macroit, j-macroit, j,
> 1.0D2*dble(macroit)/dble(j)
write(iout,'(A)') 'NEUPOP:'
write(iout,miform) laystr(1,1:nlay)
write(iout,'(A)') 'INSHIFT:'
write(iout,mform) shift_in(1:laystr(1,1))
write(iout,'(A)') 'INSCALE:'
write(iout,mform) fact_in(1:laystr(1,1))
write(iout,'(A)') 'FINAL W:'
write(iout,mform) W(1:wei_end)
write(iout,'(A)') 'FINAL B:'
write(iout,mform) B(1:lay_end)
write(iout,*) 'FINAL RMS:', rms
write(iout,*) 'FINAL RMS(REF):', ref_rms
write(iout,*) 'FINAL LAMBDA',lambda*mqfact
write(iout,asline)
endif
end
!--------------------------------------------------------------------------------------
subroutine check_mqstep(W,B,wterr,rms,ref_rms,last,ref_last,
> wsave,bsave,wsave_ref,bsave_ref,
> fails,ref_fails,lambda,update,ref_conv,mqfact,
> ref_in,ref_out,wei_end,
> typop,laystr,weistr,
> nlay,npat,nref)
use nn_params
use nncommons
use nndbg_mod
implicit none
! Compare current parameter set's performance with current best and
! revert if necessary.
integer npat,nref
double precision W(maxwei),B(neucap)
double precision wsave(maxwei),bsave(neucap)
double precision wsave_ref(maxwei),bsave_ref(neucap)
double precision ref_in(maxnin,maxpats),ref_out(maxpout,maxpats)
double precision wterr(maxpout,maxpats)
double precision rms,ref_rms,last,ref_last
double precision lambda,mqfact
integer fails,ref_fails
integer laystr(3,maxlay),typop(maxtypes,maxlay)
integer weistr(2,maxlay,2)
integer nlay
logical update,ref_conv
integer lay_end,wei_end
wei_end=weistr(2,nlay-1,1)
lay_end=laystr(2,nlay)-1+len_out
! First, check fitting data set
if (last.lt.rms) then
! Revert parameter changes
W(1:wei_end)=wsave(1:wei_end)
B(1:lay_end)=bsave(1:lay_end)
lambda=lambda*mqfact
update=.false.
fails=fails+1
return
else
if (lambda.gt.zero) then
lambda=lambda/mqfact
endif
update=.true.
fails=0
endif
! Evaluate error of reference data set
call mkerr(W,B,wterr(1,npat+1),ref_rms,ref_in,ref_out,
> typop,laystr,nlay,nref)
if (dbg) then
write(iout,*) 'LAST(REF):',ref_last,'RMS(REF):', ref_rms
endif
! Next, check reference data set
if (ref_last.lt.ref_rms) then
if (dbg) then
write(iout,'(A)') 'VALIDATION SET ERROR INCREASED.'
endif
! keep backup of old parameter set but continue fit
ref_fails=ref_fails+1
if (ref_fails.eq.1) then
wsave_ref(1:wei_end)=wsave(1:wei_end)
bsave_ref(1:lay_end)=bsave(1:lay_end)
endif
if (ref_fails.ge.maxref_fails) then
ref_conv=.true.
! if reference rms increased despite fit improving,
! discard changes and exit
W(1:wei_end)=wsave_ref(1:wei_end)
B(1:lay_end)=bsave_ref(1:lay_end)
if (dbg) then
write(iout,'(A)') 'VALIDATION SEIZED IMPROVING, GIVE UP'
endif
return
endif
else
ref_last=ref_rms
ref_fails=0
endif
! save changes disregarding reference set
wsave(1:wei_end)=W(1:wei_end)
bsave(1:lay_end)=B(1:lay_end)
end
!--------------------------------------------------------------------------------------
subroutine mkjsq(W,B,wterr,jsquare,rms,grad,gradnorm,jac_end,
> pat_in,pat_out,wei_end,
> typop,laystr,nlay,npat)
use axel, only: init_input
use nn_params
use nncommons
use nndbg_mod
implicit none
! Directly evaluates J^T J and gradient.
! Since jsquare is symmetric, only the upper triangle is evaluated.
!
! nlay: number of given layers
! npat: number of given pattern pairs
! rms: (weighted) root mean square error
! wei_end: position of last defined W-matrix-element in W-vector!
! jac_end: number of all weights and biases together
!
! pat_in: input patterns
! pat_out: desired output patterns
! pat_*(i,N): value of ith in-/output neuron for pattern N
!
! wterr: weight factors for each element of the error vector e
!
! jacrow: One row of the jacobian matrix. It consists of matrix elements
! corresponding to all Weights as they are kept in memory (W),
! followed by all Biases.
!
! jsquare: J^T J
! outgrads: the derivatives of the arbitrary error function with respect to
! the neuronal outputs.
!
! grad: total error vector transformed by transposed jacobian
! gradnorm: norm of gradient grad
!
! del: neuron error vector
! pat_err: segment of the total error vector for one pattern.
! deriv: activation function derivatives
! W: weight matrix vector
! B: bias vector
! L: layer vector
! typop: type population matrix
! laystr: layer structure matrix
! laystr(1,N): number of neurons in layer N
! laystr(2,N): starting pos. for layer N
! laystr(3,N): starting pos. for weight matrix from layer N to N+1
integer npat,nlay,wei_end,jac_end
double precision W(maxwei),B(neucap)
double precision jsquare(wbcap,wbcap),grad(wbcap)
double precision pat_in(maxnin,maxpats),pat_out(maxpout,maxpats)
double precision wterr(maxpout,maxpats)
double precision rms,gradnorm
integer laystr(3,maxlay),typop(maxtypes,maxlay)
double precision L(neucap),jacrow(wbcap)
double precision del(neucap),deriv(neucap),pat_err(maxpout)
double precision outgrads(maxnout,maxpout)
integer pos_out,pos_jac
integer j,k,n,m
pos_out=laystr(2,nlay)-1 !increment leading to output layer pos.
rms=0.0D0
del=0.0D0
do j=1,jac_end
do m=j,jac_end
jsquare(m,j)=0.0d0
enddo
grad(j)=0.0d0
enddo
do n=1,npat
call init_input(L,pat_in(1,n),shift_in,fact_in,len_in)
call propagate(W,B,L,deriv,typop,laystr,nlay)
pos_jac=(n-1)*inp_out !increment for err-vector pos.
! evaluate pat_err
call nnerror(pat_err,pat_in(1,n),pat_out(1,n),L(pos_out+1))
! evaluate output value derivatives
call nnoutgrad(outgrads,pat_in(1,n),L(pos_out+1))
do k=1,inp_out
rms=rms+wterr(k,n)*pat_err(k)**2
! prepare sensitivity vector
del=0.0D0
do j=1,len_out
del(pos_out+j)=-deriv(pos_out+j)*outgrads(j,k)
> * dsqrt(wterr(k,n))
enddo
! evaluate J-Matrix elements for a single row
call backprop(del,W,deriv,laystr,nlay)
call nnjacob(del,L,jacrow,wei_end,laystr,nlay)
! build up jsquare and gradient
do j=1,jac_end
do m=j,jac_end
jsquare(m,j)=jsquare(m,j)+jacrow(j)*jacrow(m)
enddo
grad(j)=grad(j)+jacrow(j)*pat_err(k)*dsqrt(wterr(k,n))
enddo
enddo
enddo
do j=1,jac_end
do m=j+1,jac_end
jsquare(j,m)=jsquare(m,j)
enddo
enddo
rms=dsqrt(rms)
gradnorm=dsqrt(dot_product(grad(1:jac_end),grad(1:jac_end)))
end
!--------------------------------------------------------------------------------------
subroutine nnjacob(del,L,jacrow,wei_end,laystr,nlay)
use nn_params
use nncommons
use nndbg_mod
implicit none
! Evaluates one row of the Jacobian
!
! nlay: number of given layers
! nprop: number of single-layer propagations
! neu_io: number of neurons in giv./prev. layer
! neu_oi: number of neurons in prev./giv. layer
! poslay: starting position of layer in L- and B-vector
! poswei: starting position of weight-matrix in W-vector
! wei_end: position of last defined W-matrix-element in W-vector
!
! del: neuron error vector
! L: layer vector
! jacrow: A single row of the jacobian matrix. It consists of all weights as they
! are kept in memory (W), followed by all biases.
! laystr: layer structure matrix
!
! laystr(1,N): number of neurons in layer N
! laystr(2,N): starting pos. for layer N
! laystr(3,N): starting pos. for Weight Matrix from layer N to N+1
integer wei_end
double precision del(neucap),L(neucap),jacrow(wbcap)
integer laystr(3,maxlay)
integer nlay
integer poslay,poswei,nprop,neu_io,neu_oi
integer k
nprop=nlay-1
neu_io=laystr(1,1) !number of input neurons ('layer N')
poslay=laystr(2,1)
poswei=laystr(3,1)
do k=2,2*(nprop/2),2
neu_oi=laystr(1,k) !number of output neurons ('layer N+1')
! input neurons have no bias (no J-elements), hence -len_in
call jalay(neu_io,neu_oi,del(poslay),L(poslay),jacrow(poswei),
> jacrow(wei_end+poslay-len_in))
poslay=laystr(2,k)
poswei=laystr(3,k)
neu_io=laystr(1,k+1) !new number of output neurons ('layer N')
! former output neurons are now input, _io and _oi switch places!
! (done for efficiency)
call jalay(neu_oi,neu_io,del(poslay),L(poslay),jacrow(poswei),
> jacrow(wei_end+poslay-len_in))
poslay=laystr(2,k+1)
poswei=laystr(3,k+1)
enddo
do k=1,mod(nprop,2) !for odd nprop one iteration is left
neu_oi=laystr(1,nlay)
call jalay(neu_io,neu_oi,del(poslay),L(poslay),jacrow(poswei),
> jacrow(wei_end+poslay-len_in))
enddo
end
!--------------------------------------------------------------------------------------
subroutine jalay(neu_in,neu_out,del,L,welems,belems)
use nn_params
use nndbg_mod
implicit none
! Evaluates Matrix-elements corresponding to one NN-layer.
!
! neu_in: number of neurons in layer N
! neu_out: number of neurons in layer N+1
!
! del: neuron error vector
! L: layer vector (beginning at layer N)
! welems: elements corresponding to W-matrix
! belems: elements corresponding to B-vector
!
integer neu_in,neu_out
double precision L(neu_in),del(neu_in+neu_out)
double precision welems(neu_in,neu_out),belems(neu_in+neu_out)
integer neu_tot,pos_out
integer j,k
neu_tot=neu_in+neu_out !total number of neurons in both layers
pos_out=neu_in+1 !position of first element in layer N+1
do j=pos_out,neu_tot
belems(j)=del(j)
enddo
do j=1,neu_out
do k=1,neu_in
welems(k,j)=L(k)*del(neu_in+j)
enddo
enddo
end
!--------------------------------------------------------------------------------------
subroutine mkerr(W,B,wterr,rms,pat_in,pat_out,
> typop,laystr,nlay,npat)
use nn_params
use nncommons
use nndbg_mod
implicit none
! Evaluates rms only.
! nlay: number of given layers
! npat: number of given pattern pairs
! rms: (weighted) root mean square error
!
! pat_in: input patterns
! pat_out: desired output patterns
! pat_*(i,N): value of ith in-/output neuron for pattern N
!
! wterr: weight factors for each element of the error vector e
! pat_err: segment of the total error vector for one pattern.
!
! deriv: activation function derivatives (discarded)
! W: weight matrix vector
! B: bias vector
! L: layer vector
! typop: type population matrix
! laystr: layer structure matrix
! laystr(1,N): number of neurons in layer N
! laystr(2,N): starting pos. for layer N
! laystr(3,N): starting pos. for weight matrix from layer N to N+1
integer npat
double precision W(maxwei),B(neucap)
double precision pat_in(maxnin,maxpats),pat_out(maxpout,maxpats)
double precision wterr(maxpout,npat)
double precision rms
integer laystr(3,maxlay),typop(maxtypes,maxlay)
integer nlay
double precision pat_err(maxpout)
integer n,k
rms=0.0D0
do n=1,npat
call mkerrvec(W,B,pat_err,pat_in(1,n),pat_out(1,n),
> typop,laystr,nlay)
do k=1,inp_out
rms=rms+wterr(k,n)*pat_err(k)**2
enddo
enddo
rms=dsqrt(rms)
end
!--------------------------------------------------------------------------------------
subroutine mkerrvec(W,B,pat_err,pat_in,pat_out,
> typop,laystr,nlay)
use axel, only: init_input
use nn_params
use nncommons
use nndbg_mod
implicit none
! Generates error vector pat_err out of given ANN parameters
! for a *single* pattern pair.
!
! pat_in: input pattern
! pat_out: desired output pattern
! pat_*(i): value of ith in-/output neuron
!
! pat_err: error vector for one pattern.
!
! deriv: activation function derivatives (discarded)
! W: weight matrix vector
! B: bias vector
! L: layer vector
! typop: type population matrix
! laystr: layer structure matrix
! laystr(1,N): number of neurons in layer N
! laystr(2,N): starting pos. for layer N
! laystr(3,N): starting pos. for weight matrix from layer N to N+1
double precision W(maxwei),B(neucap)
double precision pat_in(maxnin),pat_out(maxpout)
integer laystr(3,maxlay),typop(maxtypes,maxlay)
integer nlay
double precision L(neucap),deriv(neucap),pat_err(maxpout)
integer pos_out
pos_out=laystr(2,nlay)-1 !increment leading to output layer pos.
L=0.0d0
call init_input(L,pat_in,shift_in,fact_in,len_in)
call propagate(W,B,L,deriv,typop,laystr,nlay)
! evaluate pat_err
call nnerror(pat_err,pat_in,pat_out,L(pos_out+1))
end
!--------------------------------------------------------------------------------------
subroutine marqstep(jsquare,wbsteps,lambda,jac_end,grad,wbnorm,
> skip)
use nn_params
use nndbg_mod
implicit none
! Evaluates steps for W and B using the equation
! (J^T J + lambda*1) wbsteps = -J^T e,
! where "J^T e" is already given as grad and "J^T J" as jsquare,
!
! wbsteps: Steps for weights and biases, same order as a single jacobian-row.
! lambda: parameter for Marquard-Levenberg
! jac_end: number of all weights and biases together
! grad: error vector transformed by transposed jacobian
! jsquare: J^T J. Only the upper triangle of it is required,
! that is jsquare(i,j) needs only to be defined for i>=j.
! jscop: working copy of jsquare
! skip: true if fatal error has occured
!
double precision jsquare(wbcap,wbcap),grad(wbcap),wbsteps(wbcap)
double precision lambda,wbnorm
integer jac_end
logical skip
double precision jscop
allocatable jscop(:,:)
integer k,j
allocate(jscop(wbcap,wbcap))
do k=1,jac_end
do j=1,jac_end
jscop(j,k)=jsquare(j,k) !brutally inefficient.
enddo
enddo
do k=1,jac_end
jscop(k,k)=jscop(k,k)+lambda
enddo
! solve for wbsteps using Cholesky decomposition
call choldcsol(jscop,grad,wbsteps,jac_end,wbcap,skip)
! call mqinvertsol(jscop,grad,wbsteps,jac_end)
deallocate(jscop)
if (skip) then
return
endif
wbnorm=sqrt(dot_product(wbsteps(1:jac_end),wbsteps(1:jac_end)))
end
!--------------------------------------------------------------------------------------
subroutine mqupdate(W,B,wbsteps,act,lay_end,wei_end)
use nn_params
use nncommons
use nndbg_mod
implicit none
! Updates W and B according to wbsteps.
!
! wei_end: position of last defined weight in W-vector
! lay_end: position of last defined bias in B-vector
! len_in: number of input-neurons. Since they have no biases
! B(1:len_in) is meaningless.
!
! W: weight matrix vector
! B: bias vector
! wbsteps: steps for weights and biases, same order as a single jacobian-row.
! act: decides which weights and biases are actually updated (1=active)
double precision W(maxwei),B(neucap),wbsteps(wbcap)
integer act(wbcap)
integer lay_end,wei_end
integer k
do k=1,wei_end
if (act(k).eq.1) then
W(k)=W(k)-wbsteps(k)
endif
enddo
do k=len_in+1,lay_end
if (act(wei_end+k-len_in).eq.1) then
B(k)=B(k)-wbsteps(wei_end+k-len_in)
endif
enddo
end
!--------------------------------------------------------------------------------------
subroutine mqinvertsol(jscop,grad,wbsteps,jac_end)
use nn_params
use nndbg_mod
implicit none
! Generate step not from using cholesky decomposition, but by directly
! inverting the matrix jscop.
!
! wbsteps: Steps for weights and biases, same order as a single jacobian-row.
! jac_end: number of all weights and biases together
! grad: error vector transformed by transposed jacobian
! jscop: J^T J + lambda. Only the upper triangle of it is written,
! that is jsquare(i,j) needs only to be defined for i>=j.
! js_trans: eigenvectors (equivalent to transformation matrix)
! js_eigen: eigenvalues
double precision jscop(wbcap,wbcap),grad(wbcap),wbsteps(wbcap)
integer jac_end
double precision js_eigen
double precision js_trans,js_inv
allocatable js_eigen(:)
allocatable js_trans(:,:),js_inv(:,:)
integer k,j,n
allocate(js_eigen(wbcap))
allocate(js_trans(wbcap,wbcap))
allocate(js_inv(wbcap,wbcap))
! fill the lower triangle of the matrix
! DW: FIXME: probably useless now.
do k=1,jac_end
do j=k+1,jac_end
jscop(j,k)=jscop(k,j)
enddo
enddo
! solve wbsteps by diagonalizing
call ddiag(jscop,js_eigen,js_trans,wbcap,jac_end)
js_inv=0.0d0
! invert hessian
do n=1,jac_end
do k=1,jac_end
do j=1,jac_end
js_inv(j,k)=js_inv(j,k)
> + js_trans(j,n)*js_trans(k,n)/js_eigen(n)
enddo
enddo
enddo
! apply inverted hessian to grad
do j=1,jac_end
wbsteps(j)=0.0d0
do k=1,jac_end
wbsteps(j)=wbsteps(j)+js_inv(k,j)*grad(k)
enddo
enddo
deallocate(js_eigen)
deallocate(js_trans)
deallocate(js_inv)
end

131
src/nnread.f Normal file
View File

@ -0,0 +1,131 @@
subroutine read_net_prim(fname,par,nlay,laystr,weistr,typop)
use nn_params
use nndbg_mod
implicit none
! Subroutine reading ANN-parameters as generated by punch_net_prim
integer nlay
integer laystr(3,maxlay),typop(maxtypes,maxlay)
integer weistr(2,maxlay,2)
double precision par(*)
character*32 fname
character*2048 full_fname, net_id
integer neupop(maxlay)
integer par_end,len_out
integer file_maxtypes
integer j
full_fname = trim(fname) // '.par'
open(nnunit,file=trim(full_fname),status='old',action='read')
write(6,'(4096A)') '# READING ''' // trim(full_fname) // '''...'
! read structure parameters
read(nnunit,*,end=800) nlay
read(nnunit,*,end=801) file_maxtypes
! Nobody needs segfaults from corrupted input files.
if ((file_maxtypes.gt.maxtypes).or.(file_maxtypes.le.0)) then
write(6,'(A,I12)') 'ERROR: READ_NET_PRIM: '
> //'VARIABLE MAXTYPES OUT OF BOUNDS:',maxtypes
stop 1
else if ((nlay.gt.maxlay).or.(nlay.le.0)) then
write(6,'(A,I12)') 'ERROR: READ_NET_PRIM: '
> //'VARIABLE NLAY OUT OF BOUNDS:',nlay
stop 1
endif
read(nnunit,*,end=802) neupop(1:nlay)
read(nnunit,*,end=803) typop(1:file_maxtypes,1:nlay)
len_out=neupop(nlay)
net_id=' '
read(nnunit,'(2048A)',end=804) net_id
if (.not.(len_trim(net_id).eq.0)) then
write(6,'(4096A)') '# MODEL ID: ' // trim(net_id(4:))
endif
! initialize laystr
call mknet(laystr,weistr,neupop,nlay)
par_end=laystr(3,nlay)-1 !final W-position
! move to final bias
do j=2,nlay
par_end=par_end + neupop(j)
enddo
read(nnunit,*,end=805) par(1:par_end)
close(nnunit)
return
800 write(6,'(A)') 'ERROR: READ_NET_PRIM: BROKEN OR MISSING NLAY'
801 write(6,'(A)') 'ERROR: READ_NET_PRIM: BROKEN OR MISSING'
> // ' MAXTYPE'
802 write(6,'(A)') 'ERROR: READ_NET_PRIM: BROKEN OR MISSING NEUPOP'
803 write(6,'(A)') 'ERROR: READ_NET_PRIM: BROKEN OR MISSING TYPOP'
804 write(6,'(A)') 'ERROR: READ_NET_PRIM: BROKEN MODEL-ID'
805 write(6,'(A)') 'ERROR: READ_NET_PRIM: BROKEN OR MISSING PARAMS'
end
!--------------------------------------------------------------------------------
subroutine read_record(par,weistr,nlay,nset)
use nn_params
use nncommons
use io_parameters
use nndbg_mod
implicit none
double precision par(wbcap,maxset)
integer weistr(2,maxlay,2)
integer nlay,nset
integer wb_end, wb_end_rec
integer nset_rec
character*64 fname
integer k,k_rec
fname=trim(nnrecfile) // '.rec'
wb_end=weistr(2,nlay,2)
write(6,'(A)') 'RECORD: Reading record from file '''
> // trim(fname) // '''...'
open(nnunit,file=trim(fname),action='READ')
read(nnunit,*) nset_rec
if (nset_rec.ne.nset) then
write(6,'(A)') 'ERROR: INCONSISTENT NUMBER OF PARAMETER SETS.'
write(6,'("(",I4," vs.",I4,")")')
stop 1
endif
read(nnunit,*) wb_end_rec
if (wb_end_rec.ne.wb_end) then
write(6,'(A)') 'ERROR: INCONSISTENT NUMBER OF PARAMETER SETS.'
write(6,'("(",I4," vs.",I4,")")')
stop 1
endif
do k=1,nset
read(nnunit,*) k_rec, par(1:wb_end,k)
if (k.ne.k_rec) then
write(6,'(A,I05,A)') 'ERROR: MISSING PARAMETER SET: ', k
write(6,'(A,I05,A)') 'FOUND ', k_rec, ' INSTEAD'
stop 1
endif
enddo
close(nnunit)
write(6,'(A,I5)') 'Done. Read ',nset, ' parameter sets in total.'
end

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

@ -0,0 +1,32 @@
**** ERROR CATALOGUE -- this defines what kind of errors parse.f throws
! 1 32 64
! v v v
! '................................................................'
errcat( 1)='ILLOGICALLY SMALL VALUE'
errcat( 2)='VALUE EXCEEDS SET MAXIMUM'
errcat( 3)='GIVEN DATA STRUCTURE SIZE INCONSISTENT WITH'
> // ' PREVIOUS DECLARATION'
errcat( 4)='IMPLIED NEURON NUMBER INCONSISTENT WITH NEUPOP'
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)=
! 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)=

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

@ -0,0 +1,309 @@
**** 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)='SETS:'
keylist(2, 4)='+IN'
keylist(1, 5)='NPAT:'
keylist(2, 5)='+I1'
keylist(1, 6)='NPOINTS:'
keylist(2, 6)='+IN'
keylist(1, 7)='VALIDATION:'
keylist(2, 7)='+I1'
keylist(1, 8)='RANDOM:'
keylist(2, 8)='E'
keylist(1, 9)='FREEZE:'
keylist(2, 9)='E'
keylist(1,10)='DRYRUN:'
keylist(2,10)='E'
keylist(1,11)='RECORD:'
keylist(2,11)='C1'
keylist(1,12)='NLAY:'
keylist(2,12)='+I!1'
keylist(1,13)='NEUPOP:'
keylist(2,13)='+I!N'
keylist(1,14)='TYPOP:'
keylist(2,14)='+I!N'
keylist(1,15)='DEPRECATED:'
keylist(2,15)='E'
keylist(1,16)='DEPRECATED:'
keylist(2,16)='E'
keylist(1,17)='INPUTS:'
keylist(2,17)='+I1'
keylist(1,18)='OUTPUTS:'
keylist(2,18)='+I1'
keylist(1,19)='MAXFAILS:'
keylist(2,19)='+I1'
keylist(1,20)='NOMAXFAILS:'
keylist(2,20)='E'
keylist(1,21)='REFFAILS:'
keylist(2,21)='+I1'
keylist(1,22)='NOREFFAILS:'
keylist(2,22)='E'
keylist(1,23)='DEPRECATED:'
keylist(2,23)='E'
keylist(1,24)='MICIT:'
keylist(2,24)='+I1'
keylist(1,25)='MAXBPIT:'
keylist(2,25)='+I1'
keylist(1,26)='GSPREAD:'
keylist(2,26)='+D1'
keylist(1,27)='WSPREAD:'
keylist(2,27)='+D1'
keylist(1,28)='BSPREAD:'
keylist(2,28)='+D1'
keylist(1,29)='HART2EV:'
keylist(2,29)='E'
keylist(1,30)='HART2ICM:'
keylist(2,30)='E'
keylist(1,31)='ARBUNITS:'
keylist(2,31)='+D1'
keylist(1,32)='UCUSTOM:'
keylist(2,32)='C2'
keylist(1,33)='RMSOPT:'
keylist(2,33)='+D1'
keylist(1,34)='MINGRAD:'
keylist(2,34)='+D1'
keylist(1,35)='MINWBSTEP:'
keylist(2,35)='+D1'
keylist(1,36)='DEPRECATED:'
keylist(2,36)='E'
keylist(1,37)='ECHO:'
keylist(2,37)='CN'
keylist(1,38)='ERRCUT:'
keylist(2,38)='DN'
keylist(1,39)='CUTWT:'
keylist(2,39)='+DN'
keylist(1,40)='INSHIFT:'
keylist(2,40)='DN'
keylist(1,41)='INSCALE:'
keylist(2,41)='DN'
keylist(1,42)='NORMINP:'
keylist(2,42)='E'
keylist(1,43)='ZERO:'
keylist(2,43)='E'
keylist(1,44)='VALPER:'
keylist(2,44)='+D1'
keylist(1,45)='DEPRECATED:'
keylist(2,45)='E'
keylist(1,46)='RUNCHUNK:'
keylist(2,46)='+I2'
keylist(1,47)='RUNFROM:'
keylist(2,47)='+I1'
keylist(1,48)='RUNTO:'
keylist(2,48)='+I1'
keylist(1,49)='LEGACY-WT:'
keylist(2,49)='E'
keylist(1,50)='INCLUDE-DATA:'
keylist(2,50)='C1'
keylist(1,51)='NOSCANWALK:'
keylist(2,51)='E'
keylist(1,52)='LAMBDA:'
keylist(2,52)='+D1'
keylist(1,53)='MQFACT:'
keylist(2,53)='+D1'
keylist(1,54)='NDIAB:'
keylist(2,54)='+I1'
!
! 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)=
do j=1,maxkeys
if (keylist(1,j)(1:1).eq.' ') then
keynum=j-1
write(6,'("Number of accepted input keys: ",I3)') keynum
exit
endif
enddo

265
src/parser/nndata_new.f Normal file
View File

@ -0,0 +1,265 @@
! This is a rewrite of the original nndata. Consider debugging it.
!---------------------------------------------------------------------------
subroutine nndata(infile,pat_in,pat_out,ref_in,ref_out,wterr,
> dat_start,linenum,npat,nref,llen)
use nn_params
use nncommons
use io_parameters, only: nstat,nmeta,maxoutp,dnlen,maxlines,
> maxdat,clen,klen,maxkeys,maxerrors,mprun
use nndbg_mod
implicit none
! Routine reading DATA-block.
! If npat is nonzero, only the first npat pattern pairs are read.
!
! infile: input file as string vector
! infile(n) nth line of input file
! linenum: number of lines in input file
! dat_start: starting position of DATA-block
! llen: maximum length of a single input line
!
!.....ANN-specific variables
! nlay: number of given layers
! npat: number of given pattern pairs
! nref: number of reference patterns
! wterr: weight factors for each element of the error vector e
!
! pat_in: input patterns
! pat_out: desired output patterns
! pat_*(i,N): value of ith in-/output neuron for pattern N
!
! ref_*: in analogy to pat_in/out for reference data (convergence tests)
!
! 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 pat_in(maxnin,maxpats),pat_out(maxpout,maxpats)
double precision ref_in(maxnin,maxpats),ref_out(maxpout,maxpats)
double precision wterr(maxpout,maxpats)
integer npat,nref,dat_start,linenum,llen
character infile(*)*(llen)
double precision norm
double precision xtest(maxnin)
integer pat_count,line
integer yval_count
integer k,j
pat_count=1
! count the lines of y-values. inp_out y-values = 1 pattern
yval_count=0
! We will initialize wterr for each new pattern.
wterr(1:inp_out,1)=1.0D0
do line=dat_start,linenum
! Treat WT: lines differently
if (infile(line)(1:3).eq.'WT:') then
if (yval_count.eq.0) then
write(6,'(A)') 'ERROR: WT: KEY PRECEDES ACTUAL DATA.'
write(6,'("(Line #",I06,")")') line
stop ec_read
else if (legacy_wt) then
read(in(line)(4:llen),*,err=515,end=514)
> wterr(yval_count,pat_count)
cycle
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
else if (yval_count.eq.inp_out) then
read(infile(line)(4:llen),*,err=511,end=508)
> wterr(1:inp_out,pat_count)
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
write(6,'(A)') 'ERROR: UNEXPECTED WT: KEY'
write(6,'(A)') 'Consider using LEGACY-WT:.'
stop ec_read
endif
cycle
endif
! Check whether a new pattern begins
if (yval_count.lt.inp_out) then
yval_count=yval_count+1
else
! If npat patterns are completed, finish
if (pat_count.eq.npat) then
exit
endif
if (pat_count.ge.maxpats) then
write(6,418) pat_count,maxpats
stop ec_dimrd
endif
pat_count=pat_count+1
yval_count=1
wterr(1:inp_out,pat_count)=1.0D0
endif
! Read line
read(infile(line)(1:llen),*,err=513,end=510)
> pat_out(yval_count,pat_count),xtest(1:inp_in)
! I CAN DO DATA TRANSFORM HERE
! BY TRANSFORMING PAT_OUT INTO THE DESIRED SHAPE
! TRANSFORM DATA TO ADIABATIC REPRESANTATION.
! Copy x vector from first entry.
! Compare all others to first.
if (yval_count.eq.1) then
pat_in(1:inp_in,pat_count)=xtest(1:inp_in)
else if (
> any(xtest(1:inp_in).ne.pat_in(1:inp_in,pat_count))
> ) then
write(6,421) pat_count, line
write(6,'(A)') '(x values inconsistent with '
> //'previous line)'
stop ec_read
endif
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
enddo
! Did the data file end abruptly?
if (yval_count.ne.inp_out) then
write(6,419) pat_count
write(6,'(A)') '(Unexpected EOF)'
stop ec_read
endif
! pat_count is now actual number of patterns
if (pat_count.le.0) then
write(6,419) 1
stop ec_read
else if (npat.le.0) then
! set npat dynamically
npat=pat_count
else if (npat.ne.pat_count) then
write(6,420) npat,pat_count
stop ec_read
endif
! Rescale weights based on a predefined scheme
call mkweights(wterr,npat,pat_out)
! Split current dataset into actual fitting sets and reference
call mkrefset_tail(pat_in,pat_out,ref_in,ref_out,npat,nref)
norm=0.0D0
! normalize weights of fitting data
do k=1,npat
do j=1,inp_out
wterr(j,k)=dabs(wterr(j,k))
norm=norm+wterr(j,k)
enddo
enddo
do k=1,npat
wterr(1:inp_out,k)=wterr(1:inp_out,k)/norm
enddo
norm=0.0D0
! normalize weights of reference data
do k=npat+1,npat+nref
do j=1,inp_out
wterr(j,k)=dabs(wterr(j,k))
norm=norm+wterr(j,k)
enddo
enddo
do k=npat+1,npat+nref
wterr(1:inp_out,k)=wterr(1:inp_out,k)/norm
enddo
417 format('ERROR: CORRUPTED WEIGHT INPUT (SET #',I9,')')
418 format('ERROR: NPAT EXCEEDING MAXPATS (',I9,' vs.',I9,')')
419 format('ERROR: INCOMPLETE OR MISSING DATA SET. SET #',I9)
420 format('ERROR: NUMBER OF DATA POINTS INCONSISTENT WITH NPAT CARD',
> '(',I9,' vs.',I9,')')
421 format('ERROR: CORRUPTED DATA POINT INPUT (SET #',I9,', LINE,',
> I9,')')
end
!---------------------------------------------------------------------------
subroutine infer_npat(infile,dat_start,linenum,npat,llen)
use nn_params
use nncommons
use io_parameters, only: nstat,nmeta,maxoutp,dnlen,maxlines,
> maxdat,clen,klen,maxkeys,maxerrors,mprun
use nndbg_mod
implicit none
! Count the number of input patterns the DATA block has if it is
! free of errors. No safety checks are done here as they are done
! later.
double precision pat_in(maxnin,maxpats),pat_out(maxpout,maxpats)
double precision ref_in(maxnin,maxpats),ref_out(maxpout,maxpats)
double precision wterr(maxpout,maxpats)
integer npat,nref,dat_start,linenum,llen
character infile(*)*(llen)
double precision norm
double precision xtest(maxnin)
integer pat_count,line,line_count
logical dvecne
integer k,j
pat_count=0
line=dat_start !count lines
line_count=0
do line=dat_start,linenum
if (in(line)(1:3).eq.'WT:') then
cycle
else
line_count=line_count+1
endif
enddo
pat_count=line_count/inp_out
! set npat dynamically
npat=pat_count
if (npat.gt.maxpats) then
write(6,500) npat,maxpats
stop ec_dimrd
endif
500 format('ERROR: NPAT EXCEEDING MAXPATS (',I9,' vs.',I9,')')
end

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

@ -0,0 +1,154 @@
module parse_errors
implicit none
contains
!--------------------------------------------------------------------------------
subroutine signal_p_error(key_id,msg)
! Signal generic error with user-defined message MSG.
use nn_params
use nncommons, only: keylist
implicit none
integer key_id
character*(*) msg
write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id))
> // ' ' // trim(msg)
stop 1
end subroutine
!--------------------------------------------------------------------------------
subroutine signal_dim_error(key_id,msg_code,value,expval)
! Signals errors where one specific dimensioning value is ill-set.
! If the optional parameter EXPVAL is given, return it as expected
! dimensioning value.
use nn_params
use nncommons, only: keylist,errcat
implicit none
integer key_id, msg_code, value
integer, optional :: expval
! optional expval
character*16 int2string
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.
use nn_params
use nncommons, only: keylist,errcat
implicit none
integer key_id
integer, optional :: alt_key
integer msg_code
! optional expval
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)
! 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.
use nn_params
use nncommons, only: keylist,errcat
implicit none
integer key_id, msg_code, value,expval
optional expval
character*16 int2string
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)
! 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.
use nn_params
use nncommons, only: keylist,errcat
implicit none
integer key_id
double precision value,expval
integer msg_code
optional expval
character*16 shortdble2string
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
end module
!--------------------------------------------------------------------------------
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).
use nn_params
use nncommons, only: keylist,errcat
implicit none
integer key_id,msg_code
write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id))
> // ' ' // trim(errcat(msg_code))
stop ec_read
end subroutine

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

File diff suppressed because it is too large Load Diff

816
src/puNNch.f Normal file
View File

@ -0,0 +1,816 @@
************************************************************************
*** puNNch
*** printing (punching) ANN data structures
***
************************************************************************
subroutine punch_data(pat_in,pat_out,npat,append)
use nn_params
use nncommons
use nndbg_mod
implicit none
! Subroutine generating geNNetic DATA: block for ANN fitting.
!
! nlay: number of given layers
! npat: number of pattern-pairs desired
! pat_in: input patterns
! pat_out: desired output patterns
! inp_in: number of coordinates written into input.
! inp_out: number of values written to output
!
! inp_format: format used for datapoints
! scans_fmt: format used for sample-visualisation-file
! nndatfile: filename for analytically generated DATA-blocks
! (see nnparams)
! append: if true, append to given file if it exists
double precision pat_in(maxnin,*),pat_out(maxpout,*)
integer npat
logical append
character*16 inp_format,scans_fmt
character*35 full_fname
logical alive
integer k,j
if (inp_in.ge.10**6) then
stop 'ERROR: NUMBER OF COORDINATES TOO LARGE TO HANDLE'
endif
! generate format string
write(inp_format,'(I6,A7)') inp_in+1,'ES23.14'
inp_format = '(' // trim(inp_format) // ')'
full_fname = trim(nndatfile) // '.in'
write(6,'(A)') "generating DATA-file '" // trim(full_fname)
> // "'..."
! write file
if (.not.append) then
open(nnunit,file=trim(full_fname),status='REPLACE')
else
inquire(file=trim(full_fname),exist=alive)
if (alive) then
! open existing file and append
open(nnunit,file=trim(full_fname),status='old',
> position='append')
else
! file does not exist; make it
open(nnunit,file=trim(full_fname),status='new')
endif
endif
write(nnunit,'(A5)') 'DATA:'
write(nnunit,*) ''
write(unit=nnunit,advance='no',fmt='("!")')
write(nnunit,sline)
write(nnunit,*) ''
do k=1,npat
do j=1,inp_out
write(nnunit,inp_format) pat_out(j,k), pat_in(1:inp_in,k)
enddo
write(nnunit,'(A4)') '!WT:'
write(nnunit,*) ''
enddo
close(nnunit)
! generate sample format string
write(scans_fmt,'(I6,A7)') inp_in,'ES23.14'
scans_fmt = '(' // trim(scans_fmt) // ')'
! write file
open(nnunit,file=trim(sampfile),status='REPLACE')
write(6,'(A)') "dumping sampled points in '" // trim(sampfile)
> // "'..."
write(nnunit,'(A)') '# This file shows all sampled points in '
> // 'the given configuration space.'
do k=1,npat
write(nnunit,scans_fmt) pat_in(1:inp_in,k)
enddo
close(nnunit)
end subroutine
!--------------------------------------------------------------------------------------
subroutine punch_net(funit,fname,par,
> typop,laystr,weistr,nlay,append,noprim)
use nn_params
use nncommons
use io_parameters
use nndbg_mod
implicit none
! Subroutine writing all relevant structural NN information
! to file.
!
! funit: file unit to be used. If negative or 0, use nnunit.
! fname: name of the file
! append: if true, append to given file if it exists
! noprim: if true, do not generate primitive representation
character*32 fname
double precision par(wbcap)
integer laystr(3,maxlay),typop(maxtypes,maxlay)
integer weistr(2,maxlay,2)
integer nlay
integer funit
logical append, noprim
integer file_unit
integer wbnum,plen
integer nnkeynum
character*35 full_fname
character*(klen) nnkeylist(2,maxnnkeys)
logical alive
integer j
if (funit.le.0) then
file_unit=nnunit
else
file_unit=funit
endif
full_fname = trim(fname) // '.in'
if (.not.append) then
open(file_unit,file=trim(full_fname),status='replace')
else
inquire(file=trim(full_fname),exist=alive)
if (alive) then
! open existing file and append
open(file_unit,file=trim(full_fname),status='old',
> position='append')
else
! file does not exist; make it
open(file_unit,file=trim(full_fname),status='new')
endif
endif
! recover information to construct ANN
write(file_unit,'("NLAY:",I4)') nlay
write(file_unit,'(/,"NEUPOP:",100(I6,:))') laystr(1,1:nlay)
write(file_unit,'("TYPOP:",100(I6,:),//)') typop(:,2:nlay)
write(file_unit,'(A)') 'INSHIFT: &'
call write_longreal(file_unit,shift_in,len_in,lrfmt,5)
write(file_unit,'(A)') 'INSCALE: &'
call write_longreal(file_unit,fact_in,len_in,lrfmt,5)
! write out parameter set
write(file_unit,'(A)') '!.....NEURAL NETWORK PARAMETERS:'
! number of weights (and biases)
wbnum=nlay-1
! construct keys
call NNkeygen(nnkeylist,nnkeynum,nlay,.false.)
! write weight matrices
do j=1,wbnum
write(file_unit,newline)
write(file_unit,'(A," &")') trim(nnkeylist(1,1+j))
plen=1+weistr(2,j,1)-weistr(1,j,1)
call write_longreal(file_unit,par(weistr(1,j,1)),plen,lrfmt,5)
enddo
! write bias vectors
do j=1,wbnum
write(file_unit,newline)
write(file_unit,'(A," &")') trim(nnkeylist(1,1+wbnum+j))
plen=1+weistr(2,j+1,2)-weistr(1,j+1,2)
call write_longreal(file_unit,par(weistr(1,j+1,2)),plen,
> lrfmt,5)
enddo
close(file_unit)
if (.not.noprim) then
call punch_net_prim(funit,fname,par,
> typop,laystr,weistr,nlay)
endif
end subroutine
!--------------------------------------------------------------------------------------
subroutine punch_net_prim(funit,fname,par,
> typop,laystr,weistr,nlay)
use axel, only: unnorm_input
use nn_params
use nncommons
use io_parameters
use nndbg_mod
implicit none
! Subroutine writing all relevant structural NN information
! to a primitively readable file. The resulting parameters no longer
! assume a pre-normalized input
!
! funit: file unit to be used. If negative or 0, use nnunit.
! fname: name of the file
character*32 fname
double precision par(*)
integer funit
integer laystr(3,maxlay),typop(maxtypes,maxlay)
integer weistr(2,maxlay,2)
integer nlay
character*36 full_fname
double precision par_copy(wbcap)
integer par_pos,par_end,par_len
integer file_unit
integer j
if (funit.le.0) then
file_unit=nnunit
else
file_unit=funit
endif
full_fname = trim(fname) // '.par'
open(file_unit,file=trim(full_fname),status='replace')
par_pos=weistr(1,1,1)
par_end=weistr(2,nlay,2)
par_len=1+par_end-par_pos
write(file_unit,*) nlay
write(file_unit,*) maxtypes
write(file_unit,'(100(I6,:))') laystr(1,1:nlay)
write(file_unit,'(100(I6,:),//)') typop(:,1:nlay)
write(file_unit,'(A)') '***'//trim(prim_tag)
! copy parameter set and unddo norm
do j=par_pos,par_end
par_copy(1+j-par_pos)=par(j)
enddo
call unnorm_input(par_copy,laystr,shift_in,fact_in,weistr,.true.)
! write par-vector
do j=1,par_len
write(unit=file_unit,fmt=lrfmt,advance='NO') par_copy(j)
enddo
close(file_unit)
end subroutine
!--------------------------------------------------------------------------------------
subroutine punch_scans(pat_in,pat_out)
use nn_params
use nncommons
use io_parameters
use nndbg_mod
implicit none
! Subroutine writing plot files for random scans from input.
! pat_in: input patterns
! pat_out: desired output patterns
! inp_in: number of coordinates written into input.
! inp_out: number of values written to output
double precision pat_in(maxnin,*),pat_out(maxpout,*)
integer total
character*64 fname
integer k,j
if (sets.ge.10**4) then
write(6,'(A)') 'WARNING: punch_scans: Too many scan files'
> // ' to generate.'
write(6,'(A)') 'Garbage file ' // trim(nnsdir)
> // '''scan_****.dat'' will be created.'
endif
! count number of data points written to file
total=0
do k=1,sets
! generate filename
write(fname,'(A32)') ''
write(fname,'(I4.4)') k
fname = trim(nnsdir) // 'scan_' // trim(fname) // '.dat'
if (dbg) write(*,*) 'writing ''' // trim(fname) // '''...'
open(unit=nnunit,status='replace',file=trim(fname))
! dump scan into file
do j=1,ndata(k)
total = total+1
write(nnunit,'(1000(ES23.15,:))') pat_in(1:inp_in,total),
> pat_out(1:inp_out,total)
enddo
close(nnunit)
enddo
end subroutine
!--------------------------------------------------------------------------------------
subroutine punch_fitscans(par,pat_in,pat_out,wterr,
> typop,laystr,weistr,
> nlay,walk)
use nn_params
use nncommons
use io_parameters
use nndbg_mod
implicit none
! Subroutine writing plot files for fitted random scans.
! For now only output in terms of diabatic energies is supported.
!
! walk: determines how coordinate-dependency is
! written to files
! true -- write scans as functions of t in [0,1] (walk along the scan)
! false -- dump full coordinate vector to file
!
! pat_in: input patterns
! pat_out: desired output patterns
! inp_in: number of coordinates written into input.
! inp_out: number of values written to output
!
! laystr: layer structure matrix
! typop: type population matrix
! nlay: number of given layers
!
double precision par(*)
double precision pat_in(maxnin,*),pat_out(maxpout,*)
double precision wterr(maxpout,maxpats)
integer laystr(3,maxlay),typop(maxtypes,maxlay)
integer weistr(2,maxlay,2)
integer nlay
logical walk
double precision nnoutp(maxnout),adiaoutp(maxpout)
double precision max_err,err_vec(maxpout)
double precision x_diff(maxnin)
double precision walktime,walknorm
integer total
character*64 fname
integer k,j
integer end_int, bgn_int
! the coordianate in pat_in is order in the following way
! pat_In(INPUTS,INTERNAL COORDIANATE)
bgn_int = typop(1,1)+1 ! the begin of theinternal coordiante
end_int = typop(1,1)+6
if (sets.ge.10**4) then
write(6,'(A)') 'WARNING: punch_fitscans: Too many scan files'
> // ' to generate.'
write(6,'(A)') 'Garbage file ''' // trim(nnsdir)
> // 'fit_scan_****.dat'' will be created.'
endif
! count number of data points written to file
total=0
do k=1,sets
! generate filename
write(fname,'(A32)') ''
write(fname,'(I4.4)') k
fname = trim(nnsdir) // 'fit_scan_' // trim(fname) // '.dat'
if (dbg) write(*,*) 'writing ''' // trim(fname) // '''...'
open(unit=nnunit,status='replace',file=trim(fname))
if (walk) then
write(nnunit,'("# SCAN",I4.4,
>"[t,F(NN(x(t))),f(x(t)),NN(x(t)),We(x(t))]")') k
write(nnunit,'("# XDIM:",I6)') 1
else
write(nnunit,
> '("# SCAN",I4.4,"[x,F(NN(x)),f(x),NN(x),We(x)]")') k
write(nnunit,'("# XDIM:",I6)') inp_in
endif
write(nnunit,'("# OUTPUT VALUES:",I6)') inp_out
write(nnunit,'("# DATA POINTS:",I6,/)') ndata(k)
write(nnunit,'(A)') '# UNIT: ' // trim(unit_string)
walknorm=0.0d0
walktime=0.0d0
if (walk) then
do j=2,ndata(k)
x_diff(bgn_int:end_int)= pat_in(bgn_int:end_int,
> total+j) - pat_in(bgn_int:
> end_int,total+j-1)
walknorm=walknorm +dsqrt(sum(x_diff(bgn_int:end_int)**2))
enddo
endif
! dump scan into file
max_err=0
do j=1,ndata(k)
total = total+1
max_err=0.0d0
! generate model energies
nnoutp=0.0d0
call neunet(pat_in(1,total),nnoutp,par,
> typop,laystr,weistr,nlay)
call nnadia(pat_in(1,total),nnoutp,adiaoutp)
if (walk) then
if (j.eq.1) then
x_diff=0.0d0
else
x_diff(bgn_int:end_int)=
> pat_in(bgn_int:end_int,total)
> - pat_in(bgn_int:end_int,total-1)
endif
walktime = walktime
> + dsqrt(sum(x_diff(bgn_int:end_int)**2))/walknorm
write(nnunit,'(1000(ES23.15,:))') walktime,
> adiaoutp(1:inp_out)*unit_con,
> pat_out(1:inp_out,total)*unit_con,
> nnoutp(1:len_out),
> wterr(1:inp_out,total)
else
write(nnunit,'(1000(ES23.15,:))') pat_in(bgn_int:
> end_int,total),
> adiaoutp(1:inp_out)*unit_con,
> pat_out(1:inp_out,total)*unit_con,
> nnoutp(1:len_out),
> wterr(1:inp_out,total)
endif
err_vec=dabs(adiaoutp-pat_out(:,total))
max_err=max(max_err,sum(err_vec(1:inp_out)**2))
enddo
write(nnunit,'(/,"## SUP NORM:",E23.15,A)')
> dsqrt(max_err)*unit_con, trim(unit_string)
close(nnunit)
enddo
end subroutine
!--------------------------------------------------------------------------------------
subroutine punch_fitpoints(par,pat_in,pat_out,
> typop,laystr,weistr,nlay,npat,fname)
use nn_params
use nncommons
use nndbg_mod
implicit none
! Subroutine dumping all reference data points into a single file.
! Also produces unweighted (!!) errors for each point
!
! nlay: number of given layers
! npat: number of given pattern pairs
! fname: name of output-file
!
! pat_in: input patterns
! pat_out: desired output patterns
! pat_*(i,N): value of ith in-/output neuron for pattern N
!
! del: neuron error vector
! pat_err: error of the network output for a single pattern
! deriv: activation function derivatives
! deriv: activation function derivatives
! typop: type population matrix
! laystr: layer structure matrix
!
integer npat
double precision par(*)
double precision pat_in(maxnin,*),pat_out(maxpout,*)
integer laystr(3,maxlay),typop(maxtypes,maxlay)
integer weistr(2,maxlay,2)
integer nlay
character*32 fname
double precision nn_out(maxnout)
double precision pat_err(maxpout),abs_err
integer len_form
integer n,k
character*32 form
len_form=1+len_in+2*len_out !number of value blocks to be written
if (dbg.or.vbs) then
write(6,'(A)') 'dumping pointwise errors into '''
> // trim(fname) // '''...'
endif
open(unit=nnunit,status='replace',file=trim(fname))
write(nnunit,'(A)') '#DATA POINT DUMP '
> //'[x,NN(x),f(x),sqrt((F(NN)-f)^2)]'
write(form,'("(",I6,A,")")') len_form,'ES25.8'
do n=1,npat
! propagate nth input pattern
call neunet(pat_in(1,n),nn_out,par,typop,laystr,weistr,nlay)
! evaluate error
call nnerror(pat_err,pat_in(1,n),pat_out(1,n),nn_out)
abs_err=0.0D0
do k=1,inp_out
abs_err=abs_err+pat_err(k)**2
enddo
abs_err=dsqrt(abs_err)
!? valgrind does not like variable format strings
write(nnunit,'(10000(ES25.8,:))') pat_in(1:len_in,n),
> nn_out(1:len_out),
> pat_out(1:inp_out,n), abs_err
enddo
close(nnunit)
end subroutine
!--------------------------------------------------------------------------------------
subroutine punch_fitstat(fname,par,pat_in,pat_out,err_vec,npat,
> typop,laystr,weistr,
> nlay,append)
use nn_params
use nncommons
use io_parameters
use nndbg_mod
implicit none
! Subroutine providing a complete vector over all root mean square
! errors over all points from 1 to npat in a single file.
!
! This routine is used to construct errors_*.out files.
!
! fname: name of the file to be written
! pat_in: input patterns
! pat_out: desired output patterns
! npat: number of given pattern pairs
! inp_in: number of coordinates written into input.
! inp_out: number of values written to output
! err_vec: vector containing all abs. pattern errors (sorted)
! append: if true, append to given file if it exists
!
character*32 fname
integer npat
double precision par(wbcap)
double precision pat_in(maxnin,*),pat_out(maxpout,*)
double precision err_vec(npat)
integer laystr(3,maxlay),typop(maxtypes,maxlay)
integer weistr(2,maxlay,2)
integer nlay
logical append
double precision pat_err(maxpout)
integer, dimension(:), allocatable :: err_pos
logical alive
integer n
if (.not.append) then
open(nnunit,file=trim(fname),status='replace')
else
inquire(file=trim(fname),exist=alive)
if (alive) then
! open existing file and append
open(nnunit,file=trim(fname),status='old',
> position='append')
write(nnunit,asline)
else
! file does not exist; make it
open(nnunit,file=trim(fname),status='new')
endif
endif
! accumulate errors to long vector
allocate(err_pos(maxpats))
do n=1,npat
call NNerrvec(par,pat_err,pat_in(1,n),pat_out(1,n),
> typop,laystr,weistr,nlay)
err_vec(n)=dsqrt(sum(pat_err(1:inp_out)**2))
err_pos(n)=n
enddo
! sort vector
call reverse_dqsort2(npat,err_vec,err_pos)
write(nnunit,'("#",A12,2A13)') 'RANK','ERROR [' //
> trim(unit_string) // ']','PAT#'
do n=1,npat
write(nnunit,'(I13,ES13.4,I13)') n, err_vec(n)*unit_con,
> err_pos(n)
enddo
close(nnunit)
deallocate(err_pos)
end subroutine
!--------------------------------------------------------------------------------------
subroutine punch_netdistrib(fdir,par,pat_in,typop,laystr,
> weistr,nlay,npat,ftag)
use nn_params
use nncommons
use io_parameters
use nndbg_mod
implicit none
! Subroutine evaluating the activity of all neurons for each data
! point. Also returns information about the network to construct it.
!
! fdir: directory for files to be written in
! pat_in: input patterns
! npat: number of given pattern pairs
! inp_in: number of coordinates written into input.
! inp_out: number of values written to output
! err_vec: vector containing all abs. pattern errors (sorted)
! ftag: prefix for generated filenames
character*16 fdir
integer npat
double precision par(wbcap)
double precision pat_in(maxnin,npat)
integer laystr(3,maxlay),typop(maxtypes,maxlay)
integer weistr(2,maxlay,2)
integer nlay
character*8 ftag
character*128 fname
double precision deriv(neucap),L(neucap)
double precision, dimension(:,:), allocatable :: neurons, derivs
double precision median(len_out), rec_scale(len_out)
integer med_pos(2)
integer lay_end,poslay
integer n,j
poslay=laystr(2,nlay)
lay_end=poslay-1+len_out
allocate(neurons(npat,len_out),derivs(npat,len_out))
! evaluate ANN for each pattern
do n=1,npat
L=0.0d0
deriv=0.0d0
call neunet_full(pat_in(1,n),L,deriv,par,
> typop,laystr,weistr,nlay)
neurons(n,1:len_out)=L(poslay:lay_end)
enddo
! compute location of median
if (1.eq.modulo(npat,2)) then
med_pos = (npat+1)/2
else
med_pos(1) = npat/2
med_pos(2) = med_pos(1) + 1
endif
do n=1,len_out
call dqsort(npat,neurons(1,n))
median(n)=(neurons(med_pos(1),n)+neurons(med_pos(2),n))/2.0d0
neurons(:,n)=neurons(:,n)
rec_scale(n)=(neurons(npat,n)-neurons(1,n))/2.0d0
enddo
! file containing the real ANN outputs
fname=trim(fdir)// trim(ftag) //'netdist-med.dat'
write(6,'(A)') 'Writing distribution of (shifted) '
> // 'ANN output values to ''' // trim(fname) // '''..'
open(nnunit,file=trim(fname),status='replace')
write(nnunit,'(A)') '# ANN OUTPUT VALUES'
write(nnunit,'(A)') '# SORT INDEX, OUTPUT NEURON(S) 1,2,.. ,'
> // ' (MINUS MEDIAN)'
write(nnunit,'(A,1000(F10.5,:))') '# Recommended rescaling: ',
> rec_scale(:)
write(nnunit,'(A,1000(F10.5,:))') '# Computed median: ',
> median(:)
do n=1,npat
write(nnunit,'(I11, 10000(ES11.2,:))') n,
> (neurons(n,j)-median(j), j=1,len_out)
enddo
close(nnunit)
! file containing outputs shifted by median
fname=trim(fdir)// trim(ftag) //'netdist.dat'
write(6,'(A)') 'Writing distribution of ANN output values '
> // 'to ''' // trim(fname) // '''..'
open(nnunit,file=trim(fname),status='replace')
write(nnunit,'(A)') '# ANN OUTPUT VALUES'
write(nnunit,'(A)') '# SORT INDEX, OUTPUT NEURON(S) 1,2,..'
write(nnunit,'(A,1000(F10.5,:))') '# Recommended rescaling: ',
> rec_scale(:)
write(nnunit,'(A,1000(F10.5,:))') '# Computed median: ',
> median(:)
do n=1,npat
write(nnunit,'(I11, 10000(ES11.2,:))') n, neurons(n,:)
enddo
close(nnunit)
deallocate(neurons,derivs)
end subroutine
!--------------------------------------------------------------------------------------
subroutine punch_record(par,weistr,nlay,nset,preserve)
use nn_params
use nncommons
use io_parameters
use nndbg_mod
implicit none
double precision par(wbcap,maxset)
integer weistr(2,maxlay,2)
integer nlay,nset
logical preserve
integer wb_end
logical file_exists
character*64 fname
integer k,j
fname=trim(nnrecfile) // '.rec'
wb_end=weistr(2,nlay,2)
if (preserve) then
inquire(file=trim(fname),exist=file_exists)
if (file_exists) then
! File exists already, try an alternative file name
write(6,'(A)') 'WARNING: File ''' //
> trim(fname) // ''' already exists.'
write(6,'(A)') 'Attempting to create an alternative file..'
k=1
do while ((k.le.99).and.file_exists)
write(fname,'("_",I2.2)') k
fname=trim(nnrecfile) // trim(fname) // '.rec'
inquire(file=trim(fname),exist=file_exists)
k=k+1
enddo
! File STILL exists?
if (file_exists) then
write(6,'(A)') 'WARNING: No safe backup could be made.'
fname=trim(nnrecfile) // '_XX.rec'
endif
endif
endif
write(6,'(A)') 'RECORD: Writing record to file '''
> // trim(fname) // '''...'
open(nnunit,file=trim(fname),action='WRITE')
write(nnunit,*) nset
write(nnunit,*) wb_end
do k=1,nset
write(nnunit,'(I0)',advance='no') k
do j=1,wb_end
write(nnunit,'(ES23.15)',advance='no') par(j,k)
enddo
write(nnunit,newline)
enddo
close(nnunit)
write(6,'(A)') 'Done.'
end subroutine

385
src/scans.f Normal file
View File

@ -0,0 +1,385 @@
!--------------------------------------------------------------------------------------
subroutine lscan_bounds(bounds,refp,dvec,xmin,xmax,dim,backwd)
use nn_params
implicit none
! Determine how far a scan can progress within a box-shaped boundary
! in terms of the length of the scan starting from the reference
! point.
!
! dim: dimension of coordinate space to be scanned
! xmin/max: minimum/maximum allowed value in each coordinate
! refp: reference point at which linear scan begins
! dvec: (normalized) vector pointing into the direction of the scan
! backwd: if true, evaluate boundary also in -dvec-direction
! bounds: maximum distance(s) from reference point
! bounds(1): in dvec-direction
! bounds(2): in -dvec-direction (default 0.0D0)
! res: resolution -- maximum error in bound estimates
integer dim
double precision refp(dim),dvec(dim)
double precision xmin(dim),xmax(dim)
double precision bounds(2)
logical backwd
double precision min_len,step_len,box_diag
integer j
! begin at a resolution of 10% the box diagonal
box_diag=0.0D0
do j=1,dim
box_diag=box_diag+(xmax(j)-xmin(j))**2
enddo
box_diag=sqrt(box_diag)
step_len=0.1D0*box_diag
min_len=0.0D0
do while (step_len.ge.scan_res)
! find lower boundary given current resolution
call lscan_estim_bound(min_len,step_len,refp,dvec,
> xmin,xmax,dim)
! refine resolution
step_len=0.5D0*step_len
enddo
bounds(1)=min_len
bounds(2)=0.0D0
if (backwd) then
! follow vector in a negative direction
step_len=-0.1D0*box_diag
min_len=0.0D0
do while (dabs(step_len).ge.scan_res)
! find lower boundary given current resolution
! this could be further numerically refined; since the step distance
! is halved, we know that no more than 1 step can be successful.
call lscan_estim_bound(min_len,step_len,refp,dvec,
> xmin,xmax,dim)
! refine resolution
step_len=0.5D0*step_len
enddo
bounds(2)=abs(min_len)
endif
end
!--------------------------------------------------------------------------------------
subroutine lscan_estim_bound(min_len,step_len,refp,dvec,xmin,xmax,
> dim)
implicit none
! Estimate a lower bound min_len for the length a linear scan can progress
! within a box-shaped boundary, given an inital guess which
! is also a lower bound and a step resolution step_len.
!
! dim: dimension of coordinate space to be scanned
! xmin/max: minimum/maximum allowed value in each coordinate
! refp: reference point at which linear scan begins
! dvec: (normalized) vector pointing into the direction of the scan
! min_len: estimate for minimal length of scan (will be overwritten
! with refined result)
! step_len: interval at which the algorithm checks for boundary violation
integer dim
double precision refp(dim),dvec(dim)
double precision xmin(dim),xmax(dim)
double precision step_len,min_len
double precision test_vec(dim)
logical in_bound
logical dbetween
integer j
in_bound=.true.
do while (.true.)
do j=1,dim
test_vec(j)=refp(j)+(min_len+step_len)*dvec(j)
in_bound=in_bound.and.dbetween(xmin(j),test_vec(j),xmax(j))
enddo
if (in_bound) then
min_len=min_len+step_len
else
exit
endif
enddo
end
!--------------------------------------------------------------------------------------
subroutine mkescans(pat_in,neu_in,npat,scans,xranges)
use nn_params
use nndbg_mod
implicit none
! Generate input patterns for elliptic random scans. Datapoints
! on scans are arranged in concentric ellipsoids around the
! origin. The outermost ellipsoid is bounded by xranges(i,2) as it's
! principal axes. The innermost ellipsoid is the smallest one where
! no possible point violates the smallest allowed value in any
! dimension.
!
! For the sake of simplicity, the coordinate system is effectively
! rescaled such that the outer ellipsoid becomes a unit sphere
! and then transfomed back.
!
! npat: number points on the scan
! scans: number of scans
! pat_in: input patterns
! pat_*(i,N): value of ith in-/output neuron for pattern N
! rmin: radius of the smallest sphere enclosing all forbidden areas
! in the rescaled coordinate system
! len_step: radius step size for rescaled coordinate system
!
! xranges: range for (random) input distribution:
! |xranges(:,1)| < |pat_in(:,k)| < |xranges(i,2)| forall k
! xranges(i,3) : if it's absolute value is >=1,
! dimension i will always have the same sign as xranges(i,3).
integer npat,scans
integer neu_in
double precision xranges(maxnin,xrcap)
double precision pat_in(maxnin,npat,scans)
double precision rvec(maxnin)
double precision rmin,len_step
double precision dum
integer n,k,j
! rescale minimum distances such that corresponding
! outer ellipsoid transforms to a unit sphere and
! pick the largest of these minimal radii to actually use.
rmin=0.0d0
do k=1,neu_in
dum=dabs(xranges(k,1)/xranges(k,2))
if (dum.gt.rmin) rmin=dum
enddo
if (dbg.or.vbs) then
write(*,*) 'MINIMAL EFFECTIVE RADIUS:', rmin
endif
! evaluate step size
len_step=(1.0d0-rmin)/dble(npat-1)
do n=1,scans
! generate normalized isotropic random vector
call normal_grv(rvec,neu_in,1)
! adjust signs
do j=1,neu_in
if (dabs(xranges(j,3)).ge.1.0d0) then
rvec(j)=sign(rvec(j),xranges(j,3))
endif
enddo
do k=1,npat
do j=1,neu_in
! make equidistant steps along that direction
pat_in(j,k,n) = (rmin + (k-1)*len_step)*rvec(j)
! rescale
pat_in(j,k,n) = pat_in(j,k,n)*xranges(j,2)
enddo
enddo
enddo
! update npat to actual number of patterns
npat=npat*scans
end
!--------------------------------------------------------------------------------------
subroutine mklscan(pat_in,neu_in,npat,xranges)
use nn_params
use nndbg_mod
implicit none
! Generate a single set of input patterns forming a single linear
! scan going through both specified points
!
! npat: number points on the scan
! pat_in: input patterns
! pat_*(i,N): value of ith in-/output neuron for pattern N
! xranges: starting point and end point of linear scan
! xranges(i,1) : starting point in coordinate space (r0)
! xranges(i,2) : end point in coordinate space (r1)
!
! dvec: direction vector pointing from r0 to r1.
double precision xranges(maxnin,xrcap)
double precision pat_in(maxnin,maxpats)
integer npat
integer neu_in
double precision dvec(maxnin)
integer n,j
! determine direction vector pointing from r0 to r1
do j=1,neu_in
dvec(j)=xranges(j,2)-xranges(j,1)
enddo
do n=1,npat
do j=1,neu_in
pat_in(j,n)=dble(n-1)/dble(npat-1)*dvec(j) + xranges(j,1)
enddo
enddo
end
!--------------------------------------------------------------------------------------
subroutine mklscans(pat_in,neu_in,npat,scans,xranges)
use nn_params
use nndbg_mod
implicit none
! Generate input patterns for linear random scans inside a
! box-shaped coordinate subspace. Reference point is NOT included
! in the scan.
!
! npat: number points on the scan
! scans: number of scans
! pat_in: input patterns
! pat_*(i,N): value of ith in-/output neuron for pattern N
!
! xranges: ranges specifying scan properties (bounds etc)
! xranges(i,1) < pat_in(i,k) < xranges(i,2) forall i,k
! xranges(i,3) : reference point from which all scans originate
!
! res: convergence parameter for bound finding algorithm
integer npat,scans
integer neu_in
double precision xranges(maxnin,xrcap)
double precision pat_in(maxnin,npat,scans)
double precision bounds(2)
double precision rvec(neu_in)
double precision len_step
logical backwd
parameter (backwd=.false.)
integer n,k,j
do n=1,scans
! generate normalized isotropic random vector
call normal_grv(rvec,neu_in,1)
! numerically determine distance from box boundary
call lscan_bounds(bounds,xranges(1,3),rvec,
> xranges(1,1),xranges(1,2),neu_in,backwd)
! determine length of a single step
len_step=bounds(1)/dble(npat)
! generate scan
do k=1,npat
do j=1,neu_in
pat_in(j,k,n) = xranges(j,3) + len_step*dble(k)*rvec(j)
enddo
enddo
enddo
! update npat to actual number of patterns
npat=npat*scans
end
!--------------------------------------------------------------------------------------
subroutine mktscans(pat_in,neu_in,npat,scans,xranges)
use nn_params
use io_parameters
use nndbg_mod
implicit none
! Generate scans touching a sphere of fixed width and origin
! with random orientation. They are bounded within a box
! defined by xranges.
!
! npat: number points on the scan
! scans: number of scans
! pat_in: input patterns
! pat_*(i,N): value of ith in-/output neuron for pattern N
!
! xranges: ranges specifying scan properties (bounds etc)
! xranges(i,1) < pat_in(i,k) < xranges(i,2) forall i,k
! xranges(i,3) : center of the sphere
! xranges(1,4) : radius of the sphere
integer npat,scans
integer neu_in
double precision pat_in(maxnin,npat,scans)
double precision xranges(maxnin,xrcap)
double precision rvec(maxnin),rtang(maxnin)
double precision rtnorm,overlap,radius
double precision bounds(2),len_step
logical backwd
parameter (backwd=.true.)
integer n,k,j
! determine radius of the sphere
radius=xranges(1,4)
do n=1,scans
! generate normalized isotropic random vector
call normal_grv(rvec,neu_in,1)
! generate another one orthogonal to the first using
! Grahm-Schmidt
rtnorm=0.0D0
do while (rtnorm.le.zero)
call normal_grv(rtang,neu_in,1)
rtnorm=0.0D0
overlap=dot_product(rvec(1:neu_in),rtang(1:neu_in))
do j=1,neu_in
rtang(j)=rtang(j)-overlap*rvec(j)
rtnorm = rtnorm + rtang(j)**2
enddo
rtnorm=dsqrt(rtnorm)
enddo
! reposition and scale rvec to rest on the desired sphere
! normalize rtang
do j=1,neu_in
rvec(j)=radius*rvec(j) + xranges(j,3)
rtang(j)=rtang(j)/rtnorm
enddo
! numerically determine distance from box boundary in both
! directions
call lscan_bounds(bounds,rvec,rtang,
> xranges(1,1),xranges(1,2),neu_in,backwd)
! determine step length
len_step=(bounds(1)+bounds(2))/dble(npat-1)
! set the scan to begin at an end point instead of in the middle
! of the tangent
do j=1,neu_in
rvec(j)=rvec(j)-rtang(j)*bounds(2)
enddo
! generate random scan
do k=1,npat
do j=1,neu_in
pat_in(j,k,n) = rvec(j) + len_step*dble(k-1)*rtang(j)
enddo
enddo
enddo
! evaluate true number of patterns
npat=npat*scans
end