first push
This commit is contained in:
jean paul nshuti
commit
3fbacaf43d
|
|
@ -0,0 +1,177 @@
|
|||
######################################################################
|
||||
# GNU MAKEFILE #
|
||||
######################################################################
|
||||
# There may be some trickery involved in this file; most of which is #
|
||||
# hopefully explained sufficiently. This makefile is unlikely to #
|
||||
# work with non-GNU make utilities. #
|
||||
# #
|
||||
######################################################################
|
||||
SHELL = /bin/bash
|
||||
# clear out suffix list
|
||||
.SUFFIXES :
|
||||
# declare suffixes allowed to be subject to implicit rules.
|
||||
.SUFFIXES : .f .o .f90
|
||||
|
||||
current_version=4.0c
|
||||
tarname=NH3-Plus
|
||||
|
||||
|
||||
src = ./src/
|
||||
build = ./obj/
|
||||
bin = ./bin/
|
||||
|
||||
ldir = $(src)lib/
|
||||
pdir = $(src)parser/
|
||||
|
||||
|
||||
# DEFINE THE PATH
|
||||
|
||||
VPATH = $(src)
|
||||
VPATH += $(ldir)
|
||||
VPATH += $(pdir)
|
||||
|
||||
|
||||
# extra dir
|
||||
extra_dirs = logs nnfits scans
|
||||
gincl = -I$(src) -I$(pdir) -I$(ldir)
|
||||
|
||||
# GFORTRAN COMPILER
|
||||
FC := gfortran
|
||||
GFFLAGS = -O2 -fopenmp -fbackslash -fmax-errors=5 -Wall -Werror
|
||||
GFFLAGS += -std=legacy -cpp -J$(build)
|
||||
GFFLAGS += $(gincl)
|
||||
#GFFLAGS += -Wall -Wextra -Werror -Wno-error=integer-division -Wno-error=conversion \
|
||||
-Wno-error=intrinsic-shadow
|
||||
GLLAPCK = -llapack
|
||||
|
||||
DBGFFLAGS = -O0 -fcheck=bounds -fcheck=do -fcheck=mem -fcheck=pointer -p -debug all
|
||||
|
||||
#cGINCL = -I -I$(pdir) -I$(ldir)
|
||||
|
||||
GFFLAGS += $(GINCL)
|
||||
GFFLAGS += $(GLLAPCK)
|
||||
DBGFFLAGS += $(GLLAPCK)
|
||||
|
||||
#IFORT COMPILER
|
||||
|
||||
IFC := ifort
|
||||
IFFLAGS = -O3 -qopenmp -qmkl -fpp -stand f95 -warn all -warn noerrors \
|
||||
-fp-model precise -traceback -assume byterecl
|
||||
IFFLAGS += -g -diag-disable=10448
|
||||
DBGIFC = -O0 -g -check all -traceback -fpp -warn all -fp-stack-check
|
||||
|
||||
LDFLAGS = -llapack
|
||||
|
||||
# CHOSE THE COMPILER
|
||||
###########################
|
||||
COMPILER = $(FC)
|
||||
|
||||
ifeq ($(COMPILER),IFC)
|
||||
FC = $(IFC)
|
||||
FFLAGS = $(IFFLAGS)
|
||||
DBGFLAGS = $(DBGIFC)
|
||||
else
|
||||
#FC = $(FC)
|
||||
FFLAGS = $(GFFLAGS)
|
||||
DBGFLAGS = $(DBGFFLAGS)
|
||||
endif
|
||||
######################################################################
|
||||
### Functions
|
||||
######################################################################
|
||||
|
||||
# return 'true' if file $(1) exists, else return ''
|
||||
file_exists = $(shell if [ -f $(1) ]; then echo "true"; fi)
|
||||
# return 'true' if file $(1) doesn't exist, else return ''
|
||||
file_lost = $(shell if [ ! -f $(1) ]; then echo "true"; fi)
|
||||
|
||||
######################################################################
|
||||
### Objects
|
||||
######################################################################
|
||||
|
||||
# Objects solely relying on ANN parameters
|
||||
ann_objects = backprop.o ff_neunet.o neuron_types.o \
|
||||
axel.o nnmqo.o scans.o nnread.o
|
||||
|
||||
# Objects relying on both genetic & ANN params
|
||||
genann_objects = geNNetic.o iNNterface.o puNNch.o \
|
||||
mkNN.o error.o long_io.o parse_errors.o parser.o
|
||||
|
||||
# Objects depending on model
|
||||
#mod_objects = nnmodel.o nncoords.o
|
||||
pln_objects = invariants_no3.o nncoords_no3.o genetic_param_no3.o model_no3.o nnadia_no3.o
|
||||
#pyr_objects = invariants_nh3.o nncoords_nh3.o fit_genetic_Umb.o model_dipole_nh3.o dip_nh3plus_model.o
|
||||
#mod_objects = invariants_nh3.o nncoords_nh3.o fit_genetic.o \
|
||||
new_model_dipole.o dip_nh3plus_model.o
|
||||
|
||||
# Objects belonging to internal library
|
||||
lib_objects = misc.o ran_gv.o choldc.o diag.o \
|
||||
qsort.o dmatrix.o imatrix.o strings.o ran.o \
|
||||
fileread.o keyread.o long_keyread.o
|
||||
|
||||
# Objects from hell; if it exists, don't compile it
|
||||
hell_objects = $(ldir)random.o
|
||||
hell_flags = -O3
|
||||
hell_flags += -llapack
|
||||
|
||||
# All objects (one would want to update)
|
||||
objects = $(addprefix $(build), $(ann_objects) $(genann_objects) $(pln_objects) \
|
||||
$(lib_objects))
|
||||
#umb_objects = $(addprefix $(build), $(ann_objects) $(genann_objects) $(pyr_objects) \
|
||||
$(lib_objects))
|
||||
#surface_obj = $(addprefix $(build), invariants_nh3.o nncoords_nh3.o nnread.o \
|
||||
try_param.o model_dipole_nh3.o)
|
||||
# Name of the main program
|
||||
main = genANN
|
||||
|
||||
######################################################################
|
||||
### Include files
|
||||
######################################################################
|
||||
|
||||
ann_include = nncommon.incl nndbg.incl nnparams.incl
|
||||
gen_include = common.incl params.incl keylist.incl errcat.incl
|
||||
mod_include = JTmod.incl only_model.incl dip_planar_genetic.incl
|
||||
|
||||
# Misc. files generated during compilation
|
||||
trash = *__genmod* *~ *\# *.g .mod
|
||||
|
||||
$(main) : $(objects)
|
||||
ifeq ($(call file_exists,$(hell_objects)),)
|
||||
$(MAKE) hell
|
||||
endif
|
||||
$(FC) $(FFLAGS) $(hell_objects) $(objects) $(LDFLAGS) -o $(bin)$(main)
|
||||
#$(FFLAGS)
|
||||
|
||||
#pyram_ANN : $(umb_objects)
|
||||
# $(FC) $(FFLAGS) $(hell_objects) $(umb_objects) $(LDFLAGS) -o $(bin)pyram_ANN
|
||||
# compile a library for the Diabatic Dipole
|
||||
|
||||
#libdipole_surface.a : $(surface_obj) $(build)Diabatic_Dipole.o
|
||||
# ar rcs $(bin)libdipole_surface.a $(surface_obj) $(build)Diabatic_Dipole.o
|
||||
# EXPLICIT RULE FOR COMPILING
|
||||
|
||||
$(build)%.o : %.f
|
||||
$(FC) -c $(FFLAGS) $< -o $@
|
||||
$(build)%.o : %.f90
|
||||
$(FC) -c $(FFLAGS) $< -o $@
|
||||
|
||||
# add dependencies to include files
|
||||
$(ann_objects) : $(ann_include) $(lib_objects)
|
||||
$(genann_objects) : $(ann_include) $(gen_include) $(lib_objects)
|
||||
$(mod_objects) : $(ann_include) $(gen_include) $(mod_include) $(lib_objects)
|
||||
# overrule standard compilation method for hellfiles.
|
||||
$(hell_objects) : override FFLAGS=$(hell_flags)
|
||||
|
||||
nnmqo.o : axel.o
|
||||
|
||||
# making
|
||||
|
||||
.PHONY : clean dirs neat hell pyram_ANN all
|
||||
clean:
|
||||
$(RM) $(objects) $(hell_objects) $(trash) $(bin)/$(main)
|
||||
dirs:
|
||||
@mkdir -p $(build) $(bin) $(extra_dirs)
|
||||
neat:
|
||||
$(RM) -f $(TRASH)
|
||||
hell : $(hell_objects)
|
||||
|
||||
all : clean hell $(main) pyram_ANN libdipole_surface.a
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,88 @@
|
|||
module Diab_dipole
|
||||
implicit none
|
||||
contains
|
||||
|
||||
Subroutine Dipole_Diab_nn(X1,Dx,Dy)
|
||||
use ctrans_mod, only: ctrans
|
||||
implicit none
|
||||
include "nnparams.incl"
|
||||
!include "nncommon.incl"
|
||||
!include "nndbg.incl"
|
||||
double precision,intent(inout):: x1(maxnin)
|
||||
double precision,intent(out):: Dx(4,4),Dy(4,4)
|
||||
! compute the symmetric coordianate and all the invariants needed for ANN
|
||||
call ctrans(x1)
|
||||
! get the diabatic dipole matrix
|
||||
call coord2Dip(x1,Dx,Dy)
|
||||
|
||||
end subroutine Dipole_Diab_nn
|
||||
|
||||
! subroutine for DIab dipole
|
||||
subroutine coord2Dip(nn_in,Dx,Dy)
|
||||
use diabmodel, only: diab_x,diab_y
|
||||
implicit none
|
||||
include "nnparams.incl"
|
||||
include "nncommon.incl"
|
||||
include "nndbg.incl"
|
||||
include "ann.incl"
|
||||
real(8),intent(in),dimension(maxnin):: nn_in
|
||||
real(8),intent(out),dimension(4,4):: Dx,Dy
|
||||
real(8),dimension(maxnout)::nn_out
|
||||
! call neunet and propagate ANN
|
||||
call neunet(nn_in,nn_out,netpars)
|
||||
! generate dibatic matrix
|
||||
|
||||
call diab_x(nn_in,Dx,nn_out)
|
||||
call diab_y(nn_in,Dy,nn_out)
|
||||
end subroutine coord2Dip
|
||||
|
||||
|
||||
|
||||
subroutine networkpinit()
|
||||
implicit none
|
||||
include 'nnparams.incl' !this includes ANN-parameters
|
||||
include 'nncommon.incl' !this includes ANN struture restrictions
|
||||
include 'ann.incl' !this includes ANN structure variables
|
||||
!include 'netpars.incl' !this contains all network parameters
|
||||
include 'nndbg.incl' !this includes debug-mode specifics
|
||||
|
||||
!real*8 verte1,verte2,verte3
|
||||
!common /pot_vertical/verte1,verte2,verte3
|
||||
|
||||
!save /ann/,/nnio/
|
||||
!save /pnetwork/
|
||||
|
||||
!.....ANN-specific variables
|
||||
character*32 netfile
|
||||
! parameter (netfile='network')
|
||||
! parameter (netfile='Par_no35s_6D') !FF: Original parameter file for the 6D NN with b
|
||||
parameter (netfile='fit_pars') !FF: New parameter file for the 6D refitt
|
||||
|
||||
|
||||
! write in the output
|
||||
write(6,*) "# NH3Plus Dipole for 4 states"
|
||||
write(6,*) "# use the PES Of Maik"
|
||||
write(6,*) "# Last update 22.09.2025"
|
||||
write(6,*) "# Only the stretch cuts"
|
||||
call nninit_mod()
|
||||
call read_net_prim(netfile,netpars,nlay,laystr,weistr,typop)
|
||||
|
||||
!! get energies at reference point
|
||||
! nn_in=0.0d0
|
||||
! len_in=laystr(1,1)
|
||||
! len_out=laystr(1,nlay)
|
||||
!
|
||||
!! propagate ANN
|
||||
! call neunet(nn_in,nn_out,netpars)
|
||||
!! generate diabatic matrix from ANN output
|
||||
! call nndiab(nn_in,diab_matr,nn_out)
|
||||
|
||||
|
||||
|
||||
End subroutine
|
||||
subroutine nninit_mod()
|
||||
implicit none
|
||||
|
||||
include 'nnparams.incl'
|
||||
end subroutine
|
||||
end module
|
||||
|
|
@ -0,0 +1 @@
|
|||
JTmod-v1.0.incl
|
||||
|
|
@ -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)
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
****Basic data structures and special constants for ANN
|
||||
***
|
||||
*** /ann/: block containing basic structural information
|
||||
*** required for propagation etc
|
||||
***
|
||||
integer laystr(3,maxlay),typop(maxtypes,maxlay)
|
||||
integer weistr(2,maxlay,2)
|
||||
integer nlay
|
||||
real*8 netpars(wbcap)
|
||||
|
||||
common /ann/ nlay, laystr, weistr, typop
|
||||
common /pnetwork/ netpars
|
||||
|
||||
|
||||
!!! add
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,317 @@
|
|||
************************************************************************
|
||||
*** aXel
|
||||
*** convergence accelerators for ANN's Marquardt-Levenberg
|
||||
***
|
||||
************************************************************************
|
||||
|
||||
module axel
|
||||
implicit none
|
||||
contains
|
||||
|
||||
subroutine mqlimstep(wbsteps,wbnorm,gradnorm,fails,lambda,
|
||||
> mqfact,weistr,nlay)
|
||||
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
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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.
|
||||
|
||||
include 'params.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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,F8.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.
|
||||
implicit none
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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.
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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
|
||||
|
|
@ -0,0 +1,105 @@
|
|||
|
||||
|
||||
|
||||
!--------------------------------------------------------------------------------------
|
||||
|
||||
subroutine backprop(del,W,deriv,laystr,nlay)
|
||||
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
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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)
|
||||
!
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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
|
||||
|
|
@ -0,0 +1 @@
|
|||
/mnt/home.ipr/jnshuti/Documents/work/NH3+/Dipole-4-4/Dipole_NH3/Pyramidal/20few_points.genetic
|
||||
|
|
@ -0,0 +1,51 @@
|
|||
!.. npar: number of parameters
|
||||
!.. pst: starting addresses and lengths of parameter blocks
|
||||
integer 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 keynum,datpos(3,maxdat)
|
||||
character*(klen) keylist(2,maxkeys)
|
||||
character*64 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
|
||||
|
||||
double precision cutoff(maxoutp),cutwei(maxoutp)
|
||||
logical showcut
|
||||
|
||||
common /eval/ cutoff, cutwei, showcut
|
||||
Binary file not shown.
|
|
@ -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
|
||||
|
|
@ -0,0 +1,196 @@
|
|||
*** 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)
|
||||
implicit none
|
||||
! Generate error vector from adiabatic model.
|
||||
!
|
||||
! nn_out: output from neural network
|
||||
! pat_err: error vector for single pattern
|
||||
!
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
include 'nncommon.incl'
|
||||
|
||||
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)
|
||||
implicit none
|
||||
! Evaluate system specific weighting for 1 pattern.
|
||||
|
||||
include 'params.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
|
||||
include 'JTmod.incl'
|
||||
|
||||
double precision wterr(maxpout),pat_out(maxpout)
|
||||
|
||||
double precision eref(nstat)
|
||||
double precision wten(3)
|
||||
|
||||
integer j
|
||||
|
||||
wten=1
|
||||
|
||||
eref(1)=E0_sig
|
||||
eref(2:3)=E0_pi
|
||||
! eref(1:3)=eref(1:3)+600.d0*icm2hart
|
||||
eref(1:3)=eref(1:3)+1000.d0*icm2hart
|
||||
|
||||
!! kill state 2 and 3
|
||||
! wten(2:3)=0
|
||||
|
||||
do j=1,3
|
||||
! weighting of energies
|
||||
wterr(j)=wdamp(pat_out(j)-eref(j))*wterr(j)*wten(j)
|
||||
enddo
|
||||
|
||||
contains
|
||||
double precision function wdamp(dE)
|
||||
implicit none
|
||||
include 'nnparams.incl'
|
||||
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)
|
||||
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.
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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
|
||||
|
|
@ -0,0 +1,204 @@
|
|||
!**** Declarations
|
||||
|
||||
double precision pi,infty,zero
|
||||
double precision scan_res
|
||||
double precision hart2eV, eV2hart
|
||||
double precision hart2icm, icm2hart
|
||||
double precision eV2icm, icm2eV
|
||||
double precision deg2rad, rad2deg
|
||||
integer maxneu,maxlay,maxtypes,maxtpar
|
||||
integer maxpats
|
||||
integer maxnin,maxnout,maxpout
|
||||
integer maxwei,neucap,wbcap
|
||||
integer maxset, maxnnkeys
|
||||
integer maxxrmeta,xrcap
|
||||
integer iinfty
|
||||
integer iout,nnunit,perfunit,fitunit
|
||||
integer ec_error,ec_read,ec_dim,ec_log
|
||||
integer ec_dimrd
|
||||
integer record_read,record_write,record_overwrite
|
||||
integer record_update
|
||||
character*2 newline
|
||||
character*8 stdfmt
|
||||
character*8 nnldir
|
||||
character*8 nntag
|
||||
character*16 prim_tag
|
||||
character*16 nnfdir,nnsdir
|
||||
character*16 sline,asline,hline
|
||||
character*16 mform,smform,miform
|
||||
character*16 lrfmt,lifmt
|
||||
character*32 nndmpfile,nnexpfile
|
||||
character*32 nndatfile,nnreffile
|
||||
character*32 sampfile,perfile
|
||||
character*32 nnparfile,nnp10file
|
||||
character*32 nnrecfile
|
||||
!**********************************************************
|
||||
!**** 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
|
||||
|
||||
!*** WARNING: maxnout should not be > maxneu, deriv-like structures
|
||||
!*** assume so.
|
||||
parameter (maxneu=150,maxnin=20,maxnout=15)
|
||||
parameter (maxpout=15,maxset=10000)
|
||||
parameter (maxlay=3,maxtypes=2,maxtpar=1)
|
||||
parameter (maxpats=50000)
|
||||
|
||||
parameter (maxxrmeta=3)
|
||||
|
||||
!**********************************************************
|
||||
!**** 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
|
||||
|
||||
parameter (maxwei=(maxlay-3)*maxneu**2+maxneu*(maxnin+maxnout))
|
||||
parameter (neucap=(maxlay-2)*maxneu+maxnin+maxnout)
|
||||
parameter (wbcap=maxwei+neucap)
|
||||
parameter (xrcap=2+maxxrmeta)
|
||||
parameter (maxnnkeys=4*maxlay)
|
||||
|
||||
!*** 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
|
||||
|
||||
! 3.14159265358979323846264338327950...
|
||||
parameter (pi=3.1415926536D0)
|
||||
parameter (infty=huge(1.0D0),iinfty=huge(1))
|
||||
parameter (zero=1.0D-8,scan_res=1.0D-8)
|
||||
|
||||
!**********************************************************
|
||||
!**** Unit Conversion Parameters
|
||||
!*** X2Y: convert from X to Y.
|
||||
!***
|
||||
!**** !? currently inexact. FIX THIS.
|
||||
!*** hart: hartree
|
||||
!*** eV: electron volt
|
||||
!*** icm: inverse centimeters (h*c/cm)
|
||||
!****
|
||||
!*** deg: degree
|
||||
!*** rad: radians
|
||||
|
||||
parameter (hart2icm=219474.69d0)
|
||||
parameter (hart2eV=27.211385d0)
|
||||
parameter (eV2icm=hart2icm/hart2eV)
|
||||
parameter (icm2hart=1.0d0/hart2icm)
|
||||
parameter (eV2hart=1.0d0/hart2eV)
|
||||
parameter (icm2eV=1.0d0/eV2icm)
|
||||
parameter (deg2rad=pi/180.0d0)
|
||||
parameter (rad2deg=1.0d0/deg2rad)
|
||||
|
||||
!**********************************************************
|
||||
!**** 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
|
||||
|
||||
parameter (nndatfile='DATA_ANN')
|
||||
parameter (nnreffile='REF_ANN')
|
||||
parameter (nnparfile='../nnfits/fit_pars')
|
||||
parameter (nnp10file='../nnfits/fit_10p')
|
||||
parameter (nnexpfile='../nnfits/exp_pars')
|
||||
parameter (nndmpfile='../nnfits/fit_dump.dat')
|
||||
parameter (sampfile='../scans/samples.dat')
|
||||
parameter (perfile='../logs/performance.log')
|
||||
parameter (nnrecfile='../nnfits/record')
|
||||
parameter (nnfdir='../nnfits/',nnsdir='../scans/')
|
||||
parameter (nnldir='../logs/')
|
||||
parameter (nntag='',prim_tag=' Time-stamp: " "')
|
||||
|
||||
parameter (lrfmt='(ES20.12)',lifmt='(I12)')
|
||||
|
||||
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
|
||||
|
||||
parameter (sline='(75("*"))',asline='(75("#"))')
|
||||
parameter (hline='(75("-"))')
|
||||
parameter (newline='()')
|
||||
parameter (mform='(5ES12.4)',smform='(5ES10.2)')
|
||||
parameter (miform='(5I12)')
|
||||
parameter (stdfmt='(A)')
|
||||
|
||||
!**********************************************************
|
||||
!**** Continuation Parameters
|
||||
!*** record_*: Various possible values for the common block variable
|
||||
!*** record_state. See the parser for more.
|
||||
|
||||
parameter (record_read=0,record_write=1,record_overwrite=-1)
|
||||
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
|
||||
|
||||
|
||||
parameter (ec_error=1,ec_read=2,ec_dim=4,ec_log=8)
|
||||
|
||||
parameter (ec_dimrd=ec_dim+ec_read)
|
||||
|
||||
|
|
@ -0,0 +1,153 @@
|
|||
|
||||
|
||||
|
||||
|
||||
!--------------------------------------------------------------------------------------
|
||||
|
||||
subroutine propagate(W,B,L,deriv,typop,laystr,nlay)
|
||||
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
|
||||
!
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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)
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,268 @@
|
|||
!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 axel, only: renorm_input,unnorm_input
|
||||
implicit none
|
||||
include 'params.incl' !this includes the size definitions,
|
||||
!number of states and modes
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl' !this includes ANN-parameters
|
||||
include 'nncommon.incl' !this includes ANN struture variables
|
||||
include 'nndbg.incl' !this includes debug-mode specifics
|
||||
|
||||
!.....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,ntot)
|
||||
! NOTE: create API trans_out
|
||||
!.. copy reference part
|
||||
do j=1,nref
|
||||
ref_in(:,j)=pat_in(:,npat+j)
|
||||
enddo
|
||||
|
||||
!.. 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)
|
||||
|
||||
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
|
||||
|
|
@ -0,0 +1,974 @@
|
|||
|
||||
|
||||
******************************************************************************
|
||||
*** 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)
|
||||
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
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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
|
||||
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
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
|
||||
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
|
||||
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
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
|
||||
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)
|
||||
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
|
||||
!
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
include 'nncommon.incl'
|
||||
|
||||
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,A,"(#",I4.4,")")')
|
||||
> loc_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)
|
||||
|
||||
|
||||
write(6,'(/,A)') 'Done.'
|
||||
end subroutine
|
||||
|
||||
!--------------------------------------------------------------------------------------
|
||||
|
||||
subroutine NNrank(nset,nref,par,rms,ref_rms)
|
||||
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
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
include 'nncommon.incl'
|
||||
|
||||
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)
|
||||
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
|
||||
!
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
include 'nncommon.incl'
|
||||
|
||||
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)
|
||||
implicit none
|
||||
! Evaluates error of given ANN using nnmqo's mkerr subroutine,
|
||||
! and generates an output file.
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
implicit none
|
||||
! Evaluates error vector of given ANN for a *single* pattern using
|
||||
! nnmqo's mkerrvec subroutine.
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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,...
|
||||
|
||||
include 'params.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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
|
||||
!
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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
|
||||
Binary file not shown.
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
File diff suppressed because it is too large
Load Diff
Binary file not shown.
|
|
@ -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 -------------------------------
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
|
||||
integer typenum,maxtypelen
|
||||
parameter (typenum=6,maxtypelen=2)
|
||||
character*(maxtypelen) types(typenum)
|
||||
parameter (types=['I ', '+I', 'D ', '+D', 'C ', 'E '])
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1,432 @@
|
|||
subroutine mknet(laystr,weistr,neupop,nlay)
|
||||
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
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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
|
||||
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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.
|
||||
!
|
||||
include 'nnparams.incl'
|
||||
include 'params.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'common.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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.
|
||||
include 'nnparams.incl'
|
||||
include 'params.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'common.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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
|
||||
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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)
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
integer npat
|
||||
double precision wterr(maxpout,npat),pat_out(maxpout,npat)
|
||||
|
||||
character*32 fname
|
||||
integer j,k,n,total
|
||||
|
||||
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(1,k),pat_out(1,k))
|
||||
enddo
|
||||
|
||||
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
|
||||
|
|
@ -0,0 +1 @@
|
|||
../../../../Genetic/NO3/Dipole_NO3/Fit_stretch_Latest/fit_genric_bend_no3.f90
|
||||
|
|
@ -0,0 +1,82 @@
|
|||
Module invariants_mod
|
||||
implicit none
|
||||
contains
|
||||
!----------------------------------------------------
|
||||
subroutine invariants(a,xs,ys,xb,yb,b,inv)
|
||||
implicit none
|
||||
!include "nnparams.incl"
|
||||
double precision, intent(in) :: a, xs, ys, xb, yb, b
|
||||
double precision, intent(out) :: inv(3)
|
||||
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
|
||||
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 ))
|
||||
|
||||
! the only non zero invariant for bend pure cuts
|
||||
|
||||
inv(1) = invar(3)
|
||||
inv(2) = invar(8)
|
||||
inv(3) = invar(12)
|
||||
|
||||
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
|
||||
! modify the invariants to only consider few of them
|
||||
!
|
||||
!invar(13:22)=0.0d0
|
||||
end subroutine invariants
|
||||
end module invariants_mod
|
||||
|
|
@ -0,0 +1,469 @@
|
|||
module diabmodel
|
||||
!use dim_parameter,only:qn,ndiab,pst
|
||||
use iso_fortran_env, only: idp => int32, dp => real64
|
||||
!use accuracy_constants, only:dp,idp
|
||||
use dip_param, only: init_dip_planar_data, p,pst,np
|
||||
|
||||
implicit none
|
||||
include "nnparams.incl"
|
||||
integer(idp),parameter:: ndiab=5
|
||||
logical :: debug=.false.
|
||||
contains
|
||||
|
||||
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
subroutine diab_x(q,e,nn_out)
|
||||
real(dp),intent(in)::q(maxnin)
|
||||
real(dp),intent(out)::e(ndiab,ndiab)
|
||||
real(dp),intent(inout):: nn_out(maxnout)
|
||||
integer(idp) id,i,j, ii, non_zer_p
|
||||
real(dp) xs,xb,ys,yb,a,b,ss,sb,v3(8),v2(6)
|
||||
xs=q(5)
|
||||
ys=q(6)
|
||||
xb=q(7)
|
||||
yb=q(8)
|
||||
a=q(4)
|
||||
b=q(9)
|
||||
|
||||
call init_dip_planar_data()
|
||||
non_zer_p = count(p /= 0.0d0)
|
||||
|
||||
ii=1
|
||||
do i=1,np-2
|
||||
if (p(i) .ne. 0) then
|
||||
p(i) =p(i)*(1.0_dp + 1.0d-2 + nn_out(ii))
|
||||
ii=ii+1
|
||||
else
|
||||
p(i)=p(i)
|
||||
endif
|
||||
enddo
|
||||
ss=xs**2+ys**2 ! totaly symmetric term
|
||||
sb=xb**2+yb**2
|
||||
v2(1)=xs**2-ys**2
|
||||
v2(2)=xb**2-yb**2
|
||||
v2(3)=xs*xb-ys*yb
|
||||
v2(4)=2*xs*ys
|
||||
v2(5)=2*xb*yb
|
||||
v2(6)=xs*yb+xb*ys
|
||||
|
||||
v3( 1) = xs*(xs**2-3*ys**2)
|
||||
v3( 2) = xb*(xb**2-3*yb**2)
|
||||
v3( 3) = xb*(xs**2-ys**2) - 2*yb*xs*ys
|
||||
v3( 4) = xs*(xb**2-yb**2) - 2*ys*xb*yb
|
||||
v3( 5) = ys*(3*xs**2-ys**2)
|
||||
v3( 6) = yb*(3*xb**2-yb**2)
|
||||
v3( 7) = yb*(xs**2-ys**2)+2*xb*xs*ys
|
||||
v3( 8) = ys*(xb**2-yb**2)+2*xs*xb*yb
|
||||
|
||||
|
||||
|
||||
e=0.0d0
|
||||
id=1 ! 1
|
||||
e(1,1)=e(1,1)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb ! 2 param
|
||||
id=id+1 ! 2
|
||||
e(2,2)=e(2,2)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb ! 2 p
|
||||
e(3,3)=e(3,3)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb
|
||||
id =id+1 ! 3
|
||||
e(4,4)=e(4,4)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb ! 2 p
|
||||
e(5,5)=e(5,5)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb
|
||||
|
||||
|
||||
id=id+1 ! 4
|
||||
! order 2
|
||||
e(1,1)=e(1,1)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) & ! 5 p
|
||||
+p(pst(1,id)+2)*(xs*xb-ys*yb)
|
||||
id =id+1 ! 5
|
||||
e(2,2)=e(2,2)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) &
|
||||
+p(pst(1,id)+2)*(xs*xb-ys*yb)
|
||||
e(3,3)=e(3,3)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) &
|
||||
+p(pst(1,id)+2)*(xs*xb-ys*yb)
|
||||
id =id+1 ! 6
|
||||
e(4,4)=e(4,4)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) &
|
||||
+p(pst(1,id)+2)*(xs*xb-ys*yb)
|
||||
e(5,5)=e(5,5)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) &
|
||||
+p(pst(1,id)+2)*(xs*xb-ys*yb)
|
||||
! order 3
|
||||
id=id+1 ! 7
|
||||
e(1,1)=e(1,1)+p(pst(1,id))*xs*ss+p(pst(1,id)+1)*xb *sb ! 2 param
|
||||
id=id+1 ! 8
|
||||
e(2,2)=e(2,2)+p(pst(1,id))*xs*ss+p(pst(1,id)+1)*xb *sb ! 2 p
|
||||
e(3,3)=e(3,3)+p(pst(1,id))*xs*ss+p(pst(1,id)+1)*xb*sb
|
||||
id =id+1 ! 9
|
||||
e(4,4)=e(4,4)+p(pst(1,id))*xs*ss+p(pst(1,id)+1)*xb*sb ! 2 p
|
||||
e(5,5)=e(5,5)+p(pst(1,id))*xs*ss+p(pst(1,id)+1)*xb*sb
|
||||
|
||||
|
||||
! W and Z term of E1
|
||||
! order 0
|
||||
id=id+1 ! 10
|
||||
e(2,2)=e(2,2)+p(pst(1,id))
|
||||
e(3,3)=e(3,3)-p(pst(1,id))
|
||||
!e(2,3)=e(2,3)
|
||||
|
||||
! order 1
|
||||
id=id+1 ! 11 ! 2 param
|
||||
e(2,2)=e(2,2)+ p(pst(1,id))*xs+p(pst(1,id)+1)*xb
|
||||
e(3,3)=e(3,3)- (p(pst(1,id))*xs+p(pst(1,id)+1)*xb)
|
||||
e(2,3)=e(2,3)- p(pst(1,id))*ys -p(pst(1,id)+1)*yb
|
||||
! order 2
|
||||
id=id+1 ! 12 ! 3p
|
||||
do i=1,3
|
||||
e(2,2)=e(2,2)+p(pst(1,id)+(i-1))*v2(i)
|
||||
e(3,3)=e(3,3)-p(pst(1,id)+(i-1))*v2(i)
|
||||
e(2,3)=e(2,3)+ p(pst(1,id)+(i-1))*v2(i+3)
|
||||
enddo
|
||||
! order 3
|
||||
id=id+1 ! 13 ! 8 param
|
||||
do i=1,4
|
||||
e(2,2)=e(2,2)+(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3(i)
|
||||
e(3,3)=e(3,3)-(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3(i)
|
||||
e(2,3)=e(2,3)+(-p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3(i+4)
|
||||
enddo
|
||||
|
||||
! try the testing of higher order terms
|
||||
!e(2,3)=e(2,3)- p(pst(1,id))*ys*ss +p(pst(1,id)+1)*ss*2*xs*ys
|
||||
|
||||
|
||||
|
||||
|
||||
! W and Z for E2
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
id=id+1 ! 14
|
||||
e(4,4)=e(4,4)+p(pst(1,id))
|
||||
e(5,5)=e(5,5)-p(pst(1,id))
|
||||
e(4,5)=e(4,5)
|
||||
|
||||
! order 1
|
||||
id=id+1 ! 2 param 15
|
||||
e(4,4)=e(4,4)+ p(pst(1,id))*xs+p(pst(1,id)+1)*xb
|
||||
e(5,5)=e(5,5)- (p(pst(1,id))*xs+p(pst(1,id)+1)*xb)
|
||||
e(4,5)=e(4,5)- p(pst(1,id))*ys-p(pst(1,id)+1)*yb
|
||||
! order 2
|
||||
id=id+1 ! 16 ! 3p
|
||||
do i=1,3
|
||||
e(4,4)=e(4,4)+p(pst(1,id)+(i-1))*v2(i)
|
||||
e(5,5)=e(5,5)-p(pst(1,id)+(i-1))*v2(i)
|
||||
e(4,5)=e(4,5)+ p(pst(1,id)+(i-1))*v2(i+3)
|
||||
enddo
|
||||
|
||||
! order 3
|
||||
id=id+1 ! 17 ! 8 param
|
||||
do i=1,4
|
||||
e(4,4)=e(4,4)+(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3(i)
|
||||
e(5,5)=e(5,5)-(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3(i)
|
||||
e(4,5)=e(4,5)+(-p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3(i+4)
|
||||
enddo
|
||||
|
||||
!e(4,4) = e(4,4)+ p(pst(1,id))*xs*ss + p(pst(1,id)+1)*xb*sb
|
||||
!e(5,5)=e(5,5)- (p(pst(1,id))*xs*ss + p(pst(1,id)+1)*xb*sb)
|
||||
!e(4,5)=e(4,5)- p(pst(1,id))*ys*ss -p(pst(1,id)+1)*yb*sb
|
||||
|
||||
! E1 X E2
|
||||
! WW and ZZ
|
||||
|
||||
|
||||
id =id+1 ! 18
|
||||
e(2,4)=e(2,4)+p(pst(1,id))*b
|
||||
e(3,5)=e(3,5)-p(pst(1,id))*b
|
||||
|
||||
! ORDER 1
|
||||
id=id+1 ! 19 ! 6 parama
|
||||
e(2,4)=e(2,4)+b*((p(pst(1,id))+p(pst(1,id)+1)+p(pst(1,id)+2))*xs+(p(pst(1,id)+3)+p(pst(1,id)+4)+p(pst(1,id)+5))*xb)
|
||||
e(3,5)=e(3,5)+b*((p(pst(1,id))+p(pst(1,id)+1)-p(pst(1,id)+2))*xs+(p(pst(1,id)+3)+p(pst(1,id)+4)-p(pst(1,id)+5))*xb)
|
||||
e(2,5)=e(2,5)+b*((p(pst(1,id))-p(pst(1,id)+1)-p(pst(1,id)+2))*ys+(p(pst(1,id)+3)-p(pst(1,id)+4)-p(pst(1,id)+5))*yb)
|
||||
e(3,4)=e(3,4)+b*((-p(pst(1,id))+p(pst(1,id)+1)-p(pst(1,id)+2))*ys+(-p(pst(1,id)+3)+p(pst(1,id)+4)-p(pst(1,id)+5))*yb)
|
||||
! order 2
|
||||
id=id+1 ! 20
|
||||
|
||||
do i=1,3 ! 9 param
|
||||
e(2,4)=e(2,4)+b*(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+2))+p(pst(1,id)+(i+5)))*v2(i)
|
||||
e(3,5)=e(3,5)+b*(-p(pst(1,id)+(i-1))+p(pst(1,id)+(i+2))+p(pst(1,id)+(i+5)))*v2(i)
|
||||
e(2,5)=e(2,5)+b*(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+2))-p(pst(1,id)+(i+5)))*v2(i+3)
|
||||
e(3,4)=e(3,4)+b*(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+2))+p(pst(1,id)+(i+5)))*v2(i+3)
|
||||
enddo
|
||||
|
||||
! pseudo A2 & E1
|
||||
! ##################################################
|
||||
!###################################################
|
||||
! order 0
|
||||
id=id+1 ! 1 param ! 21
|
||||
|
||||
e(1,3)=e(1,3)+b*(p(pst(1,id)))
|
||||
|
||||
! order 1
|
||||
id = id +1 ! 22
|
||||
e(1,2)=e(1,2)-b*(p(pst(1,id))*ys + p(pst(1,id)+1)*yb)
|
||||
e(1,3)=e(1,3)+b*(p(pst(1,id))*xs + p(pst(1,id)+1)*xb)
|
||||
|
||||
! order 2
|
||||
id=id+1 ! 23
|
||||
|
||||
e(1,2)=e(1,2)+b*(p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)+p(pst(1,id)+2)*(xs*yb+xb*ys))
|
||||
e(1,3)=e(1,3)+b*(p(pst(1,id))*(xs**2-ys**2) + p(pst(1,id)+1)*(xb**2-yb**2) &
|
||||
+p(pst(1,id)+2)*(xs*xb-ys*yb))
|
||||
|
||||
! COUPLING OF A2 WITH E2
|
||||
|
||||
!##########################################################################################################
|
||||
|
||||
! order 0
|
||||
id =id+1 !24
|
||||
e(1,5)=e(1,5)+p(pst(1,id))
|
||||
|
||||
! order 1
|
||||
id = id +1 ! 25
|
||||
e(1,4)=e(1,4)-(p(pst(1,id))*ys + p(pst(1,id)+1)*yb)
|
||||
e(1,5)=e(1,5)+(p(pst(1,id))*xs + p(pst(1,id)+1)*xb)
|
||||
|
||||
! order 2
|
||||
id=id+1 ! 26
|
||||
|
||||
e(1,4)=e(1,4)+p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)+p(pst(1,id)+2)*(xs*yb+xb*ys)
|
||||
e(1,5)=e(1,5)+p(pst(1,id))*(xs**2-ys**2) + p(pst(1,id)+1)*(xb**2-yb**2) &
|
||||
+p(pst(1,id)+2)*(xs*xb-ys*yb)
|
||||
|
||||
! order 3
|
||||
id=id+1 ! 27 ! 8 param
|
||||
do i=1,4
|
||||
e(1,4)=e(1,4)+(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+3)))*v3(i+4)
|
||||
e(1,5)=e(1,5)+(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3(i)
|
||||
|
||||
enddo
|
||||
|
||||
|
||||
call copy_2_lower_triangle(e)
|
||||
!temp = e(2,2)
|
||||
!e(2,2)=e(3,3)
|
||||
!e(3,3)=temp
|
||||
if (debug) then
|
||||
do i=1,ndiab
|
||||
write(34,'(5f14.6)') (e(i,j),j=1,ndiab)
|
||||
enddo
|
||||
write(34,*)""
|
||||
endif
|
||||
|
||||
end subroutine diab_x
|
||||
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! THE Y COMPONENT OF DIPOLE
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
subroutine diab_y(q,e,nn_out)
|
||||
real(dp),intent(in)::q(maxnin)
|
||||
real(dp),intent(out)::e(ndiab,ndiab)
|
||||
real(dp),intent(inout):: nn_out(maxnout)
|
||||
integer(idp) id,i,j, ii, non_zer_p
|
||||
real(dp) xs,xb,ys,yb,a,b,ss,sb,v3(8),v2(6)
|
||||
xs=q(5)
|
||||
ys=q(6)
|
||||
xb=q(7)
|
||||
yb=q(8)
|
||||
a=q(4)
|
||||
b=q(9)
|
||||
|
||||
call init_dip_planar_data()
|
||||
non_zer_p = count(p /= 0.0d0)
|
||||
|
||||
ii=1
|
||||
do i=1,np-2
|
||||
if (p(i) .ne. 0) then
|
||||
p(i) =p(i)*(1.0_dp + 1.0d-2 + nn_out(ii))
|
||||
ii=ii+1
|
||||
else
|
||||
p(i)=p(i)
|
||||
endif
|
||||
enddo
|
||||
ss=xs**2+ys**2 ! totaly symmetric term
|
||||
sb=xb**2+yb**2
|
||||
v2(1)=xs**2-ys**2
|
||||
v2(2)=xb**2-yb**2
|
||||
v2(3)=xs*xb-ys*yb
|
||||
v2(4)=2*xs*ys
|
||||
v2(5)=2*xb*yb
|
||||
v2(6)=xs*yb+xb*ys
|
||||
|
||||
|
||||
v3( 1) = xs*(xs**2-3*ys**2)
|
||||
v3( 2) = xb*(xb**2-3*yb**2)
|
||||
v3( 3) = xb*(xs**2-ys**2) - 2*yb*xs*ys
|
||||
v3( 4) = xs*(xb**2-yb**2) - 2*ys*xb*yb
|
||||
v3( 5) = ys*(3*xs**2-ys**2)
|
||||
v3( 6) = yb*(3*xb**2-yb**2)
|
||||
v3( 7) = yb*(xs**2-ys**2)+2*xb*xs*ys
|
||||
v3( 8) = ys*(xb**2-yb**2)+2*xs*xb*yb
|
||||
|
||||
e=0.0d0
|
||||
! V-term
|
||||
|
||||
id=1 ! 1
|
||||
! order 1
|
||||
e(1,1)=e(1,1)+p(pst(1,id))*ys + p(pst(1,id)+1)*yb
|
||||
id=id+1 ! 2
|
||||
e(2,2)=e(2,2)+p(pst(1,id))*ys + p(pst(1,id)+1)*yb
|
||||
e(3,3)=e(3,3)+p(pst(1,id))*ys + p(pst(1,id)+1)*yb
|
||||
id =id+1 ! 3
|
||||
e(4,4)=e(4,4)+p(pst(1,id))*ys + p(pst(1,id)+1)*yb
|
||||
e(5,5)=e(5,5)+p(pst(1,id))*ys + p(pst(1,id)+1)*yb
|
||||
|
||||
id=id+1 ! 4b*(
|
||||
e(1,1)=e(1,1)-(p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)+p(pst(1,id)+2)*(xs*yb+xb*ys))
|
||||
id =id+1 ! 5
|
||||
e(2,2)=e(2,2)-(p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)+p(pst(1,id)+2)*(xs*yb+xb*ys))
|
||||
e(3,3)=e(3,3)-(p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)+p(pst(1,id)+2)*(xs*yb+xb*ys))
|
||||
id=id+1 ! 6
|
||||
e(4,4)=e(4,4)-(p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)+p(pst(1,id)+2)*(xs*yb+xb*ys))
|
||||
e(5,5)=e(5,5)-(p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)+p(pst(1,id)+2)*(xs*yb+xb*ys))
|
||||
! order 3
|
||||
id=id+1 ! 7
|
||||
|
||||
e(1,1)=e(1,1)+p(pst(1,id))*ys*ss + p(pst(1,id)+1)*yb*sb
|
||||
id=id+1 ! 2
|
||||
e(2,2)=e(2,2)+p(pst(1,id))*ys*ss + p(pst(1,id)+1)*yb*sb
|
||||
e(3,3)=e(3,3)+p(pst(1,id))*ys*ss + p(pst(1,id)+1)*yb*sb
|
||||
id =id+1 ! 3
|
||||
e(4,4)=e(4,4)+p(pst(1,id))*ys*ss + p(pst(1,id)+1)*yb*sb
|
||||
e(5,5)=e(5,5)+p(pst(1,id))*ys*ss + p(pst(1,id)+1)*yb*sb
|
||||
|
||||
! W and Z of E1
|
||||
! order 0
|
||||
id=id+1 ! 10
|
||||
e(2,3)=e(2,3)+p(pst(1,id))
|
||||
! order 1
|
||||
id=id+1 !
|
||||
e(2,2)=e(2,2)-p(pst(1,id))*ys -p(pst(1,id)+1)*yb
|
||||
e(3,3)=e(3,3)+p(pst(1,id))*ys+ p(pst(1,id)+1)*yb
|
||||
e(2,3)=e(2,3)-p(pst(1,id))*xs -p(pst(1,id)+1)*xb
|
||||
! order 2
|
||||
id=id+1 ! 12
|
||||
do i=1,3
|
||||
e(2,2)=e(2,2)+p(pst(1,id)+(i-1))*v2(i+3)
|
||||
e(3,3)=e(3,3)-p(pst(1,id)+(i-1))*v2(i+3)
|
||||
e(2,3)=e(2,3)-p(pst(1,id)+(i-1))*v2(i)
|
||||
enddo
|
||||
|
||||
id=id+1 ! 8
|
||||
do i=1,4
|
||||
e(2,2)=e(2,2)+(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+3)))*v3(i+4)
|
||||
e(3,3)=e(3,3)-(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+3)))*v3(i+4)
|
||||
e(2,3)=e(2,3)+(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3(i)
|
||||
enddo
|
||||
|
||||
|
||||
!! W and Z of E2
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! order 0
|
||||
id=id+1 ! 14
|
||||
e(4,5)=e(4,5)+p(pst(1,id))
|
||||
! order 1
|
||||
id=id+1 ! 15
|
||||
e(4,4)=e(4,4)-p(pst(1,id))*ys -p(pst(1,id)+1)*yb
|
||||
e(5,5)=e(5,5)+p(pst(1,id))*ys+ p(pst(1,id)+1)*yb
|
||||
e(4,5)=e(4,5)-p(pst(1,id))*xs -p(pst(1,id)+1)*xb
|
||||
! order 2
|
||||
id=id+1 ! 16
|
||||
do i=1,3
|
||||
e(4,4)=e(4,4)+p(pst(1,id)+(i-1))*v2(i+3)
|
||||
e(5,5)=e(5,5)-p(pst(1,id)+(i-1))*v2(i+3)
|
||||
e(4,5)=e(4,5)-p(pst(1,id)+(i-1))*v2(i)
|
||||
enddo
|
||||
|
||||
id=id+1 ! 17
|
||||
do i=1,4
|
||||
e(4,4)=e(4,4)+(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+3)))*v3(i+4)
|
||||
e(5,5)=e(5,5)-(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+3)))*v3(i+4)
|
||||
e(4,5)=e(4,5)+(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3(i)
|
||||
enddo
|
||||
! PSEUDO JAHN-TELLER E1 AND E2
|
||||
|
||||
!ORDER 0
|
||||
id=id+1 ! 18
|
||||
|
||||
e(2,5)=e(2,5)+p(pst(1,id))*b
|
||||
e(3,4)=e(3,4)+p(pst(1,id))*b
|
||||
! order 1
|
||||
|
||||
id=id+1
|
||||
e(2,4)=e(2,4)+b*((p(pst(1,id))+p(pst(1,id)+1)-p(pst(1,id)+2))*ys+(p(pst(1,id)+3)+p(pst(1,id)+4)-p(pst(1,id)+5))*yb)
|
||||
e(3,5)=e(3,5)+b*((p(pst(1,id))+p(pst(1,id)+1)+p(pst(1,id)+2))*ys+(p(pst(1,id)+3)+p(pst(1,id)+4)+p(pst(1,id)+5))*yb)
|
||||
e(2,5)=e(2,5)+b*((-p(pst(1,id))+p(pst(1,id)+1)-p(pst(1,id)+2))*xs+(-p(pst(1,id)+3)+p(pst(1,id)+4)-p(pst(1,id)+5))*xb)
|
||||
e(3,4)=e(3,4)+b*((p(pst(1,id))-p(pst(1,id)+1)-p(pst(1,id)+2))*xs+(+p(pst(1,id)+3)-p(pst(1,id)+4)-p(pst(1,id)+5))*xb)
|
||||
|
||||
! order 2
|
||||
id=id+1
|
||||
|
||||
e(2,4)=e(2,4)+(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+2))-p(pst(1,id)+(i+5)))*v2(i+3)*b
|
||||
e(3,5)=e(3,5)+(-p(pst(1,id)+(i-1))-p(pst(1,id)+(i+2))-p(pst(1,id)+(i+5)))*v2(i+3)*b
|
||||
e(2,5)=e(2,5)+(-p(pst(1,id)+(i-1))+p(pst(1,id)+(i+2))-p(pst(1,id)+(i+5)))*v2(i)*b
|
||||
e(3,4)=e(3,4)+(-p(pst(1,id)+(i-1))-p(pst(1,id)+(i+2))+p(pst(1,id)+(i+5)))*v2(i)*b
|
||||
|
||||
! no order 3
|
||||
!!!!!!!!!!!!!!!!
|
||||
|
||||
! the coupling A2 & E1
|
||||
! #####################
|
||||
! order 0
|
||||
|
||||
id=id+1
|
||||
e(1,2)=e(1,2)+b*(p(pst(1,id)))
|
||||
! order 1
|
||||
|
||||
id=id+1
|
||||
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
|
||||
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))
|
||||
|
||||
! COUPLING OF A2 WITH E2
|
||||
!#######################################################################################
|
||||
!###############################################################################
|
||||
! order 0
|
||||
|
||||
id = id+1
|
||||
e(1,4)=e(1,4)+p(pst(1,id))
|
||||
! order 1
|
||||
|
||||
id=id+1
|
||||
e(1,4)=e(1,4)-(p(pst(1,id))*xs + p(pst(1,id)+1)*xb)
|
||||
e(1,5)=e(1,5)-(p(pst(1,id))*ys + p(pst(1,id)+1)*yb)
|
||||
|
||||
! order 2
|
||||
id=id+1
|
||||
e(1,4)=e(1,4)-(p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) &
|
||||
+p(pst(1,id)+2)*(xs*xb-ys*yb))
|
||||
e(1,5)=e(1,5)+(p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)+ &
|
||||
p(pst(1,id)+2)*(xs*yb+xb*ys))
|
||||
|
||||
!write(*,*)'idy=',id
|
||||
call copy_2_lower_triangle(e)
|
||||
|
||||
if (debug) then
|
||||
do i=1,ndiab
|
||||
write(*,'(5f14.6)') (e(i,j),j=1,ndiab)
|
||||
enddo
|
||||
write(*,*)""
|
||||
endif
|
||||
end subroutine diab_y
|
||||
|
||||
|
||||
subroutine copy_2_lower_triangle(mat)
|
||||
real(dp), intent(inout) :: mat(:, :)
|
||||
integer :: m, n
|
||||
! write lower triangle of matrix symmetrical
|
||||
do n=1,size(mat,1)
|
||||
do m=n,size(mat,1)
|
||||
mat(m,n)=mat(n,m)
|
||||
enddo
|
||||
enddo
|
||||
end subroutine copy_2_lower_triangle
|
||||
|
||||
end module diabmodel
|
||||
|
|
@ -0,0 +1,63 @@
|
|||
subroutine nninit_mod()
|
||||
implicit none
|
||||
|
||||
include 'nnparams.incl'
|
||||
end subroutine
|
||||
|
||||
|
||||
subroutine nnadia(coords,coeffs,adiaoutp)
|
||||
USE diabmodel, only: diab_x
|
||||
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 'nnparams.incl'
|
||||
include 'JTmod.incl'
|
||||
integer ndiab
|
||||
parameter ndiab=5
|
||||
DOUBLE PRECISION coords(maxnin),coeffs(maxnout)
|
||||
DOUBLE PRECISION adiaoutp(maxpout),dmat_x(ndiab,ndiab)
|
||||
!DOUBLE PRECISION dmat_y(ndiab,ndiab)
|
||||
!integer i,j,ii
|
||||
call diab_x(coords,dmat_x,coeffs)
|
||||
!call diab_y(coords,dmat_y,coeffs)
|
||||
|
||||
! rewrite the diabatic matrix into 1D array of adiaoutp
|
||||
!ii=1
|
||||
!do i=1,ndiab
|
||||
!do j=i,ndiab
|
||||
! adiaoutp(ii)=dmat_x(i,j)
|
||||
! adiaoutp(ii+10) = -1*dmat_y(i,j)
|
||||
! ii=ii+1
|
||||
!enddo
|
||||
!enddo
|
||||
adiaoutp(1) = dmat_x(1,1)
|
||||
adiaoutp(2) = dmat_x(2,1)
|
||||
adiaoutp(3) = dmat_x(2,2)
|
||||
adiaoutp(4) = dmat_x(3,1)
|
||||
adiaoutp(5) = dmat_x(3,2)
|
||||
adiaoutp(6) = dmat_x(3,3)
|
||||
adiaoutp(7) = dmat_x(4,1)
|
||||
adiaoutp(8) = dmat_x(4,2)
|
||||
adiaoutp(9) = dmat_x(4,3)
|
||||
adiaoutp(10) = dmat_x(4,4)
|
||||
adiaoutp(11) = dmat_x(5,1)
|
||||
adiaoutp(12) = dmat_x(5,2)
|
||||
adiaoutp(13) = dmat_x(5,3)
|
||||
adiaoutp(14) = dmat_x(5,4)
|
||||
adiaoutp(15) = dmat_x(5,5)
|
||||
|
||||
!write(*,*) dmat_x(1,1)
|
||||
END SUBROUTINE
|
||||
|
||||
|
|
@ -0,0 +1,716 @@
|
|||
|
||||
!--------------------------------------------------------------------------------------
|
||||
|
||||
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
! % SUBROUTINE CTRANS(...)
|
||||
! %
|
||||
! % M. Vossel 21.03.2023
|
||||
! %
|
||||
! % Routine to transform symmetryinput coordinates to symmetrized
|
||||
! % coordinates. Distances Are discribet by Morse coordinates or
|
||||
! % TMC depending on Set Parameters in the Genetic Input.
|
||||
! %
|
||||
! % input variables
|
||||
! % q:
|
||||
! % q(1): H1x
|
||||
! % q(2): y
|
||||
! % q(3): z
|
||||
! % q(4): H2x
|
||||
! % q(5): y
|
||||
! % q(6): z
|
||||
! % q(7): H3x
|
||||
! % q(8): y
|
||||
! % q(9): z
|
||||
!
|
||||
!
|
||||
!
|
||||
! % Internal variables:
|
||||
! % t: primitive coordinates (double[qn])
|
||||
! % t(1):
|
||||
! % t(2):
|
||||
! % t(3):
|
||||
! % t(4):
|
||||
! % t(5):
|
||||
! % t(6):
|
||||
! % t(7):
|
||||
! % t(8):
|
||||
! % t(9):
|
||||
! % t: dummy (double[qn])
|
||||
! % p: parameter vector
|
||||
! % npar: length of parameter vector
|
||||
! %
|
||||
! % Output variables
|
||||
! % s: symmetrized coordinates (double[qn])
|
||||
! % s(1): CH-symetric streatch
|
||||
! % s(2): CH-asymetric streatch-ex
|
||||
! % s(3): CH-asymetric streatch-ey
|
||||
! % s(4): CH-bend-ex
|
||||
! % s(5): CH-bend-ey
|
||||
! % s(6): CH-umbrella
|
||||
! % s(7): CH-umbrella**2
|
||||
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
module ctrans_mod
|
||||
implicit none
|
||||
include 'only_model.incl'
|
||||
include 'nnparams.incl'
|
||||
! precalculate pi, 2*pi and angle to radian conversion
|
||||
double precision, parameter :: pii = 4.00d0*datan(1.00d0)
|
||||
double precision, parameter :: pi2 = 2.00d0*pii
|
||||
double precision, parameter :: ang2rad = pii/180.00d0
|
||||
! precalculate roots
|
||||
double precision, parameter:: sq2 = 1.00d0/dsqrt(2.00d0)
|
||||
double precision, parameter:: sq3 = 1.00d0/dsqrt(3.00d0)
|
||||
double precision, parameter:: sq6 = 1.00d0/dsqrt(6.00d0)
|
||||
! change distances for equilibrium
|
||||
double precision, parameter :: dchequi = 2.344419d0
|
||||
|
||||
contains
|
||||
subroutine ctrans(q)
|
||||
!use dim_parameter, only: qn
|
||||
use invariants_mod, only: invariants
|
||||
integer k !running indices
|
||||
double precision, intent(inout) :: q(maxnin) !given coordinates
|
||||
double precision :: s(maxnin) !output coordinates symmetry adapted and scaled
|
||||
double precision :: t(maxnin) !output coordinates symmetry adapted but not scaled
|
||||
! ANN Variables
|
||||
!double precision, optional, intent(out) :: invariants(:)
|
||||
! kartesian coordianates copy from MeF+ so substitute c by n and removed f
|
||||
double precision ch1(3), ch2(3), ch3(3), c_atom(3)
|
||||
double precision nh1(3), nh2(3), nh3(3)
|
||||
double precision zaxis(3), xaxis(3), yaxis(3)
|
||||
double precision ph1(3), ph2(3), ph3(3)
|
||||
! primitive coordinates
|
||||
double precision dch1, dch2, dch3 !nh-distances
|
||||
double precision umb !Umbrella Angle from xy-plane
|
||||
|
||||
! Symmetry coordinates
|
||||
double precision aR !a1-modes H-Dist.,
|
||||
double precision exR, exAng !ex components H-Dist., H-Ang.
|
||||
double precision eyR, eyAng !ey components H-Dist., H-Ang.
|
||||
double precision inv(3)
|
||||
! debugging
|
||||
logical, parameter :: dbg = .false.
|
||||
|
||||
! initialize coordinate vectors
|
||||
s = 0.0d0
|
||||
t = 0.0d0
|
||||
|
||||
! write kartesian coords for readability
|
||||
c_atom(1:3) = q(1:3) ! N-atom at origin
|
||||
do k = 1, 3
|
||||
ch1(k) = q(k + 3)
|
||||
ch2(k) = q(k + 6)
|
||||
ch3(k) = q(k + 9)
|
||||
end do
|
||||
q=0.d0
|
||||
|
||||
! construct z-axis
|
||||
nh1 = normalized(ch1)
|
||||
nh2 = normalized(ch2)
|
||||
nh3 = normalized(ch3)
|
||||
zaxis = create_plane(nh1, nh2, nh3)
|
||||
|
||||
! calculate bonding distance
|
||||
dch1 = norm(ch1)
|
||||
dch2 = norm(ch2)
|
||||
dch3 = norm(ch3)
|
||||
|
||||
! construct symmertic and antisymmetric strech
|
||||
aR = symmetrize(dch1 - dchequi, dch2 - dchequi, dch3 - dchequi, 'a')
|
||||
exR = symmetrize(dch1, dch2, dch3, 'x')
|
||||
eyR = symmetrize(dch1, dch2, dch3, 'y')
|
||||
|
||||
! construc x-axis and y axis
|
||||
ph1 = normalized(project_point_into_plane(nh1, zaxis, c_atom))
|
||||
xaxis = normalized(ph1)
|
||||
yaxis = xproduct(zaxis, xaxis) ! right hand side koordinates
|
||||
|
||||
! project H atoms into C plane
|
||||
ph2 = normalized(project_point_into_plane(nh2, zaxis, c_atom))
|
||||
ph3 = normalized(project_point_into_plane(nh3, zaxis, c_atom))
|
||||
|
||||
call construct_HBend(exAng, eyAng, ph1, ph2, ph3, xaxis, yaxis)
|
||||
umb = construct_umbrella(nh1, nh2, nh3, zaxis)
|
||||
|
||||
! set symmetry coordinates and even powers of umbrella
|
||||
!s(1) = dch1-dchequi!aR
|
||||
!s(2) = dch2-dchequi!exR
|
||||
!s(3) = dch3-dchequi!eyR
|
||||
! call invariants and get them
|
||||
! 24 invariants
|
||||
|
||||
call invariants(0.0d0,exR,eyR,exAng,eyAng,umb,inv)
|
||||
q(1:3)=inv(1:3)
|
||||
q(4) = aR
|
||||
q(5) = exR
|
||||
q(6) = eyR
|
||||
q(7) = exAng
|
||||
q(8) = -1.0d0*eyAng
|
||||
q(9) = umb
|
||||
! pairwise distances as second coordinate set
|
||||
!call pair_distance(q, t(1:6))
|
||||
|
||||
!if (dbg) write (6, '("sym coords s=",9f16.8)') s(1:qn)
|
||||
!if (dbg) write (6, '("sym coords t=",9f16.8)') t(1:qn)
|
||||
!if (present(invariants)) then
|
||||
! call get_invariants(s, invariants)
|
||||
!end if
|
||||
! RETURN Q AS INTERNAL COORD
|
||||
end subroutine ctrans
|
||||
! subroutine ctrans(q)
|
||||
! use invariants_mod, only: invariants
|
||||
! implicit none
|
||||
! double precision, intent(inout):: q(maxnin)
|
||||
! double precision:: invar(24)
|
||||
! double precision:: a,b,esx,esy,ebx,eby
|
||||
! a=q(1)
|
||||
! esx=q(2)
|
||||
! esy=q(3)
|
||||
! ebx=q(4)
|
||||
! eby=q(5)
|
||||
! b=q(6)
|
||||
! call invariants(a,esx,esy,ebx,eby,b,invar)
|
||||
!
|
||||
! q(1:24)=invar(1:24)
|
||||
! q(25)=esx
|
||||
! q(26)=esy
|
||||
! q(27)=ebx
|
||||
! q(28)=eby
|
||||
! q(29)=b
|
||||
! end subroutine ctrans
|
||||
subroutine pair_distance(q, r)
|
||||
double precision, intent(in) :: q(9)
|
||||
double precision, intent(out) :: r(6)
|
||||
double precision :: atom(3, 4)
|
||||
integer :: n, k, count
|
||||
|
||||
!atom order: H1 H2 H3 N
|
||||
atom(:, 1:3) = reshape(q, [3, 3])
|
||||
atom(:, 4) = (/0.00d0, 0.00d0, 0.00d0/)
|
||||
|
||||
! disntace order 12 13 14 23 24 34
|
||||
count = 0
|
||||
do n = 1, size(atom, 2)
|
||||
do k = n + 1, size(atom, 2)
|
||||
count = count + 1
|
||||
r(count) = sqrt(sum((atom(:, k) - atom(:, n))**2))
|
||||
end do
|
||||
end do
|
||||
end subroutine pair_distance
|
||||
|
||||
function morse_and_symmetrize(x,p,pst) result(s)
|
||||
double precision, intent(in),dimension(3) :: x
|
||||
double precision, intent(in),dimension(11) :: p
|
||||
integer, intent(in),dimension(2) :: pst
|
||||
integer :: k
|
||||
double precision, dimension(3) :: s
|
||||
double precision, dimension(3) :: t
|
||||
|
||||
! Morse transform
|
||||
do k=1,3
|
||||
t(k) = morse_transform(x(k), p, pst)
|
||||
end do
|
||||
s(1) = symmetrize(t(1), t(2), t(3), 'a')
|
||||
s(2) = symmetrize(t(1), t(2), t(3), 'x')
|
||||
s(3) = symmetrize(t(1), t(2), t(3), 'y')
|
||||
end function morse_and_symmetrize
|
||||
|
||||
! subroutine get_invariants(s, inv_out)
|
||||
! use dim_parameter, only: qn
|
||||
! use select_monom_mod, only: v_e_monom, v_ee_monom
|
||||
! double precision, intent(in) :: s(qn)
|
||||
! double precision, intent(out) :: inv_out(:)
|
||||
! ! double precision, parameter :: ck = 1.00d0, dk = 1.00d0/ck ! scaling for higher order invariants
|
||||
! double precision inv(24)
|
||||
! integer, parameter :: inv_order(12) = & ! the order in which the invariants are selected
|
||||
! & [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12]
|
||||
! double precision Rch, umb, xR, yR, xAng, yAng
|
||||
!! for readability
|
||||
! Rch = s(1)
|
||||
! xR = s(2)
|
||||
! yR = s(3)
|
||||
! xAng = s(4)
|
||||
! yAng = s(5)
|
||||
! umb = s(6)**2
|
||||
!! invarianten
|
||||
!! a moden
|
||||
! inv(1) = Rch
|
||||
! inv(2) = umb
|
||||
!! invariante e pairs
|
||||
! inv(3) = v_e_monom(xR, yR, 1)
|
||||
! inv(4) = v_e_monom(xAng, yAng, 1)
|
||||
!! third order e pairs
|
||||
! inv(5) = v_e_monom(xR, yR, 2)
|
||||
! inv(6) = v_e_monom(xAng, yAng, 2)
|
||||
! ! invariant ee coupling
|
||||
! inv(7) = v_ee_monom(xR, yR, xAng, yAng, 1)
|
||||
! ! mode combinations
|
||||
! inv(8) = Rch*umb
|
||||
!
|
||||
! inv(9) = Rch*v_e_monom(xR, yR, 1)
|
||||
! inv(10) = umb*v_e_monom(xR, yR, 1)
|
||||
!
|
||||
! inv(11) = Rch*v_e_monom(xAng, yAng, 1)
|
||||
! inv(12) = umb*v_e_monom(xAng, yAng, 1)
|
||||
!
|
||||
!! damp coordinates because of second order and higher invariants
|
||||
! inv(3) = sign(sqrt(abs(inv(3))), inv(3))
|
||||
! inv(4) = sign(sqrt(abs(inv(4))), inv(4))
|
||||
! inv(5) = sign((abs(inv(5))**(1./3.)), inv(5))
|
||||
! inv(6) = sign((abs(inv(6))**(1./3.)), inv(6))
|
||||
! inv(7) = sign((abs(inv(7))**(1./3.)), inv(7))
|
||||
! inv(8) = sign(sqrt(abs(inv(8))), inv(8))
|
||||
! inv(9) = sign((abs(inv(9))**(1./3.)), inv(9))
|
||||
! inv(10) = sign((abs(inv(10))**(1./3.)), inv(10))
|
||||
! inv(11) = sign((abs(inv(11))**(1./3.)), inv(11))
|
||||
! inv(12) = sign((abs(inv(12))**(1./3.)), inv(12))
|
||||
!
|
||||
! inv_out(:) = inv(inv_order(1:size(inv_out, 1)))
|
||||
!
|
||||
! end subroutine get_invariants
|
||||
|
||||
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
! % real part of spherical harmonics
|
||||
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
! Ylm shifted to 0 for theta=0
|
||||
! double precision function ylm(theta, phi, l, m)
|
||||
! implicit none
|
||||
! double precision theta, phi
|
||||
! integer l, m
|
||||
! ylm = plm2(dcos(theta), l, m)*cos(m*phi) - plm2(1.00d0, l, m)
|
||||
! end function ylm
|
||||
!!----------------------------------------------------------
|
||||
! double precision function plm2(x, l, n)
|
||||
! implicit none
|
||||
! double precision x
|
||||
! integer l, m, n
|
||||
!
|
||||
! double precision pmm, p_mp1m, pllm
|
||||
! integer ll
|
||||
!
|
||||
!! negative m und bereich von x abfangen
|
||||
! if ((l .lt. 0)&
|
||||
! &.or. (abs(n) .gt. abs(l))&
|
||||
! &.or. (abs(x) .gt. 1.)) then
|
||||
! write (6, '(''bad arguments in legendre'')')
|
||||
! stop
|
||||
! end if
|
||||
!
|
||||
!! fix sign of m to compute the positiv m
|
||||
! m = abs(n)
|
||||
!
|
||||
! pmm = (-1)**m*dsqrt(fac(2*m))*1./((2**m)*fac(m))& !compute P(m,m) not P(l,l)
|
||||
! &*(dsqrt(1.-x**2))**m
|
||||
!
|
||||
! if (l .eq. m) then
|
||||
! plm2 = pmm !P(l,m)=P(m,m)
|
||||
! else
|
||||
! p_mp1m = x*dsqrt(dble(2*m + 1))*pmm !compute P(m+1,m)
|
||||
! if (l .eq. m + 1) then
|
||||
! plm2 = p_mp1m !P(l,m)=P(m+1,m)
|
||||
! else
|
||||
! do ll = m + 2, l
|
||||
! pllm = x*(2*ll - 1)/dsqrt(dble(ll**2 - m**2))*p_mp1m& ! compute P(m+2,m) up to P(l,m) recursively
|
||||
! &- dsqrt(dble((ll - 1)**2 - m**2))&
|
||||
! &/dsqrt(dble(l**2 - m**2))*pmm
|
||||
!! schreibe m+2 und m+1 jeweils fuer die naechste iteration
|
||||
! pmm = p_mp1m !P(m,m) = P(m+1,m)
|
||||
! p_mp1m = pllm !P(m+1,m) = P(m+2,m)
|
||||
! end do
|
||||
! plm2 = pllm !P(l,m)=P(m+k,m), k element N
|
||||
! end if
|
||||
! end if
|
||||
!
|
||||
!! sets the phase of -m term right (ignored to gurantee Ylm=(Yl-m)* for JT terms
|
||||
!! if(n.lt.0) then
|
||||
!! plm2 = (-1)**m * plm2 !* fac(l-m)/fac(l+m)
|
||||
!! endif
|
||||
!
|
||||
! end function
|
||||
!----------------------------------------------------------------------------------------------------
|
||||
double precision function fac(i)
|
||||
integer i
|
||||
select case (i)
|
||||
case (0)
|
||||
fac = 1.00d0
|
||||
case (1)
|
||||
fac = 1.00d0
|
||||
case (2)
|
||||
fac = 2.00d0
|
||||
case (3)
|
||||
fac = 6.00d0
|
||||
case (4)
|
||||
fac = 24.00d0
|
||||
case (5)
|
||||
fac = 120.00d0
|
||||
case (6)
|
||||
fac = 720.00d0
|
||||
case (7)
|
||||
fac = 5040.00d0
|
||||
case (8)
|
||||
fac = 40320.00d0
|
||||
case (9)
|
||||
fac = 362880.00d0
|
||||
case (10)
|
||||
fac = 3628800.00d0
|
||||
case (11)
|
||||
fac = 39916800.00d0
|
||||
case (12)
|
||||
fac = 479001600.00d0
|
||||
case default
|
||||
write (*, *) 'ERROR: no case for given faculty, Max is 12!'
|
||||
stop
|
||||
end select
|
||||
end function fac
|
||||
|
||||
! Does the simplest morse transform possible
|
||||
! one skaling factor + shift
|
||||
function morse_transform(x, p, pst) result(t)
|
||||
double precision, intent(in) :: x
|
||||
double precision, intent(in) :: p(11)
|
||||
integer, intent(in) :: pst(2)
|
||||
double precision :: t
|
||||
if (pst(2) == 11) then
|
||||
t = 1.00d0 - exp(-abs(p(2))*(x - p(1)))
|
||||
else
|
||||
error stop 'in morse_transform key required or wrong number of parameters'
|
||||
end if
|
||||
end function morse_transform
|
||||
|
||||
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
! % FUNCTION F(...) ! MAIK DEPRICATING OVER THE TOP MORSE FUNCTION FOR MYSELF
|
||||
! %
|
||||
! % Returns exponent of tunable Morse coordinate
|
||||
! % exponent is polynomial * gaussian (skewed)
|
||||
! % ilabel = 1 or 2 selects the parameters a and sfac to be used
|
||||
! %
|
||||
! % Background: better representation of the prefector in the
|
||||
! % exponend of the morse function.
|
||||
! % Formular: f(r) = lest no3 paper
|
||||
! %
|
||||
! % Variables:
|
||||
! % x: distance of atoms (double)
|
||||
! % p: parameter vector (double[20])
|
||||
! % ii: 1 for CCl and 2 for CCH (int)
|
||||
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
pure function f(x, p, ii)
|
||||
integer , intent(in) :: ii !1 for CCL and 2 for CCH
|
||||
double precision, intent(in) :: x !coordinate
|
||||
double precision, intent(in) :: p(11) !parameter-vector
|
||||
|
||||
integer i !running index
|
||||
|
||||
double precision r !equilibrium distance
|
||||
double precision gaus !gaus part of f
|
||||
double precision poly !polynom part of f
|
||||
double precision skew !tanh part of f
|
||||
|
||||
double precision f !prefactor of exponent and returned value
|
||||
|
||||
integer npoly(2) !order of polynom
|
||||
|
||||
! Maximum polynom order
|
||||
npoly(1) = 5
|
||||
npoly(2) = 5
|
||||
|
||||
! p(1): position of equilibrium
|
||||
! p(2): constant of exponent
|
||||
! p(3): constant for skewing the gaussian
|
||||
! p(4): tuning for skewing the gaussian
|
||||
! p(5): Gaussian exponent
|
||||
! p(6): Shift of Gaussian maximum
|
||||
! p(7)...: polynomial coefficients
|
||||
! p(8+n)...: coefficients of Morse Power series
|
||||
|
||||
! 1-exp{[p(2)+exp{-p(5)[x-p(6)]^2}[Taylor{p(7+n)}(x-p(6))]][x-p(1)]}
|
||||
|
||||
! Tunable Morse function
|
||||
! Power series in Tunable Morse coordinates of order m
|
||||
! exponent is polynomial of order npoly * gaussian + switching function
|
||||
|
||||
! set r r-r_e
|
||||
r = x
|
||||
r = r - p(1)
|
||||
|
||||
! set up skewing function:
|
||||
skew = 0.50d0*p(3)*(dtanh(dabs(p(4))*(r - p(6))) + 1.00d0)
|
||||
|
||||
! set up gaussian function:
|
||||
gaus = dexp(-dabs(p(5))*(r - p(6))**2)
|
||||
|
||||
! set up power series:
|
||||
poly = 0.00d0
|
||||
do i = 0, npoly(ii) - 1
|
||||
poly = poly + p(7 + i)*(r - p(6))**i
|
||||
end do
|
||||
! set up full exponent function:
|
||||
f = dabs(p(2)) + skew + gaus*poly
|
||||
|
||||
end function
|
||||
!----------------------------------------------------------------------------------------------------
|
||||
pure function xproduct(a, b) result(axb)
|
||||
double precision, intent(in) :: a(3), b(3)
|
||||
double precision :: axb(3) !crossproduct a x b
|
||||
axb(1) = a(2)*b(3) - a(3)*b(2)
|
||||
axb(2) = a(3)*b(1) - a(1)*b(3)
|
||||
axb(3) = a(1)*b(2) - a(2)*b(1)
|
||||
end function xproduct
|
||||
|
||||
pure function normalized(v) result(r)
|
||||
double precision, intent(in) :: v(:)
|
||||
double precision :: r(size(v))
|
||||
r = v/norm(v)
|
||||
end function normalized
|
||||
|
||||
pure function norm(v) result(n)
|
||||
double precision, intent(in) :: v(:)
|
||||
double precision n
|
||||
n = dsqrt(sum(v(:)**2))
|
||||
end function norm
|
||||
|
||||
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
! % FUNCTION Project_Point_Into_Plane(x,n,r0) result(p)
|
||||
! % return the to n orthogonal part of a vector x-r0
|
||||
! % p: projected point in plane
|
||||
! % x: point being projected
|
||||
! % n: normalvector of plane
|
||||
! % r0: Point in plane
|
||||
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
pure function project_point_into_plane(x, n, r0) result(p)
|
||||
double precision, intent(in) :: x(:), n(:), r0(:)
|
||||
double precision :: p(size(x)), xs(size(x))
|
||||
xs = x - r0
|
||||
p = xs - plane_to_point(x, n, r0)
|
||||
end function project_point_into_plane
|
||||
|
||||
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
! % Function Plane_To_Point(x,n,r0) result(p)
|
||||
! % p: part of n in x
|
||||
! % x: point being projected
|
||||
! % n: normalvector of plane
|
||||
! % r0: Point in plane
|
||||
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
pure function plane_to_point(x, n, r0) result(p)
|
||||
double precision, intent(in) :: x(:), n(:), r0(:)
|
||||
double precision p(size(x)), xs(size(x)), nn(size(n))
|
||||
nn = normalized(n)
|
||||
xs = x - r0
|
||||
p = dot_product(nn, xs)*nn
|
||||
end function plane_to_point
|
||||
|
||||
subroutine check_coordinates(q)
|
||||
! check for faulty kartesain coordinates
|
||||
double precision, intent(in) :: q(:)
|
||||
integer :: i
|
||||
if (all(abs(q) <= epsilon(0.00d0))) then
|
||||
stop 'Error (ctrans): all kartesian coordinates are<=1d-8'
|
||||
end if
|
||||
do i = 1, 9, 3
|
||||
if (all(abs(q(i:i + 2)) <= epsilon(0.00d0))) then
|
||||
write (*, *) q
|
||||
stop 'Error(ctrans):kartesian coordinates zero for one atom'
|
||||
end if
|
||||
end do
|
||||
end subroutine
|
||||
|
||||
pure function rotor_a_to_z(a, z) result(r)
|
||||
double precision, intent(in) :: a(3), z(3)
|
||||
double precision :: r(3, 3)
|
||||
double precision :: alpha
|
||||
double precision :: s1(3), s(3, 3), rotor(3, 3)
|
||||
s1 = xproduct(normalized(a), normalized(z))
|
||||
alpha = asin(norm(s1))
|
||||
s(:, 1) = normalized(s1)
|
||||
s(:, 2) = normalized(z)
|
||||
s(:, 3) = xproduct(s1, z)
|
||||
rotor = init_rotor(alpha, 0.00d0, 0.00d0)
|
||||
r = matmul(s, matmul(rotor, transpose(s)))
|
||||
end function
|
||||
|
||||
! function returning Rz(gamma) * Ry(beta) * Rx(alpha) for basis order xyz
|
||||
pure function init_rotor(alpha, beta, gamma) result(rotor)
|
||||
double precision, intent(in) :: alpha, beta, gamma
|
||||
double precision :: rotor(3, 3)
|
||||
rotor = 0.00d0
|
||||
rotor(1, 1) = dcos(beta)*dcos(gamma)
|
||||
rotor(1, 2) = dsin(alpha)*dsin(beta)*dcos(gamma)&
|
||||
&- dcos(alpha)*dsin(gamma)
|
||||
rotor(1, 3) = dcos(alpha)*dsin(beta)*dcos(gamma)&
|
||||
&+ dsin(alpha)*dsin(gamma)
|
||||
|
||||
rotor(2, 1) = dcos(beta)*dsin(gamma)
|
||||
rotor(2, 2) = dsin(alpha)*dsin(beta)*dsin(gamma)&
|
||||
&+ dcos(alpha)*dcos(gamma)
|
||||
rotor(2, 3) = dcos(alpha)*dsin(beta)*dsin(gamma)&
|
||||
&- dsin(alpha)*dcos(gamma)
|
||||
|
||||
rotor(3, 1) = -dsin(beta)
|
||||
rotor(3, 2) = dsin(alpha)*dcos(beta)
|
||||
rotor(3, 3) = dcos(alpha)*dcos(beta)
|
||||
end function init_rotor
|
||||
|
||||
pure function create_plane(a, b, c) result(n)
|
||||
double precision, intent(in) :: a(3), b(3), c(3)
|
||||
double precision :: n(3)
|
||||
double precision :: axb(3), bxc(3), cxa(3)
|
||||
axb = xproduct(a, b)
|
||||
bxc = xproduct(b, c)
|
||||
cxa = xproduct(c, a)
|
||||
n = normalized(axb + bxc + cxa)
|
||||
end function create_plane
|
||||
|
||||
function symmetrize(q1, q2, q3, sym) result(s)
|
||||
double precision, intent(in) :: q1, q2, q3
|
||||
character, intent(in) :: sym
|
||||
double precision :: s
|
||||
select case (sym)
|
||||
case ('a')
|
||||
s = (q1 + q2 + q3)*sq3
|
||||
case ('x')
|
||||
s = sq6*(2.00d0*q1 - q2 - q3)
|
||||
case ('y')
|
||||
s = sq2*(q2 - q3)
|
||||
case default
|
||||
write (*, *) 'ERROR: no rule for symmetrize with sym=', sym
|
||||
stop
|
||||
end select
|
||||
end function symmetrize
|
||||
|
||||
subroutine construct_HBend(ex, ey, ph1, ph2, ph3, x_axis, y_axis)
|
||||
double precision, intent(in) :: ph1(3), ph2(3), ph3(3)
|
||||
double precision, intent(in) :: x_axis(3), y_axis(3)
|
||||
double precision, intent(out) :: ex, ey
|
||||
double precision :: x1, y1, alpha1
|
||||
double precision :: x2, y2, alpha2
|
||||
double precision :: x3, y3, alpha3
|
||||
! get x and y components of projected points
|
||||
x1 = dot_product(ph1, x_axis)
|
||||
y1 = dot_product(ph1, y_axis)
|
||||
x2 = dot_product(ph2, x_axis)
|
||||
y2 = dot_product(ph2, y_axis)
|
||||
x3 = dot_product(ph3, x_axis)
|
||||
y3 = dot_product(ph3, y_axis)
|
||||
! -> calculate H deformation angles
|
||||
alpha3 = datan2(y2, x2)
|
||||
alpha2 = -datan2(y3, x3) !-120*ang2rad
|
||||
! write(*,*)' atan2'
|
||||
! write(*,*) 'alpha2:' , alpha2/ang2rad
|
||||
! write(*,*) 'alpha3:' , alpha3/ang2rad
|
||||
if (alpha2 .lt. 0) alpha2 = alpha2 + pi2
|
||||
if (alpha3 .lt. 0) alpha3 = alpha3 + pi2
|
||||
alpha1 = (pi2 - alpha2 - alpha3)
|
||||
! write(*,*)' fixed break line'
|
||||
! write(*,*) 'alpha1:' , alpha1/ang2rad
|
||||
! write(*,*) 'alpha2:' , alpha2/ang2rad
|
||||
! write(*,*) 'alpha3:' , alpha3/ang2rad
|
||||
alpha1 = alpha1 !- 120.00d0*ang2rad
|
||||
alpha2 = alpha2 !- 120.00d0*ang2rad
|
||||
alpha3 = alpha3 !- 120.00d0*ang2rad
|
||||
! write(*,*)' delta alpha'
|
||||
! write(*,*) 'alpha1:' , alpha1/ang2rad
|
||||
! write(*,*) 'alpha2:' , alpha2/ang2rad
|
||||
! write(*,*) 'alpha3:' , alpha3/ang2rad
|
||||
! write(*,*)
|
||||
|
||||
! construct symmetric and antisymmetric H angles
|
||||
ex = symmetrize(alpha1, alpha2, alpha3, 'x')
|
||||
ey = symmetrize(alpha1, alpha2, alpha3, 'y')
|
||||
end subroutine construct_HBend
|
||||
|
||||
pure function construct_umbrella(nh1, nh2, nh3, n)&
|
||||
&result(umb)
|
||||
double precision, intent(in) :: nh1(3), nh2(3), nh3(3)
|
||||
double precision, intent(in) :: n(3)
|
||||
double precision :: umb
|
||||
double precision :: theta(3)
|
||||
! calculate projections for umberella angle
|
||||
theta(1) = dacos(dot_product(n, nh1))
|
||||
theta(2) = dacos(dot_product(n, nh2))
|
||||
theta(3) = dacos(dot_product(n, nh3))
|
||||
! construct umberella angle
|
||||
umb = sum(theta(1:3))/3.00d0 - 90.00d0*ang2rad
|
||||
end function construct_umbrella
|
||||
|
||||
pure subroutine construct_sphericals&
|
||||
&(theta, phi, cf, xaxis, yaxis, zaxis)
|
||||
double precision, intent(in) :: cf(3), xaxis(3), yaxis(3), zaxis(3)
|
||||
double precision, intent(out) :: theta, phi
|
||||
double precision :: x, y, z, v(3)
|
||||
v = normalized(cf)
|
||||
x = dot_product(v, normalized(xaxis))
|
||||
y = dot_product(v, normalized(yaxis))
|
||||
z = dot_product(v, normalized(zaxis))
|
||||
theta = dacos(z)
|
||||
phi = -datan2(y, x)
|
||||
end subroutine construct_sphericals
|
||||
|
||||
! subroutine int2kart(internal, kart)
|
||||
! double precision, intent(in) :: internal(6)
|
||||
! double precision, intent(out) :: kart(9)
|
||||
! double precision :: h1x, h1y, h1z
|
||||
! double precision :: h2x, h2y, h2z
|
||||
! double precision :: h3x, h3y, h3z
|
||||
! double precision :: dch0, dch1, dch2, dch3
|
||||
! double precision :: a1, a2, a3, wci
|
||||
!
|
||||
! kart = 0.00d0
|
||||
! dch1 = dchequi + sq3*internal(1) + 2*sq6*internal(2)
|
||||
! dch2 = dchequi + sq3*internal(1) - sq6*internal(2) + sq2*internal(3)
|
||||
! dch3 = dchequi + sq3*internal(1) - sq6*internal(2) - sq2*internal(3)
|
||||
! a1 = 2*sq6*internal(4)
|
||||
! a2 = -sq6*internal(4) + sq2*internal(5)
|
||||
! a3 = -sq6*internal(4) - sq2*internal(5)
|
||||
! wci = internal(6)
|
||||
!
|
||||
! ! Berechnung kartesische Koordinaten
|
||||
! ! -----------------------
|
||||
! h1x = dch1*cos(wci*ang2rad)
|
||||
! h1y = 0.0
|
||||
! h1z = -dch1*sin(wci*ang2rad)
|
||||
!
|
||||
! h3x = dch2*cos((a2 + 120)*ang2rad)*cos(wci*ang2rad)
|
||||
! h3y = dch2*sin((a2 + 120)*ang2rad)*cos(wci*ang2rad)
|
||||
! h3z = -dch2*sin(wci*ang2rad)
|
||||
!
|
||||
! h2x = dch3*cos((-a3 - 120)*ang2rad)*cos(wci*ang2rad)
|
||||
! h2y = dch3*sin((-a3 - 120)*ang2rad)*cos(wci*ang2rad)
|
||||
! h2z = -dch3*sin(wci*ang2rad)
|
||||
!
|
||||
! kart(1) = h1x
|
||||
! kart(2) = h1y
|
||||
! kart(3) = h1z
|
||||
! kart(4) = h2x
|
||||
! kart(5) = h2y
|
||||
! kart(6) = h2z
|
||||
! kart(7) = h3x
|
||||
! kart(8) = h3y
|
||||
! kart(9) = h3z
|
||||
! end subroutine int2kart
|
||||
|
||||
end module ctrans_mod
|
||||
!**** Define coordinate transformation applied to the input before fit.
|
||||
!***
|
||||
!***
|
||||
!****Conventions:
|
||||
!***
|
||||
!*** ctrans: subroutine transforming a single point in coordinate space
|
||||
|
||||
subroutine trans_in(pat_in,ntot)
|
||||
use ctrans_mod, only: ctrans
|
||||
implicit none
|
||||
|
||||
include 'nnparams.incl'
|
||||
!include 'nndbg.incl'
|
||||
!include 'nncommon.incl'
|
||||
|
||||
double precision pat_in(maxnin,maxpats)
|
||||
integer ntot
|
||||
|
||||
integer j
|
||||
|
||||
do j=1,ntot
|
||||
call ctrans(pat_in(:,j))
|
||||
! FIRST ELEMENT OF PAT-IN ARE USED BY NEURON NETWORK
|
||||
write(62,'(6f16.8)') pat_in(4:9,j)
|
||||
enddo
|
||||
end
|
||||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
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.
|
||||
|
||||
include 'nnparams.incl'
|
||||
|
||||
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)
|
||||
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.
|
||||
|
||||
include 'nnparams.incl'
|
||||
|
||||
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)
|
||||
implicit none
|
||||
! linear activation function
|
||||
|
||||
include 'nnparams.incl'
|
||||
|
||||
double precision L(*)
|
||||
integer ntype
|
||||
|
||||
integer i
|
||||
|
||||
do i=1,ntype
|
||||
L(i)=L(i)
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
subroutine deriv2(deriv,ntype)
|
||||
implicit none
|
||||
! linear activation function
|
||||
|
||||
include 'nnparams.incl'
|
||||
|
||||
integer ntype
|
||||
double precision deriv(*)
|
||||
|
||||
integer i
|
||||
|
||||
do i=1,ntype
|
||||
deriv(i)=1.0D0
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
**********************
|
||||
|
|
@ -0,0 +1,336 @@
|
|||
module diabmodel
|
||||
use dip_param, only: p,pst,init_dip_planar_data
|
||||
implicit none
|
||||
include "nnparams.incl"
|
||||
integer, parameter:: ndiab=4
|
||||
logical:: debug=.false.
|
||||
contains
|
||||
|
||||
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
subroutine diab_x(q,e,nn_out)
|
||||
implicit none
|
||||
!include "dip_planar_genetic.incl"
|
||||
double precision,intent(in)::q(maxnin)
|
||||
double precision,intent(out)::e(ndiab,ndiab)
|
||||
double precision,intent(inout):: nn_out(maxnout)
|
||||
!double precision:: mod_param(maxnout)
|
||||
!double precision:: cj(maxnout)
|
||||
integer id,i,j
|
||||
double precision xs,xb,ys,yb,a,b,ss,sb,v3_vec(8)
|
||||
call init_dip_planar_data()
|
||||
xs=q(25)
|
||||
ys=q(26)
|
||||
xb=q(27)
|
||||
yb=q(28)
|
||||
a=q(24)
|
||||
b=q(29)
|
||||
|
||||
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
|
||||
|
||||
|
||||
!do i=1,maxnout
|
||||
! mod_param(i)=1+0.0001*nn_out(i)
|
||||
!enddo
|
||||
|
||||
e=0.0d0
|
||||
|
||||
|
||||
|
||||
id=1 !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))*(1+0.0001*nn_out(1))*xs+p(pst(1,id)+1)*xb ! here
|
||||
e(3,3)=e(3,3)+p(pst(1,id))*(1+0.0001*nn_out(1))*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))*(1+0.0001*nn_out(2))*(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))*(1+0.0001*nn_out(2))*(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))*(1+0.0001*nn_out(3))
|
||||
e(3,3)=e(3,3)-p(pst(1,id))*(1+0.0001*nn_out(3))
|
||||
! order 1
|
||||
id=id+1 !11
|
||||
e(2,2)=e(2,2)+p(pst(1,id))*(1+0.0001*nn_out(4))*xs+p(pst(1,id)+1)*xb
|
||||
e(3,3)=e(3,3)-p(pst(1,id))*(1+0.0001*nn_out(4))*xs-p(pst(1,id)+1)*xb
|
||||
e(2,3)=e(2,3)-p(pst(1,id))*(1+0.0001*nn_out(4))*ys-p(pst(1,id)+1)*yb
|
||||
! order 2
|
||||
id=id+1 !12
|
||||
e(2,2)=e(2,2)+p(pst(1,id))*(1+0.0001*nn_out(5))*(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))*(1+0.0001*nn_out(5))*(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))*(1+0.0001*nn_out(5))*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))
|
||||
|
||||
|
||||
!! THE COUPLING OF A2 WITH A1
|
||||
!####################################################
|
||||
!####################################################
|
||||
! order 1
|
||||
id=id+1 !17
|
||||
e(1,4)=e(1,4)+b*(p(pst(1,id))*xs+p(pst(1,id)+1)*xb)
|
||||
id=id+1 !18
|
||||
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 !19
|
||||
e(2,4)=e(2,4)+p(pst(1,id))
|
||||
|
||||
! order 1
|
||||
id=id+1 !20
|
||||
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 !21
|
||||
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)
|
||||
|
||||
!! 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(q,e,nn_out)
|
||||
implicit none
|
||||
!integer , intent(in)::npar
|
||||
!include "dip_planar_genetic.incl"
|
||||
double precision,intent(in)::q(maxnin)
|
||||
double precision,intent(out)::e(ndiab,ndiab)
|
||||
double precision,intent(inout):: nn_out(maxnout)
|
||||
!double precision:: mod_param(maxnout)
|
||||
!double precision :: cj(maxnout)
|
||||
integer id,i,j
|
||||
double precision ys,xb,a,b,xs,yb,ss,sb,v3_vec(8)
|
||||
call init_dip_planar_data()
|
||||
xs=q(25)
|
||||
ys=q(26)
|
||||
xb=q(27)
|
||||
yb=q(28)
|
||||
a=q(24)
|
||||
b=q(29)
|
||||
|
||||
|
||||
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
|
||||
!do i=1,maxnout
|
||||
! mod_param(i)=1+0.0001*nn_out(i)
|
||||
!enddo
|
||||
|
||||
|
||||
e=0.0d0
|
||||
! V-term
|
||||
id=1 !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))*(1+0.0001*nn_out(1))*ys+p(pst(1,id)+1)*yb
|
||||
e(3,3)=e(3,3)+p(pst(1,id))*(1+0.0001*nn_out(1))*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))*(1+0.0001*nn_out(2))*(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))*(1+0.0001*nn_out(2))*(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))*(1+0.0001*nn_out(3))
|
||||
! order 1
|
||||
|
||||
id=id+1 !11
|
||||
e(2,2)=e(2,2)-p(pst(1,id))*(1+0.0001*nn_out(4))*ys-p(pst(1,id)+1)*yb
|
||||
e(3,3)=e(3,3)+p(pst(1,id))*(1+0.0001*nn_out(4))*ys+p(pst(1,id)+1)*yb
|
||||
e(2,3)=e(2,3)-p(pst(1,id))*(1+0.0001*nn_out(4))*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))*(1+0.0001*nn_out(5))*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))*(1+0.0001*nn_out(5))*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))*(1+0.0001*nn_out(5))*(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))
|
||||
|
||||
! 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)
|
||||
|
||||
! 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_y
|
||||
|
||||
end module diabmodel
|
||||
|
|
@ -0,0 +1,98 @@
|
|||
!**** 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
|
||||
|
||||
|
||||
double precision wei_alim,bi_alim,wei_amax,bi_amax
|
||||
double precision wei_ascale,bi_ascale,wb_arad
|
||||
double precision shift_in(maxnin),fact_in(maxnin)
|
||||
double precision wspread,bspread
|
||||
double precision ipmut, dpmut,ipins,dpins
|
||||
double precision unit_con
|
||||
double precision lambda_initial, mqfact_default
|
||||
integer len_in,len_out,inp_out,inp_in
|
||||
integer maxbpit,maxfails,maxref_fails
|
||||
integer from_fit, to_fit
|
||||
integer npoints(maxpats), ndata(maxpats)
|
||||
integer sets
|
||||
integer record_state
|
||||
logical limstep,pres_inp,norm_inp
|
||||
logical use_record
|
||||
character*4 unit_string
|
||||
|
||||
common /nngene/ wspread,bspread,ipmut,dpmut,ipins,dpins
|
||||
common /nnprop/ lambda_initial, mqfact_default,
|
||||
> maxbpit, maxfails, maxref_fails
|
||||
common /nnio/ inp_out,inp_in, len_in, len_out
|
||||
common /nnopt/ wei_alim,bi_alim,wei_amax,bi_amax,
|
||||
> wei_ascale,bi_ascale,wb_arad,shift_in,fact_in,
|
||||
> pres_inp,norm_inp,limstep
|
||||
common /nnunits/ unit_con,unit_string
|
||||
common /nnplot/ npoints, sets, ndata
|
||||
common /nnpartial/ from_fit, to_fit, record_state, use_record
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
!**** Parameters
|
||||
!*** dbg: enables debugging features.
|
||||
!*** vbs: enables verbose mode
|
||||
!*** rats: enables mass calculation mode
|
||||
!*** conlog: enables convergence logs
|
||||
!***
|
||||
logical dbg,vbs,rats
|
||||
logical conlog
|
||||
logical ldbg
|
||||
|
||||
! parameter (dbg=.false.,vbs=.false.,rats=.false.)
|
||||
|
||||
! parameter (dbg=.false.,vbs=.false.,rats=.true.)
|
||||
! parameter (dbg=.false.,vbs=.true.,rats=.false.)
|
||||
! parameter (dbg=.true.,vbs=.false.,rats=.false.)
|
||||
|
||||
! parameter (dbg=.true.,vbs=.true.,rats=.false.)
|
||||
! parameter (dbg=.true.,vbs=.false.,rats=.true.)
|
||||
parameter (dbg=.false.,vbs=.true.,rats=.true.)
|
||||
|
||||
parameter (conlog=.true.)
|
||||
! parameter (conlog=.false.)
|
||||
|
||||
!**** Inferred Parameters
|
||||
!*** ldbg: "long dbg": enables massive information
|
||||
!*** dumps if rats is not present. Best for
|
||||
!*** small data sets.
|
||||
|
||||
parameter (ldbg=(dbg.and.(.not.rats)))
|
||||
|
|
@ -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)
|
||||
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
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
include 'nncommon.incl'
|
||||
|
||||
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)
|
||||
|
||||
implicit none
|
||||
! Compare current parameter set's performance with current best and
|
||||
! revert if necessary.
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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
|
||||
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
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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
|
||||
!
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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
|
||||
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
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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
|
||||
!
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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)
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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
|
||||
|
|
@ -0,0 +1,204 @@
|
|||
!**** Declarations
|
||||
|
||||
double precision pi,infty,zero
|
||||
double precision scan_res
|
||||
double precision hart2eV, eV2hart
|
||||
double precision hart2icm, icm2hart
|
||||
double precision eV2icm, icm2eV
|
||||
double precision deg2rad, rad2deg
|
||||
integer maxneu,maxlay,maxtypes,maxtpar
|
||||
integer maxpats
|
||||
integer maxnin,maxnout,maxpout
|
||||
integer maxwei,neucap,wbcap
|
||||
integer maxset, maxnnkeys
|
||||
integer maxxrmeta,xrcap
|
||||
integer iinfty
|
||||
integer iout,nnunit,perfunit,fitunit
|
||||
integer ec_error,ec_read,ec_dim,ec_log
|
||||
integer ec_dimrd
|
||||
integer record_read,record_write,record_overwrite
|
||||
integer record_update
|
||||
character*2 newline
|
||||
character*8 stdfmt
|
||||
character*8 nnldir
|
||||
character*8 nntag
|
||||
character*16 prim_tag
|
||||
character*16 nnfdir,nnsdir
|
||||
character*16 sline,asline,hline
|
||||
character*16 mform,smform,miform
|
||||
character*16 lrfmt,lifmt
|
||||
character*32 nndmpfile,nnexpfile
|
||||
character*32 nndatfile,nnreffile
|
||||
character*32 sampfile,perfile
|
||||
character*32 nnparfile,nnp10file
|
||||
character*32 nnrecfile
|
||||
!**********************************************************
|
||||
!**** 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
|
||||
|
||||
!*** WARNING: maxnout should not be > maxneu, deriv-like structures
|
||||
!*** assume so.
|
||||
parameter (maxneu=150,maxnin=15,maxnout=30)
|
||||
parameter (maxpout=15,maxset=10000)
|
||||
parameter (maxlay=3,maxtypes=2,maxtpar=1)
|
||||
parameter (maxpats=50000)
|
||||
|
||||
parameter (maxxrmeta=3)
|
||||
|
||||
!**********************************************************
|
||||
!**** 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
|
||||
|
||||
parameter (maxwei=(maxlay-3)*maxneu**2+maxneu*(maxnin+maxnout))
|
||||
parameter (neucap=(maxlay-2)*maxneu+maxnin+maxnout)
|
||||
parameter (wbcap=maxwei+neucap)
|
||||
parameter (xrcap=2+maxxrmeta)
|
||||
parameter (maxnnkeys=4*maxlay)
|
||||
|
||||
!*** 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
|
||||
|
||||
! 3.14159265358979323846264338327950...
|
||||
parameter (pi=3.1415926536D0)
|
||||
parameter (infty=huge(1.0D0),iinfty=huge(1))
|
||||
parameter (zero=1.0D-8,scan_res=1.0D-8)
|
||||
|
||||
!**********************************************************
|
||||
!**** Unit Conversion Parameters
|
||||
!*** X2Y: convert from X to Y.
|
||||
!***
|
||||
!**** !? currently inexact. FIX THIS.
|
||||
!*** hart: hartree
|
||||
!*** eV: electron volt
|
||||
!*** icm: inverse centimeters (h*c/cm)
|
||||
!****
|
||||
!*** deg: degree
|
||||
!*** rad: radians
|
||||
|
||||
parameter (hart2icm=219474.69d0)
|
||||
parameter (hart2eV=27.211385d0)
|
||||
parameter (eV2icm=hart2icm/hart2eV)
|
||||
parameter (icm2hart=1.0d0/hart2icm)
|
||||
parameter (eV2hart=1.0d0/hart2eV)
|
||||
parameter (icm2eV=1.0d0/eV2icm)
|
||||
parameter (deg2rad=pi/180.0d0)
|
||||
parameter (rad2deg=1.0d0/deg2rad)
|
||||
|
||||
!**********************************************************
|
||||
!**** 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
|
||||
|
||||
parameter (nndatfile='DATA_ANN')
|
||||
parameter (nnreffile='REF_ANN')
|
||||
parameter (nnparfile='../nnfits/fit_pars')
|
||||
parameter (nnp10file='../nnfits/fit_10p')
|
||||
parameter (nnexpfile='../nnfits/exp_pars')
|
||||
parameter (nndmpfile='../nnfits/fit_dump.dat')
|
||||
parameter (sampfile='../scans/samples.dat')
|
||||
parameter (perfile='../logs/performance.log')
|
||||
parameter (nnrecfile='../nnfits/record')
|
||||
parameter (nnfdir='../nnfits/',nnsdir='../scans/')
|
||||
parameter (nnldir='../logs/')
|
||||
parameter (nntag='',prim_tag=' Time-stamp: " "')
|
||||
|
||||
parameter (lrfmt='(ES20.12)',lifmt='(I12)')
|
||||
|
||||
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
|
||||
|
||||
parameter (sline='(75("*"))',asline='(75("#"))')
|
||||
parameter (hline='(75("-"))')
|
||||
parameter (newline='()')
|
||||
parameter (mform='(5ES12.4)',smform='(5ES10.2)')
|
||||
parameter (miform='(5I12)')
|
||||
parameter (stdfmt='(A)')
|
||||
|
||||
!**********************************************************
|
||||
!**** Continuation Parameters
|
||||
!*** record_*: Various possible values for the common block variable
|
||||
!*** record_state. See the parser for more.
|
||||
|
||||
parameter (record_read=0,record_write=1,record_overwrite=-1)
|
||||
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
|
||||
|
||||
|
||||
parameter (ec_error=1,ec_read=2,ec_dim=4,ec_log=8)
|
||||
|
||||
parameter (ec_dimrd=ec_dim+ec_read)
|
||||
|
||||
|
|
@ -0,0 +1,132 @@
|
|||
subroutine read_net_prim(fname,par,nlay,laystr,weistr,typop)
|
||||
implicit none
|
||||
! Subroutine reading ANN-parameters as generated by punch_net_prim
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
implicit none
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
*** nstat: number of electronic states [maxnout] ***
|
||||
*** nmeta: max. number of metadata output values [maxnout] ***
|
||||
*** such as CI coefficients etc ***
|
||||
|
||||
integer nstat, nmeta
|
||||
integer maxoutp
|
||||
integer dnlen
|
||||
integer maxlines,llen
|
||||
integer maxdat,clen
|
||||
integer klen, maxkeys
|
||||
integer maxerrors
|
||||
|
||||
logical mprun
|
||||
|
||||
parameter (nstat=4, nmeta=20)
|
||||
|
||||
|
||||
******************************************************************************
|
||||
**** Inferred Parameters
|
||||
***
|
||||
*** maxoutp: max. number of output values.
|
||||
|
||||
parameter (maxoutp=nstat+nmeta)
|
||||
|
||||
******************************************************************************
|
||||
**** I/O-Parameters
|
||||
***
|
||||
*** dnlen: maximum char length of data file path
|
||||
*** maxlines: maximum input file length
|
||||
*** llen: character maximum per line
|
||||
*** maxdat: maximum number of input data values of one kind
|
||||
*** (e.g. integer values) excluding DATA:-block
|
||||
*** clen: max. character length of string data
|
||||
*** klen: maximum length of key or typestring
|
||||
*** maxkeys: max. number of keys
|
||||
*** maxerrors: max. number of pre-defined error messages.
|
||||
|
||||
parameter (dnlen=8192)
|
||||
parameter (maxlines=300000,llen=750)
|
||||
parameter (klen=32,maxkeys=200)
|
||||
parameter (maxdat=10000,clen=1024)
|
||||
parameter (maxerrors=100)
|
||||
|
||||
******************************************************************************
|
||||
**** OpenMP-Parameters
|
||||
***
|
||||
*** mprun: true if openmp is used.
|
||||
|
||||
parameter (mprun=.true.)
|
||||
! parameter (mprun=.false.)
|
||||
|
|
@ -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)=
|
||||
|
|
@ -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)=
|
||||
! keylist(2,54)=
|
||||
!
|
||||
! keylist(1,55)=
|
||||
! keylist(2,55)=
|
||||
!
|
||||
! keylist(1,56)=
|
||||
! keylist(2,56)=
|
||||
!
|
||||
! keylist(1,57)=
|
||||
! keylist(2,57)=
|
||||
!
|
||||
! keylist(1,58)=
|
||||
! keylist(2,58)=
|
||||
!
|
||||
! keylist(1,59)=
|
||||
! keylist(2,59)=
|
||||
!
|
||||
! keylist(1,60)=
|
||||
! keylist(2,60)=
|
||||
|
||||
! keylist(1,61)=
|
||||
! keylist(2,61)=
|
||||
!
|
||||
! keylist(1,62)=
|
||||
! keylist(2,62)=
|
||||
!
|
||||
! keylist(1,63)=
|
||||
! keylist(2,63)=
|
||||
!
|
||||
! keylist(1,64)=
|
||||
! keylist(2,64)=
|
||||
!
|
||||
! keylist(1,65)=
|
||||
! keylist(2,65)=
|
||||
!
|
||||
! keylist(1,66)=
|
||||
! keylist(2,66)=
|
||||
!
|
||||
! keylist(1,67)=
|
||||
! keylist(2,67)=
|
||||
!
|
||||
! keylist(1,68)=
|
||||
! keylist(2,68)=
|
||||
!
|
||||
! keylist(1,69)=
|
||||
! keylist(2,69)=
|
||||
!
|
||||
! keylist(1,70)=
|
||||
! keylist(2,70)=
|
||||
!
|
||||
! keylist(1,71)=
|
||||
! keylist(2,71)=
|
||||
!
|
||||
! keylist(1,72)=
|
||||
! keylist(2,72)=
|
||||
!
|
||||
! keylist(1,73)=
|
||||
! keylist(2,73)=
|
||||
!
|
||||
! keylist(1,74)=
|
||||
! keylist(2,74)=
|
||||
!
|
||||
! keylist(1,75)=
|
||||
! keylist(2,75)=
|
||||
!
|
||||
! keylist(1,76)=
|
||||
! keylist(2,76)=
|
||||
!
|
||||
! keylist(1,77)=
|
||||
! keylist(2,77)=
|
||||
!
|
||||
! keylist(1,78)=
|
||||
! keylist(2,78)=
|
||||
!
|
||||
! keylist(1,79)=
|
||||
! keylist(2,79)=
|
||||
!
|
||||
! keylist(1,80)=
|
||||
! keylist(2,80)=
|
||||
!
|
||||
! keylist(1,81)=
|
||||
! keylist(2,81)=
|
||||
!
|
||||
! keylist(1,82)=
|
||||
! keylist(2,82)=
|
||||
!
|
||||
! keylist(1,83)=
|
||||
! keylist(2,83)=
|
||||
!
|
||||
! keylist(1,84)=
|
||||
! keylist(2,84)=
|
||||
!
|
||||
! keylist(1,85)=
|
||||
! keylist(2,85)=
|
||||
!
|
||||
! keylist(1,86)=
|
||||
! keylist(2,86)=
|
||||
!
|
||||
! keylist(1,87)=
|
||||
! keylist(2,87)=
|
||||
!
|
||||
! keylist(1,88)=
|
||||
! keylist(2,88)=
|
||||
!
|
||||
! keylist(1,89)=
|
||||
! keylist(2,89)=
|
||||
!
|
||||
! keylist(1,90)=
|
||||
! keylist(2,90)=
|
||||
!
|
||||
! keylist(1,91)=
|
||||
! keylist(2,91)=
|
||||
!
|
||||
! keylist(1,92)=
|
||||
! keylist(2,92)=
|
||||
!
|
||||
! keylist(1,93)=
|
||||
! keylist(2,93)=
|
||||
!
|
||||
! keylist(1,94)=
|
||||
! keylist(2,94)=
|
||||
!
|
||||
! keylist(1,95)=
|
||||
! keylist(2,95)=
|
||||
!
|
||||
! keylist(1,96)=
|
||||
! keylist(2,96)=
|
||||
!
|
||||
! keylist(1,97)=
|
||||
! keylist(2,97)=
|
||||
!
|
||||
! keylist(1,98)=
|
||||
! keylist(2,98)=
|
||||
!
|
||||
! keylist(1,99)=
|
||||
! keylist(2,99)=
|
||||
|
||||
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
|
||||
|
|
@ -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)
|
||||
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
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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.
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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
|
||||
|
|
@ -0,0 +1,160 @@
|
|||
module parse_errors
|
||||
implicit none
|
||||
|
||||
contains
|
||||
|
||||
!--------------------------------------------------------------------------------
|
||||
|
||||
subroutine signal_p_error(key_id,msg)
|
||||
! Signal generic error with user-defined message MSG.
|
||||
implicit none
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
|
||||
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.
|
||||
implicit none
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
|
||||
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.
|
||||
implicit none
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
|
||||
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.
|
||||
implicit none
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
|
||||
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.
|
||||
implicit none
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
|
||||
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).
|
||||
implicit none
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
|
||||
integer key_id,msg_code
|
||||
|
||||
write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id))
|
||||
> // ' ' // trim(errcat(msg_code))
|
||||
stop ec_read
|
||||
|
||||
end subroutine
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,822 @@
|
|||
************************************************************************
|
||||
*** puNNch
|
||||
*** printing (punching) ANN data structures
|
||||
***
|
||||
************************************************************************
|
||||
|
||||
subroutine punch_data(pat_in,pat_out,npat,append)
|
||||
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
|
||||
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
include 'nncommon.incl'
|
||||
|
||||
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)
|
||||
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
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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
|
||||
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
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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
|
||||
!
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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
|
||||
!
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
include 'nncommon.incl'
|
||||
|
||||
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)
|
||||
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
|
||||
!
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
implicit none
|
||||
|
||||
include 'params.incl'
|
||||
include 'common.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nncommon.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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
|
||||
|
|
@ -0,0 +1,385 @@
|
|||
!--------------------------------------------------------------------------------------
|
||||
|
||||
subroutine lscan_bounds(bounds,refp,dvec,xmin,xmax,dim,backwd)
|
||||
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
|
||||
|
||||
include 'nnparams.incl'
|
||||
|
||||
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)
|
||||
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).
|
||||
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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.
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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
|
||||
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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)
|
||||
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
|
||||
|
||||
include 'params.incl'
|
||||
include 'nnparams.incl'
|
||||
include 'nndbg.incl'
|
||||
|
||||
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
|
||||
Loading…
Reference in New Issue