commit d40633e1e82d2b988d1e81223a2e6b2a309ab6a0 Author: Jean Paul Nshuti Date: Mon Jun 15 15:28:22 2026 +0200 First commit diff --git a/src/README b/src/README new file mode 100644 index 0000000..22db75a --- /dev/null +++ b/src/README @@ -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) diff --git a/src/accuracy_constants.f90 b/src/accuracy_constants.f90 new file mode 100644 index 0000000..a56a530 --- /dev/null +++ b/src/accuracy_constants.f90 @@ -0,0 +1,7 @@ +module accuracy_constants + use iso_fortran_env + implicit none + integer, parameter :: dp = real64 + integer, parameter :: idp = int32 + !real(dp), parameter :: pi = acos(-1.0_dp) +end module diff --git a/src/ann_inc.f90 b/src/ann_inc.f90 new file mode 100644 index 0000000..a259824 --- /dev/null +++ b/src/ann_inc.f90 @@ -0,0 +1,9 @@ +module ann_inc + use accuracy_constants + use nn_params, only: maxlay,maxtypes,wbcap + implicit none + integer(idp):: laystr(3,maxlay),typop(maxtypes,maxlay) + integer(idp):: weistr(2,maxlay,2) + integer(idp):: nlay + real(dp):: netpars(wbcap) +end module diff --git a/src/axel.f b/src/axel.f new file mode 100644 index 0000000..1fc546a --- /dev/null +++ b/src/axel.f @@ -0,0 +1,316 @@ +************************************************************************ +*** aXel +*** convergence accelerators for ANN's Marquardt-Levenberg +*** +************************************************************************ + + module axel + implicit none + contains + + subroutine mqlimstep(wbsteps,wbnorm,gradnorm,fails,lambda, + > mqfact,weistr,nlay) + use nn_params + use nncommons + use nndbg_mod + implicit none +! Rescales step if stepsize restrictions are violated. +! +! Depending on the size of each parameter, this subroutine +! establishes a maximum allowed size for the parameter's +! corresponding step. This maximum size is absolute for small +! parameter sizes (below the given threshold), but scales relatively +! to the current parameter value for larger ones. The entire step +! vector is normalized in such a way that the largest offending +! stepsize is reduced to it's maximum allowed value. Additionally, +! if the total length of the step vector exceeds a certain trust +! radius, it is renormalized as well. +! +! wei_end: position of last defined weight in W-vector +! lay_end: position of last defined bias in B-vector +! len_in: number of input-neurons. Since they have no biases +! B(1:len_in) is meaningless. +! large_rel: number of relative threshold violations in step +! large_abs: number of absolute threshold violations in step +! +! +! W: weight matrix vector +! B: bias vector +! wbsteps: steps for weights and biases, same order as a single +! jacobian-row. +! +! stepsize-control parameters for WEIghts and BIases +! +! wb_arad: maximal length of a single step through the entire parameter space, +! aka the trust radius +! *_alim: threshold for switching from relative to absolute scaling +! *_ascale: multiplicative factor by which parameter size is multiplied +! to determine relative maximum step size +! *_amax: hard step limit for small parameter values + + + double precision wbsteps(wbcap) + double precision lambda,wbnorm,gradnorm + double precision mqfact + integer weistr(2,maxlay,2),nlay + integer fails + + double precision scale + integer jac_end + + + jac_end=weistr(2,nlay,2) + + write(6,*) 'CHECKNORM' + write(6,*) wbnorm,gradnorm + + if (wbnorm.gt.gradnorm*unit_con) then !? does that make sense??? + write(6,*) 'FIXING..' + scale=gradnorm*unit_con/wbnorm + wbsteps(1:jac_end)=wbsteps(1:jac_end)*scale + wbnorm=sqrt(dot_product(wbsteps(1:jac_end),wbsteps(1:jac_end))) +! undo whatever happened in the last step to lambda + if (fails.eq.0) then + lambda=lambda*mqfact + else + lambda=lambda/mqfact + endif + endif + + write(6,*) wbnorm + + + end subroutine + +!-------------------------------------------------------------------------------------- + + subroutine renorm_input(pat_in,npat,preserve,par, + > laystr,weistr) + use nn_params + use nncommons + use io_parameters + use nndbg_mod + implicit none +! Evaluate average and standard deviation of input set and generate +! shifts and normalization factors such that they are normalized to +! an average of 0 and a variance of 1, respectively. If an input is +! constant, do not normalize the variance. +! +! If preserve is true, the network which is assumed to already have +! been fitted will be manipulated such that, given the initial +! values of fact_in and shift_in, it will yield the same output as +! before. +! +! This works as follows: Let u,v be differently normalized versions +! of x and f(u) a function fitted using the data set {u}. +! u and v are given by +! +! u = D1^-1 (x - x1) and +! v = D2^-1 (x - x2). +! +! Since v(x) is invertible we can transform f(u) into an equivalent +! g(v) using f(u(x)) = f(u(v^-1(v(x)))) =: g(v(x)) +! +! x = D2 v + x2 +! => u(v) = D1^-1 (D2 v + x2 - x1) +! u(v) = D1^-1 D2( v + D2^-1 (x2 - x1)) +! = D12 (v - x12) +! +! A transformation of that form can easily be pulled into the ANN +! parameters using the routine unnorm_input. + + + double precision par(wbcap) + double precision pat_in(maxnin,maxpats) + integer laystr(3,maxlay), weistr(2,maxlay,2) + integer npat + logical preserve + + double precision old_shift(maxnin), old_fact(maxnin) + double precision diff_shift(maxnin),diff_fact(maxnin) + + integer j + + if (preserve) then + old_shift=shift_in + old_fact=fact_in + endif + +! get mean for input data + call safe_average(pat_in,shift_in,len_in,maxnin,npat) +! get variance for input data + call safe_variance(pat_in,shift_in,fact_in,len_in,maxnin,npat) + +! generate actual norms + do j=1,len_in + fact_in(j)=dsqrt(fact_in(j)) + if (dbg) then + write(6,'(A,I3.3,A,ES14.4)') "Computed factor #", j, + > ": ",fact_in(j) + endif + if (fact_in(j).le.zero) then + write(6,'(A,I3.3,A,ES10.2)') "WARNING: Nigh-constant" + > // " coordinate #",j,": ",fact_in(j) + if (vbs) then + write(6,'(A,I3.3)') "Skipping normalization " + > // "of coordinate #", j + endif + fact_in(j) = 1.0d0 + endif + enddo + + if (preserve) then +! Compute shift displacement x12 + do j=1,len_in + diff_shift(j)=(old_shift(j)-shift_in(j))/fact_in(j) + enddo +! Compute factor change D12 + do j=1,len_in + diff_fact(j)=old_fact(j)/fact_in(j) + enddo + write(6,'("Absorbing coordinate scaling factors into ANN: ")') + call printvec_full(diff_fact,'(ES12.4)',8,len_in,5) + write(6,'("Absorbing coordinate shift into ANN: ")') + call printvec_full(diff_shift,'(ES12.4)',8,len_in,5) + if (all(abs(diff_shift(1:len_in)).le.zero) + > .and. all(abs(diff_fact(1:len_in)-1.d0).le.zero)) then + write(6,'("REMARK: Shifts and scaling factors' + > // ' near identical to data set.")') + endif +! integrate differences into network + call unnorm_input(par,laystr,diff_shift,diff_fact,weistr) + endif + + end subroutine + +!-------------------------------------------------------------------------------------- + + subroutine init_input(lay_in,pat_in,shift,norm,len_in) +! Initialize input layer with optimized coordinates. +! +! Ideally, each coordinate should be normalized such that it has an +! average of 0 and a variance of 1. + use nn_params + use nndbg_mod + implicit none + + + integer len_in + double precision lay_in(len_in),pat_in(maxnin) + double precision shift(maxnin),norm(maxnin) + + integer k + + do k=1,len_in + lay_in(k)=(pat_in(k)-shift(k))/norm(k) + enddo + + end subroutine + +!-------------------------------------------------------------------------------------- + + subroutine unnorm_input(par,laystr,shift_in,fact_in,weistr, + > preserve) + use nn_params + use io_parameters + use nndbg_mod + implicit none +! Transfer factors and shifts from input normalization to first +! weight matrix and bias, respectively. The equations read as +! follows: +! +! For any un-normalized input vector x we can find a normalized +! counterpart +! +! v = D^-1 (x - ), +! +! where D is a diagonal matrix of the standard deviations of the +! respective input coordinate (input layer entry) and 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 - ) + B +! = (W D^-1) x + (B - W D^-1 ) +! +! 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' +! +! we yield a re-parametrized network taking the original coordinates +! x as input. +! +! If preserve is true, this routine acts non-destructively on +! shift_in, fact_in. Absent is equivalent to false. + + + integer laystr(3,maxlay) + integer weistr(2,maxlay,2) + double precision par(wbcap) + double precision shift_in(maxnin),fact_in(maxnin) + logical, intent(in), optional :: preserve + + integer len_in + double precision norm_in(maxnin),new_shift(maxneu) + + integer j + + len_in=laystr(1,1) + + do j=1,len_in + norm_in(j)=1.0d0/fact_in(j) + enddo + +! rescale weights: + call rescalemat_in(par(weistr(1,1,1)),norm_in, + > len_in,laystr(1,2)) + + call dmatvec(par(weistr(1,1,1)),shift_in,new_shift, + > len_in,laystr(1,2)) + + new_shift=-new_shift + +! shift biases: + call shiftmat(par(weistr(1,2,2)),new_shift,laystr(1,2),1) + + + if ((.not.present(preserve)).or.(.not.preserve)) then + fact_in=1.0d0 + shift_in=0.0d0 + endif + end subroutine + +!-------------------------------------------------------------------------------------- + + double precision function sim_score(x,y,zero) +! Function to measure similarity between two values, giving them a +! score between 1 (identical) and 0 (opposing/far apart). +! +! If both values are small enough that their abs. values are below +! the threshold argument zero, they are treated as identical +! regardless of actual value. In any other case, values which +! differ by sign are considered opposite, yielding 0. + implicit none + + double precision zero,x,y + + double precision sgn,maxpar,minpar + +! Check whether x and y have the same sign + sgn=sign(1.0d0,x)*sign(1.0d0,y) + maxpar=max(dabs(x),dabs(y)) + + if (maxpar.le.zero) then +! penalize numerical zeros + sim_score=1.0d0 + else if (sgn.le.0.0d0) then + sim_score=0.0d0 + else + minpar=min(dabs(x),dabs(y)) + sim_score=minpar/maxpar + endif + + end function + + end module diff --git a/src/backprop.f b/src/backprop.f new file mode 100644 index 0000000..66eaa11 --- /dev/null +++ b/src/backprop.f @@ -0,0 +1,105 @@ + + + +!-------------------------------------------------------------------------------------- + + subroutine backprop(del,W,deriv,laystr,nlay) + use nn_params + use nndbg_mod + implicit none +! Backpropagates full FF-NN with given output-errors. +! nlay: number of given layers +! nprop: number of single-layer propagations +! neu_io: number of neurons in giv./prev. layer +! neu_oi: number of neurons in prev./giv. layer +! poslay: starting position of layer in L- and B-vector +! poswei: starting position of Weight-Matrix in W-vector +! +! del: Neuron Error Vector +! deriv: Activation function derivatives +! W: Weight Matrix Vector +! laystr: Layer Structure Matrix +! +! laystr(1,N): number of neurons in layer N +! laystr(2,N): starting pos. for layer N +! laystr(3,N): starting pos. for Weight Matrix from layer N to N+1 + + + integer nlay,laystr(3,maxlay) + double precision del(neucap),deriv(neucap) + double precision W(maxwei) + + integer poslay,poswei,nprop,neu_io,neu_oi + integer k + + nprop=nlay-1 + +! evaluate deltas + neu_io=laystr(1,nlay) !number of input neurons + + do k=nprop,2,-2 + neu_oi=laystr(1,k) !number of output neurons + poslay=laystr(2,k) + poswei=laystr(3,k) + call backlay(neu_io,neu_oi,del(poslay),W(poswei), + > deriv(poslay)) + + neu_io=laystr(1,k-1) !new number of output neurons + poslay=laystr(2,k-1) + poswei=laystr(3,k-1) + +! former output neurons are now input, _io and _oi switch places! +! (done for efficiency) + + call backlay(neu_oi,neu_io,del(poslay),W(poswei), + > deriv(poslay)) + + enddo + + do k=1,mod(nprop,2) !for odd nprop one iteration is left + neu_oi=laystr(1,1) + poslay=laystr(2,1) + poswei=laystr(3,1) + + call backlay(neu_oi,neu_io,del(poslay),W(poswei), + > deriv(poslay)) + enddo + + end + +!-------------------------------------------------------------------------------------- + + subroutine backlay(neu_in,neu_out,del,W,deriv) + use nn_params + use nndbg_mod + implicit none +! Backpropagates given layer in FF-NN. + +! neu_in: number of neurons in layer N+1 +! neu_out: number of neurons in layer N +! +! +! del: Neuron Error Vector +! W: Weight Matrix (layer N to layer N+1) +! deriv: Derivative Vector (beginning at layer N) +! + + integer neu_in,neu_out + double precision del(neu_out+neu_in),deriv(neu_out) + double precision W(neu_out,neu_in) + + integer j,k + + do j=1,neu_out + del(j)=0.0D0 + enddo + do k=1,neu_in + do j=1,neu_out + del(j)=del(j)+del(neu_out+k)*W(j,k) + enddo + enddo + do k=1,neu_out + del(k)=del(k)*deriv(k) + enddo + + end diff --git a/src/common_inc.f90 b/src/common_inc.f90 new file mode 100644 index 0000000..a6c36a1 --- /dev/null +++ b/src/common_inc.f90 @@ -0,0 +1,61 @@ +module common + use accuracy_constants, only: idp, dp + use nn_params, only: maxoutp + implicit none + + !.. npar: number of parameters + !.. pst: starting addresses and lengths of parameter blocks + integer(idp):: npar, pst(2,100) + + !common /parnum/ npar, pst + + !****************************************************************************** + !**** Syntactic & Parsing parameters + !*** + !*** keylist: Registry of keys containing the name of the key + !*** and it's type information. + !*** keylist(N,1): keyname. It should be in all-caps. + !*** keylist(N,2): type string of the form "X#" + !*** keynum: actual number of keys on keylist + !*** datpos: integer array assigning read values to the keys + !*** datpos(1,N): internalized type (0: I, 1: +I, 2: D, 3: +D, + !*** 4: C, 5: E) + !*** datpos(2,N): starting pos. in respective data array + !*** datpos(3,N): length of data block + + integer(idp):: keynum,datpos(3,maxdat) + character(len=klen):: keylist(2,maxkeys) + character(len=klen):: errcat(maxerrors) + + !common /synt/ datpos,keynum,keylist,errcat + + !****************************************************************************** + !**** Misc. fit modifiers + !*** + !*** zero_par: set all fitting parameters to zero + !*** legacy_wt: WT:-cards are expected for each output component + !*** individually + !*** walk_scan: if true, map scans to the unit interval [0,1] + !*** otherwise, dump full coordinate vector instead. + + logical:: zero_par, legacy_wt + logical:: walk_scan + + !common /fitmisc/ zero_par, legacy_wt, walk_scan + + !****************************************************************************** + !**** Generic error analysis parameters + !*** + !*** cutoff: maximal value to be considered for each output in the + !*** context of an unweighted error + !*** showcut: if true, calculate unweighted errors with cutoff thresholds + + real(dp):: cutoff(maxoutp),cutwei(maxoutp) + logical:: showcut + + !common /eval/ cutoff, cutwei, showcut + + + + +END Module \ No newline at end of file diff --git a/src/dmatrix.f b/src/dmatrix.f new file mode 100644 index 0000000..e2990e7 --- /dev/null +++ b/src/dmatrix.f @@ -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 diff --git a/src/error.f b/src/error.f new file mode 100644 index 0000000..578783e --- /dev/null +++ b/src/error.f @@ -0,0 +1,199 @@ +*** Define subroutine to generate output layer error for one pattern, +*** as well as the derivate of the error in respect to the neuronal output +*** +*** +*** +****Conventions: +*** +*** Most of the data structures are larger than declared; +*** however, only their relevant subsection is passed to the +*** subroutine and hence considered. +*** +*** nnerror: subroutine evaluating the output layer's error. +*** +*** nnweight: system specific weight adaptions for fit +*** +*** pat_err: segment of the total error vector for one pattern. +*** +*** len_in: Actual number of input neurons +*** len_out: Actual number of output neurons +*** +*** pat_in: Input pattern +*** pat_in(i): value of ith input neuron for given pattern +*** +*** pat_out: Desired output pattern +*** pat_out(i): desired value of ith output neuron for given pattern +*** +*** L: Final layer, starting at the first neuron +*************************************************************************** +****Note: +*** neu_in and neu_out, if needed, should ideally not be hardcoded. +*** Instead they should be passed by the main program to ensure +*** matching dimensionalities. +*** +*************************************************************************** + + subroutine nnerror(pat_err,pat_in,pat_out,nn_out) + use nn_params + use nncommons + use nndbg_mod + implicit none +! Generate error vector from adiabatic model. +! +! nn_out: output from neural network +! pat_err: error vector for single pattern +! + + + double precision nn_out(maxnout) + double precision pat_in(maxnin),pat_out(maxpout),pat_err(maxpout) + + double precision adiaoutp(maxpout) + + integer j + + call nnadia(pat_in,nn_out,adiaoutp) + + do j=1,inp_out + pat_err(j) = pat_out(j) - adiaoutp(j) + enddo + + end + +!-------------------------------------------------------------------------------------- + + subroutine nnweight(wterr,pat_out,npat) + use nn_params + use nncommons + use io_parameters + implicit none +! Evaluate system specific weighting for 1 pattern. + + + !include 'JTmod.incl' + + double precision wterr(maxpout,npat),pat_out(maxpout,npat) + integer npat + + integer i,j, ii,k + + ii =0 + do k =1,sets + do j = 1,ndata(k) + ii = ii +1 + do i =5, inp_out + if (wterr (i,ii) .gt. 0.0d0) then + wterr( i,ii) = 1.0d-4 + endif + enddo + enddo + enddo + + ! check whether npat equals the number of point in each set + if (npat .ne. ii ) then + write(6,*)" Error in the weight. not consistent npat", npat + stop + endif + + pat_out=pat_out + + contains + double precision function wdamp(dE) + use nn_params + implicit none + double precision dE + +! Weight decay rate + double precision, parameter :: unit=eV2hart +! ln(3)/2 = artanh(1/2) +! double precision, parameter :: alpha=0.5d0*log(3.d0)/unit +! (1+tanh(-x))/2 ~ exp(-2x) +! double precision, parameter :: alpha=0.5d0*log(2.d0)/unit +! + double precision, parameter :: alpha=log(10.d0)/unit + +! cutoff + double precision, parameter :: minweight=1.d-4 + +! asymptotically, +! wdamp=(1.d0+tanh(-alpha*dE))*0.5d0 + minweight + wdamp=1.0d0 + + if (dE.lt.0) then + wdamp=1.d0 + else if (dE.lt.(4*eV2hart)) then + wdamp=exp(-alpha*dE)+minweight + else + wdamp=0 + endif + + end function wdamp + end subroutine + +!-------------------------------------------------------------------------------------- + + subroutine nnoutgrad(ad_grads,pat_in,nn_out) + use nn_params + use nncommons + use nndbg_mod + implicit none +! Compute the derivative of each output value (i.e. adiab. energies) +! with respect to the Neural Network output-neurons. +! +! nn_out: output from neural network +! ad_grads: derivatives as described above +! ad_grads(:,i): gradient of energy i +! eps: finite differences for derivatives +! eps(i): finite difference for output neuron i +! dis_out: ANN output displaced by finite differences +! dis_out(:,1): equivalent to L + eps +! dis_out(:,2): equivalent to L - eps +! dis_ad: yielded adiabatic output for current displacements +! +! ddelta: factor used to determine eps. + + + double precision nn_out(maxnout) + double precision pat_in(maxnin) + double precision ad_grads(maxnout,maxpout) + + double precision eps(maxnout),dis_out(maxnout,2) + double precision dis_ad(maxpout,2) + double precision ddelta + + integer n,j,k + + parameter (ddelta = 1.0D-2) !reduce again if appropriate + +! determine appropriate finite differences for each parameter: + do k=1,len_out + eps(k)=abs(nn_out(k))*ddelta + if (eps(k).lt.zero) then + eps(k)=zero + endif + enddo + + do n=1,len_out + do k=1,2 +! copy ANN-output + do j=1,len_out + dis_out(j,k) = nn_out(j) + enddo + enddo + +! apply finite difference for output-neuron n + dis_out(n,1) = dis_out(n,1) + eps(n) + dis_out(n,2) = dis_out(n,2) - eps(n) + + do k=1,2 +! get energies and ci-values + call nnadia(pat_in,dis_out(1,k),dis_ad(1,k)) + enddo + +! apply finite differences to generate numerical gradient + do k=1,inp_out + ad_grads(n,k) = (dis_ad(k,1)-dis_ad(k,2))/(2.0d0*eps(n)) + enddo + enddo + + end diff --git a/src/ff_neunet.f b/src/ff_neunet.f new file mode 100644 index 0000000..d52a0d2 --- /dev/null +++ b/src/ff_neunet.f @@ -0,0 +1,153 @@ + + + + +!-------------------------------------------------------------------------------------- + + subroutine propagate(W,B,L,deriv,typop,laystr,nlay) + use nn_params + use nndbg_mod + implicit none +! Propagates full FF-NN. +! nlay: number of given layers +! nprop: number of single-layer propagations +! neu_io: number of neurons in giv./prev. layer +! neu_oi: number of neurons in prev./giv. layer +! poslay: starting position of layer in L- and B-vector +! poswei: starting position of Weight-Matrix in W-vector +! +! W: Weight Matrix Vector +! B: Bias Vector +! L: Layer Vector +! deriv: Activation function derivatives +! typop: Type Population Matrix +! laystr: Layer Structure Matrix +! +! laystr(1,N): number of neurons in layer N +! laystr(2,N): starting pos. for layer N +! laystr(3,N): starting pos. for Weight Matrix from layer N to N+1 +! + + integer nlay,laystr(3,maxlay),typop(maxtypes,maxlay) + double precision W(maxwei),B(neucap),L(neucap),deriv(neucap) + + integer poslay,poswei,nprop,neu_io,neu_oi + integer k + + nprop=nlay-1 + + neu_io=laystr(1,1) !number of input neurons + poslay=laystr(2,1) + poswei=laystr(3,1) + + do k=2,2*(nprop/2),2 + neu_oi=laystr(1,k) !number of output neurons + + call proplay(neu_io,neu_oi,W(poswei),B(poslay),L(poslay), + > deriv(poslay),typop(1,k)) + + poslay=laystr(2,k) + poswei=laystr(3,k) + neu_io=laystr(1,k+1) !new number of output neurons + +! former output neurons are now input, _io and _oi switch places! +! (done for efficiency) + + call proplay(neu_oi,neu_io,W(poswei),B(poslay),L(poslay), + > deriv(poslay),typop(1,k+1)) + + poslay=laystr(2,k+1) + poswei=laystr(3,k+1) + enddo + + do k=1,mod(nprop,2) !for odd nprop one iteration is left + neu_oi=laystr(1,nlay) + call proplay(neu_io,neu_oi,W(poswei),B(poslay),L(poslay), + > deriv(poslay),typop(1,nlay)) + enddo + + end + +!-------------------------------------------------------------------------------------- + + subroutine proplay(neu_in,neu_out,W,B,L,deriv,typop) + use nn_params + use nndbg_mod + implicit none +! Evaluates given layer in FF-NN. +! +! neu_in: number of neurons in previous Layer +! neu_out: number of neurons in given Layer +! +! W: Weight Matrix Vector +! B: Bias Vector (beginning at prev. layer) +! L: Layer Vector (beginning at prev. layer) +! deriv: Activation function derivatives +! typop: Type Population Matrix (beginning at curr. layer) + + + integer neu_in,neu_out,typop(maxtypes) + double precision L(neu_in+neu_out),deriv(neu_in+neu_out) + double precision W(neu_in,neu_out),B(neu_in+neu_out) + + integer neu_tot,pos_out + integer j,k + + neu_tot=neu_in+neu_out !total number of neurons in both layers + pos_out=neu_in+1 !pos. of current layer's first element + + do j=pos_out,neu_tot + L(j)=B(j) !add bias + do k=1,neu_in + L(j)=L(j)+W(k,j-neu_in)*L(k) !matrix x vector + enddo + enddo + +! apply nonlin. functions to vector elements + call neurons(neu_out,L(pos_out),deriv(pos_out),typop) + + end + +!-------------------------------------------------------------------------------------- + + subroutine neurons(neu_out,L,deriv,typop) + use nn_params + use nndbg_mod + implicit none +! Applies non-linear activation functions to given layer. +! type-unspecified neurons have the activation function f(x)=x. +! +! ni: Number of neurons of type i in given layer. +! +! L: Layer Vector containing accumulated neuronal input +! deriv: Activation function derivatives +! typop: Type Population Matrix + + + integer neu_out + double precision L(neu_out),deriv(neu_out) + integer typop(maxtypes) + + integer n1,n2!,n3 + integer j + + n1=typop(1) + n2=typop(2) +! n3=typop(3) + + call deriv1(L(1),deriv(1),n1) + call neuron1(L(1),n1) + +! type 2 is as of now type 0 synonym + do j=n1+1,neu_out + deriv(j)=1.0D0 + enddo + +! terrible idea to do deriv(n1+1), it can (and will) overstep boundaries by 1 +! call deriv2(deriv(n1+1),n2) !deriv2 is L-independent +! call neuron2(L(n1+1),n2) + +! call deriv3(L(n1+n2+1),deriv(n1+n2+1),n3) +! call neuron3(L(n1+n2+1),n3) + + end diff --git a/src/geNNetic.f b/src/geNNetic.f new file mode 100644 index 0000000..f66775c --- /dev/null +++ b/src/geNNetic.f @@ -0,0 +1,277 @@ +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! c +! PROGRAM GENETIC c +! c +! A program for non-linear fitting in multiple dimensions based on a c +! Marquardt-Levenberg non-linear least-squares fit and parameter c +! selection by a genetic algorithm c +! c +! Written by Wolfgang Eisfeld, Dec. 2002 c +! c +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! c +! Version 1.0 c +! c +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +!***************************************************************************** +!** *** +!** nstat: number of states *** +!** maxpout: maximum number of output values *** +! *** +!** pat_in: *** +!** pat_out: *** +! *** +!** wterr: Vector containing the individual weights of data points *** +!** par: Matrix containing the parameter vectors *** +!** npar: actual number of parameters *** +!** num: actual number of data points y *** +!** act: vector that selects which parameters are active *** +!** seed: integer to select random seed *** +!** nset: number of parameter sets *** +!** sets: number of data sets for plotting *** +!** ndata: contains the number of data points for each block for plot *** +!** par_spread: factor by which each parameter spreads around its centre *** +!** *** +!** Special UNIT values *** +!** 8xxx and above: automatically generated. DO NOT ASSIGN MANUALLY. *** +!***************************************************************************** +!** Structural ANN constants: +!** +!** laystr: layer structure matrix +!** laystr(1,N): number of neurons in layer N +!** laystr(2,N): starting pos. for layer N +!** laystr(3,N): starting pos. for weight matrix from layer N to N+1 +!** +!** weistr: weight structure matrix +!** weistr(1,N,1): starting pos. of weight matrix N in memory (layer N to N+1) +! identical to laystr(3,N) +!** weistr(2,N,1): end pos. of weight matrix N in memory +!** weistr(1,N,2): starting pos. of bias vector of layer N in memory +!** weistr(2,N,2): end pos. of bias vector of layer N in memory +!** +!** typop: type population matrix +!** +!** nlay: number of given layers +!***************************************************************************** + program genetic + !use + use axel, only: renorm_input,unnorm_input + !use data_transf_mod, only: data_transform + use print_error, only: print_ErrorSummary + use nn_params + use nncommons + use io_parameters + use nndbg_mod + implicit none + !number of states and modes + +!.....Genetic-specific variables + double precision, dimension(:,:), allocatable :: par + double precision, dimension(:), allocatable :: par_spread + double precision, dimension(:), allocatable :: rms,ref_rms + double precision, dimension(:,:), allocatable :: wterr + integer, dimension(:), allocatable :: act + integer seed, nset + logical freeze + logical lrnd + +!.....ANN-specific variables + double precision, dimension(:,:), allocatable :: pat_in,pat_out + integer, dimension(:,:), allocatable :: laystr,typop + integer, dimension(:,:,:), allocatable :: weistr + + integer nlay + +!.....validation set for convergence testing + double precision, dimension(:,:), allocatable :: ref_in,ref_out + double precision rmsopt,mingrad,minwbstep + integer npat,nref + logical dry_run + + integer init_rtype + integer tenptile + integer ntot + + integer j + + !include 'keylist.incl' !this defines all special input keys + !include 'errcat.incl' !this defines generic parser error messages + + +!.....(manual) allocation of all large arrays (prevents stack overflow) + allocate(par(wbcap,maxset)) + allocate(par_spread(wbcap),rms(maxset), ref_rms(maxset)) + allocate(wterr(maxpout,maxpats)) + allocate(act(wbcap)) + allocate(pat_in(maxnin,maxpats),pat_out(maxpout,maxpats)) + allocate(laystr(3,maxlay),typop(maxtypes,maxlay)) + allocate(weistr(2,maxlay,2)) + allocate(ref_in(maxnin,maxpats),ref_out(maxpout,maxpats)) + + freeze=.false. + + call nninit_mod() + + if (dbg) write(6,'(A)') 'Reading input...' + +!.. read input file and initialize data structures: + call read_input(wterr,par,act,seed,nset, + > par_spread,lrnd,dry_run,npat,nref, + > pat_in,pat_out,ref_in,ref_out, + > typop,laystr,weistr,nlay, + > rmsopt,mingrad,minwbstep,freeze) + + if (dbg) write(6,'(A)') 'Input file read: OK' + +!.. transform input + ntot=npat+nref + call trans_in(pat_in) +! NOTE: create API trans_out +!.. copy reference part + do j=1,nref + ref_in(:,j)=pat_in(:,npat+j) + enddo +! transform the data y +! call data_transform(pat_out,ref_out,ntot) + +!.. generate normalization factors for network inputs + + if (norm_inp) then +! If scales and shifts are given, preserve them, if not, generate +! new. + call renorm_input(pat_in,npat,pres_inp, + > par,laystr,weistr) + endif + + if (freeze) then + write(6,'(A)') 'Parameters frozen. Skipping fit.' + endif + + + if (use_record.and.((record_state.eq.record_read) + > .or.(record_state.eq.record_update))) then +! instead of random parameter sets, use the record. + call read_record(par,weistr,nlay,nset) + else if (lrnd) then +! create initial nset random parameter sets: + write(6,'(A)') 'Generating initial parameter sets..' + + if (freeze) then + init_rtype=3 + else if (any(act(1:npar).eq.0)) then + write(6,'(A)') 'Inactive Parameters found, ' + > // 'skipping parameter normalization.' + init_rtype=0 + write(6,'(A)') 'ERROR: Individual freezing of parameters ' + > // 'not implemented.' + stop 1 + else + init_rtype=3 + endif + + do j=1,nset + call mkpars(par(1,j),par_spread,laystr,typop,weistr, + > nlay,init_rtype) + enddo + + if (dbg) write(6,*) 'done.' + endif + + + if (dry_run) then +! DRYRUN: + write(6,'(A)') 'Running model...' + call NNerr(par,pat_in,pat_out,ref_in,ref_out, + > wterr,typop,laystr,weistr,nlay, + > rms(1),ref_rms(1),npat,nref) + write(6,'(A)') 'Done. Exiting..' + + else if (.not.freeze) then +!.. train ANNs and move the best to the top. + call traiNNsets(nset,npat,nref,par,act,rms,ref_rms, + > pat_in,pat_out,ref_in,ref_out, + > wterr, + > typop,laystr,weistr,nlay, + > rmsopt,mingrad,minwbstep) + + write(6,'(A)') 'Writing best parameters to ''' // + > trim(nnparfile) // ''' ...' + + call punch_net(0,nnparfile,par, + > typop,laystr,weistr,nlay,.false.,.false.) + + if (nset.gt.10) then +! evaluate 10th percentile position + tenptile=ceiling(0.1D0*dble(nset)) + write(6,'(A)') 'Writing 10th percentile parameters to ''' + > // trim(nnp10file) // ''' ...' + call punch_net(0,nnp10file,par(1,tenptile), + > typop,laystr,weistr,nlay, + > .false.,.false.) + endif + +! generate plotfiles for the best result + call punch_fitscans(par,pat_in,pat_out,wterr, + > typop,laystr,weistr, + > nlay,walk_scan) + + + else +! RANDOM: and FREEZE: or +! FREEZE: only + if (dbg) then + write(6,asline) + write(6,'(A)') 'NEUPOP:' + write(6,miform) laystr(1,1:nlay) + write(6,'(A)') 'INSHIFT:' + write(6,mform) shift_in(1:laystr(1,1)) + write(6,'(A)') 'INSCALE:' + write(6,mform) fact_in(1:laystr(1,1)) + write(6,'(A)') 'FINAL W:' + write(6,mform) par(weistr(1,1,1):weistr(2,nlay-1,1),1) + write(6,'(A)') 'FINAL B:' + write(6,mform) par(weistr(1,2,2):weistr(2,nlay,2),1) + write(6,asline) + endif + + call NNerr(par,pat_in,pat_out,ref_in,ref_out, + > wterr,typop,laystr,weistr,nlay, + > rms(1),ref_rms(1),npat,nref) + + call NNstat(1,npat,nref,par,rms,ref_rms, + > pat_in,pat_out,ref_in,ref_out, + > typop,laystr,weistr,nlay,nntag) + + call punch_fitscans(par,pat_in,pat_out,wterr, + > typop,laystr,weistr, + > nlay,walk_scan) + call punch_fitpoints(par,pat_in,pat_out, + > typop,laystr,weistr,nlay,npat,nndmpfile) + call punch_net(0,nnparfile,par, + > typop,laystr,weistr,nlay,.false.,.false.) + + call punch_netdistrib(nnfdir,par,pat_in,typop,laystr,weistr, + > nlay,npat,nntag) + + call print_ErrorSummary(par,pat_in,pat_out,ref_in,ref_out, + > wterr,typop,laystr,weistr,nlay, + > npat,nref) + + endif + + write(6,'(A)') 'Writing successful.' + + deallocate(par) + deallocate(par_spread,rms, ref_rms) + deallocate(wterr) + deallocate(act) + deallocate(pat_in,pat_out) + deallocate(laystr,typop) + deallocate(weistr) + deallocate(ref_in,ref_out) + + + end diff --git a/src/iNNterface.f b/src/iNNterface.f new file mode 100644 index 0000000..c4be843 --- /dev/null +++ b/src/iNNterface.f @@ -0,0 +1,973 @@ + + +****************************************************************************** +*** iNNterface +*** connecting ANN with genetic +*** by David Williams +*** & Jerome Collet +*** +*** name(s) [synonyms or equivalents] +*** wertnum [npat] +*** q,x1 [pat_in] +*** y [pat_out] +*** par [W,B] +*** num [npat] +*** +*** +*** +****************************************************************************** + + subroutine NNmin(npat,nref,par,act,rms,ref_rms,pat_in,pat_out, + > ref_in,ref_out,wterr, + > typop,laystr,weistr,nlay,rmsopt, + > mingrad,minwbstep,fit_id,skip) + use nn_params + use nncommons + use io_parameters + use nndbg_mod + implicit none +! Non-linear least-squares fitting using feed forward NN and +! Marquardt-Levenberg learning. +! +! fit_id: unique identifying integer for a given fit +! +! parnum: number of parameters +! par: Parameter vector containing all weights and biases +! (weights first, biases second). Weights are in the +! natural order of the memory: +! W1(1,1) W1(2,1) ... W1(1,2) ... W2(1,1) ... +! ... B1(1) B1(2) ... B2(1) ... +! these may be followed by further parameters +! *not* used by ANN. +! act: vector, indicating the active parameters +! rms: (weighted) root mean square +! ref_rms: rms of reference data +! skip: failure state on exit +! +! +! name [ANN-synonym] +!****************************************************************** +! npat: number of given pattern pairs +! nref: number of reference patterns +! rms: (weighted) root mean square error +! rmsopt: error threshold +! mingrad: error gradient threshold +! minwbstep: threshold for wbnorm +! +! pat_in: input patterns +! pat_out: desired output patterns +! pat_*(i,N): value of ith in-/output neuron for pattern N +! ref_*: in analogy to pat_in/out for reference data +! (convergence tests) +! +! wterr: weight factors for each element of the error vector e +! +! wbsteps: Steps for weights and biases, same order as a single jacobian-row. +! mqpar: initial parameter (lambda) for Marquard-Levenberg +! mqfact: factor by which lambda is multiplied/divided after each iteration +! +! par [W]: weight matrix vector +! par [B]: bias vector +! +! common-block /ann/ +!****************************************************************** +! nlay: number of given layers +! typop: type population matrix +! laystr: layer structure matrix +! laystr(1,N): number of neurons in layer N +! laystr(2,N): starting pos. for layer N +! laystr(3,N): starting pos. for weight matrix from layer N to N+1 + + + double precision par(wbcap) + double precision pat_in(maxnin,*),pat_out(maxpout,*) + double precision ref_in(maxnin,*),ref_out(maxnout,*) + double precision wterr(maxpout,maxpats) + double precision rms,ref_rms,rmsopt + double precision mingrad,minwbstep + integer laystr(3,maxlay),typop(maxtypes,maxlay) + integer weistr(2,maxlay,2) + integer nlay + integer npat,nref + integer act(wbcap) + integer fit_id + logical skip + + double precision mqpar,mqfact + + integer pos_out,inact_num + integer lay_end,wei_end,bi_pos,bi_end + integer funit + character*32 fname + + integer k + + pos_out=laystr(2,nlay)-1 !increment leading to output layer pos. + +! total number of neurons / W-matrix elements + lay_end=pos_out+len_out +! total number of neurons / W-matrix elements in vector par + wei_end=weistr(2,nlay-1,1) +! starting position and end position of Bias vector in par + bi_pos=weistr(1,1,2) + bi_end=weistr(2,nlay,2) + + + if (dbg) write(6,*) 'NNmin entered' + if (dbg) write(6,*) 'NPAT:', npat + + rms=infty + +! initialize MQL-factor and parameter + mqpar=lambda_initial + mqfact=mqfact_default + +! fits currently pattern pairs (x1,y) + + if (all(act(1:bi_end).eq.0)) then + write(6,'(A)') 'Parameters frozen, skip to output' + return + else if (any(act(1:bi_end).eq.0)) then + write(6,'(A)') 'Some parameters set inactive' + inact_num=0 + do k=1,bi_end + if (act(k).eq.0) then + inact_num=inact_num+1 + endif + enddo + write(6,'(A,I5.5)') "Total inactive: ",inact_num + endif + + if (ldbg) then + write(6,sline) + write(6,'(A)') 'W:' + write(6,mform) par(1:wei_end) + write(6,sline) + write(6,'(A)') 'B:' + write(6,mform) par(bi_pos:bi_end) + write(6,sline) + write(6,'(A)') 'TYPOP:' + do k=1,nlay + write(6,'(2I6,:)') typop(1:2,k) + enddo + write(6,sline) + write(6,*) + write(6,'(A)') 'X,Y' + do k=1,npat + write(unit=6,advance='no',fmt='(A2,1000(ES14.6,:))') 'X:', + > pat_in(1:len_in,k) + write(6,'(A3,1000(ES14.6,:))') ' Y:', pat_out(1:inp_out,k) + enddo + write(6,asline) + write(6,'(A)') 'Entering nnmqo..' + endif + +! W , B + call nnmarq(rms,ref_rms,mqpar,mqfact,par,par(bi_pos),act, + > wterr,pat_in,pat_out,ref_in,ref_out, + > typop,laystr,weistr,nlay, + > rmsopt,npat,nref,mingrad,minwbstep,fit_id,skip) + + if (rats) then + funit=fitunit+fit_id + fname=trim(nnfdir) // '.fit_' + write(fname,'(A,I5.5)') trim(fname), fit_id + call punch_net(funit,fname,par, + > typop,laystr,weistr,nlay,.false.,.true.) + endif + + + end subroutine + +!-------------------------------------------------------------------------------------- + + subroutine neunet(x,y,par,typop,laystr,weistr,nlay) + use axel, only: init_input + use nn_params + use nncommons + implicit none +! Wrapper for ANN's propagate +! +! y: neural network output value(s) +! x: input coordinate set +! par: Parameter vector containing all weights and biases +! (weights first, biases second). Weights are in the +! natural order of the memory: +! W1(1,1) W1(2,1) ... W1(1,2) ... W2(1,1) ... +! +! nlay: number of given layers (in common block /ann/) +! +! L: layer vector +! deriv: activation function derivatives (currently discarded) +! typop: type population matrix (in common black /ann/) +! laystr: layer structure matrix (in common block /ann/) +! +! laystr(1,N): number of neurons in layer N +! laystr(2,N): starting pos. for layer N +! laystr(3,N): starting pos. for Weight Matrix from layer N to N+1 + + + double precision y(maxnout),x(maxnin),par(wbcap) + integer laystr(3,maxlay),typop(maxtypes,maxlay) + integer weistr(2,maxlay,2) + integer nlay + + double precision L(neucap) + double precision deriv(neucap) + integer wei_end,lay_end + integer pos_out + integer bi_pos,bi_end + + pos_out=laystr(2,nlay)-1 !increment leading to output layer pos. + +! total number of neurons / W-matrix elements + lay_end=pos_out+len_out + wei_end=weistr(2,nlay-1,1) +! starting position and end position of Bias vector in par + bi_pos=weistr(1,1,2) + bi_end=weistr(2,nlay,2) + +! write coordinate values on input neurons + call init_input(L,x,shift_in,fact_in,len_in) + + call propagate(par(1),par(bi_pos),L,deriv,typop,laystr,nlay) + +! write output on y + y(1:len_out)=L(pos_out+1:pos_out+len_out) + + end subroutine + +!-------------------------------------------------------------------------------------- + + subroutine neunet_full(x,L,deriv,par,typop,laystr,weistr,nlay) + use axel, only: init_input + use nn_params + use nncommons + implicit none +! Wrapper for ANN's propagate, containing all outputs +! +! x: input coordinate set +! par: Parameter vector containing all weights and biases +! (weights first, biases second). Weights are in the +! natural order of the memory: +! W1(1,1) W1(2,1) ... W1(1,2) ... W2(1,1) ... +! +! nlay: number of given layers (in common block /ann/) +! +! L: layer vector +! deriv: activation function derivatives (currently discarded) +! typop: type population matrix (in common black /ann/) +! laystr: layer structure matrix (in common block /ann/) +! +! laystr(1,N): number of neurons in layer N +! laystr(2,N): starting pos. for layer N +! laystr(3,N): starting pos. for Weight Matrix from layer N to N+1 + + + double precision x(maxnin),par(wbcap) + double precision L(neucap) + double precision deriv(neucap) + integer laystr(3,maxlay),typop(maxtypes,maxlay) + integer weistr(2,maxlay,2) + integer nlay + + + integer wei_end,lay_end + integer pos_out + integer bi_pos,bi_end + + pos_out=laystr(2,nlay)-1 !increment leading to output layer pos. + +! total number of neurons / W-matrix elements + lay_end=pos_out+len_out + wei_end=weistr(2,nlay-1,1) +! starting position and end position of Bias vector in par + bi_pos=weistr(1,1,2) + bi_end=weistr(2,nlay,2) + +! write coordinate values on input neurons + call init_input(L,x,shift_in,fact_in,len_in) + + call propagate(par(1),par(bi_pos),L,deriv,typop,laystr,nlay) + + end subroutine + +!-------------------------------------------------------------------------------------- + + subroutine traiNNsets(nset,npat,nref,par,act,rms,ref_rms, + > pat_in,pat_out,ref_in,ref_out, + > wterr, + > typop,laystr,weistr,nlay, + > rmsopt,mingrad,minwbstep) + use print_error, only: print_ErrorSummary + use nn_params + use nncommons + use io_parameters + use nndbg_mod + implicit none +! Uses NNmin to train all nset initialized neural networks using NNmin. +! The first parameterset will be overwritten with the ANN yielding the +! smallest rms. Remaining sets will be sorted in ascending order. +! +! par: Parameter vector containing all weights and biases +! (weights first, biases second). Weights are in the +! natural order of the memory: +! W1(1,1) W1(2,1) ... W1(1,2) ... W2(1,1) ... +! ... B1(1) B1(2) ... B2(1) ... +! these may be followed by further parameters +! *not* used by ANN. +! act: vector, indicating the active parameters +! rms: (weighted) root mean square for each parameter set. +! rms(1): best rms achieved, overwrites set #1. +! rms(n): final rms of set #n. +! ref_rms: rms of reference data +! +! +! name [ANN-synonym] +!****************************************************************** +! nset: number of ANNs to be optimized. +! npat: number of given pattern pairs +! nref: number of reference patterns +! rms: (weighted) root mean square error +! rmsopt: error threshold +! mingrad: error gradient threshold +! minwbstep: threshold for wbnorm +! +! pat_in: input patterns +! pat_out: desired output patterns +! pat_*(i,N): value of ith in-/output neuron for pattern N +! ref_*: in analogy to pat_in/out for reference data +! (convergence tests) +! +! wterr: weight factors for each element of the error vector e +! +! wbsteps: Steps for weights and biases, same order as a single jacobian-row. +! mqpar: initial parameter (lambda) for Marquard-Levenberg +! mqfact: factor by which lambda is multiplied/divided after each iteration +! +! par [W]: weight matrix vector +! par [B]: bias vector +! + + + double precision par(wbcap,maxset),rms(maxset),ref_rms(maxset) + double precision wterr(maxpout,maxpats) + double precision pat_in(maxnin,*),pat_out(maxpout,*) + double precision ref_in(maxnin,*),ref_out(maxnout,*) + double precision rmsopt,mingrad,minwbstep + integer laystr(3,maxlay),typop(maxtypes,maxlay) + integer weistr(2,maxlay,2) + integer nlay + integer act(wbcap) + integer nset,nref,npat + + integer wei_end, bi_pos, bi_end + + double precision loc_par(wbcap),loc_rms,loc_ref_rms + logical loc_skip + + integer i,k + + + if (rats) then +! create logfile + open(unit=perfunit,file=trim(perfile),status='REPLACE') + write(perfunit,'(A)') '# UNIT: ' // trim(unit_string) + write(unit=perfunit,fmt='("#",A9,3A10,A17,A10)') 'RMS', + > 'RMS(REF)', 'WBNORM','GRADNORM', 'UPDATE/IT.', + > 'FIT#' + endif + +! total number of neurons / W-matrix elements in vector par + wei_end=weistr(2,nlay-1,1) +! starting position and end position of Bias vector in par + bi_pos=weistr(1,1,2) + bi_end=weistr(2,nlay,2) + + if (mprun) write(6,asline) + +! initialize rms to impossible value + rms(1:nset)=-1.0d0 + ref_rms(1:nset)=-1.0d0 + + + if ((from_fit.gt.1).or.(to_fit.lt.nset)) then + write(6,'(A)') 'Detected continuation.' + write(6,'(A,ES10.2)') 'Setting all undefined RMS values to:', + > infty + do i=1,from_fit-1 + rms(i)=infty + ref_rms(i)=infty + enddo + do i=to_fit+1,nset + rms(i)=infty + ref_rms(i)=infty + enddo + endif + +!$omp parallel do default(shared) private(i,loc_par,loc_rms, +!$omp& loc_ref_rms,loc_skip) +!$omp& schedule(dynamic) + do i=from_fit, to_fit + if (.not.mprun) write(6,asline) + write(6,'(A,I4.4,A)')'Neural Network #',i,': Start!' + +! make a local copy of current parameter set + do k=1,bi_end + loc_par(k)=par(k,i) + enddo + +! initialize failure state + loc_skip=.false. + +! train ANN with ith parameter set + call NNmin(npat,nref,loc_par,act,loc_rms,loc_ref_rms,pat_in, + > pat_out,ref_in,ref_out, + > wterr,typop,laystr,weistr,nlay, + > rmsopt,mingrad,minwbstep,i,loc_skip) + + if (.not.loc_skip) then + write(6,'("Final rms:",ES21.14,X,"Validation rms:", + > ES21.14,X,A,"(#",I4.4,")")') + > loc_rms*unit_con,loc_ref_rms*unit_con, + > unit_string,i + +! return optimized values to global data structures. + par(:,i)=loc_par + rms(i)=loc_rms + ref_rms(i)=loc_ref_rms + else + rms=infty + ref_rms=infty + endif + + enddo +!$omp end parallel do + + if (rats) then + close(unit=perfunit) + endif + + if (use_record) then + write(6,sline) + if (record_state.eq.record_write) then + call punch_record(par,weistr,nlay,nset,.true.) + else if (record_state.eq.record_overwrite) then + call punch_record(par,weistr,nlay,nset,.false.) + else if (record_state.eq.record_update) then + call punch_record(par,weistr,nlay,nset,.false.) + endif + endif + write(6,newline) + write(6,asline) + write(6,'(A)') 'Training complete.' + +! sort parameter sets + call NNrank(nset,nref,par,rms,ref_rms) + call NNstat(nset,npat,nref,par,rms,ref_rms, + > pat_in,pat_out,ref_in,ref_out, + > typop,laystr,weistr,nlay,nntag) + call print_ErrorSummary(par,pat_in,pat_out,ref_in,ref_out, + > wterr,typop,laystr,weistr,nlay, + > npat,nref) + + + write(6,'(/,A)') 'Done.' + end subroutine + +!-------------------------------------------------------------------------------------- + + subroutine NNrank(nset,nref,par,rms,ref_rms) + use nn_params + use nncommons + use io_parameters + use nndbg_mod + implicit none +! Sorts the parameter sets from best to worst, as well as the +! corresponding rms and ref_rms values. Prints an excerpt from the +! resulting ranking. +! +! nset: number of optimized ANNs +! nref: number of reference patterns +! rms: (weighted) root mean square errors +! ref_rms: (weighted) root mean square errors of validation set +! tenptile: position of the 10th percentile + + + double precision par(wbcap,nset),rms(nset),ref_rms(nset) + integer nset,nref + + double precision, dimension(:,:), allocatable :: par_copy + double precision rms_copy(nset),ref_copy(nset) + integer rms_pos(nset) + integer tenptile,rank_end + + double precision rms_avrg,ref_avrg + + integer k + + allocate(par_copy(wbcap,nset)) + + tenptile=ceiling(0.1D0*dble(nset)) + + rms_copy=0.0d0 + +! create copy of rms-vector to be sorted + do k=1,nset + par_copy(:,k)=par(:,k) + rms_copy(k)=rms(k) + ref_copy(k)=ref_rms(k) + rms_pos(k)=k + enddo + +! rank individual trained NNs by rms error. + write(6,'(A)') 'Searching for best fit..' + call dqsort2(nset,rms_copy,rms_pos) + + write(6,'(A,ES21.4,X,A)') 'Best rms found:', rms_copy(1)*unit_con, + > trim(unit_string) + if (nref.gt.0) then + write(6,'(A,ES21.4,X,A)') 'Reference rms: ', + > ref_rms(rms_pos(1))*unit_con, + > trim(unit_string) +! produce easy-to-grep rms summary + write(6,'(A,ES12.4,X,A,X,"(",ES14.4,X,A,")")') 'RESULT:', + > rms_copy(1)*unit_con, trim(unit_string), + > ref_rms(rms_pos(1))*unit_con, trim(unit_string) + else + write(6,'(A,ES12.4,X,A)') 'RESULT:', + > rms_copy(1)*unit_con, trim(unit_string) + endif + write(6,sline) + + if (dbg) then + write(6,'(/,A)') 'Ranking errors:' + rank_end=nset + else + write(6,'(/,A,/)') 'Ranking errors (top 10%):' + rank_end=tenptile + endif + write(6,'(A15,2A12)') 'FIT#','RMS ['//trim(unit_string)//']', + > 'REF ['//trim(unit_string)//']' + + rms_avrg=0.0D0 + ref_avrg=0.0D0 + + do k=1,rank_end + write(6,'(I15,2ES12.4)') rms_pos(k), + > rms_copy(k)*unit_con, ref_rms(rms_pos(k))*unit_con + rms_avrg=rms_avrg + rms_copy(k) + ref_avrg=ref_avrg + ref_rms(rms_pos(k)) + enddo + rms_avrg=rms_avrg/dble(rank_end) + ref_avrg=ref_avrg/dble(rank_end) + if (.not.dbg) then + write(6,hline) + write(6,'(A15,2ES12.4)') 'AVERAGE ['//trim(unit_string)//']:', + > rms_avrg*unit_con,ref_avrg*unit_con + endif + + write(6,sline) + + do k=1,nset + par(:,k)=par_copy(:,rms_pos(k)) + rms(k)=rms_copy(k) + ref_rms(k)=ref_copy(rms_pos(k)) + enddo + + deallocate(par_copy) + + end subroutine + +!-------------------------------------------------------------------------------------- + + subroutine NNstat(nset,npat,nref,par,rms,ref_rms, + > pat_in,pat_out,ref_in,ref_out, + > typop,laystr,weistr,nlay,ftag) + use nn_params + use nncommons + use io_parameters + use nndbg_mod + implicit none +! Writes files presenting the distributions of error for the best +! fits, assuming par has already been sorted. +! +! nset: number of optimized ANNs +! npat: number of given pattern pairs +! npar: number of parameters +! nref: number of reference patterns +! rms: (weighted) root mean square errors +! ref_rms: (weighted) root mean square errors of validation set +! tenptile: position of the 10th percentile +! ftag: infix for generated filenames +! + + + double precision par(wbcap,maxset),rms(maxset),ref_rms(maxset) + double precision pat_in(maxnin,*),pat_out(maxpout,*) + double precision ref_in(maxnin,*),ref_out(maxnout,*) + integer laystr(3,maxlay),typop(maxtypes,maxlay) + integer weistr(2,maxlay,2) + integer nlay + character*8 ftag + + integer nset,npat,nref + + double precision, dimension(:), allocatable :: err_vec + double precision, dimension(:), allocatable :: ref_vec + double precision med, med_ref + integer med_pos(2), med_ref_pos(2) + integer tenptile,rank_end + character*64 fname + character*8 unit + + integer k + + allocate(err_vec(maxpats)) + allocate(ref_vec(maxpats)) + + tenptile=ceiling(0.1D0*dble(nset)) + rank_end=min(tenptile,1000) + unit = '[' // trim(unit_string) // ']' + + write(6,'(A)') 'Generating error statistic..' + write(6,sline) + write(6,'(A15,6A12)') 'NETWORK#', + > 'RMS ' // trim(unit), 'MED. ' // trim(unit), + > 'MAX ' // trim(unit), + > 'REF ' // trim(unit), 'MED. ' // trim(unit), + > 'MAX ' // trim(unit) + + if (1.eq.modulo(npat,2)) then + med_pos = (npat+1)/2 + else + med_pos(1) = npat/2 + med_pos(2) = med_pos(1) + 1 + endif + + if (nref.le.1) then + med_ref_pos = 1 + else if (1.eq.modulo(nref,2)) then + med_ref_pos = (nref+1)/2 + else + med_ref_pos(1) = nref/2 + med_ref_pos(2) = med_ref_pos(1) + 1 + endif + + do k=1,rank_end + write(fname,'(A32)') '' + write(fname,'(I4.4)') k + fname = trim(nnfdir) // 'errors_' // trim(ftag) + > // trim(fname) // '.out' + + call punch_fitstat(fname,par(1,k),pat_in,pat_out,err_vec,npat, + > typop,laystr,weistr,nlay, + > .false.) + +! get median + med=0.5d0*(err_vec(med_pos(1))+err_vec(med_pos(2))) + + + if (nref.gt.0) then + open(nnunit,file=trim(fname),status='old',position='append') + write(nnunit,'(A)') '' + write(nnunit,asline) + write(nnunit,'(A)') '# REF:' + close(nnunit) + + call punch_fitstat(fname,par(1,k),ref_in,ref_out, + > ref_vec,nref, + > typop,laystr,weistr,nlay,.true.) + + else + ref_vec(1)=0.0d0 + endif + +! get median + if (nref.eq.0) then + med_ref=0.0d0 + else + med_ref=0.5d0*(ref_vec(med_ref_pos(1)) + > + ref_vec(med_ref_pos(2))) + endif + + write(6,'(I15,6ES12.4)') k, + > rms(k)*unit_con, med*unit_con, err_vec(1)*unit_con, + > ref_rms(k)*unit_con, med_ref*unit_con, ref_vec(1)*unit_con + enddo + + deallocate(err_vec) + deallocate(ref_vec) + + end subroutine + +!-------------------------------------------------------------------------------------- + + subroutine NNerr(par,pat_in,pat_out,ref_in,ref_out, + > wterr, + > typop,laystr,weistr,nlay,rms,ref_rms,npat,nref) + use nn_params + use nncommons + use io_parameters + use nndbg_mod + implicit none +! Evaluates error of given ANN using nnmqo's mkerr subroutine, +! and generates an output file. + + + double precision par(wbcap),wterr(maxpout,maxpats) + double precision pat_in(maxnin,*),pat_out(maxpout,*) + double precision ref_in(maxnin,*),ref_out(maxpout,*) + double precision rms,ref_rms + integer laystr(3,maxlay),typop(maxtypes,maxlay) + integer weistr(2,maxlay,2) + integer nlay + integer npat,nref + + integer wei_end,bi_pos,bi_end + +! total number of neurons / W-matrix elements in vector par + wei_end=weistr(2,nlay-1,1) +! starting position and end position of Bias vector in par + bi_pos=weistr(1,1,2) + bi_end=weistr(2,nlay,2) + +! W, B + call mkerr(par(1),par(bi_pos),wterr,rms, + > pat_in,pat_out, + > typop,laystr,nlay,npat) + + write(6,newline) + write(6,asline) + write(6,400) rms*unit_con, trim(unit_string) + if (nref.gt.0) then + call mkerr(par(1),par(bi_pos),wterr(1,npat+1),ref_rms, + > ref_in,ref_out, + > typop,laystr,nlay,nref) + write(6,401) ref_rms*unit_con, trim(unit_string) + else + write(6,403) rms*unit_con, trim(unit_string) + endif +! produce easy-to-grep rms summary + write(6,402) rms*unit_con, trim(unit_string), + > ref_rms*unit_con, trim(unit_string) + + write(6,sline) + + 400 format('RMS of given data and parameter set:',ES12.4,X,A) + 401 format('VALIDATION-RMS:',ES12.4,X,A) + 402 format('RESULT:',ES12.4,X,A,X,'(',ES12.4,X,A,')') + 403 format('RESULT:',ES12.4,X,A) + + + if (showcut) then + call NNcuterr(par,pat_in,pat_out,npat, + > typop,laystr,weistr, + > nlay) + endif + + end subroutine + +!-------------------------------------------------------------------------------------- + + subroutine NNerrvec(par,pat_err,pat_in,pat_out, + > typop,laystr,weistr,nlay) + use nn_params + use nncommons + use io_parameters + use nndbg_mod + implicit none +! Evaluates error vector of given ANN for a *single* pattern using +! nnmqo's mkerrvec subroutine. + + + double precision par(wbcap) + double precision pat_in(maxnin,*),pat_out(maxpout,*) + double precision pat_err(maxpout) + integer laystr(3,maxlay),typop(maxtypes,maxlay) + integer weistr(2,maxlay,2) + integer nlay + + + integer wei_end,bi_pos,bi_end + + +! total number of neurons / W-matrix elements in vector par + wei_end=weistr(2,nlay-1,1) +! starting position and end position of Bias vector in par + bi_pos=weistr(1,1,2) + bi_end=weistr(2,nlay,2) + +! W, B + call mkerrvec(par(1),par(bi_pos),pat_err,pat_in,pat_out, + > typop,laystr,nlay) + + end subroutine + +!-------------------------------------------------------------------------------------- + + subroutine NNkeygen(nnkeylist,nnkeynum,nlay,force) + use nn_params + use io_parameters + use nndbg_mod + implicit none +! Automatically generate a key list for parsing ANN parameters. +! Force, if true, will make the W(*,*) and B(*) keys mandatory. +! +!.....Keys generated are: +! W(i,i+1): B(i): +! where i=01,02,... + + + integer nlay + integer nnkeynum + character*(klen) nnkeylist(2,maxnnkeys) + logical force + + integer j + + + nnkeylist=' ' + +! To utilize the standard keyread utilities, we need the key +! signalizing the EOF + nnkeylist(1,1)='DATA:' + nnkeylist(2,1)='E!' + nnkeynum=1 + +! Next, we generate all standard weight and bias keys +! Weights first + do j=1,nlay-1 + nnkeynum=nnkeynum+1 +! keys for weight matrix elements (layer j->j+1) + write(nnkeylist(1,nnkeynum)(1:10), + > '("W(",I2.2,",",I2.2,"):")') j,j+1 +! expects: arbitrary number of reals + if (force) then + nnkeylist(2,nnkeynum)='D!N' + else + nnkeylist(2,nnkeynum)='DN' + endif + enddo +! Biases next + do j=1,nlay-1 + nnkeynum=nnkeynum+1 +! keys for bias vector (layer j+1) + write(nnkeylist(1,nnkeynum)(1:7), + > '("B(",I2.2,"):")') j+1 +! expects: arbitrary number of reals + if (force) then + nnkeylist(2,nnkeynum)='D!N' + else + nnkeylist(2,nnkeynum)='DN' + endif + enddo +! Weight spreads + do j=1,nlay-1 + nnkeynum=nnkeynum+1 + write(nnkeylist(1,nnkeynum)(1:10), + > '("SW(",I2.2,",",I2.2,"):")') j,j+1 +! expects: one positive real + nnkeylist(2,nnkeynum)='+D1' + enddo +! Bias spreads + do j=1,nlay-1 + nnkeynum=nnkeynum+1 + write(nnkeylist(1,nnkeynum)(1:7), + > '("SB(",I2.2,"):")') j+1 +! expects: one positive real + nnkeylist(2,nnkeynum)='+D1' + enddo + + + end subroutine + +!-------------------------------------------------------------------------------------- + + subroutine NNcuterr(par,pat_in,pat_out,npat, + > typop,laystr,weistr, + > nlay) + use nn_params + use nncommons + use io_parameters + use nndbg_mod + implicit none +! Subroutine providing rms error of all output pattern entries which +! lie below a fixed cutoff threshold provided by common block +! variable cutoff. +! +! pat_in: input patterns +! pat_out: desired output patterns +! npat: number of given pattern pairs +! inp_in: number of coordinates written into input. +! inp_out: number of values written to output +! + + + integer npat + double precision par(wbcap) + double precision pat_in(maxnin,*),pat_out(maxpout,*) + integer laystr(3,maxlay),typop(maxtypes,maxlay) + integer weistr(2,maxlay,2) + integer nlay + + integer fmtlen + parameter (fmtlen=16) + character*(fmtlen) intfmt,dblefmt + parameter (intfmt='(I8)',dblefmt='(ES14.2)') + double precision pat_err(maxpout),rms_vec(maxpout) + double precision cut_rms,cut_norm + integer err_count(maxpout) + + integer n,j + + rms_vec=0.0d0 + cut_rms=0.0d0 + cut_norm=0.0d0 + err_count=0 + + write(6,'(A)') 'Calculating cutoff-rms..' + +! accumulate errors sorted by corresponding output + do n=1,npat + call NNerrvec(par,pat_err,pat_in(1,n),pat_out(1,n), + > typop,laystr,weistr,nlay) +! count only errors actually contributing to cutoff-rms + do j=1,inp_out + if (pat_out(j,n).le.cutoff(j)) then + rms_vec(j)=rms_vec(j)+pat_err(j)**2 + err_count(j)=err_count(j)+1 + endif + enddo + enddo + +! calculate rms-errors + do j=1,inp_out + if (err_count(j).le.0) then + write(6,'(A,I3.3)') 'WARNING: NO OUTPUT FOUND WITHIN' + > // ' CUTOFF FOR OUTPUT VALUE #',j + rms_vec(j)=-1.0d0 + else + cut_rms=cut_rms+rms_vec(j)*cutwei(j) + cut_norm=cut_norm+cutwei(j)*dble(err_count(j)) + rms_vec(j)=dsqrt(rms_vec(j)/dble(err_count(j)))*unit_con + endif + enddo + + if (all(err_count(1:inp_out).le.0)) then + write(6,'(A)') 'WARNING: NO PATTERN WITHIN CUTOFF RANGE(S).' + else + cut_rms=dsqrt(cut_rms/cut_norm)*unit_con + endif + + write(6,'(A)') 'Number of outputs within cutoff range:' + call printivec_full(err_count,intfmt,fmtlen,inp_out,5) + write(6,'(A)') 'Individual unweighted RMS-errors ['// + > trim(unit_string)//']:' + call printvec_full(rms_vec,dblefmt,fmtlen,inp_out,5) + write(6,'(A,ES14.2)') 'Total cutoff-RMS [' + > //trim(unit_string)//']:',cut_rms + write(6,newline) + write(6,'(A)') '((RMS of -1 means undefined value))' + write(6,sline) + end subroutine diff --git a/src/io_parameters.f90 b/src/io_parameters.f90 new file mode 100644 index 0000000..a83f389 --- /dev/null +++ b/src/io_parameters.f90 @@ -0,0 +1,15 @@ +module io_parameters + use accuracy_constants, only: dp,idp + implicit none + private :: dp, idp + + integer(idp),parameter:: dnlen = 8192,maxlines = 300000 + integer(idp),parameter:: llen = 750, klen = 32 + integer(idp),parameter:: maxkeys = 200 + integer(idp),parameter:: maxdat = 10000, clen = 1024 + integer(idp),parameter:: maxerrors=100 + logical,parameter:: mprun = .true. + integer(idp),parameter:: nstat = 4,nmeta=20 + integer(idp),parameter:: maxoutp = nstat+nmeta + +END MODULE diff --git a/src/lib/choldc.f b/src/lib/choldc.f new file mode 100644 index 0000000..217b116 --- /dev/null +++ b/src/lib/choldc.f @@ -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. + 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 diff --git a/src/lib/diag.f b/src/lib/diag.f new file mode 100644 index 0000000..29f73ac --- /dev/null +++ b/src/lib/diag.f @@ -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 diff --git a/src/lib/dmatrix.f b/src/lib/dmatrix.f new file mode 100644 index 0000000..e2990e7 --- /dev/null +++ b/src/lib/dmatrix.f @@ -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 diff --git a/src/lib/dmatrix.f~ b/src/lib/dmatrix.f~ new file mode 100644 index 0000000..4922c78 --- /dev/null +++ b/src/lib/dmatrix.f~ @@ -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 diff --git a/src/lib/fileread.f b/src/lib/fileread.f new file mode 100644 index 0000000..c5f101e --- /dev/null +++ b/src/lib/fileread.f @@ -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 diff --git a/src/lib/imatrix.f b/src/lib/imatrix.f new file mode 100644 index 0000000..a231be5 --- /dev/null +++ b/src/lib/imatrix.f @@ -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 diff --git a/src/lib/keyread.f b/src/lib/keyread.f new file mode 100644 index 0000000..ba689d9 --- /dev/null +++ b/src/lib/keyread.f @@ -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 diff --git a/src/lib/long_keyread.f b/src/lib/long_keyread.f new file mode 100644 index 0000000..4c55a62 --- /dev/null +++ b/src/lib/long_keyread.f @@ -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 diff --git a/src/lib/misc.f b/src/lib/misc.f new file mode 100644 index 0000000..3037a77 --- /dev/null +++ b/src/lib/misc.f @@ -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 diff --git a/src/lib/qsort.f b/src/lib/qsort.f new file mode 100644 index 0000000..ce7e0ae --- /dev/null +++ b/src/lib/qsort.f @@ -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 diff --git a/src/lib/ran.f b/src/lib/ran.f new file mode 100644 index 0000000..60ae02c --- /dev/null +++ b/src/lib/ran.f @@ -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 diff --git a/src/lib/ran_gv.f b/src/lib/ran_gv.f new file mode 100644 index 0000000..26a11ad --- /dev/null +++ b/src/lib/ran_gv.f @@ -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 diff --git a/src/lib/random.f b/src/lib/random.f new file mode 100644 index 0000000..8e4da97 --- /dev/null +++ b/src/lib/random.f @@ -0,0 +1,1365 @@ +!Fixed file to make debugging with warnings possible +!Removed a few not used variables +!NW 22.05.2015 + + + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c 18.03.2010 A Viel +c interface for genetic to call Marius Lewerenz random generator copied here +c seed : initialization seed: large negative integer - negative forced +c ierr=6 : output for error +c n: number of random number requested +c +c initialization +c call vranf(Rand,0,seed,ierr) +c Random array with uniform distribution +c call vranf(rand,n,0,ierr) +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + function rn(seed,gtype,cont) + implicit none + integer i,seed,gtype,cont + integer ierr,iseed + + double precision rn,rand(1) + + save ierr + +c .. initialize new random number stream: +c.. cont is egal to 1 only once + do i=1,cont + ierr=6 +c force seed to be negative integer + iseed=-iabs(seed) +c initialize random number with seed=iseed + call vranf(rand,0,iseed,ierr) + enddo + +c.. generate a single random number / uniform distribution + call vranf(rand,1,0,ierr) + rn=rand(1) + + end +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c Random generator From Marius Lewerenz +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine gautrg(gran,nran,iseed,iout) +c +c vectorized portable unit standard deviation gaussian random +c number generator using the box-mueller transformation method. +c this method is faster than the central limit method, when the +c uniform random numbers are comparatively expensive. +c version working on a square with sine and cosine functions. the +c same sequence is produced independent of the sequence of calls +c if no calls to other vranf based prn generators are made. +c +c gran : vector of length nran returning the random numbers +c nran : number of desired random numbers, with nran=0 and iseed +c not 0 only generator initialization is done. no action +c when both are zero. +c iseed : if not 0, integer to start generator. use 0 to continue +c a previously used/initialized random sequence, unchanged +c on output. +c iout : unit number for messages. +c +c times for the generation of 10**6 prn's: +c rs6000/350 41 mhz 2.31 s +c r8000 75 mhz 1.43 s +c axp21064 200 mhz 1.20 s +c axp21164 250 mhz 0.572 s +c t3e-900 450 mhz 0.52 s +c cray-t90 450 mhz 0.0728 s 1.28*10**7 prn/s +c +c subroutines called: vranf, r1mach +c m. lewerenz 6/may/90, modified 17/jun/91, mar/95 +c + implicit double precision (a-h,o-z) + parameter (two=2.d0,twom=-two,one=1.d0,npoly=11) + dimension gran(nran),ccf(npoly),scf(npoly), xran(1) + save isave,gsave,tiny,twopi,pi4,ccf,scf + data isave/-1/ +C +C POLYNOMIAL FROM CHEBYSHEV APPROXIMATION ON [ 0.000, 0.790] +C FOR COS(X) WITH ABSOLUTE ERROR LESS THAN 0.2220E-14 +C + DATA ccf/ 0.9999999999999986D+00, 0.6612476846390664D-13, + # -0.4999999999989523D+00,-0.5434658088910759D-10, + # 0.4166666737609693D-01,-0.4648977428396692D-08, + # -0.1388871052129944D-02,-0.4228394738587799D-07, + # 0.2486361945804866D-04,-0.5317743184071916D-07, + # -0.2539224676809412D-06/ +C +C POLYNOMIAL FROM CHEBYSHEV APPROXIMATION ON [ 0.000, 0.790] +C FOR SIN(X) WITH ABSOLUTE ERROR LESS THAN 0.2220E-14 +C + DATA scf/-0.9443414574112906D-15, 0.1000000000000244D+01, + # -0.1224236196202217D-10,-0.1666666664242968D+00, + # -0.2471495821870120D-08, 0.8333348067492644D-02, + # -0.5482536616811601D-07,-0.1982815612039858D-03, + # -0.2017619095413939D-06, 0.2948964053761139D-05, + # -0.1051448397925916D-06/ +c + if(isave.lt.0) then + isave=0 + tiny=r1mach(0)**2 + pi4=atan(one) + twopi=pi4*8 + end if + if(iseed.ne.0) call vranf(gran,0,iseed,iout) +c + if(nran.gt.0) then + newran=nran-isave + if(isave.eq.1) gran(1)=gsave + call vranf(gran(isave+1),newran,0,iout) + do 100 i=1,newran-1,2 + fac=sqrt(twom*log(gran(isave+i)+tiny)) + x=pi4*gran(isave+i+1) + cx=(((((((((ccf(11)*x+ccf(10))*x+ccf(9))*x+ccf(8))*x + # +ccf(7))*x+ccf(6))*x+ccf(5))*x + # +ccf(4))*x+ccf(3))*x+ccf(2))*x+ccf(1) + sx=(((((((((scf(11)*x+scf(10))*x+scf(9))*x+scf(8))*x + # +scf(7))*x+scf(6))*x+scf(5))*x + # +scf(4))*x+scf(3))*x+scf(2))*x+scf(1) + sxi=(two*cx)*sx + cxi=(two*cx)*cx-one + sxi=(two*cxi)*sxi + cxi=(two*cxi)*cxi-one + sxi=(two*cxi)*sxi + cxi=(two*cxi)*cxi-one + gran(isave+i)=fac*sxi + gran(isave+i+1)=fac*cxi + 100 continue +c + if(mod(newran,2).eq.1) then + call vranf(xran(1),1,0,iout) + fac=sqrt(twom*log(gran(nran)+tiny)) + trig=twopi*xran(1) + gran(nran)=fac*sin(trig) + gsave=fac*cos(trig) + isave=1 + else + isave=0 + end if + end if + return + end +C +C---------------------------------------------------------------------- +C + FUNCTION R1MACH (IDUM) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + PARAMETER (ONE=1.D0,TWO=2.D0,HALF=0.5D0) + SAVE ICALL,EPS + DATA ICALL,EPS/0,ONE/ +C --------------------------------------------------------------------- +C THIS ROUTINE COMPUTES THE UNIT ROUNDOFF OF THE MACHINE. +C THIS IS DEFINED AS THE SMALLEST POSITIVE MACHINE NUMBER +C U SUCH THAT 1.0 + U .NE. 1.0E0 +C --------------------------------------------------------------------- + IF(ICALL.EQ.0) THEN + ICALL=1 + U = ONE + 10 U = U*HALF + COMP = ONE + U + IF(COMP .NE. ONE) GO TO 10 + EPS = U*TWO + END IF + R1MACH = EPS + RETURN + END +c +c---------------------------------------------------------------------- +c + subroutine vcopy(v1,v2,nv) +c +c copies vector v1 into v2. +c subroutines called : none m. lewerenz +c + implicit double precision (a-h,o-z) + dimension v1(nv),v2(nv) +c + if(nv.gt.0) then + do 10 i=1,nv + v2(i)=v1(i) + 10 continue + end if + return + end + +c----------------------------------------------------------------------- +c-------------------- ranf/vranf uniform random package ---------------- +c----------------------------------------------------------------------- +c + subroutine vranf(ranv,nran,iseed,iout) +c +c machine independent portable uniform random number generator for +c the interval [0,1) based on a floating point subtractive lagged +c fibonacci method similar to the feedback shift register method +c proposed by kirkpatrick/stoll. subtractive (or additive) version +c gives much better prn quality than the original xor operation. +c an additive variant is given in v r a n f a. +c +c v r a n f and r a n f use the same method and can be used to +c work together on the same random sequence. either of them can be +c used for initialization. the state of the generator can be saved +c or retrieved for restart with routine r s a v e f. +c ---------------------------------------------------------------------- +c +c ranv : vector of length nran for random numbers; output +c nran : number of desired random numbers. nran=0 and iseed.ne.0 +c -> only generator initialization. no action when both +c are zero.; input +c iseed : if not 0, integer to start generator. use 0 to continue +c a previously used/initialized random sequence, unchanged +c on output; input +c iout : unit number for error messages. silent for iout.le.0 +c +c ---------------------------------------------------------------------- +c method: +c x(k+np)=x(k)-x(k+np-nq), initial x array generated by xuinit. +c ieee standard requires double precision to have at least 48 mantissa bits. +c with nbit=48 this generator is entirely machine independent +c and will always give the same random sequence. you can change +c the period of the generator by setting a different nbit value or +c changing np and nq appropriately. +c +c ---------------------------------------------------------------------- +c this is a floating implementation of a generator described in: +C M.H. KALOS, P.A. WHITLOCK, MONTE CARLO METHODS, APPENDIX, +C WILEY 1986 +C D.W. HEERMANN, COMPUTER SIMULATION METHODS, 2ND ED.,SPRINGER 199 +C APPENDIX A1 +c d. stauffer, f.w. hehl, v. winkelmann, j.g. zabolitzky, +c computer simulation & computer algebra, section 2.2 +c +c original references: +c s. kirkpatrick, e.p. stoll, j. comput. phys. 40, 517 (1981) +c r.c. tausworthe, random numbers generated by linear recurrence +c modulo 2, math. comp. 19, 201 (1965) +c t.g. lewis, w.h. payne, generalized feedback shift register +c pseudorandom number algorithm, j. acm 20, 456 (1973) +c +c ---------------------------------------------------------------------- +c other (np,nq) values: (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 alternative additive formulation bypassing if statements: +c temp=x(k)+x(k+np-nq) +c x(k)=temp-float(int(temp)) +c +c alternative subtractive formulation bypassing if statements: +c temp=x(k)-x(k+np-nq) +c x(k)=(temp+one)-float(int(temp+one)) +c ---------------------------------------------------------------------- +c +c timing in s for 10**7 random numbers: +c +c machine mhz unroll(4) no unrolling +c ibm rs6000/350 41 2.67 3.9 +c dec axp3800 200 1.17 +c dec axp3600 150 1.35 +c dec alpha 21164 250 0.45 +c t3e alpha 21164 450 0.40 +c sun ultra1 ??? 1.38 +c ibm 3090vf 58 --- 2.47(vec), 4.57(sc) +c cray t90 450 0.31 ranf() takes 0.13 s +c +c unrolling to depth 6 gives a slight speed increase. +c ---------------------------------------------------------------------- +c subroutines called: xuinit,errprt m. lewerenz may/91 & nov/93 +c + implicit double precision (a-h,o-z) + include 'ranlfg.inc' + parameter (nratio=np/nq,nexec=4,mroll=4,zero=0.d0,one=1.d0) + dimension ranv(nran) + common /doctrl/ nroll +c +c table initialization by xuinit +c + if(iseed.ne.0) then + call xuinit(x,np,nq,0,nexec,iseed,init,last,iout) + end if +c +c fibonacci generator updates elements of x in a cyclic fashion +c and copies them into ranv in blocks of max. length np. +c loop split into chunks of max. length nq to avoid recurrence. +c unrolling improves performance on superscalar machines. +c + if(nran.gt.0) then + if(init.ne.0) then + j=0 + left=nran + 10 continue + if(nroll.gt.1) then + loop=mod((min(nq,left+last)-last),mroll) + else + loop=min(nq,left+last)-last + end if +convex, cray, and ibm directives +c$dir no_recurrence +cdir$ ivdep +cibmdir ignore recrdeps + do 500 i=last+1,last+loop + x1=x(i)-x(i+np-nq) + if(x1.lt.zero) x1=x1+one + x(i)=x1 + j=j+1 + ranv(j)=x1 + 500 continue + if(nroll.gt.1) then + do 501 i=last+loop+1,min(nq,left+last),mroll + x1=x(i)-x(i+np-nq) + x2=x(i+1)-x(i+1+np-nq) + x3=x(i+2)-x(i+2+np-nq) + x4=x(i+3)-x(i+3+np-nq) + if(x1.lt.zero) x1=x1+one + if(x2.lt.zero) x2=x2+one + if(x3.lt.zero) x3=x3+one + if(x4.lt.zero) x4=x4+one + x(i)=x1 + x(i+1)=x2 + x(i+2)=x3 + x(i+3)=x4 + ranv(j+1)=x1 + ranv(j+2)=x2 + ranv(j+3)=x3 + ranv(j+4)=x4 + j=j+4 + 501 continue + end if +c + if(last.lt.nratio*nq) then + do 650 k=1,nratio-1 + limit=min((k+1)*nq,left+last) + if(nroll.gt.1) then + loop=mod((limit-max(k*nq,last)),mroll) + else + loop=limit-max(k*nq,last) + end if +convex, cray, and ibm directives +c$dir no_recurrence +cdir$ ivdep +cibmdir ignore recrdeps + do 600 i=max(k*nq,last)+1,max(k*nq,last)+loop + x1=x(i)-x(i-nq) + if(x1.lt.zero) x1=x1+one + x(i)=x1 + j=j+1 + ranv(j)=x1 + 600 continue + if(nroll.gt.1) then + do 601 i=max(k*nq,last)+loop+1,limit,mroll + x1=x(i)-x(i-nq) + x2=x(i+1)-x(i+1-nq) + x3=x(i+2)-x(i+2-nq) + x4=x(i+3)-x(i+3-nq) + if(x1.lt.zero) x1=x1+one + if(x2.lt.zero) x2=x2+one + if(x3.lt.zero) x3=x3+one + if(x4.lt.zero) x4=x4+one + x(i)=x1 + x(i+1)=x2 + x(i+2)=x3 + x(i+3)=x4 + ranv(j+1)=x1 + ranv(j+2)=x2 + ranv(j+3)=x3 + ranv(j+4)=x4 + j=j+4 + 601 continue + end if + 650 continue + end if +c + limit=min(np,left+last) + if(nroll.gt.1) then + loop=mod((limit-max(nratio*nq,last)),mroll) + else + loop=limit-max(nratio*nq,last) + end if +convex, cray, and ibm directives +c$dir no_recurrence +cdir$ ivdep +cibmdir ignore recrdeps + do 700 i=max(nratio*nq,last)+1,max(nratio*nq,last)+loop + x1=x(i)-x(i-nq) + if(x1.lt.zero) x1=x1+one + x(i)=x1 + j=j+1 + ranv(j)=x1 + 700 continue + if(nroll.gt.1) then + do 701 i=max(nratio*nq,last)+loop+1,limit,mroll + x1=x(i)-x(i-nq) + x2=x(i+1)-x(i+1-nq) + x3=x(i+2)-x(i+2-nq) + x4=x(i+3)-x(i+3-nq) + if(x1.lt.zero) x1=x1+one + if(x2.lt.zero) x2=x2+one + if(x3.lt.zero) x3=x3+one + if(x4.lt.zero) x4=x4+one + x(i)=x1 + x(i+1)=x2 + x(i+2)=x3 + x(i+3)=x4 + ranv(j+1)=x1 + ranv(j+2)=x2 + ranv(j+3)=x3 + ranv(j+4)=x4 + j=j+4 + 701 continue + end if +c + last=mod(limit,np) + left=nran-j + if(left.gt.0) goto 10 + else + call errprt(iout,'vranf','incorrect initialization',-1) + end if + end if + return + end +c +c----------------------------------------------------------------------- +c + subroutine xuinit(x,np,nq,mode,nexec,iseed,init,last,iout) +c +c initializes a (np,nq) lagged fibonacci generator table +c with random bits generated by a congruential generator using +c l'ecuyers decomposition. ref.: bratley et al. p. 214 +c +c x : vector of length np for initial random number table; +c output +c np,nq : parameters p and q of feedback shift register generator; +c input +c mode : operation for lfg: +c mode=<0 -> subtractive generator, mode=1 additive +c nexec : number of warm up cycles for the table. nexec*nbit*np +c random numbers are generated and discarded; input +c iseed : integer seed for congruential generator generating +c the bits of the initial table entries; input +c init : returns updated seed of congruential generator. +c 0 if table was not initialized, > 0 if ok; output +c last : pointer to the last used number in the table; output +c iout : unit number for messages, silent for iout.le.0; input +c subroutines called : errprt m. lewerenz mar/93, mar/98 +c + implicit double precision (a-h,o-z) + parameter (ia=40692,ib=52774,ic=3791,ip=2147483399) + parameter (zero=0.d0,one=1.d0,half=0.5d0,iphalf=ip/2,nbit=48) + logical high + dimension x(np) +c + if(nq.ge.np.or.iseed.eq.0) then + call errprt(iout,'xuinit','illegal seed parameter(s)',-1) + else +c +c set table to zero and exercise the bit generator a little +c + ix=iabs(iseed) + if(ix.ne.0) then + do i=1,np + x(i)=zero + k1=ix/ib + ix=ia*(ix-k1*ib)-k1*ic + if(ix.lt.0) ix=ix+ip + end do +c +c assemble np numbers with mantissa length nbit from random bits +c 'high' toggle compensates for bias from odd ip +c + high=.true. + do i=1,np + add=half + do j=1,nbit + k1=ix/ib + ix=ia*(ix-k1*ib)-k1*ic + if(ix.lt.0) ix=ix+ip + if(high) then + if(ix.ge.iphalf) x(i)=x(i)+add + high=.false. + else + if(ix.gt.iphalf) x(i)=x(i)+add + high=.true. + end if + add=add*half + end do + end do + if(nexec.gt.0) call xuwarm(x,np,nq,mode,nbit*nexec,iout) + end if + init=ix + last=0 + end if + return + end +c +c----------------------------------------------------------------------- +c + subroutine xuwarm(x,np,nq,mode,nexec,iout) +c +c warms up (p,q) lagged fibonacci generators (lfg) by nexec rounds +c +c x : vector of length np for initial random number table; +c output +c np,nq : parameters p and q of feedback shift register generator; +c input +c mode : operation for lfg: +c mode=<0 -> subtractive generator, mode=1 additive +c nexec : number of warm up cycles for the table. nexec*nbit*np +c random numbers are generated and discarded; input +c iout : unit number for messages, silent for iout.le.0; input +c subroutines called : errprt m. lewerenz mar/98 +c + implicit double precision (a-h,o-z) + parameter (zero=0.d0,one=1.d0) + dimension x(np) +c + if(nq.ge.np.or.np.eq.0.or.nq.eq.0) then + call errprt(iout,'xuwarm','illegal table parameter(s)',-1) + else +c +c exercise the generator for nexec rounds of np prn's +c separate sections for subtractive or additive version +c + if(mode.le.0) then + do k=1,nexec + do i=1,nq + x(i)=x(i)-x(i+np-nq) + if(x(i).lt.zero) x(i)=x(i)+one + end do + do i=nq+1,np + x(i)=x(i)-x(i-nq) + if(x(i).lt.zero) x(i)=x(i)+one + end do + end do + else + do k=1,nexec + do i=1,nq + x(i)=x(i)+x(i+np-nq) + if(x(i).ge.one) x(i)=x(i)-one + end do + do i=nq+1,np + x(i)=x(i)+x(i-nq) + if(x(i).ge.one) x(i)=x(i)-one + end do + end do + end if + end if + return + end +c +c----------------------------------------------------------------------- +c + subroutine vrans(ranv,nran,iseed,iout) +c +c floating point subtractive lagged finonacci generator for +c uniformly distributed random numbers. +c identical with vranf but split into two separate subroutines. +c see there for description. +c +c ranv : vector of length nran for random numbers; output +c nran : number of desired random numbers. nran=0 and iseed.ne.0 +c -> only generator initialization. no action when both +c are zero.; input +c iseed : if not 0, integer to start generator. use 0 to continue +c a previously used/initialized random sequence, unchanged +c on output; input +c iout : unit number for error messages. silent for iout.le.0 +c +c times for 10**7 prn: sun ultra1 1.423 s +c cray-t90 450 mhz 0.307 s +c +c subroutines called: xuinit, fslfg, errprt m. lewerenz mar/98 +c + implicit double precision (a-h,o-z) + include 'ranlfg.inc' + parameter (nexec=4) + dimension ranv(nran) +c +c table initialization by xuinit +c + if(iseed.ne.0) then + call xuinit(x,np,nq,0,nexec,iseed,init,last,iout) + end if +c +c cyclic table update and output vector generation by fslfg +c + if(nran.gt.0) then + if(init.ne.0) then + call fslfg(x,np,nq,last,ranv,nran,iout) + else + call errprt(iout,'vrans','incorrect initialization',-1) + end if + end if + return + end +c +c----------------------------------------------------------------------- +c + subroutine vrans2(ranv,nran,a,b,iseed,iout) +c +c floating point subtractive generator for random numbers with +c uniform distribution on the interval [a,b). +c +c ranv : vector of length nran for random numbers; output +c nran : number of desired random numbers. nran=0 and iseed.ne.0 +c -> only generator initialization. no action when both +c are zero.; input +c a,b : interval limits for random numbers; input +c iseed : if not 0, integer to start generator. use 0 to continue +c a previously used/initialized random sequence, unchanged +c on output; input +c iout : unit number for error messages. silent for iout.le.0 +c +c times for 10**7 prn: sun ultra1 1.502 s +c cray-t90 0.355 s +c ---------------------------------------------------------------------- +c subroutines called: xuinit, fslfg2, errprt +c m. lewerenz mar/98 +c + implicit double precision (a-h,o-z) + include 'ranlfg.inc' + parameter (nexec=4) + dimension ranv(nran) +c +c table initialization by xuinit +c + if(iseed.ne.0) then + call xuinit(x,np,nq,0,nexec,iseed,init,last,iout) + end if +c +c cyclic table update and output vector generation by fslfg2 +c + if(nran.gt.0) then + if(init.ne.0) then + call fslfg2(x,np,nq,last,a,b,ranv,nran,iout) + else + call errprt(iout,'vrans2','incorrect initialization',-1) + end if + end if + return + end +c +c----------------------------------------------------------------------- +c + subroutine vranf2(ranv,nran,a,b,iseed,iout) +c +c identical to vrans2, kept to resolve references to vranf2. +c see vrans2 for description. m. lewerenz mar/98 +c + implicit double precision (a-h,o-z) + include 'ranlfg.inc' + parameter (nexec=4) + dimension ranv(nran) +c +c table initialization by xuinit +c + if(iseed.ne.0) then + call xuinit(x,np,nq,0,nexec,iseed,init,last,iout) + end if +c +c cyclic table update and output vector generation by fslfg2 +c + if(nran.gt.0) then + if(init.ne.0) then + call fslfg2(x,np,nq,last,a,b,ranv,nran,iout) + else + call errprt(iout,'vranf2','incorrect initialization',-1) + end if + end if + return + end +c +c----------------------------------------------------------------------- +c + subroutine vranfx(ranv,nran,iseed,iout) +c +c special version of vranf eliminating the store into the table +c during the main computation. this version cannot work together +c with ranf. 0 =< x < 1 +c +c ranv : vector of length nran returning the random numbers +c nran : number of desired random numbers. with nran=0 and iseed +c not 0 only generator initialization is done. no action +c when both are zero. +c iseed : if not 0, integer to start generator. use 0 to continue +c a previously used/initialized random sequence, unchanged +c on output +c iout : unit number for error messages. silent for iout.le.0 +c +c method and references : see comments in vranf +c subroutines called: xuinit m. lewerenz 19/jan/93 +c + implicit double precision (a-h,o-z) + include 'ranlfg.inc' + parameter (nexec=4,zero=0.d0,one=1.d0) + dimension ranv(nran) +c +c ---------- initialization of x-table and warm up ---------- +c + if(iseed.ne.0) then + call xuinit(x,np,nq,0,nexec,iseed,init,last,iout) + end if +c +c -------- generation of vector of uniform deviates ---------- +c + if(nran.gt.0) then + if(init.ne.0) then +c +c expand x-vector into ranv vector, the first loop is +c not recurrent, recurrence in second loop broken by +c explicit stripmining with vector lengths of max. nq +c + do i=1,min(nran,nq) + xx=x(i)-x(i+np-nq) + if(xx.lt.zero) xx=xx+one + ranv(i)=xx + end do +c + if(nran.gt.nq) then + istart=nq+1 + 150 continue +cdir$ ivdep + do i=istart,min(np,istart+nq-1) + xx=x(i)-ranv(i-nq) + if(xx.lt.zero) xx=xx+one + ranv(i)=xx + end do + istart=istart+nq + if(istart.le.np) goto 150 + end if +c +c main computation within ranv vector; recurrence broken +c by explicit stripmining with vector lengths of max. nq +c + if(nran.gt.np) then + istart=np+1 + 250 continue +cdir$ ivdep + do i=istart,min(nran,istart+nq-1) + xx=ranv(i-np)-ranv(i-nq) + if(xx.lt.zero) xx=xx+one + ranv(i)=xx + end do + istart=istart+nq + if(istart.le.nran) goto 250 +c +c shift the np most recent prn's back into x vector +c + do i=1,np + x(i)=ranv(nran-np+i) + end do + else +c this may look like a recurrence to some compilers +cdir$ ivdep + do i=1,np-nran + x(i)=x(i+nran) + end do + do i=np-nran+1,np + x(i)=ranv(i+nran-np) + end do + end if + else + call errprt(iout,'vranfx','incorrect initialization',-1) + end if + end if + return + end +c +c----------------------------------------------------------------------- +c + subroutine fslfg(x,np,nq,last,ranv,nran,iout) +c +c generic floating point subtractive lagged fibonacci generator. +c performs internal table update and copies random numbers into +c output vector. seed table must have been initialized separately +c e.g. by x u i n i t. +c ---------------------------------------------------------------------- +c alternative additive formulation bypassing if statements: +c temp=x(k)+x(k+np-nq) +c x(k)=temp-float(int(temp)) +c +c alternative subtractive formulation bypassing if statements: +c temp=x(k)-x(k+np-nq) +c x(k)=(temp+one)-float(int(temp+one)) +c ---------------------------------------------------------------------- +c subroutines called: errprt m. lewerenz dec/96, mar/98 +c + implicit double precision (a-h,o-z) + parameter (mroll=4,zero=0.d0,one=1.d0) + dimension ranv(nran),x(np) + common /doctrl/ nroll +c + if(np.le.0.or.nq.le.0.or.nq.ge.np.or.last.ge.np.or.last.lt.0) then + call errprt(iout,'fslfg','invalid table parameters',-1) + else + if(nran.gt.0) then + nratio=np/nq + j=0 + left=nran +c +c ------------------- straight loop version first ---------------------- +c --------------------- best for vector machines ----------------------- +c + if(nroll.le.1) then + 10 continue +cdir$ ivdep + do i=last+1,min(nq,left+last) + x1=x(i)-x(i+np-nq) + if(x1.lt.zero) x1=x1+one + x(i)=x1 + j=j+1 + ranv(j)=x1 + end do +c + if(last.lt.nratio*nq) then + do k=1,nratio-1 +cdir$ ivdep + do i=max(k*nq,last)+1,min((k+1)*nq,left+last) + x1=x(i)-x(i-nq) + if(x1.lt.zero) x1=x1+one + x(i)=x1 + j=j+1 + ranv(j)=x1 + end do + end do + end if + limit=min(np,left+last) +cdir$ ivdep + do i=max(nratio*nq,last)+1,limit + x1=x(i)-x(i-nq) + if(x1.lt.zero) x1=x1+one + x(i)=x1 + j=j+1 + ranv(j)=x1 + end do +c + last=mod(limit,np) + left=nran-j + if(left.gt.0) goto 10 +c +c --------------------- unrolled version of loops ---------------------- +c ---------------------- best for risc machines ------------------------ +c + else + 20 continue + loop=mod((min(nq,left+last)-last),mroll) + do i=last+1,last+loop + x1=x(i)-x(i+np-nq) + if(x1.lt.zero) x1=x1+one + x(i)=x1 + j=j+1 + ranv(j)=x1 + end do + do i=last+loop+1,min(nq,left+last),mroll + x1=x(i)-x(i+np-nq) + x2=x(i+1)-x(i+1+np-nq) + x3=x(i+2)-x(i+2+np-nq) + x4=x(i+3)-x(i+3+np-nq) + if(x1.lt.zero) x1=x1+one + if(x2.lt.zero) x2=x2+one + if(x3.lt.zero) x3=x3+one + if(x4.lt.zero) x4=x4+one + x(i)=x1 + x(i+1)=x2 + x(i+2)=x3 + x(i+3)=x4 + ranv(j+1)=x1 + ranv(j+2)=x2 + ranv(j+3)=x3 + ranv(j+4)=x4 + j=j+4 + end do +c + if(last.lt.nratio*nq) then + do k=1,nratio-1 + limit=min((k+1)*nq,left+last) + loop=mod((limit-max(k*nq,last)),mroll) + do i=max(k*nq,last)+1,max(k*nq,last)+loop + x1=x(i)-x(i-nq) + if(x1.lt.zero) x1=x1+one + x(i)=x1 + j=j+1 + ranv(j)=x1 + end do + do i=max(k*nq,last)+loop+1,limit,mroll + x1=x(i)-x(i-nq) + x2=x(i+1)-x(i+1-nq) + x3=x(i+2)-x(i+2-nq) + x4=x(i+3)-x(i+3-nq) + if(x1.lt.zero) x1=x1+one + if(x2.lt.zero) x2=x2+one + if(x3.lt.zero) x3=x3+one + if(x4.lt.zero) x4=x4+one + x(i)=x1 + x(i+1)=x2 + x(i+2)=x3 + x(i+3)=x4 + ranv(j+1)=x1 + ranv(j+2)=x2 + ranv(j+3)=x3 + ranv(j+4)=x4 + j=j+4 + end do + end do + end if +c + limit=min(np,left+last) + loop=mod((limit-max(nratio*nq,last)),mroll) + do i=max(nratio*nq,last)+1,max(nratio*nq,last)+loop + x1=x(i)-x(i-nq) + if(x1.lt.zero) x1=x1+one + x(i)=x1 + j=j+1 + ranv(j)=x1 + end do + do i=max(nratio*nq,last)+loop+1,limit,mroll + x1=x(i)-x(i-nq) + x2=x(i+1)-x(i+1-nq) + x3=x(i+2)-x(i+2-nq) + x4=x(i+3)-x(i+3-nq) + if(x1.lt.zero) x1=x1+one + if(x2.lt.zero) x2=x2+one + if(x3.lt.zero) x3=x3+one + if(x4.lt.zero) x4=x4+one + x(i)=x1 + x(i+1)=x2 + x(i+2)=x3 + x(i+3)=x4 + ranv(j+1)=x1 + ranv(j+2)=x2 + ranv(j+3)=x3 + ranv(j+4)=x4 + j=j+4 + end do +c + last=mod(limit,np) + left=nran-j + if(left.gt.0) goto 20 + end if + end if + end if + return + end +c +c----------------------------------------------------------------------- +c + subroutine fslfg2(x,np,nq,last,a,b,ranv,nran,iout) +c +c generic floating point subtractive lagged fibonacci generator on +c the interval [a,b]. works on the same internal table as f s l f g +c and allows mixed usage. +c performs internal table update and copies random numbers into +c output vector. seed table must have been initialized separately +c e.g. by x u i n i t. +c subroutines called: errprt m. lewerenz dec/96, mar/98 +c + implicit double precision (a-h,o-z) + parameter (mroll=4,zero=0.d0,one=1.d0) + dimension ranv(nran),x(np) + common /doctrl/ nroll +c + if(np.le.0.or.nq.le.0.or.nq.ge.np.or.last.ge.np.or.last.lt.0) then + call errprt(iout,'fslfg2','invalid table parameters',-1) + else + if(nran.gt.0) then + nratio=np/nq + j=0 + left=nran + range=b-a +c +c ------------------- straight loop version first ---------------------- +c --------------------- best for vector machines ----------------------- +c + if(nroll.le.1) then + 10 continue +cdir$ ivdep + do i=last+1,min(nq,left+last) + x1=x(i)-x(i+np-nq) + if(x1.lt.zero) x1=x1+one + x(i)=x1 + j=j+1 + ranv(j)=range*x1+a + end do +c + if(last.lt.nratio*nq) then + do k=1,nratio-1 +cdir$ ivdep + do i=max(k*nq,last)+1,min((k+1)*nq,left+last) + x1=x(i)-x(i-nq) + if(x1.lt.zero) x1=x1+one + x(i)=x1 + j=j+1 + ranv(j)=range*x1+a + end do + end do + end if + limit=min(np,left+last) +cdir$ ivdep + do i=max(nratio*nq,last)+1,limit + x1=x(i)-x(i-nq) + if(x1.lt.zero) x1=x1+one + x(i)=x1 + j=j+1 + ranv(j)=range*x1+a + end do +c + last=mod(limit,np) + left=nran-j + if(left.gt.0) goto 10 +c +c --------------------- unrolled version of loops ---------------------- +c ---------------------- best for risc machines ------------------------ +c + else + 20 continue + loop=mod((min(nq,left+last)-last),mroll) + do i=last+1,last+loop + x1=x(i)-x(i+np-nq) + if(x1.lt.zero) x1=x1+one + x(i)=x1 + j=j+1 + ranv(j)=range*x1+a + end do + do i=last+loop+1,min(nq,left+last),mroll + x1=x(i)-x(i+np-nq) + x2=x(i+1)-x(i+1+np-nq) + x3=x(i+2)-x(i+2+np-nq) + x4=x(i+3)-x(i+3+np-nq) + if(x1.lt.zero) x1=x1+one + if(x2.lt.zero) x2=x2+one + if(x3.lt.zero) x3=x3+one + if(x4.lt.zero) x4=x4+one + x(i)=x1 + x(i+1)=x2 + x(i+2)=x3 + x(i+3)=x4 + ranv(j+1)=range*x1+a + ranv(j+2)=range*x2+a + ranv(j+3)=range*x3+a + ranv(j+4)=range*x4+a + j=j+4 + end do +c + if(last.lt.nratio*nq) then + do k=1,nratio-1 + limit=min((k+1)*nq,left+last) + loop=mod((limit-max(k*nq,last)),mroll) + do i=max(k*nq,last)+1,max(k*nq,last)+loop + x1=x(i)-x(i-nq) + if(x1.lt.zero) x1=x1+one + x(i)=x1 + j=j+1 + ranv(j)=range*x1+a + end do + do i=max(k*nq,last)+loop+1,limit,mroll + x1=x(i)-x(i-nq) + x2=x(i+1)-x(i+1-nq) + x3=x(i+2)-x(i+2-nq) + x4=x(i+3)-x(i+3-nq) + if(x1.lt.zero) x1=x1+one + if(x2.lt.zero) x2=x2+one + if(x3.lt.zero) x3=x3+one + if(x4.lt.zero) x4=x4+one + x(i)=x1 + x(i+1)=x2 + x(i+2)=x3 + x(i+3)=x4 + ranv(j+1)=range*x1+a + ranv(j+2)=range*x2+a + ranv(j+3)=range*x3+a + ranv(j+4)=range*x4+a + j=j+4 + end do + end do + end if +c + limit=min(np,left+last) + loop=mod((limit-max(nratio*nq,last)),mroll) + do i=max(nratio*nq,last)+1,max(nratio*nq,last)+loop + x1=x(i)-x(i-nq) + if(x1.lt.zero) x1=x1+one + x(i)=x1 + j=j+1 + ranv(j)=range*x1+a + end do + do i=max(nratio*nq,last)+loop+1,limit,mroll + x1=x(i)-x(i-nq) + x2=x(i+1)-x(i+1-nq) + x3=x(i+2)-x(i+2-nq) + x4=x(i+3)-x(i+3-nq) + if(x1.lt.zero) x1=x1+one + if(x2.lt.zero) x2=x2+one + if(x3.lt.zero) x3=x3+one + if(x4.lt.zero) x4=x4+one + x(i)=x1 + x(i+1)=x2 + x(i+2)=x3 + x(i+3)=x4 + ranv(j+1)=range*x1+a + ranv(j+2)=range*x2+a + ranv(j+3)=range*x3+a + ranv(j+4)=range*x4+a + j=j+4 + end do +c + last=mod(limit,np) + left=nran-j + if(left.gt.0) goto 20 + end if + end if + end if + return + end +c +c----------------------------------------------------------------------- +c + function ranf(iseed,iout) +c +c generator for uniformly distributed pseudo random numbers using +c the fibonacci method with 48 bit mantissa output. single output +c version of vranf. see comments there for method. successive calls +c generate the same random sequence as vranf. ranf and vranf can be +c used together, working on the same random sequence, and either +c one can be used for initialization. this generator is machine +c independent and gives the same random sequence on any machine. +c 5.52 s for 1000000 calls on convex c210. 3.06 s on ibm-3090/300s +c +c iseed : if not 0, generator is initialized and ranf returns a +c real echo of iseed; no random number output. iseed is +c unchanged. +c if 0, ranf returns the next random number from a +c previously used or initialized random sequence. +c iout : unit number for error messages. silent for iout.le.0 +c subroutines called: vranf m. lewerenz 12/may/91 +c + implicit double precision (a-h,o-z) + include 'ranlfg.inc' + parameter (zero=0.d0,one=1.d0) + dimension dummy(1) +c +c table initialization by vranf +c + if(iseed.ne.0) then + call vranf(dummy,0,iseed,iout) + ranf=iseed + else + if(init.ne.0) then + if(last.lt.nq) then + ranf=x(last+1)-x(last+1+np-nq) + else + ranf=x(last+1)-x(last+1-nq) + end if + if(ranf.lt.zero) ranf=ranf+one + x(last+1)=ranf + last=mod(last+1,np) + else + call errprt(iout,'ranf','incorrect initialization',-1) + end if + end if + return + end +c +c----------------------------------------------------------------------- +c + subroutine rsavef(isave,iout) +c +c table backup for routines ranf, vranf, and vranf2. +c uses unit iabs(isave) to save or retrieve contents of common +c block /xrandf/ for program restart with continuation of the +c old random sequence. isave > 0 write, isave < 0 read. +c iout is a message unit. np and nq must be consistent with +c vranf and ranf! +c subroutines called: errprt,xuinit m. lewerenz 12/may/91 +c + implicit double precision (a-h,o-z) + include 'ranlfg.inc' +c + iunit=iabs(isave) + if(isave.gt.0) then + write(iunit) np,nq,last + write(iunit) x + else if(isave.lt.0) then + read(iunit) npp,nqq,last + if(npp.ne.np.or.nqq.ne.nq.or.nqq.ge.npp.or.last.lt.0. + # or.last.gt.np) then + call errprt(iout,'rsavef', + # 'illegal file contents -> using default seed',0) + iseed=123456789 + call xuinit(x,np,nq,0,4,iseed,init,last,iout) + else + read(iunit) x + init=1 + end if + else + call errprt(iout,'rsavef','illegal unit number',-1) + end if + return + end +c +c----------------------------------------------------------------------- +c + subroutine rnsetf(xsave,nx,iflag,iout) +c +c sets or gets state of generator table used in routines ranf, +c vranf, and vranf2. +c +c xsave : vector of length nx containing the state of the +c generator. nx must be > np; input or output +c nx : length of vector xsave, must be at least np+2 which +c is currently 252; input +c iflag : 0 -> xsave returns the state of the generator; +c else -> generator state is set to xsave; input +c iout : unit number for messages; silent for iout.le.0; input +c np and nq must be consistent with settings in vranf and ranf! +c subroutines called: errprt m. lewerenz jan/94 +c + implicit double precision (a-h,o-z) + include 'ranlfg.inc' + dimension xsave(nx) +c + if(nx.ge.(np+2)) then + if(iflag.eq.0) then + call vcopy(x,xsave,np) + xsave(np+1)=last + xsave(np+2)=init + else + call vcopy(xsave,x,np) + last=xsave(np+1) + init=xsave(np+2) + if(init.eq.0) then + call errprt(iout,'rnsetf','bad generator state',-1) + end if + end if + else + call errprt(iout,'rnsetf','xsave vector too short',-1) + end if + return + end +c +c----------------------------------------------------------------------- +c + subroutine vrseed(iseed,iout) +c +c returns current status of internal congruential generator used +c to seed the bit tables for ranf/vranf package. useful to seed +c other copies of ranf/vranf. +c +c iseed : seed from current congruential generator status; output +c iout : unit number for messages; silent for iout.le.0; input +c subroutines called: errprt m. lewerenz feb/98 +c + implicit double precision (a-h,o-z) + include 'ranlfg.inc' +c + iseed=init + if(init.eq.0) call errprt(iout,'vrseed','illegal seed',1) + return + end +c======================================================================= +c================== last line of ranf/vranf package ==================== +c======================================================================= +c----------------------------------------------------------------------- +c-------------------------- error handling ----------------------------- +c----------------------------------------------------------------------- +c + subroutine errprt(iout,pgname,text,icode) +c +c prints error messages from library subroutines +c +c iout : unit number for message output, 0-> no output; input +c pgname : name of the subroutine calling errprt; input +c text : message text; input +c icode : severity code: 0 -> warning, < 0 -> fatal error with +c abort, else -> error but execution continues +c subroutines called : strlen m. lewerenz dec/93 +c + character pgname*(*),text*(*),header*20,tail*40 + save nerror,nwarn,icall + common /errcnt/ maxerr,maxwrn + data icall/0/ +c + if(icall.eq.0) then + icall=1 + nerror=0 + nwarn=0 + end if +c + if(icode.lt.0) then + header=' *** fatal error,' + tail=', execution aborted ***' + else if(icode.eq.0) then + header=' *** warning,' + tail=' ***' + nwarn=nwarn+1 + else + header=' *** error,' + tail=', return without action ***' + nerror=nerror+1 + end if +c +c write the message on unit iout +c + if(iout.gt.0) then + call strlen(pgname,lname,iout) + call strlen(text,ltext,iout) + call strlen(header,lhead,iout) + call strlen(tail,ltail,iout) + write(iout,'(/6a/)') header(1:lhead),' ',text(1:ltext),' in ', + # pgname(1:lname),tail(1:ltail) + call flush + end if +c + jcode=icode + if(maxerr.gt.0.and.nerror.ge.maxerr) then + if(iout.gt.0) write(iout,'(/a)') + # ' *** maximum number of errors exceeded, program stopped *** ' + jcode=-1 + end if + if(maxwrn.gt.0.and.nwarn.ge.maxwrn) then + if(iout.gt.0) write(iout,'(/a)') + # ' *** maximum number of warnings exceeded, program stopped ***' + jcode=-1 + end if + if(iout.gt.0) call flush +c + if(jcode.lt.0) stop + return +c +c --------------------------------------------------------------------- +c error report, returns current number of errors and warning +c + entry errnum(nerr,nwrn) + nerr=nerror + nwrn=nwarn + return + end +C +C---------------------------------------------------------------------- +C + SUBROUTINE STRLEN(STRING,LS,IOUT) +C +C DETERMINES LENGTH OF STRING +C + CHARACTER STRING*(*) +C + LS=LEN(STRING) + 10 IF(LS.GT.0.AND.STRING(LS:LS).EQ.' ') THEN + LS=LS-1 + GOTO 10 + END IF + IF(LS.EQ.0) call errprt(iout,'strlen','empty string',0) + RETURN + END +c +c----------------------------------------------------------------------- +c + subroutine flush +c +c dummy to resolve calls to the buffer flushing routine +c available on dec axp and sgi machines +c + return + end diff --git a/src/lib/random.o b/src/lib/random.o new file mode 100644 index 0000000..184ec50 Binary files /dev/null and b/src/lib/random.o differ diff --git a/src/lib/ranlfg.inc b/src/lib/ranlfg.inc new file mode 100644 index 0000000..4c17024 --- /dev/null +++ b/src/lib/ranlfg.inc @@ -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 ------------------------------- diff --git a/src/lib/strings.f b/src/lib/strings.f new file mode 100644 index 0000000..21699f6 --- /dev/null +++ b/src/lib/strings.f @@ -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 diff --git a/src/lib/typedef.incl b/src/lib/typedef.incl new file mode 100644 index 0000000..c9991d5 --- /dev/null +++ b/src/lib/typedef.incl @@ -0,0 +1,5 @@ + + integer typenum,maxtypelen + parameter (typenum=6,maxtypelen=2) + character*(maxtypelen) types(typenum) + parameter (types=['I ', '+I', 'D ', '+D', 'C ', 'E ']) diff --git a/src/long_io.f b/src/long_io.f new file mode 100644 index 0000000..4c6a3e7 --- /dev/null +++ b/src/long_io.f @@ -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 diff --git a/src/mkNN.f b/src/mkNN.f new file mode 100644 index 0000000..a083118 --- /dev/null +++ b/src/mkNN.f @@ -0,0 +1,429 @@ + subroutine mknet(laystr,weistr,neupop,nlay) + use nn_params + use nndbg_mod + implicit none +! Initialize layer structure matrix exclusively. +! +! nlay: number of given layers +! neupop: neuronal population vector: contains number of neurons for each layer +! laystr: layer structure matrix +! weistr: weight structure matrix + + + integer laystr(3,maxlay),weistr(2,maxlay,2), neupop(maxlay) + integer nlay + + integer neu_tot,wei_tot + integer n + + if (dbg) write(6,'(A)') '#INITIALIZING NN....' + + neu_tot=0 !number of reserved neurons spaces in memory so far + wei_tot=0 !number of reserved weight matrix element spaces in mem. so far + + do n=1,nlay-1 + laystr(1,n)=neupop(n) !number of neurons in layer n + laystr(2,n)=neu_tot+1 !starting pos. for layer n + laystr(3,n)=wei_tot+1 !starting pos. for W-matrix + !from layer N to N+1 + neu_tot=neu_tot+neupop(n) + wei_tot=wei_tot+neupop(n)*neupop(n+1) + enddo + laystr(1,nlay)=neupop(nlay) + laystr(2,nlay)=neu_tot+1 + laystr(3,nlay)=wei_tot+1 !technically oversteps boundary + !of W-vector; practically points to first bias + if (dbg) write(6,'(A)') '#PERFORMING SANITY CHECKS..' + + weistr=0 + +! since there are no input biases, the first entry just points at +! the last few weight matrix elements + weistr(1,1,2)=wei_tot-neupop(1)+1 + weistr(2,1,2)=wei_tot + + do n=1,nlay-1 + weistr(1,n,1)=laystr(3,n) + weistr(2,n,1)=laystr(3,n+1)-1 !end pos. of corresponding W-matrix + weistr(1,n+1,2)=weistr(2,n,2)+1 !starting pos. of bias + weistr(2,n+1,2)=weistr(2,n,2)+neupop(n+1) !end pos. of bias + enddo + + + if (dbg.or.vbs) write(6,*) '#PERFORMING SANITY CHECKS..' + + if (neupop(1).gt.maxnin) then + write(6,'("ERROR: NETWORK INPUT EXCEEDS MAXIMUM.")') + write(6,'(I3.3,"/",I3.3)') neupop(1),maxnin + stop 1 + else if (neupop(nlay).gt.maxnout) then + write(6,'("ERROR: NETWORK OUTPUT EXCEEDS MAXIMUM.")') + write(6,'(I3.3,"/",I3.3)') neupop(nlay),maxnout + stop 1 + else if (nlay.gt.maxlay) then + write(6,'("ERROR: LAYER COUNT EXCEED MAXIMUM.")') + write(6,'(I2.2,"/",I2.2)') nlay,maxlay + stop 1 + endif + do n=2,nlay-1 + if (neupop(1).gt.maxnin) then + write(6,'("ERROR: HIDDEN LAYER SIZE EXCEEDS MAXIMUM.")') + write(6,'(I3.3,"/",I3.3)') neupop(n),maxneu + write(6,'("PROBLEM OCCURED IN LAYER #",I2.2)') n + stop 1 + endif + enddo + if (dbg) then + write(6,*) '#INIT SUCCESSFUL.' + write(6,'(A10,I6)') '#NEU_TOT =',neu_tot + write(6,'(A10,I6)') '#WEI_TOT =',wei_tot + write(6,'(A10,I6)') '#MAXWEI = ',maxwei + endif + end + +!-------------------------------------------------------------------------------------- + + subroutine mkpars(par,spread,laystr,typop,weistr,nlay,rtype) + use nn_params + use io_parameters + use nndbg_mod + implicit none +! Initialize Weights and Biases exclusively. +! +! +! par: one parameter vector +! spread: factor by which each weight or bias spreads around 0 +! nlay: number of given layers +! rtype: type of random distribution: +! 0 -- even distribution +! 1 -- angular uniform distribution, +! vectors normalized to sqrt(wb_end) +! 2 -- even normalized distribution: +! std. deviation of weighted sums is 1. +! Ignores act. +! 3 -- same as 2, but more exact for 2+ hidden layer +! networks +! +! Initialization of the random numbers must have been done before +! call vranf(par(1:1),0,seed,iout) is used for the initialization + + + + double precision par(wbcap),spread(wbcap) + integer laystr(3,maxlay),typop(maxtypes,maxlay) + integer weistr(2,maxlay,2) + integer rtype,nlay + + integer wb_end + + integer k + +! evalute length of entire weight- and bias-vector together + wb_end=weistr(2,nlay,2) + + if (rtype.eq.0) then +! generate random numbers within [0,1) + call vranf(par,wb_end,0,iout) +! shift range accordingly + do k=1,wb_end + par(k)=(par(k)-0.5D0)*2.0D0*spread(k) + enddo + else if (rtype.eq.1) then +! generate random numbers + call nnorm_grv(par,wb_end,1) +! shift range accordingly + do k=1,wb_end + par(k)=par(k)*2.0D0*spread(k) + enddo + else if (rtype.eq.2) then +! generate random numbers within [0,1) + call vranf(par,wb_end,0,iout) +! shift range to [-1,1) + do k=1,wb_end + par(k)=(par(k)-0.5D0)*2.0D0 + enddo + call normalize_wbvec(par,laystr,weistr,nlay) + else if (rtype.eq.3) then +! generate random numbers within [0,1) + call vranf(par,wb_end,0,iout) +! shift range to [-1,1) + do k=1,wb_end + par(k)=(par(k)-0.5D0)*2.0D0 + enddo + call normalize_wbvec_nonlin(par,laystr,weistr,typop,nlay) + par=par*spread + else + stop 'ERROR: INVALID TYPE OF RANDOM NUMBER GENERATION (RTYPE)' + endif + + end + +!-------------------------------------------------------------------------------------- + subroutine normalize_wbvec_nonlin(par,laystr,weistr,typop,nlay) + use nn_params + use nncommons + use io_parameters + use nndbg_mod + implicit none +! Normalizes weights and biases in such a way that the standard +! deviation of a layer's weighted sums is 1, assuming par has been +! initialized with evenly distributed values from -1 to 1. +! +! For ANNs with 1 hidden layer, this routine is exact. For +! multilayered ANNs, this routine approximates distortions from ANN +! activation functions linearly. The "radius" of the even +! distribution is given for a layer k by: +! +! sqrt(3)/sqrt(1+N_eff(k-1)), +! +! where N_eff(k-1) is the effective number of neurons of the +! previous layer. It is given by the sum over all squared +! activation function derivatives at 0 of the previous layer. +! Hence, for f(x)=x for all neurons in a given layer N_eff is the +! actual number of neurons in that layer. +! + + double precision par(wbcap) + integer laystr(3,maxlay),typop(maxtypes,maxlay) + integer weistr(2,maxlay,2) + integer nlay + + double precision L(maxneu),deriv(maxneu),wbfact(maxlay) + double precision effnum + integer neu_out + + integer j,n + +! input layer has a trivial activation by def. + wbfact(1)=dsqrt(3.0d0)/dsqrt(dble(laystr(1,1)+1)) + + do n=2,nlay + L=0 + deriv=0 + neu_out=laystr(1,n) + +! sum over squared derivatives + call neurons(neu_out,L,deriv,typop(1,n)) + effnum=0.0d0 + do j=1,neu_out + effnum=effnum+deriv(j)**2 + enddo + + wbfact(n)=dsqrt(3.0d0)/dsqrt(effnum+1.0d0) + enddo + + do n=1,nlay-1 + do j=weistr(1,n,1),weistr(2,n,1) + par(j)=par(j)*wbfact(n) + enddo + enddo + do n=2,nlay + do j=weistr(1,n,2),weistr(2,n,2) + par(j)=par(j)*wbfact(n-1) + enddo + enddo + + end + + +!-------------------------------------------------------------------------------------- + + subroutine normalize_wbvec(par,laystr,weistr,nlay) + use nn_params + use nncommons + use io_parameters + use nndbg_mod + implicit none +! Normalizes weights and biases in such a way that the standard +! deviation of a layer's weighted sums is 1, assuming par has been +! initialized with evenly distributed values from -1 to 1. +! +! For ANNs with 1 hidden layer, this routine is exact. For +! multilayered ANNs, this routine neglects distortion effects of the +! activation functions. + + double precision par(wbcap) + integer laystr(3,maxlay) + integer weistr(2,maxlay,2) + integer nlay + + integer j,n + + do n=1,nlay-1 + do j=weistr(1,n,1),weistr(2,n,1) + par(j)=par(j)*dsqrt(3.0d0)/dsqrt(dble(laystr(1,n)+1)) + enddo + enddo + do n=2,nlay + do j=weistr(1,n,2),weistr(2,n,2) + par(j)=par(j)*dsqrt(3.0d0) + > /dsqrt(dble(laystr(1,n-1)+1)) + enddo + enddo + + end + +!-------------------------------------------------------------------------------------- + + subroutine mkmodpars(par,act,spread,nlay,thresh) + use nn_params + use nncommons, only: pst + use io_parameters + use nndbg_mod + implicit none +! Assume weights and biases to be mostly initialized and only change +! those that have values that which have an absolute value less than +! thresh. Inactive weights and biases remain untouched. +! +! +! par: one parameter vector +! spread: factor by which each weight or bias spreads around 0 +! act: activities for the parameter vector par. Inactive +! parameters remain untouched +! nlay: number of given layers +! thresh: minimum absolute value for a parameter to be +! overwritten. If negative, default to 0.0d0. +! Initialization of the random numbers must have been done before +! call vranf(par(1:1),0,seed,iout) is used for the initialization + + + + double precision par(wbcap),spread(wbcap),thresh + integer act(wbcap) + integer nlay + + double precision ranval(2) + double precision minval + integer wb_end + + integer k + + if (thresh.le.0.0d0) then + minval=0.0d0 + else + minval=thresh + endif + +! evalute length of entire weight- and bias-vector together + wb_end=pst(1,2*(nlay-1))+pst(2,2*(nlay-1))-1 + + do k=1,wb_end +! check whether par(k) needs changing. + if ((act(k).ne.0).and.(dabs(par(k)).le.minval)) then +! generate random number within [0,1) + call vranf(ranval,1,0,iout) +! shift range accordingly + par(k)=(ranval(1)-0.5D0)*2.0D0*spread(k) + endif + enddo + + end +!-------------------------------------------------------------------------------------- + + subroutine mkrefset_tail(pat_in,pat_out,ref_in,ref_out,npat,nref) + use nn_params + use nncommons + use nndbg_mod + implicit none +! Split off the nref last pattern pairs and make them reference data. +! +! npat: number of given pattern pairs. Will be reduced by nref. +! nref: number of reference patterns +! +! pat_in: input patterns +! pat_out: desired output patterns +! pat_*(i,N): value of ith in-/output neuron for pattern N +! +! ref_*: in analogy to pat_in/out for reference data (convergence tests) + + + double precision pat_in(maxnin,maxpats),pat_out(maxpout,maxpats) + double precision ref_in(maxnin,maxpats),ref_out(maxpout,maxpats) + integer npat,nref + + integer j,k + + if (nref.ge.npat) then + write(6,*) 'ERROR: MKREFSET: NREF TOO LARGE FOR GIVEN NPAT' + stop 1 + else if (nref.lt.0) then + write(6,*) 'ERROR: MKREFSET: NEGATIVE NREF' + stop 1 + endif + +! update npat + npat=npat-nref + +! Copy tail to ref-vectors + do j=1,nref + do k=1,maxnin + ref_in(k,j)=pat_in(k,npat+j) + enddo + do k=1,maxpout + ref_out(k,j)=pat_out(k,npat+j) + enddo + enddo + end + +!-------------------------------------------------------------------------------------- + + subroutine mkweights(wterr,npat,pat_out) + use nn_params + use nncommons + use io_parameters + use nndbg_mod + implicit none +! Rescale weights depending on their kind (energy or state +! composition) based on a simplified form of the hybrid +! diabatisation weighting scheme. System specific rescaling is done +! by calling nnweights() for each pattern weight vector. +! +! npat: number of given pattern pairs +! wterr: weight factors for each element of the error vector e +! +! vecnum: number of state vectors in model + + + integer npat + double precision wterr(maxpout,npat),pat_out(maxpout,npat) + + character*32 fname + integer j,n,total,k + + fname = trim(nnfdir) // 'weights.out' + + write(6,stdfmt) 'Applying weighting scheme..' + + open(nnunit,file=trim(fname),status='replace') + write(nnunit,stdfmt) '# This is the established weighting scheme' + > // ' for the present fit.' + write(nnunit,stdfmt) '# Weights appear in the order given by the' + > // 'original input.' + write(nnunit,stdfmt) '# Weights given here are *not* normalized.' + + write(nnunit,newline) + + !do k=1,npat + + call nnweight(wterr,pat_out,npat) + !enddo + !pat_out = pat_out ! to avoid unsed complain durinng compilation + total=0 + do k=1,sets + write(nnunit,'(A10,I6.5)') '# Scan Nr.',k + do j=1,ndata(k) + total=total+1 + do n=1,inp_out + write(nnunit,'(ES25.15)',advance='NO') + > wterr(n,total) + enddo + write(nnunit,newline) + enddo + enddo + + close(nnunit) + write(6,'(A)') 'Error weight generation successful.' + write(6,'(A)') 'Wrote (not normalized) weights to ''' + > // trim(fname) // '''.' + + end diff --git a/src/model/Phase_correction.f90 b/src/model/Phase_correction.f90 new file mode 100644 index 0000000..5d0a3d0 --- /dev/null +++ b/src/model/Phase_correction.f90 @@ -0,0 +1,149 @@ +module Phase_corr + ! module for correcting the phase issue in the ab inition dipole data + + use iso_fortran_env, only: dp => real64, idp => int32 + use nncommons, only: ndiab + implicit none + + !integer(idp), parameter:: ndiab = 4 + contains + + + SUBROUTINE build_cluster(m,p) + ! subroutine which check the sign of two succesive point + !and correct it if neccessary + ! take dipole mx at point i and at point i+1 + ! update dipole at i+1 + implicit none + Real(dp), intent(in):: m(ndiab,ndiab) ! at point i + Real(dp), intent(inout):: p(ndiab,ndiab) ! mx at i+1 + !Real(dp), intent(inout):: q(qn) + !Real(dp):: prod2, prod3 + + ! check first the sign of mx0(2,3) if it the same as sign of y(coord) + ! q3 is ys + ! q5 is yb + + + + + ! check if the product of the transition element + ! of two successive point there is no flip of sign + ! check if state 1 need to be flipped + !if (needs_flip(M,P,1)) then + ! write(6,*) "state 1 is flipped" + ! call flip_e_state(P,1) + !endif + + ! check if e-state (2) need to be flipped + + if (needs_flip(M,P,2)) then + !write(6,*) "state 2 is flipped" + call flip_e_state(P,2) + endif + + ! check if state (3) need to be flipped + !if (needs_flip(M,P,3)) then + ! write(6,*) 'State 3 is flipped ' + ! call flip_e_state(P,3) + !endif + + ! check for the last state + !if (needs_flip(M,P,4)) then + ! write(6,*) "state 4 is flipped" + ! call flip_e_state(P,4) + !endif + + END SUBROUTINE build_cluster + + + SUBROUTINE flip_e_state(A,O) + ! the routine which flip the sign of the e-state element + !USE dim_parameter, only: ndiab + !USE accuracy_constants, only: idp, dp + implicit none + real(dp), intent(inout):: A(ndiab,ndiab) ! dipole matrix + integer(idp), intent(in):: O ! the index of the e-state to be flipped + real(dp):: P(ndiab,ndiab) + integer(idp):: i + !logical,save :: first_call =.true. + + ! the identity matrix will be used to create the transformation matrix P + + P = 0.0d0 + do i =1,ndiab + P(i,i)=1.0d0 + enddo + ! flipped the sign of the desired e state + + P(o,o) = -1.0d0 + + ! apply P on A + ! A' = P**TAP + A=matmul(transpose(P),matmul(A,P)) + + ! write the index of electronic state flipped + + + + END SUBROUTINE + + logical function needs_flip(m, p, s) + ! Decide whether electronic state s should be flipped + implicit none + real(dp), intent(in) :: m(ndiab, ndiab), p(ndiab, ndiab) + integer(idp), intent(in) :: s + real(dp), parameter:: tol = 1.0d-9,eps_dip =1.0d-6 + + real(dp) :: m1,m2,p1,p2,m3,p3 + + needs_flip = .false. + + select case (s) + case(1) + m1 = m(1,2) ; p1 = p(1,2) + m2 = m(1,3) ; p2 = p(1,3) + m3 = m(1,4) ; p3 = p(1,4) + if ((abs(m1) < eps_dip) .and. (abs(p1) < eps_dip)) then + m1 = m3 + p1 = p3 + else if ((abs(m2) < eps_dip) .and. (abs(p2) < eps_dip)) then + m2 = m3 + p2 = p3 + endif + + case (2) + m1 = m(2,3) ; p1 = p(2,3) + m2 = m(2,4) ; p2 = P(2,4) + + case (3) + m1 = m(2,3) ; p1 = p(2,3) + m2 = m(3,4) ; p2 = p(3,4) + + case(4) + m1 = m(2,4) ; p1 = p(2,4) + m2 = m(3,4) ; p2 = p(3,4) + m3 = m(1,4) ; p3 = p(1,4) + if ((abs(m1) < eps_dip) .and. (abs(p1) < eps_dip)) then + m1 = m3 + p1 = p3 + else if ((abs(m2) < eps_dip) .and. (abs(p2) < eps_dip)) then + m2 = m3 + p2 = p3 + endif + + case default + return + end select + + if (abs(m1*p1) < tol .and. abs(m2*p2) < tol ) return + !if (abs(m2*p2) < tol ) return + + !if (m1*p1 < 0.0_dp .and. m2*p2 < 0.0_dp) then + if (m1*p1 < 0.0_dp) then + needs_flip = .true. + end if + + end function needs_flip + +end module diff --git a/src/model/all.f90 b/src/model/all.f90 new file mode 100644 index 0000000..07c58e9 --- /dev/null +++ b/src/model/all.f90 @@ -0,0 +1,1843 @@ +Module invariants_mod + implicit none + contains + !---------------------------------------------------- + subroutine invariants(a,xs,ys,xb,yb,inv) + implicit none + !include "nnparams.incl" + double precision, intent(in) :: a, xs, ys, xb, yb + double precision, intent(out) ::inv(3) + double precision:: invar(23) + !double precision:: invar(24) + complex(8) :: q1, q2 + LOGICAL,PARAMETER:: debg =.FALSE. + integer :: i + ! express the coordinate in complex + + q1 = dcmplx(xs, ys) + q2 = dcmplx(xb, yb) + + + ! compute the invariants + !inv( 4) = a + !inv( 4) = b**2 + + ! INVARIANTS OF KIND II + !------------------------ + + invar(1) = dreal( q1 * conjg(q1) ) ! r11 + invar(2) = dreal( q1 * conjg(q2) ) ! r12 + invar(3) = dreal( q2 * conjg(q2) ) ! r22 + invar(4) = (dimag(q1 * conjg(q2)) )**2 ! rho 12**2 + + + !INVATIANTS OF KIND III + !------------------------ + + invar(5) = dreal( q1 * q1 * q1 ) ! r111 + invar(6) = dreal( q1 * q1 * q2 ) ! r112 + invar(7) = dreal( q1 * q2 * q2 ) ! r122 + invar(8) = dreal( q2 * q2 * q2 ) ! r222 + invar(9) = (dimag( q1 * q1 * q1 ))**2 ! rho111**2 + invar(10) = (dimag( q1 * q1 * q2 ))**2 ! rho112 **2 + invar(11) = (dimag( q1 * q2 * q2 ))**2 ! rho122**2 + invar(12) = (dimag( q2 * q2 * q2 ))**2 ! rho222 + + ! INVARIANTS OF KIND IV + !------------------------- + + invar(13) = (dimag( q1 * conjg(q2)) * dimag( q1 * q1 * q1 )) + invar(14) = (dimag( q1 * conjg(q2)) * dimag( q1 * q1 * q2 )) + invar(15) = (dimag( q1 * conjg(q2)) * dimag( q1 * q2 * q2 )) + invar(16) = (dimag( q1 * conjg(q2)) * dimag( q2 * q2 * q2 )) + + ! INVARIANTS OF KIND V + !---------------------- + + invar(17) = (dimag( q1 * q1 * q1 ) * dimag( q1 * q1 * q2 )) + invar(18) = (dimag( q1 * q1 * q1 ) * dimag( q1 * q2 * q2 )) + invar(19) = (dimag( q1 * q1 * q1 ) * dimag( q2 * q2 * q2 )) + invar(20) = (dimag( q1 * q1 * q2 ) * dimag( q1 * q2 * q2 )) + invar(21) = (dimag( q1 * q1 * q2 ) * dimag( q2 * q2 * q2 )) + invar(22) = (dimag( q1 * q2 * q2 ) * dimag( q2 * q2 * q2 )) + invar(23) = a + + ! the only non zero invariant for bend pure cuts + + inv(1) = invar( 1) + inv(2) = invar( 5) + inv(3) = invar( 9) + ! inv(4) = invar(1) + ! inv(5) = invar(5) + ! inv(6) = invar(9) + !inv(17)=invar(18) + !inv(19) = invar() + !inv(2) = invar(5) + !inv(3) = invar(9) + !inv(1:22)=invar(1:22) + !inv(4:8) = invar(5:9) + !inv(9)=invar(12) + + + if (debg) then + write(14,"(A,*(f10.5))")"Invar II", (invar(i),i=1,4) + write(14,"(A,*(f10.5))") "Invar III", (invar(i),i=5,12) + write(14,"(A,*(f10.5))")"Invar IV", (invar(i),i=13,16) + write(14,"(A,*(f10.5))")"Invar V", (invar(i),i=17,22) + + write(14,*)"THE INPUT COORDINATE IN COMPLEX REPRES" + write(14,*)"---------------------------------------" + write(14,*)"xs =",dreal(q1), "ys=",dimag(q1) + endif + ! modify the invariants to only consider few of them + ! + !invar(13:22)=0.0d0 + end subroutine invariants + + +! subroutine invariants_ch(a, xs, ys, xb, yb, invar) +! implicit none +! double precision, intent(in) :: a, xs, ys, xb, yb +! double precision, intent(out) :: invar(25) +! +! complex(8) :: q1, q2 +! double precision :: r11, r22, r12, eta +! double precision :: I1, I2, I3, I4 +! +! ! Define complex coordinates +! q1 = dcmplx(xs, ys) +! q2 = dcmplx(xb, yb) +! +! ! Quadratic invariants +! r11 = dreal(q1*conjg(q1)) +! r22 = dreal(q2*conjg(q2)) +! r12 = dreal(q1*conjg(q2)) +! eta = dimag(q1*conjg(q2)) +! +! ! Cubic imag parts (used many times) +! I1 = dimag(q1*q1*q1) +! I2 = dimag(q1*q1*q2) +! I3 = dimag(q1*q2*q2) +! I4 = dimag(q2*q2*q2) +! ! the totally symmetric invariant 25 +! invar(25) = a +! ! Store invariants +! invar(1) = r11 +! invar(2) = r12 +! invar(3) = r22 +! invar(4) = eta*eta +! +! invar(5) = dreal(q1*q1*q1) +! invar(6) = dreal(q1*q1*q2) +! invar(7) = dreal(q1*q2*q2) +! invar(8) = dreal(q2*q2*q2) +! +! invar(9) = I1*I1 +! invar(10) = I2*I2 +! invar(11) = I3*I3 +! invar(12) = I4*I4 +! +! invar(13) = eta * I1 +! invar(14) = eta * I2 +! invar(15) = eta * I3 +! invar(16) = eta * I4 +! +! ! Pure quartic invariants +! invar(17) = r11*r11 + r22*r22 +! invar(18) = r11*r22 - r12*r12 - eta*eta +! +! ! Cubic-imag bilinear invariants (minimal independent set) +! invar(19) = I1*I2 +! invar(20) = I1*I3 +! invar(21) = I1*I4 +! invar(22) = I2*I3 +! invar(23) = I2*I4 +! +! ! Odd cubic invariant +! invar(24) = eta**3 +! +! if (debg) then +! write(14,"(A,*(f10.5))")"Invar II", (invar(i),i=1,4) +! write(14,"(A,*(f10.5))") "Invar III", (invar(i),i=5,12) +! write(14,"(A,*(f10.5))")"Invar IV", (invar(i),i=13,16) +! write(14,"(A,*(f10.5))")"Invar V", (invar(i),i=17,22) +! +! write(14,*)"THE INPUT COORDINATE IN COMPLEX REPRES" +! write(14,*)"---------------------------------------" +! write(14,*)"xs =",dreal(q1), "ys=",dimag(q1) +! endif +! +! end subroutine + +end module invariants_mod + module trans_coord + implicit none + contains + + subroutine cart2mode(qq) + use invariants_mod, only: invariants + use nn_params + use nncommons + implicit none + double precision, intent(inout):: qq(maxnin) + double precision :: q(12),inv(3),qm(6) + double precision, parameter :: m_N=25526.04237518618d0 + double precision, parameter :: m_H=1837.152647439619d0 + double precision, parameter :: Ang2Bohr=1.889726124565d0 + + double precision diff(12), ref_geom(12) + double precision q_mod(12) +! transformation matrix + double precision mode(12,6) + integer i +! final internal coord vector + + + include 'newmodes.f' + + ref_geom(1:12)=0.d0 + ref_geom( 4 )=1.022871078d0 + ref_geom( 7 )=-.5d0*ref_geom(4) + !ref_geom( 8 )=sqrt(1.5d0)*ref_geom(4) + ref_geom( 8)=0.5d0*sqrt(3.0d0)*ref_geom(4) + ref_geom(10 )=-.5d0*ref_geom(4) + !ref_geom(11 )=-sqrt(1.5d0)*ref_geom(4) + ref_geom(11)=-0.5d0*sqrt(3.0d0)*ref_geom(4) + + !massN=25526.04237518618 + !massH=1837.152647439619 + ! + q(1:12)=qq(1:12) + q_mod = (1.0d0/Ang2Bohr)*q + +! difference vector + diff=q_mod-ref_geom + +! mass weighting + diff(1:3)=diff(1:3)*sqrt(m_N) + diff(4:12)=diff(4:12)*sqrt(m_H) + + qm=matmul(transpose(mode),diff) + do i =1,size(qm) + if (abs(qm(i)) .lt. 1.0d-6) qm(i)=0.0d0 + enddo + qm(3) = -qm(3) + call invariants(qm(1),qm(2),qm(3),qm(4),qm(5),inv) + qq =0.0d0 + qq(1:len_in)=inv(1:len_in) + qq(len_in+1:len_in+6)=qm(1:6) + + + end subroutine cart2mode + end module trans_coord +!**** Define coordinate transformation applied to the input before fit. +!*** +!*** +!****Conventions: +!*** +!*** ctrans: subroutine transforming a single point in coordinate space + + subroutine trans_in(pat_in) + !use ctrans_mod, only: ctrans + use trans_coord, only: cart2mode + use nn_params + use nncommons + implicit none + + !include 'nndbg.incl' + + double precision pat_in(maxnin,maxpats) + !integer ntot + + integer j,i,jj + jj=1 + do j=1,sets + !write(62,*)"Scan ",j + do i =1,ndata(j) + call cart2mode(pat_in(:,jj)) + ! FIRST ELEMENT OF PAT-IN ARE USED BY NEURON NETWORK + !write(62,'(*(ES16.8))') pat_in(:,jj) + jj = jj +1 + enddo + enddo + end + Module dip_param + IMPLICIT NONE + Integer,parameter :: np=101 + Double precision :: p(101) + integer :: pst(2,400) + ! Non zero parameters are 17 + !$omp threadprivate(p,pst) + contains + + SUBROUTINE init_dip_planar_data() + implicit none + p( 1)= -0.561433980D+02 + p( 2)= 0.000000000D+00 + p( 3)= 0.000000000D+00 + p( 4)= -0.558830090D+02 + p( 5)= 0.000000000D+00 + p( 6)= 0.000000000D+00 + p( 7)= -0.557220030D+02 + p( 8)= 0.000000000D+00 + p( 9)= 0.000000000D+00 + p( 10)= 0.000000000D+00 + p( 11)= 0.334452655D-02 + p( 12)= 0.000000000D+00 + p( 13)= 0.000000000D+00 + p( 14)= 0.000000000D+00 + p( 15)= 0.000000000D+00 + p( 16)= 0.000000000D+00 + p( 17)= 0.000000000D+00 + p( 18)= 0.000000000D+00 + p( 19)= 0.000000000D+00 + p( 20)= 0.000000000D+00 + p( 21)= -0.532590808D-03 + p( 22)= 0.000000000D+00 + p( 23)= 0.000000000D+00 + p( 24)= 0.000000000D+00 + p( 25)= 0.000000000D+00 + p( 26)= 0.000000000D+00 + p( 27)= 0.000000000D+00 + p( 28)= -0.226116045D-01 + p( 29)= 0.000000000D+00 + p( 30)= -0.363599361D-01 + p( 31)= 0.000000000D+00 + p( 32)= 0.962100323D-01 + p( 33)= 0.000000000D+00 + p( 34)= 0.111336127D-03 + p( 35)= 0.000000000D+00 + p( 36)= 0.000000000D+00 + p( 37)= -0.433685770D-04 + p( 38)= 0.000000000D+00 + p( 39)= 0.000000000D+00 + p( 40)= -0.548870572D-02 + p( 41)= 0.000000000D+00 + p( 42)= 0.000000000D+00 + p( 43)= 0.000000000D+00 + p( 44)= 0.000000000D+00 + p( 45)= 0.000000000D+00 + p( 46)= 0.000000000D+00 + p( 47)= 0.000000000D+00 + p( 48)= 0.000000000D+00 + p( 49)= 0.217598103D+00 + p( 50)= -0.113909871D-01 + p( 51)= 0.000000000D+00 + p( 52)= -0.123184224D-03 + p( 53)= 0.000000000D+00 + p( 54)= 0.000000000D+00 + p( 55)= 0.000000000D+00 + p( 56)= 0.000000000D+00 + p( 57)= 0.000000000D+00 + p( 58)= 0.000000000D+00 + p( 59)= 0.000000000D+00 + p( 60)= 0.000000000D+00 + p( 61)= 0.000000000D+00 + p( 62)= 0.000000000D+00 + p( 63)= 0.000000000D+00 + p( 64)= 0.000000000D+00 + p( 65)= 0.000000000D+00 + p( 66)= 0.000000000D+00 + p( 67)= 0.000000000D+00 + p( 68)= 0.000000000D+00 + p( 69)= 0.000000000D+00 + p( 70)= 0.000000000D+00 + p( 71)= 0.000000000D+00 + p( 72)= 0.000000000D+00 + p( 73)= 0.000000000D+00 + p( 74)= 0.000000000D+00 + p( 75)= 0.000000000D+00 + p( 76)= 0.000000000D+00 + p( 77)= 0.000000000D+00 + p( 78)= 0.000000000D+00 + p( 79)= 0.000000000D+00 + p( 80)= 0.000000000D+00 + p( 81)= 0.000000000D+00 + p( 82)= 0.000000000D+00 + p( 83)= 0.000000000D+00 + p( 84)= 0.000000000D+00 + p( 85)= 0.000000000D+00 + p( 86)= 0.000000000D+00 + p( 87)= -0.567206500D-02 + p( 88)= -0.613490432D-02 + p( 89)= 0.000000000D+00 + p( 90)= 0.303022045D-03 + p( 91)= 0.000000000D+00 + p( 92)= 0.000000000D+00 + p( 93)= 0.000000000D+00 + p( 94)= 0.000000000D+00 + p( 95)= 0.000000000D+00 + p( 96)= 0.000000000D+00 + p( 97)= 0.000000000D+00 + p( 98)= 0.000000000D+00 + p( 99)= 0.000000000D+00 + p(100)= 0.000000000D+00 + p(101)= 0.000000000D+00 + pst(1, 1)= 1 + pst(2, 1)= 3 + pst(1, 2)= 4 + pst(2, 2)= 3 + pst(1, 3)= 7 + pst(2, 3)= 4 + pst(1, 4)= 11 + pst(2, 4)= 2 + pst(1, 5)= 13 + pst(2, 5)= 3 + pst(1, 6)= 16 + pst(2, 6)= 2 + pst(1, 7)= 18 + pst(2, 7)= 3 + pst(1, 8)= 21 + pst(2, 8)= 3 + pst(1, 9)= 24 + pst(2, 9)= 3 + pst(1, 10)= 27 + pst(2, 10)= 1 + pst(1, 11)= 28 + pst(2, 11)= 2 + pst(1, 12)= 30 + pst(2, 12)= 2 + pst(1, 13)= 32 + pst(2, 13)= 2 + pst(1, 14)= 34 + pst(2, 14)= 3 + pst(1, 15)= 37 + pst(2, 15)= 3 + pst(1, 16)= 40 + pst(2, 16)= 3 + pst(1, 17)= 43 + pst(2, 17)= 2 + pst(1, 18)= 45 + pst(2, 18)= 2 + pst(1, 19)= 47 + pst(2, 19)= 2 + pst(1, 20)= 49 + pst(2, 20)= 1 + pst(1, 21)= 50 + pst(2, 21)= 2 + pst(1, 22)= 52 + pst(2, 22)= 5 + pst(1, 23)= 57 + pst(2, 23)= 10 + pst(1, 24)= 67 + pst(2, 24)= 1 + pst(1, 25)= 68 + pst(2, 25)= 2 + pst(1, 26)= 70 + pst(2, 26)= 4 + pst(1, 27)= 74 + pst(2, 27)= 8 + pst(1, 28)= 82 + pst(2, 28)= 2 + pst(1, 29)= 84 + pst(2, 29)= 3 + pst(1, 30)= 87 + pst(2, 30)= 1 + pst(1, 31)= 88 + pst(2, 31)= 2 + pst(1, 32)= 90 + pst(2, 32)= 4 + pst(1, 33)= 94 + pst(2, 33)= 8 + pst(1, 34)= 0 + pst(2, 34)= 0 + pst(1, 35)= 0 + pst(2, 35)= 0 + pst(1, 36)= 0 + pst(2, 36)= 0 + pst(1, 37)= 0 + pst(2, 37)= 0 + pst(1, 38)= 0 + pst(2, 38)= 0 + pst(1, 39)= 0 + pst(2, 39)= 0 + pst(1, 40)= 0 + pst(2, 40)= 0 + pst(1, 41)= 0 + pst(2, 41)= 0 + pst(1, 42)= 0 + pst(2, 42)= 0 + pst(1, 43)= 0 + pst(2, 43)= 0 + pst(1, 44)= 0 + pst(2, 44)= 0 + pst(1, 45)= 0 + pst(2, 45)= 0 + pst(1, 46)= 0 + pst(2, 46)= 0 + pst(1, 47)= 0 + pst(2, 47)= 0 + pst(1, 48)= 0 + pst(2, 48)= 0 + pst(1, 49)= 0 + pst(2, 49)= 0 + pst(1, 50)= 0 + pst(2, 50)= 0 + pst(1, 51)= 0 + pst(2, 51)= 0 + pst(1, 52)= 0 + pst(2, 52)= 0 + pst(1, 53)= 0 + pst(2, 53)= 0 + pst(1, 54)= 0 + pst(2, 54)= 0 + pst(1, 55)= 0 + pst(2, 55)= 0 + pst(1, 56)= 0 + pst(2, 56)= 0 + pst(1, 57)= 0 + pst(2, 57)= 0 + pst(1, 58)= 0 + pst(2, 58)= 0 + pst(1, 59)= 0 + pst(2, 59)= 0 + pst(1, 60)= 0 + pst(2, 60)= 0 + pst(1, 61)= 0 + pst(2, 61)= 0 + pst(1, 62)= 0 + pst(2, 62)= 0 + pst(1, 63)= 0 + pst(2, 63)= 0 + pst(1, 64)= 0 + pst(2, 64)= 0 + pst(1, 65)= 0 + pst(2, 65)= 0 + pst(1, 66)= 0 + pst(2, 66)= 0 + pst(1, 67)= 0 + pst(2, 67)= 0 + pst(1, 68)= 0 + pst(2, 68)= 0 + pst(1, 69)= 0 + pst(2, 69)= 0 + pst(1, 70)= 0 + pst(2, 70)= 0 + pst(1, 71)= 0 + pst(2, 71)= 0 + pst(1, 72)= 0 + pst(2, 72)= 0 + pst(1, 73)= 0 + pst(2, 73)= 0 + pst(1, 74)= 0 + pst(2, 74)= 0 + pst(1, 75)= 0 + pst(2, 75)= 0 + pst(1, 76)= 0 + pst(2, 76)= 0 + pst(1, 77)= 0 + pst(2, 77)= 0 + pst(1, 78)= 0 + pst(2, 78)= 0 + pst(1, 79)= 0 + pst(2, 79)= 0 + pst(1, 80)= 0 + pst(2, 80)= 0 + pst(1, 81)= 0 + pst(2, 81)= 0 + pst(1, 82)= 0 + pst(2, 82)= 0 + pst(1, 83)= 0 + pst(2, 83)= 0 + pst(1, 84)= 0 + pst(2, 84)= 0 + pst(1, 85)= 0 + pst(2, 85)= 0 + pst(1, 86)= 0 + pst(2, 86)= 0 + pst(1, 87)= 0 + pst(2, 87)= 0 + pst(1, 88)= 0 + pst(2, 88)= 0 + pst(1, 89)= 0 + pst(2, 89)= 0 + pst(1, 90)= 0 + pst(2, 90)= 0 + pst(1, 91)= 0 + pst(2, 91)= 0 + pst(1, 92)= 0 + pst(2, 92)= 0 + pst(1, 93)= 0 + pst(2, 93)= 0 + pst(1, 94)= 0 + pst(2, 94)= 0 + pst(1, 95)= 0 + pst(2, 95)= 0 + pst(1, 96)= 0 + pst(2, 96)= 0 + pst(1, 97)= 0 + pst(2, 97)= 0 + pst(1, 98)= 0 + pst(2, 98)= 0 + pst(1, 99)= 0 + pst(2, 99)= 0 + pst(1,100)= 0 + pst(2,100)= 0 + pst(1,101)= 0 + pst(2,101)= 0 + pst(1,102)= 0 + pst(2,102)= 0 + pst(1,103)= 0 + pst(2,103)= 0 + pst(1,104)= 0 + pst(2,104)= 0 + pst(1,105)= 0 + pst(2,105)= 0 + pst(1,106)= 0 + pst(2,106)= 0 + pst(1,107)= 0 + pst(2,107)= 0 + pst(1,108)= 0 + pst(2,108)= 0 + pst(1,109)= 0 + pst(2,109)= 0 + pst(1,110)= 0 + pst(2,110)= 0 + pst(1,111)= 0 + pst(2,111)= 0 + pst(1,112)= 0 + pst(2,112)= 0 + pst(1,113)= 0 + pst(2,113)= 0 + pst(1,114)= 0 + pst(2,114)= 0 + pst(1,115)= 0 + pst(2,115)= 0 + pst(1,116)= 0 + pst(2,116)= 0 + pst(1,117)= 0 + pst(2,117)= 0 + pst(1,118)= 0 + pst(2,118)= 0 + pst(1,119)= 0 + pst(2,119)= 0 + pst(1,120)= 0 + pst(2,120)= 0 + pst(1,121)= 0 + pst(2,121)= 0 + pst(1,122)= 0 + pst(2,122)= 0 + pst(1,123)= 0 + pst(2,123)= 0 + pst(1,124)= 0 + pst(2,124)= 0 + pst(1,125)= 0 + pst(2,125)= 0 + pst(1,126)= 0 + pst(2,126)= 0 + pst(1,127)= 0 + pst(2,127)= 0 + pst(1,128)= 0 + pst(2,128)= 0 + pst(1,129)= 0 + pst(2,129)= 0 + pst(1,130)= 0 + pst(2,130)= 0 + pst(1,131)= 0 + pst(2,131)= 0 + pst(1,132)= 0 + pst(2,132)= 0 + pst(1,133)= 0 + pst(2,133)= 0 + pst(1,134)= 0 + pst(2,134)= 0 + pst(1,135)= 0 + pst(2,135)= 0 + pst(1,136)= 0 + pst(2,136)= 0 + pst(1,137)= 0 + pst(2,137)= 0 + pst(1,138)= 0 + pst(2,138)= 0 + pst(1,139)= 0 + pst(2,139)= 0 + pst(1,140)= 0 + pst(2,140)= 0 + pst(1,141)= 0 + pst(2,141)= 0 + pst(1,142)= 0 + pst(2,142)= 0 + pst(1,143)= 0 + pst(2,143)= 0 + pst(1,144)= 0 + pst(2,144)= 0 + pst(1,145)= 0 + pst(2,145)= 0 + pst(1,146)= 0 + pst(2,146)= 0 + pst(1,147)= 0 + pst(2,147)= 0 + pst(1,148)= 0 + pst(2,148)= 0 + pst(1,149)= 0 + pst(2,149)= 0 + pst(1,150)= 0 + pst(2,150)= 0 + pst(1,151)= 0 + pst(2,151)= 0 + pst(1,152)= 0 + pst(2,152)= 0 + pst(1,153)= 0 + pst(2,153)= 0 + pst(1,154)= 0 + pst(2,154)= 0 + pst(1,155)= 0 + pst(2,155)= 0 + pst(1,156)= 0 + pst(2,156)= 0 + pst(1,157)= 0 + pst(2,157)= 0 + pst(1,158)= 0 + pst(2,158)= 0 + pst(1,159)= 0 + pst(2,159)= 0 + pst(1,160)= 0 + pst(2,160)= 0 + pst(1,161)= 0 + pst(2,161)= 0 + pst(1,162)= 0 + pst(2,162)= 0 + pst(1,163)= 0 + pst(2,163)= 0 + pst(1,164)= 0 + pst(2,164)= 0 + pst(1,165)= 0 + pst(2,165)= 0 + pst(1,166)= 0 + pst(2,166)= 0 + pst(1,167)= 0 + pst(2,167)= 0 + pst(1,168)= 0 + pst(2,168)= 0 + pst(1,169)= 0 + pst(2,169)= 0 + pst(1,170)= 0 + pst(2,170)= 0 + pst(1,171)= 0 + pst(2,171)= 0 + pst(1,172)= 0 + pst(2,172)= 0 + pst(1,173)= 0 + pst(2,173)= 0 + pst(1,174)= 0 + pst(2,174)= 0 + pst(1,175)= 0 + pst(2,175)= 0 + pst(1,176)= 0 + pst(2,176)= 0 + pst(1,177)= 0 + pst(2,177)= 0 + pst(1,178)= 0 + pst(2,178)= 0 + pst(1,179)= 0 + pst(2,179)= 0 + pst(1,180)= 0 + pst(2,180)= 0 + pst(1,181)= 0 + pst(2,181)= 0 + pst(1,182)= 0 + pst(2,182)= 0 + pst(1,183)= 0 + pst(2,183)= 0 + pst(1,184)= 0 + pst(2,184)= 0 + pst(1,185)= 0 + pst(2,185)= 0 + pst(1,186)= 0 + pst(2,186)= 0 + pst(1,187)= 0 + pst(2,187)= 0 + pst(1,188)= 0 + pst(2,188)= 0 + pst(1,189)= 0 + pst(2,189)= 0 + pst(1,190)= 0 + pst(2,190)= 0 + pst(1,191)= 0 + pst(2,191)= 0 + pst(1,192)= 0 + pst(2,192)= 0 + pst(1,193)= 0 + pst(2,193)= 0 + pst(1,194)= 0 + pst(2,194)= 0 + pst(1,195)= 0 + pst(2,195)= 0 + pst(1,196)= 0 + pst(2,196)= 0 + pst(1,197)= 0 + pst(2,197)= 0 + pst(1,198)= 0 + pst(2,198)= 0 + pst(1,199)= 0 + pst(2,199)= 0 + pst(1,200)= 0 + pst(2,200)= 0 + pst(1,201)= 0 + pst(2,201)= 0 + pst(1,202)= 0 + pst(2,202)= 0 + pst(1,203)= 0 + pst(2,203)= 0 + pst(1,204)= 0 + pst(2,204)= 0 + pst(1,205)= 0 + pst(2,205)= 0 + pst(1,206)= 0 + pst(2,206)= 0 + pst(1,207)= 0 + pst(2,207)= 0 + pst(1,208)= 0 + pst(2,208)= 0 + pst(1,209)= 0 + pst(2,209)= 0 + pst(1,210)= 0 + pst(2,210)= 0 + pst(1,211)= 0 + pst(2,211)= 0 + pst(1,212)= 0 + pst(2,212)= 0 + pst(1,213)= 0 + pst(2,213)= 0 + pst(1,214)= 0 + pst(2,214)= 0 + pst(1,215)= 0 + pst(2,215)= 0 + pst(1,216)= 0 + pst(2,216)= 0 + pst(1,217)= 0 + pst(2,217)= 0 + pst(1,218)= 0 + pst(2,218)= 0 + pst(1,219)= 0 + pst(2,219)= 0 + pst(1,220)= 0 + pst(2,220)= 0 + pst(1,221)= 0 + pst(2,221)= 0 + pst(1,222)= 0 + pst(2,222)= 0 + pst(1,223)= 0 + pst(2,223)= 0 + pst(1,224)= 0 + pst(2,224)= 0 + pst(1,225)= 0 + pst(2,225)= 0 + pst(1,226)= 0 + pst(2,226)= 0 + pst(1,227)= 0 + pst(2,227)= 0 + pst(1,228)= 0 + pst(2,228)= 0 + pst(1,229)= 0 + pst(2,229)= 0 + pst(1,230)= 0 + pst(2,230)= 0 + pst(1,231)= 0 + pst(2,231)= 0 + pst(1,232)= 0 + pst(2,232)= 0 + pst(1,233)= 0 + pst(2,233)= 0 + pst(1,234)= 0 + pst(2,234)= 0 + pst(1,235)= 0 + pst(2,235)= 0 + pst(1,236)= 0 + pst(2,236)= 0 + pst(1,237)= 0 + pst(2,237)= 0 + pst(1,238)= 0 + pst(2,238)= 0 + pst(1,239)= 0 + pst(2,239)= 0 + pst(1,240)= 0 + pst(2,240)= 0 + pst(1,241)= 0 + pst(2,241)= 0 + pst(1,242)= 0 + pst(2,242)= 0 + pst(1,243)= 0 + pst(2,243)= 0 + pst(1,244)= 0 + pst(2,244)= 0 + pst(1,245)= 0 + pst(2,245)= 0 + pst(1,246)= 0 + pst(2,246)= 0 + pst(1,247)= 0 + pst(2,247)= 0 + pst(1,248)= 0 + pst(2,248)= 0 + pst(1,249)= 0 + pst(2,249)= 0 + pst(1,250)= 0 + pst(2,250)= 0 + pst(1,251)= 0 + pst(2,251)= 0 + pst(1,252)= 0 + pst(2,252)= 0 + pst(1,253)= 0 + pst(2,253)= 0 + pst(1,254)= 0 + pst(2,254)= 0 + pst(1,255)= 0 + pst(2,255)= 0 + pst(1,256)= 0 + pst(2,256)= 0 + pst(1,257)= 0 + pst(2,257)= 0 + pst(1,258)= 0 + pst(2,258)= 0 + pst(1,259)= 0 + pst(2,259)= 0 + pst(1,260)= 0 + pst(2,260)= 0 + pst(1,261)= 0 + pst(2,261)= 0 + pst(1,262)= 0 + pst(2,262)= 0 + pst(1,263)= 0 + pst(2,263)= 0 + pst(1,264)= 0 + pst(2,264)= 0 + pst(1,265)= 0 + pst(2,265)= 0 + pst(1,266)= 0 + pst(2,266)= 0 + pst(1,267)= 0 + pst(2,267)= 0 + pst(1,268)= 0 + pst(2,268)= 0 + pst(1,269)= 0 + pst(2,269)= 0 + pst(1,270)= 0 + pst(2,270)= 0 + pst(1,271)= 0 + pst(2,271)= 0 + pst(1,272)= 0 + pst(2,272)= 0 + pst(1,273)= 0 + pst(2,273)= 0 + pst(1,274)= 0 + pst(2,274)= 0 + pst(1,275)= 0 + pst(2,275)= 0 + pst(1,276)= 0 + pst(2,276)= 0 + pst(1,277)= 0 + pst(2,277)= 0 + pst(1,278)= 0 + pst(2,278)= 0 + pst(1,279)= 0 + pst(2,279)= 0 + pst(1,280)= 0 + pst(2,280)= 0 + pst(1,281)= 0 + pst(2,281)= 0 + pst(1,282)= 0 + pst(2,282)= 0 + pst(1,283)= 0 + pst(2,283)= 0 + pst(1,284)= 0 + pst(2,284)= 0 + pst(1,285)= 0 + pst(2,285)= 0 + pst(1,286)= 0 + pst(2,286)= 0 + pst(1,287)= 0 + pst(2,287)= 0 + pst(1,288)= 0 + pst(2,288)= 0 + pst(1,289)= 0 + pst(2,289)= 0 + pst(1,290)= 0 + pst(2,290)= 0 + pst(1,291)= 0 + pst(2,291)= 0 + pst(1,292)= 0 + pst(2,292)= 0 + pst(1,293)= 0 + pst(2,293)= 0 + pst(1,294)= 0 + pst(2,294)= 0 + pst(1,295)= 0 + pst(2,295)= 0 + pst(1,296)= 0 + pst(2,296)= 0 + pst(1,297)= 0 + pst(2,297)= 0 + pst(1,298)= 0 + pst(2,298)= 0 + pst(1,299)= 0 + pst(2,299)= 0 + pst(1,300)= 0 + pst(2,300)= 0 + pst(1,301)= 0 + pst(2,301)= 0 + pst(1,302)= 0 + pst(2,302)= 0 + pst(1,303)= 0 + pst(2,303)= 0 + pst(1,304)= 0 + pst(2,304)= 0 + pst(1,305)= 0 + pst(2,305)= 0 + pst(1,306)= 0 + pst(2,306)= 0 + pst(1,307)= 0 + pst(2,307)= 0 + pst(1,308)= 0 + pst(2,308)= 0 + pst(1,309)= 0 + pst(2,309)= 0 + pst(1,310)= 0 + pst(2,310)= 0 + pst(1,311)= 0 + pst(2,311)= 0 + pst(1,312)= 0 + pst(2,312)= 0 + pst(1,313)= 0 + pst(2,313)= 0 + pst(1,314)= 0 + pst(2,314)= 0 + pst(1,315)= 0 + pst(2,315)= 0 + pst(1,316)= 0 + pst(2,316)= 0 + pst(1,317)= 0 + pst(2,317)= 0 + pst(1,318)= 0 + pst(2,318)= 0 + pst(1,319)= 0 + pst(2,319)= 0 + pst(1,320)= 0 + pst(2,320)= 0 + pst(1,321)= 0 + pst(2,321)= 0 + pst(1,322)= 0 + pst(2,322)= 0 + pst(1,323)= 0 + pst(2,323)= 0 + pst(1,324)= 0 + pst(2,324)= 0 + pst(1,325)= 0 + pst(2,325)= 0 + pst(1,326)= 0 + pst(2,326)= 0 + pst(1,327)= 0 + pst(2,327)= 0 + pst(1,328)= 0 + pst(2,328)= 0 + pst(1,329)= 0 + pst(2,329)= 0 + pst(1,330)= 0 + pst(2,330)= 0 + pst(1,331)= 0 + pst(2,331)= 0 + pst(1,332)= 0 + pst(2,332)= 0 + pst(1,333)= 0 + pst(2,333)= 0 + pst(1,334)= 0 + pst(2,334)= 0 + pst(1,335)= 0 + pst(2,335)= 0 + pst(1,336)= 0 + pst(2,336)= 0 + pst(1,337)= 0 + pst(2,337)= 0 + pst(1,338)= 0 + pst(2,338)= 0 + pst(1,339)= 0 + pst(2,339)= 0 + pst(1,340)= 0 + pst(2,340)= 0 + pst(1,341)= 0 + pst(2,341)= 0 + pst(1,342)= 0 + pst(2,342)= 0 + pst(1,343)= 0 + pst(2,343)= 0 + pst(1,344)= 0 + pst(2,344)= 0 + pst(1,345)= 0 + pst(2,345)= 0 + pst(1,346)= 0 + pst(2,346)= 0 + pst(1,347)= 0 + pst(2,347)= 0 + pst(1,348)= 0 + pst(2,348)= 0 + pst(1,349)= 0 + pst(2,349)= 0 + pst(1,350)= 0 + pst(2,350)= 0 + pst(1,351)= 0 + pst(2,351)= 0 + pst(1,352)= 0 + pst(2,352)= 0 + pst(1,353)= 0 + pst(2,353)= 0 + pst(1,354)= 0 + pst(2,354)= 0 + pst(1,355)= 0 + pst(2,355)= 0 + pst(1,356)= 0 + pst(2,356)= 0 + pst(1,357)= 0 + pst(2,357)= 0 + pst(1,358)= 0 + pst(2,358)= 0 + pst(1,359)= 0 + pst(2,359)= 0 + pst(1,360)= 0 + pst(2,360)= 0 + pst(1,361)= 0 + pst(2,361)= 0 + pst(1,362)= 0 + pst(2,362)= 0 + pst(1,363)= 0 + pst(2,363)= 0 + pst(1,364)= 0 + pst(2,364)= 0 + pst(1,365)= 0 + pst(2,365)= 0 + pst(1,366)= 0 + pst(2,366)= 0 + pst(1,367)= 0 + pst(2,367)= 0 + pst(1,368)= 0 + pst(2,368)= 0 + pst(1,369)= 0 + pst(2,369)= 0 + pst(1,370)= 0 + pst(2,370)= 0 + pst(1,371)= 0 + pst(2,371)= 0 + pst(1,372)= 0 + pst(2,372)= 0 + pst(1,373)= 0 + pst(2,373)= 0 + pst(1,374)= 0 + pst(2,374)= 0 + pst(1,375)= 0 + pst(2,375)= 0 + pst(1,376)= 0 + pst(2,376)= 0 + pst(1,377)= 0 + pst(2,377)= 0 + pst(1,378)= 0 + pst(2,378)= 0 + pst(1,379)= 0 + pst(2,379)= 0 + pst(1,380)= 0 + pst(2,380)= 0 + pst(1,381)= 0 + pst(2,381)= 0 + pst(1,382)= 0 + pst(2,382)= 0 + pst(1,383)= 0 + pst(2,383)= 0 + pst(1,384)= 0 + pst(2,384)= 0 + pst(1,385)= 0 + pst(2,385)= 0 + pst(1,386)= 0 + pst(2,386)= 0 + pst(1,387)= 0 + pst(2,387)= 0 + pst(1,388)= 0 + pst(2,388)= 0 + pst(1,389)= 0 + pst(2,389)= 0 + pst(1,390)= 0 + pst(2,390)= 0 + pst(1,391)= 0 + pst(2,391)= 0 + pst(1,392)= 0 + pst(2,392)= 0 + pst(1,393)= 0 + pst(2,393)= 0 + pst(1,394)= 0 + pst(2,394)= 0 + pst(1,395)= 0 + pst(2,395)= 0 + pst(1,396)= 0 + pst(2,396)= 0 + pst(1,397)= 0 + pst(2,397)= 0 + pst(1,398)= 0 + pst(2,398)= 0 + pst(1,399)= 0 + pst(2,399)= 0 + pst(1,400)= 0 + pst(2,400)= 0 +End SUBROUTINE init_dip_planar_data +End Module dip_param +module pesmod + !use dim_parameter,only:qn,ndiab,pst + use iso_fortran_env, only: idp => int32, dp => real64 + use dip_param + + use nn_params + use nncommons + implicit none + + integer(idp),parameter:: ndiab=4 + private + public :: potential_nh3_low + contains + + + subroutine potential_nh3_low(e,q,nn_out) + implicit none + real(dp),intent(in)::q(maxnin) + real(dp),intent(out)::e(:,:) + real(dp),intent(inout):: nn_out(maxnout) + !logical,intent(in):: sym + !integer(idp),intent(in)::key + integer(idp) id,i, ii + real(dp) tmp,xs,xb,ys,yb,a,b,ss,sb + logical, parameter:: switch = .false. ! parameter to switch when you want to know Ex and Ey + logical, parameter:: sym = .false. ! to include r**2 in the Genetic fitting + real(dp),parameter:: tol = 1.0d-9 + real(dp),dimension(17):: scal, shift + + xs=q(len_in+2) + ys=q(len_in+3) + xb=q(len_in+4) + yb=q(len_in+5) + a=q(len_in+1) + b=q(len_in+6) + + ss= xs**2+ys**2 + sb= xb**2+yb**2 + call init_dip_planar_data() + scal = 1.0d-3 + shift = 1.0d0 + ii = 1 + do i =1 ,27 ! pes parameter key index + if( abs(p(i)) .gt. tol ) then + p(i) = p(i)*(shift(ii)+ scal(ii)*nn_out(ii)) + ii = ii + 1 + + endif + enddo + !write(6,*)" PES non zero", ii-1 + + + e = 0.0_dp + id = 1 ! 1 + ! v -term + ! oth order only + ! A2" + e(1,1) = e(1,1) + p(pst(1,id)) !- p(pst(1,1)) + if (sym) then + e(1,1)=e(1,1) + p(pst(1,id)+1)*ss +p(pst(1,id)+2)*sb + endif + id = id +1 !2 + ! E block + e(2,2) = e(2,2)+ p(pst(1,id))! - p(pst(1,1)) + e(3,3) = e(3,3)+ p(pst(1,id))! - p(pst(1,1)) + if (sym) then + e(2,2)=e(2,2)+p(pst(1,id)+1)*ss +p(pst(1,id)+2)*ss**2 + e(3,3)=e(3,3)+p(pst(1,id)+1)*ss +p(pst(1,id)+2)*ss**2 + endif + + id = id +1 ! 3 + + !A1' + e(4,4) = e(4,4) + p(pst(1,id))! - p(pst(1,1)) + if (sym) then + e(4,4)=e(4,4) + p(pst(1,id)+1)*ss +p(pst(1,id)+2)*ss**2 & + + p(pst(1,id)+3)*ss**3 + endif + + ! W and z of JT block + + ! first order + id = id +1 !4 + + e(2,2) = e(2,2) + p(pst(1,id))*xs + p(pst(1,id)+1)*xb + e(3,3) = e(3,3) - p(pst(1,id))*xs - p(pst(1,id)+1)*xb + e(2,3) = e(2,3) + p(pst(1,id))*ys + p(pst(1,id)+1)*yb + + ! order 2 + id = id +1 ! 5 + e(2,2) = e(2,2) + p(pst(1,id))*(xs**2-ys**2) & + + p(pst(1,id)+1)*(xb**2-yb**2) & + + p(pst(1,id)+2)*(xs*xb - ys*yb) + e(3,3) = e(3,3) - p(pst(1,id))*(xs**2-ys**2) & + - p(pst(1,id)+1)*(xb**2-yb**2) & + - p(pst(1,id)+2)*(xs*xb - ys*yb) + e(2,3) = e(2,3) - p(pst(1,id))*(2*xs*ys) & + - p(pst(1,id)+1)*(2*xb*yb) & + - p(pst(1,id)+2)*(xs*yb+xb*ys) + + ! the coupling of A2' and E' + ! order 1 + id = id +1 !6 + + e(1,2) = e(1,2) + b*(p(pst(1,id))*xs + p(pst(1,id)+1)*yb) + e(1,3) = e(1,3) - b*(p(pst(1,id))*ys + p(pst(1,id)+1)*yb) + ! order 2 + id =id +1 ! 7 + e(1,2) = e(1,2) +b*(p(pst(1,id))*(xs**2-ys**2) & + + p(pst(1,id)+1)*(xb**2-yb**2) & + + p(pst(1,id)+2)*(xs*xb -ys*yb)) + e(1,3) = e(1,3) +b*(p(pst(1,id))*(2*xs*ys) & + + p(pst(1,id)+1)*(2*xb*yb) & + + p(pst(1,id)+2)*(xs*yb + xb*ys)) + + ! the coupling of A1' and E' + id = id +1 ! 8 + e(2,4) = e(2,4) + p(pst(1,id))*xs + p(pst(1,id)+1)*xb + e(3,4) = e(3,4) - p(pst(1,id))*ys - p(pst(1,id)+1)*yb + if (sym) then + e(2,4) = e(2,4)+ p(pst(1,id)+2)*xs*ss + e(3,4) = e(3,4)- p(pst(1,id)+2)*ys*ss + endif + + ! order 2 + id = id +1 ! 9 + e(2,4) = e(2,4) + p(pst(1,id))*(xs**2-ys**2) & + + p(pst(1,id)+1)*(xb**2-yb**2) & + + p(pst(1,id)+2)*(xs*xb -ys*yb) + e(3,4) = e(3,4) + p(pst(1,id))*(2*xs*ys) & + + p(pst(1,id)+1)*(2*xb*yb) & + + p(pst(1,id)+2)*(xs*yb + xb*ys) + ! the couplign between A + id = id +1 ! 10 + e(1,4) = e(1,4) + b*p(pst(1,id)) + !write(*,*) 'Id = ',id + + call copy_2_lower_triangle(e) + if (switch) then + write( 6,*)" EX AND EY ARE SWITCHED" + tmp = e(2,2) + e(2,2) = e(3,3) + e(3,3) = tmp + + ! the coupling + + tmp = e(2,4) + e(2,4) = e(3,4) + e(3,4) = tmp + e(4,2) = e(2,4) + e(4,3) = e(3,4) + endif + end subroutine potential_nh3_low + + + subroutine copy_2_lower_triangle(mat) + real(dp), intent(inout) :: mat(:, :) + integer :: m, n + ! write lower triangle of matrix symmetrical + do n = 2, size(mat, 1) + do m = 1, n - 1 + mat(n, m) = mat(m, n) + end do + end do + end subroutine copy_2_lower_triangle + + +end module +module diabmodel + use dip_param + use iso_fortran_env, only:dp => real64,idp => int32 + use nn_params + use nncommons + implicit none + + !integer(idp),parameter:: ndiab=4 + !logical :: debug=.false. + private + public:: diab_x + contains + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine diab_x(e,q,nn_out) + real(dp),intent(in) :: q(maxnin) + real(dp),intent(inout) :: nn_out(maxnout) + real(dp),intent(out) :: e(:,:) + integer(idp) id,i,j, ii + real(dp) xs,xb,ys,yb,a,b,ss,sb,v3_vec(8) + real(dp), dimension(17) :: shift,scal + real(dp), parameter:: tol = 1.0d-9 + + xs=q(len_in+2) + ys=q(len_in+3) + xb=q(len_in+4) + yb=q(len_in+5) + a=q(len_in+1) + b=q(len_in+6) + + id = 11 + + call init_dip_planar_data() + scal = 1.0d0 + !scal(19:20) = 1.0d-2 + + shift =1.0d0 + ii = 5 + do i = 28 ,np ! pes parameter key index + if( abs(p(i)) .gt. tol ) then + p(i) = p(i)*(shift(ii)+ scal(ii)*nn_out(ii)) + ii = ii + 1 + endif + enddo + !write(6,*)" Dipole non-zero", ii-1 + + ss=xs**2+ys**2 ! totaly symmetric term + sb=xb**2+yb**2 + + v3_vec( 1) = xs*(xs**2-3*ys**2) + v3_vec( 2) = xb*(xb**2-3*yb**2) + v3_vec( 3) = xb*(xs**2-ys**2) - 2*yb*xs*ys + v3_vec( 4) = xs*(xb**2-yb**2) - 2*ys*xb*yb + v3_vec( 5) = ys*(3*xs**2-ys**2) + v3_vec( 6) = yb*(3*xb**2-yb**2) + v3_vec( 7) = yb*(xs**2-ys**2)+2*xb*xs*ys + v3_vec( 8) = ys*(xb**2-yb**2)+2*xs*xb*yb + + + + e=0.0d0 + + + + !id=key !1 + ! V-term + ! order 1 + e(1,1)=e(1,1)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb + id=id+1 !2 + e(2,2)=e(2,2)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb + e(3,3)=e(3,3)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb + id=id+1 !3 + e(4,4)=e(4,4)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb + ! order 2 + id=id+1 !4 + e(1,1)=e(1,1)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2)& + +p(pst(1,id)+2)*(xs*xb-ys*yb) + id=id+1 !5 + e(2,2)=e(2,2)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) +& + p(pst(1,id)+2)*(xs*xb-ys*yb) + e(3,3)=e(3,3)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) +& + p(pst(1,id)+2)*(xs*xb-ys*yb) + id=id+1 !6 + e(4,4)=e(4,4)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) + & + p(pst(1,id)+2)*(xs*xb-ys*yb) + ! order 3 + id=id+1 !7 + e(1,1)=e(1,1)+p(pst(1,id))*xs*ss+p(pst(1,id)+1)*xb*sb + id=id+1 !8 + e(2,2)=e(2,2)+p(pst(1,id))*xs*ss+p(pst(1,id)+1)*xb*sb + e(3,3)=e(3,3)+p(pst(1,id))*xs*ss+p(pst(1,id)+1)*xb*sb + id=id+1 !9 + e(4,4)=e(4,4)+p(pst(1,id))*xs*ss+p(pst(1,id)+1)*xb*sb + + ! JAHN TELLER COUPLING W AND Z + ! order 0 + id=id+1 !10 + e(2,2)=e(2,2)+p(pst(1,id)) + e(3,3)=e(3,3)-p(pst(1,id)) + ! order 1 + id=id+1 !11 + e(2,2)=e(2,2)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb + e(3,3)=e(3,3)-p(pst(1,id))*xs-p(pst(1,id)+1)*xb + e(2,3)=e(2,3)-p(pst(1,id))*ys-p(pst(1,id)+1)*yb + ! order 2 + id=id+1 !12 + e(2,2)=e(2,2)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) & + +p(pst(1,id)+2)*(xs*xb-ys*yb)+p(pst(1,id)+3)*ss+p(pst(1,id)+4)*sb + e(3,3)=e(3,3)-(p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) & + +p(pst(1,id)+2)*(xs*xb-ys*yb)+p(pst(1,id)+3)*ss+p(pst(1,id)+4)*sb) + e(2,3)=e(2,3)+p(pst(1,id))*2*xs*ys+p(pst(1,id)+1)*2*xb*yb+ & + p(pst(1,id)+2)*(xs*yb+xb*ys) + ! order 3 + + id=id+1 !13 + do i=1,4 + j=i-1 + e(2,2)=e(2,2)+(p(pst(1,id)+j)+p(pst(1,id)+j+4))*v3_vec(i) + e(3,3)=e(3,3)-(p(pst(1,id)+j)+p(pst(1,id)+j+4))*v3_vec(i) + e(2,3)=e(2,3)+(-p(pst(1,id)+j)+p(pst(1,id)+j+4))*v3_vec(i+4) + enddo + + e(2,2)=e(2,2)+p(pst(1,id)+8)*xs*ss+p(pst(1,id)+9)*xb*sb + e(3,3)=e(3,3)-(p(pst(1,id)+8)*xs*ss+p(pst(1,id)+9)*xb*sb) + e(2,3)=e(2,3)-p(pst(1,id)+8)*ys*ss-p(pst(1,id)+9)*yb*sb + ! PSEUDO JAHN TELLER + + ! A2 ground state coupled with E + ! ################################################### + ! ################################################### + + ! order 0 + id=id+1 !14 + e(1,2)=e(1,2)+b*p(pst(1,id)) + + ! order 1 + id=id+1 !15 + e(1,2)=e(1,2)+b*(p(pst(1,id))*xs+p(pst(1,id)+1)*xb) + e(1,3)=e(1,3)+b*(p(pst(1,id))*ys+p(pst(1,id)+1)*yb) + ! order 2 + id=id+1 !16 + e(1,2)=e(1,2)+b*(p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2)& + +p(pst(1,id)+2)*(xs*xb-ys*yb) + p(pst(1,id)+3)*(xs**2+ys**2)) + e(1,3)=e(1,3)-b*(p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)& + +p(pst(1,id)+2)*(xs*yb+xb*ys)) + ! order 3 + id =id+1 ! 17 + + do i=1,4 + e(1,2)=e(1,2)+b*(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3_vec(i) + e(1,3)=e(1,3)+b*(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+3)))*v3_vec(i+4) + enddo + + + + !! THE COUPLING OF A2 WITH A1 + !#################################################### + !#################################################### + ! order 1 + id=id+1 !18 + e(1,4)=e(1,4)+b*(p(pst(1,id))*xs+p(pst(1,id)+1)*xb) + id=id+1 !19 + e(1,4)=e(1,4)+b*(p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2)& + +p(pst(1,id)+2)*(xs*xb-ys*yb)) + + + !!! THE COUPLING OF A1 WITH E + !!#################################################### + !#################################################### + ! order 0 + + id=id+1 !20 + e(2,4)=e(2,4)+p(pst(1,id)) + + ! order 1 + id=id+1 !21 + e(2,4)=e(2,4)+p(pst(1,id))*xs + p(pst(1,id)+1)*xb + e(3,4)=e(3,4)+p(pst(1,id))*ys + p(pst(1,id)+1)*yb + + ! order 2 + id=id+1 !22 + e(2,4)=e(2,4)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) & + +p(pst(1,id)+2)*(xs*xb-ys*yb) +p(pst(1,id)+3)*(xs**2+ys**2) + e(3,4)=e(3,4)-p(pst(1,id))*(2*xs*ys)-p(pst(1,id)+1)*(2*xb*yb) & + -p(pst(1,id)+2)*(xs*yb+xb*ys) + ! order 3 + id=id+1 !23 + do i=1,4 + e(2,4)=e(2,4)+(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3_vec(i) + e(3,4)=e(3,4)+(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+3)))*v3_vec(i+4) + enddo + + !! End of the model + + e(2,1)=e(1,2) + e(3,1)=e(1,3) + e(3,2)=e(2,3) + e(4,1)=e(1,4) + e(4,2)=e(2,4) + e(4,3)=e(3,4) + end subroutine diab_x + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! THE Y COMPONENT OF DIPOLE + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!subroutine diab_y(e,q,nn_out) +! real(dp),intent(in) :: q(maxnin) +! real(dp),intent(inout) :: nn_out(maxnout) +! real(dp),intent(out) :: e(:,:) +! integer(idp) id,i,j, ii +! real(dp) xs,xb,ys,yb,a,b,ss,sb,v3_vec(8) +! real(dp), dimension(23) :: shift,scal +! real(dp), parameter:: tol = 1.0d-9 +! +! xs=q(5) +! ys=q(6) +! xb=q(7) +! yb=q(8) +! a=q(4) +! b=q(9) +! +! id = 11 +! +! call init_dip_planar_data() +! scal = 1.0d-3 +! shift =1.0d0 +! ii = 1 +! do i = 11 ,np ! pes parameter key index +! if( abs(p(i)) .gt. tol ) then +! p(i) = p(i)*(shift(ii)+ scal(ii)*nn_out(ii)) +! ii = ii + 1 +! endif +! enddo +! +! id = 11 +! +! ss=xs**2+ys**2 ! totaly symmetric term +! sb=xb**2+yb**2 +! +! v3_vec( 1) = xs*(xs**2-3*ys**2) +! v3_vec( 2) = xb*(xb**2-3*yb**2) +! v3_vec( 3) = xb*(xs**2-ys**2) - 2*yb*xs*ys +! v3_vec( 4) = xs*(xb**2-yb**2) - 2*ys*xb*yb +! v3_vec( 5) = ys*(3*xs**2-ys**2) +! v3_vec( 6) = yb*(3*xb**2-yb**2) +! v3_vec( 7) = yb*(xs**2-ys**2)+2*xb*xs*ys +! v3_vec( 8) = ys*(xb**2-yb**2)+2*xs*xb*yb +! +! +! +! +! +! e=0.0d0 +! ! V-term +! !id=key !1 +! e(1,1)=e(1,1)+p(pst(1,id))*ys+p(pst(1,id)+1)*yb +! +! id=id+1 !2 +! e(2,2)=e(2,2)+p(pst(1,id))*ys+p(pst(1,id)+1)*yb +! e(3,3)=e(3,3)+p(pst(1,id))*ys+p(pst(1,id)+1)*yb +! id=id+1 !3 +! e(4,4)=e(4,4)+p(pst(1,id))*ys+p(pst(1,id)+1)*yb +! ! order 2 +! id=id+1 !4 +! e(1,1)=e(1,1)-p(pst(1,id))*(2*xs*ys)-p(pst(1,id)+1)*(2*xb*yb) & +! -p(pst(1,id)+2)*(xs*yb+xb*ys) +! id=id+1 !5 +! e(2,2)=e(2,2)-p(pst(1,id))*(2*xs*ys)-p(pst(1,id)+1)*(2*xb*yb) & +! -p(pst(1,id)+2)*(xs*yb+xb*ys) +! +! +! e(3,3)=e(3,3)-p(pst(1,id))*(2*xs*ys)-p(pst(1,id)+1)*(2*xb*yb) & +! -p(pst(1,id)+2)*(xs*yb+xb*ys) +! id=id+1 !6 +! e(4,4)=e(4,4)-p(pst(1,id))*(2*xs*ys)-p(pst(1,id)+1)*(2*xb*yb) & +! -p(pst(1,id)+2)*(xs*yb+xb*ys) +! ! order 3 +! id=id+1 !7 +! e(1,1)=e(1,1)+p(pst(1,id))*ys*ss+p(pst(1,id)+1)*yb*sb +! id=id+1 !8 +! e(2,2)=e(2,2)+p(pst(1,id))*ys*ss+p(pst(1,id)+1)*yb*sb +! e(3,3)=e(3,3)+p(pst(1,id))*ys*ss+p(pst(1,id)+1)*yb*sb +! id=id+1 !9 +! e(4,4)=e(4,4)+p(pst(1,id))*ys*ss+p(pst(1,id)+1)*yb*sb +! +! ! V- term + totally symmetric coord a +! +! ! JAHN TELLER COUPLING TERM +! ! order 0 +! id=id+1 !10 +! e(2,3)=e(2,3)+p(pst(1,id)) +! ! order 1 +! +! id=id+1 !11 +! e(2,2)=e(2,2)-p(pst(1,id))*ys-p(pst(1,id)+1)*yb +! e(3,3)=e(3,3)+p(pst(1,id))*ys+p(pst(1,id)+1)*yb +! e(2,3)=e(2,3)-p(pst(1,id))*xs-p(pst(1,id)+1)*xb +! !id=id+1 !12 +! ! order 2 +! id=id+1 !12 +! e(2,2)=e(2,2)+p(pst(1,id))*2*xs*ys+p(pst(1,id)+1)*2*xb*yb+p(pst(1,id)+2)*(xs*yb+xb*ys) +! e(3,3)=e(3,3)-p(pst(1,id))*2*xs*ys-p(pst(1,id)+1)*2*xb*yb-p(pst(1,id)+2)*(xs*yb+xb*ys) +! e(2,3)=e(2,3)-(p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2)) & +! -p(pst(1,id)+2)*(xs*xb-ys*yb)+p(pst(1,id)+3)*ss+p(pst(1,id)+4)*sb +! ! order 3 +! id=id+1 !13 +! do i=1,4 +! j=i-1 +! e(2,2)=e(2,2)+(p(pst(1,id)+j)-p(pst(1,id)+j+4))*v3_vec(i+4) +! e(3,3)=e(3,3)-(p(pst(1,id)+j)-p(pst(1,id)+j+4))*v3_vec(i+4) +! e(2,3)=e(2,3)+(p(pst(1,id)+j)+p(pst(1,id)+j+4))*v3_vec(i) +! enddo +! e(2,2)=e(2,2)-p(pst(1,id)+8)*ys*ss-p(pst(1,id)+9)*yb*sb +! e(3,3)=e(3,3)+p(pst(1,id)+8)*ys*ss+p(pst(1,id)+9)*yb*sb +! e(2,3)=e(2,3)-p(pst(1,id)+8)*xs*ss-p(pst(1,id)+1)*xb*sb +! ! PSEUDO JAHN TELLER +! ! ORDER 0 +! ! THE COUPLING OF A2 GROUND STATE WITH E +! ! ################################################### +! ! ################################################### +! ! order 0 +! id=id+1 !14 +! e(1,3)=e(1,3)-b*(p(pst(1,id))) +! ! order 1 +! id=id+1 !15 +! e(1,2)=e(1,2)-b*(p(pst(1,id))*ys+p(pst(1,id)+1)*yb) +! e(1,3)=e(1,3)+b*(p(pst(1,id))*xs+p(pst(1,id)+1)*xb) +! +! ! order 2 +! id=id+1 !16 +! e(1,2)=e(1,2)+b*(p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)& +! +p(pst(1,id)+2)*(xs*yb+xb*ys)) +! e(1,3)=e(1,3)+b*(p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2)& +! +p(pst(1,id)+2)*(xs*xb-ys*yb) - p(pst(1,id)+3)*(xs**2+ys**2)) +! +! ! order 3 +! id = id+1 ! 17 +! do i=1,4 +! e(1,2)=e(1,2)+b*(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+3)))*v3_vec(i+4) +! e(1,3)=e(1,3)-b*(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3_vec(i) +! enddo +! +! +! ! THE COUPLING OF A2 WITH A1 +! !#################################################### +! !#################################################### +! ! order 1 +! id=id+1 !17 +! e(1,4)=e(1,4)+b*(p(pst(1,id))*ys+p(pst(1,id)+1)*yb) +! ! order 2 +! id=id+1 !18 +! e(1,4)=e(1,4)-b*(p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)& +! +p(pst(1,id)+2)*(xs*yb+xb*ys)) +! +! +! ! THE COUPLING OF A1 WITH E +! !#################################################### +! !#################################################### +! ! order 0 +! id=id+1 !19 +! e(3,4)=e(3,4)-p(pst(1,id)) +! ! order 1 +! id=id+1 !20 +! e(2,4)=e(2,4)-p(pst(1,id))*ys-p(pst(1,id)+1)*yb +! e(3,4)=e(3,4)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb +! ! order 2 +! id=id+1 !21 +! e(2,4)=e(2,4)+p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb) & +! +p(pst(1,id)+2)*(xs*yb+xb*ys) +! e(3,4)=e(3,4)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) & +! +p(pst(1,id)+2)*(xs*xb-ys*yb) - p(pst(1,id)+3)*(xs**2+ys**2) +! +! id =id+1 ! 23 +! ! order 3 +! do i=1,4 +! e(2,4)=e(2,4)+(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+3)))*v3_vec(i+4) +! e(3,4)=e(3,4)-(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3_vec(i) +! enddo +! +! ! end of the model +! e(2,1)=e(1,2) +! e(3,1)=e(1,3) +! e(3,2)=e(2,3) +! e(4,1)=e(1,4) +! e(4,2)=e(2,4) +! e(4,3)=e(3,4) +! ! change Ex and Ey +!end subroutine diab_y + +! potential nh3 +! parth + + +!subroutine copy_2_lower_triangle(mat) +! real(dp), intent(inout) :: mat(:, :) +! integer :: m, n +! write lower triangle of matrix symmetrical +! do n = 2, size(mat, 1) +! do m = 1, n - 1 +! mat(n, m) = mat(m, n) +! end do +! end do +! end subroutine copy_2_lower_triangle + +end module diabmodel + subroutine nninit_mod() + use nn_params + implicit none + + end subroutine + + + subroutine nnadia(coords,coeffs,adiaoutp) + USE pesmod, only: potential_nh3_low + Use diabmodel, only: diab_x + + use nn_params + use nncommons + implicit none + ! returns THE DIABATIC MATRIX UPPER MATRIX OF BOTH X AND Y COMPONENT OF DIPOLE +! +! coords: vector containing symmetry-adapted coordinates. +! coeffs: vector containing coeffs of diab dipole matrix + +! adiaoutp: upper diab matrix of dipole +! x component come first and then y component +! +! dmat_x & dmat_y: analytic model of dipole, x and y +! +! matdim: dimension of hamiltoniam matrix +! mkeigen: integer: no eigenvectors if =0 +! eigenvs: dummy storage for eigenvectors + + !include 'JTmod.incl' + integer ndiab + parameter (ndiab=4) + DOUBLE PRECISION,intent(in):: coords(maxnin) + DOUBLE PRECISION,INTENT(INOUT)::coeffs(maxnout) + DOUBLE PRECISION,INTENT(OUT):: adiaoutp(maxpout) + DOUBLE PRECISION, DIMENSION(ndiab,ndiab):: v,U,ex,temp + double precision, dimension(ndiab):: e + Double precision, allocatable:: mat(:,:) + integer i, ij, j, max_row + + ! variable for lapack + integer,parameter :: lwork = 1000 + double precision work(lwork) + integer info + + call potential_nh3_low(V,coords,coeffs) + + ! diagonalize the pes + u=0.0d0 + allocate(mat,source=V) + call DSYEV('V','U',ndiab,mat,ndiab,e,work,lwork, info) + + if (info .ne. 0) then + write(6,*)"The diagonalizing routine failed", info + stop + end if + U(:,:)= mat(:,:) + deallocate(mat) + do i =1,ndiab + adiaoutp(i)=e(i) + enddo + + ! Fix the phase of U matrix + ! fix phas of U + do i =1,ndiab + max_row=maxloc(abs(U(:,i)),1) + if(U(max_row,i) .lt. 0) then + U(:,i) = -1.0d0*U(:,i) + endif + enddo + + call diab_x(ex,coords,coeffs) ! ex is the dipole x component + + ! transforrm the dipole + + temp = matmul(transpose(U),ex) + ex = matmul(temp,U) + ij = 4 + do i =1,ndiab + do j = i,ndiab + ij = ij+1 + adiaoutp(ij) = ex(i,j) + enddo + enddo + + END SUBROUTINE + + + diff --git a/src/model/ctrans.f b/src/model/ctrans.f new file mode 100644 index 0000000..0971f33 --- /dev/null +++ b/src/model/ctrans.f @@ -0,0 +1,58 @@ +! Author: jnshuti +! Created: 2025-10-24 16:44:03 +! Last modified: 2026-01-12 11:20:55 jnshuti + subroutine cart2mode(qq) + use invariants_mod, only: invariants + use nn_params + use nncommons + implicit none + double precision, intent(inout):: qq(maxnin) + double precision :: q(12),inv(4) + double precision :: qm(6) + + double precision, parameter :: m_N=25526.04237518618d0 + double precision, parameter :: m_H=1837.152647439619d0 + double precision, parameter :: Ang2Bohr=1.889726124565d0 + + double precision diff(12), ref_geom(12) + double precision q_mod(12) +! transformation matrix + double precision mode(12,6) +! final internal coord vector + + + include 'newmodes.f' + + ref_geom(1:12)=0.d0 + ref_geom( 4 )=1.022871078d0 + ref_geom( 7 )=-.5d0*ref_geom(4) + !ref_geom( 8 )=sqrt(1.5d0)*ref_geom(4) + ref_geom( 8)=0.5d0*sqrt(3.0d0)*ref_geom(4) + ref_geom(10 )=-.5d0*ref_geom(4) + !ref_geom(11 )=-sqrt(1.5d0)*ref_geom(4) + ref_geom(11)=-0.5d0*sqrt(3.0d0)*ref_geom(4) + + !massN=25526.04237518618 + !massH=1837.152647439619 + ! + q(1:12)=qq(1:12) + q_mod = (1.0d0/Ang2Bohr)*q + +! difference vector + diff=q_mod-ref_geom + +! mass weighting + diff(1:3)=diff(1:3)*sqrt(m_N) + diff(4:12)=diff(4:12)*sqrt(m_H) + + qm=matmul(transpose(mode),diff) + do i =1,6 + if ( abs(qm(i)) .lt. 1.0d-6) qm(i) = 0.0d0 + enddo + qm(3) = -qm(3) + call invariants(qm(1),qm(2),qm(3),qm(4),qm(5),inv) + qq(1:len_in)=inv(1:len_in) + qq(len_in+1:len_in+5)=qm(2:6) + + + end subroutine cart2mode diff --git a/src/model/data_transform.f90 b/src/model/data_transform.f90 new file mode 100644 index 0000000..4678c3e --- /dev/null +++ b/src/model/data_transform.f90 @@ -0,0 +1,174 @@ +! Author: jnshuti +! Created: 2025-10-28 10:05:45 +! Last modified: 2026-02-04 10:18:40 jnshuti +! Subroutine which transform the data in any desired format +module data_transf_mod + use iso_fortran_env, only: dp => real64, idp => int32 + use nncommons, only: sets, ndata, inp_out,ndiab + use nn_params, only: maxpout,maxpats + use Phase_corr + implicit none + !integer(idp),parameter:: ndiab=4 + private + public :: data_transform + contains + + SUBROUTINE data_transform(pat_out,npat) + ! IN: pat_out: the output patterns + ! x1 the input pattern + ! the aim it to transform pat_out in any disired form + implicit none + + real(dp),intent(inout):: pat_out(maxpout,maxpats) + !real(dp),intent(inout):: ref_out(maxpout,maxpats) + integer(idp), intent(in):: npat ! the total number of point + ! internal varibles + integer(idp) i,j,total ,ii,m,n + integer(idp), dimension(sets):: flipped_scan2, flipped_scan3 + integer(idp), dimension(sets):: flipped_scan4 + Real(dp),allocatable:: mux(:,:,:) + integer(idp):: scn_strt, scn_end,iref + + logical, parameter:: flip =.true. + + !write(6,*)"The total numbe of points used in data transform =",npat + + + ! allocatable varables + allocate(mux(ndiab,ndiab,npat)) + + ! define the scann need to be flipped + ! list of all the scan need to flip the sign depending on the result of the molpro calculation + flipped_scan2 = 0; flipped_scan3 = 0; flipped_scan4 =0 + flipped_scan3 = [1,3,4,5,6,7,8,9,10,11, & + 12,13,14,15,16,17,18,19,20, & + 21,22,24,25,54,55,56, & + 58,59,60,61,62,63] + flipped_scan2 = [27,28,29,30,31,32,33,34,35, & + 36,37,38,39,40,41,42,43,44, & + 45,46,47,48,49,50,51,52,53, & + 65,67,68,69,70,71, & + 72,73,74] + flipped_scan4 = [23,64] + !flipped_scan2 = [77,80,118,120] + !flipped_scan3 = [56,111] + + + + + + + + + total=0 + + do i =1,sets + do j=1,ndata(i) + total = total+1 + !pat_out(1:inp_out,total)=pat_out(1:inp_out,total)!-ref_en + ! transform the y to matrix form + + call Y2mat(pat_out(5:inp_out,total),Mux(:,:,total)) + if (flip) then + if (j .gt. 2) call build_cluster(Mux(:,:,total-1),Mux(:,:,total)) + + endif + + enddo + enddo + + + + ! flipe the required scan + if (flip) then + scn_end = 0 + iref=0 + do i =1,sets + if (ndata(i) .eq. 0) cycle + scn_strt = scn_end +1 + scn_end = scn_end + ndata(i) + + if (any(flipped_scan2 .eq. remap(i) )) then + do j = scn_strt,scn_end + call flip_e_state(Mux(:,:,j),2) + enddo + endif + if (any(flipped_scan3 .eq. remap(i) )) then + do j = scn_strt,scn_end + call flip_e_state(Mux(:,:,j),3) + enddo + endif + if (any(flipped_scan4 .eq. remap(i))) then + do j =scn_strt,scn_end + call flip_e_state(Mux(:,:,j),4) + enddo + endif + + ii = 4 + do m=1,ndiab + do n = m,ndiab + ii = ii +1 + pat_out(ii,scn_strt:scn_end) = & + Mux(m,n,scn_strt:scn_end) + enddo + enddo + + + + enddo + endif + + deallocate(Mux) + + END SUBROUTINE data_transform + + subroutine Y2mat(Y,Mx) + IMPLICIT NONE + Real(dp), intent(in):: y(:) + Real(dp),intent(out):: Mx(ndiab,ndiab) + ! internal variables + integer(idp):: ii,i,j + + !ntot = ndiab*(ndiab+1)/2 + !if (inp_out/2 .ne. ntot) then + ! write(6,*)"output not equal ntot", inp_out,ntot + ! stop + !endif + ii=1 + do i=1,ndiab + do j=i,ndiab + ! !mx + + mx(i,j)=y(ii) + ! + ii=ii+1 + enddo + enddo + call copy_2_low(mx) + !call copy_2_low(my) + end subroutine + ! ! subroutine which copy the upper matrix to lower + subroutine copy_2_low(m) + implicit none + real(dp), intent(inout) :: m(:,:) + integer(idp) :: i,j + ! copy the lower part of the matrix to the upper part + do i=1,size(m,1) + do j=i,size(m,1) + m(j,i) = m(i,j) + enddo + enddo + end subroutine copy_2_low + + integer function remap(i) + integer(idp),intent(in):: i + + + remap = i + 0 + + end function remap + + + end module data_transf_mod + + diff --git a/src/model/dipole_model.f90 b/src/model/dipole_model.f90 new file mode 100644 index 0000000..2792908 --- /dev/null +++ b/src/model/dipole_model.f90 @@ -0,0 +1,411 @@ +module diabmodel + use dip_param + use iso_fortran_env, only:dp => real64,idp => int32 + use nn_params + use nncommons, only: len_in + implicit none + + !integer(idp),parameter:: ndiab=4 + !logical :: debug=.false. + private + public:: diab_x + contains + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine diab_x(e,q,nn_out) + real(dp),intent(in) :: q(maxnin) + real(dp),intent(inout) :: nn_out(maxnout) + real(dp),intent(out) :: e(:,:) + integer(idp) id,i,j, ii + real(dp) xs,xb,ys,yb,a,b,ss,sb,v3_vec(8) + real(dp), dimension(16) :: shift,scal + ! real(dp),dimension(17):: shi,scalee + real(dp), parameter:: tol = 1.0d-9 + !include "shift-scale-70N.incl" + !include "sh-scal-50.incl" + + xs=q(len_in+2) + ys=q(len_in+3) + xb=q(len_in+4) + yb=q(len_in+5) + a=q(len_in+1) + b=q(len_in+6) + + id = 11 + + call init_dip_planar_data() + shift =1.0d0 + scal = 1.0d0 + ii = 5 + do i = 28 ,np ! pes parameter key index + if( abs(p(i)) .gt. tol ) then + p(i) = p(i)*(shift(ii)+ scal(ii)*nn_out(ii)) + ii = ii + 1 + endif + enddo + !write(6,*)" Dipole non-zero", ii-1 + + ss=xs**2+ys**2 ! totaly symmetric term + sb=xb**2+yb**2 + + v3_vec( 1) = xs*(xs**2-3*ys**2) + v3_vec( 2) = xb*(xb**2-3*yb**2) + v3_vec( 3) = xb*(xs**2-ys**2) - 2*yb*xs*ys + v3_vec( 4) = xs*(xb**2-yb**2) - 2*ys*xb*yb + v3_vec( 5) = ys*(3*xs**2-ys**2) + v3_vec( 6) = yb*(3*xb**2-yb**2) + v3_vec( 7) = yb*(xs**2-ys**2)+2*xb*xs*ys + v3_vec( 8) = ys*(xb**2-yb**2)+2*xs*xb*yb + + + + e=0.0d0 + + + + !id=key !1 + ! V-term + ! order 1 + e(1,1)=e(1,1)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb + id=id+1 !2 + e(2,2)=e(2,2)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb + e(3,3)=e(3,3)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb + id=id+1 !3 + e(4,4)=e(4,4)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb + ! order 2 + id=id+1 !4 + e(1,1)=e(1,1)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2)& + +p(pst(1,id)+2)*(xs*xb-ys*yb) + id=id+1 !5 + e(2,2)=e(2,2)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) +& + p(pst(1,id)+2)*(xs*xb-ys*yb) + e(3,3)=e(3,3)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) +& + p(pst(1,id)+2)*(xs*xb-ys*yb) + id=id+1 !6 + e(4,4)=e(4,4)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) + & + p(pst(1,id)+2)*(xs*xb-ys*yb) + ! order 3 + id=id+1 !7 + e(1,1)=e(1,1)+p(pst(1,id))*xs*ss+p(pst(1,id)+1)*xb*sb + id=id+1 !8 + e(2,2)=e(2,2)+p(pst(1,id))*xs*ss+p(pst(1,id)+1)*xb*sb + e(3,3)=e(3,3)+p(pst(1,id))*xs*ss+p(pst(1,id)+1)*xb*sb + id=id+1 !9 + e(4,4)=e(4,4)+p(pst(1,id))*xs*ss+p(pst(1,id)+1)*xb*sb + + ! JAHN TELLER COUPLING W AND Z + ! order 0 + id=id+1 !10 + e(2,2)=e(2,2)+p(pst(1,id)) + e(3,3)=e(3,3)-p(pst(1,id)) + ! order 1 + id=id+1 !11 + e(2,2)=e(2,2)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb + e(3,3)=e(3,3)-p(pst(1,id))*xs-p(pst(1,id)+1)*xb + e(2,3)=e(2,3)-p(pst(1,id))*ys-p(pst(1,id)+1)*yb + ! order 2 + id=id+1 !12 + e(2,2)=e(2,2)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) & + +p(pst(1,id)+2)*(xs*xb-ys*yb)+p(pst(1,id)+3)*ss+p(pst(1,id)+4)*sb + e(3,3)=e(3,3)-(p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) & + +p(pst(1,id)+2)*(xs*xb-ys*yb)+p(pst(1,id)+3)*ss+p(pst(1,id)+4)*sb) + e(2,3)=e(2,3)+p(pst(1,id))*2*xs*ys+p(pst(1,id)+1)*2*xb*yb+ & + p(pst(1,id)+2)*(xs*yb+xb*ys) + ! order 3 + + id=id+1 !13 + do i=1,4 + j=i-1 + e(2,2)=e(2,2)+(p(pst(1,id)+j)+p(pst(1,id)+j+4))*v3_vec(i) + e(3,3)=e(3,3)-(p(pst(1,id)+j)+p(pst(1,id)+j+4))*v3_vec(i) + e(2,3)=e(2,3)+(-p(pst(1,id)+j)+p(pst(1,id)+j+4))*v3_vec(i+4) + enddo + + e(2,2)=e(2,2)+p(pst(1,id)+8)*xs*ss+p(pst(1,id)+9)*xb*sb + e(3,3)=e(3,3)-(p(pst(1,id)+8)*xs*ss+p(pst(1,id)+9)*xb*sb) + e(2,3)=e(2,3)-p(pst(1,id)+8)*ys*ss-p(pst(1,id)+9)*yb*sb + ! PSEUDO JAHN TELLER + + ! A2 ground state coupled with E + ! ################################################### + ! ################################################### + + ! order 0 + id=id+1 !14 + e(1,2)=e(1,2)+b*p(pst(1,id)) + + ! order 1 + id=id+1 !15 + e(1,2)=e(1,2)+b*(p(pst(1,id))*xs+p(pst(1,id)+1)*xb) + e(1,3)=e(1,3)+b*(p(pst(1,id))*ys+p(pst(1,id)+1)*yb) + ! order 2 + id=id+1 !16 + e(1,2)=e(1,2)+b*(p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2)& + +p(pst(1,id)+2)*(xs*xb-ys*yb) + p(pst(1,id)+3)*(xs**2+ys**2)) + e(1,3)=e(1,3)-b*(p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)& + +p(pst(1,id)+2)*(xs*yb+xb*ys)) + ! order 3 + id =id+1 ! 17 + + do i=1,4 + e(1,2)=e(1,2)+b*(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3_vec(i) + e(1,3)=e(1,3)+b*(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+3)))*v3_vec(i+4) + enddo + + + + !! THE COUPLING OF A2 WITH A1 + !#################################################### + !#################################################### + ! order 1 + id=id+1 !18 + e(1,4)=e(1,4)+b*(p(pst(1,id))*xs+p(pst(1,id)+1)*xb) + id=id+1 !19 + e(1,4)=e(1,4)+b*(p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2)& + +p(pst(1,id)+2)*(xs*xb-ys*yb)) + + + !!! THE COUPLING OF A1 WITH E + !!#################################################### + !#################################################### + ! order 0 + + id=id+1 !20 + e(2,4)=e(2,4)+p(pst(1,id)) + + ! order 1 + id=id+1 !21 + e(2,4)=e(2,4)+p(pst(1,id))*xs + p(pst(1,id)+1)*xb + e(3,4)=e(3,4)+p(pst(1,id))*ys + p(pst(1,id)+1)*yb + + ! order 2 + id=id+1 !22 + e(2,4)=e(2,4)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) & + +p(pst(1,id)+2)*(xs*xb-ys*yb) +p(pst(1,id)+3)*(xs**2+ys**2) + e(3,4)=e(3,4)-p(pst(1,id))*(2*xs*ys)-p(pst(1,id)+1)*(2*xb*yb) & + -p(pst(1,id)+2)*(xs*yb+xb*ys) + ! order 3 + id=id+1 !23 + do i=1,4 + e(2,4)=e(2,4)+(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3_vec(i) + e(3,4)=e(3,4)+(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+3)))*v3_vec(i+4) + enddo + + !! End of the model + + e(2,1)=e(1,2) + e(3,1)=e(1,3) + e(3,2)=e(2,3) + e(4,1)=e(1,4) + e(4,2)=e(2,4) + e(4,3)=e(3,4) + end subroutine diab_x + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! THE Y COMPONENT OF DIPOLE + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!subroutine diab_y(e,q,nn_out) +! real(dp),intent(in) :: q(maxnin) +! real(dp),intent(inout) :: nn_out(maxnout) +! real(dp),intent(out) :: e(:,:) +! integer(idp) id,i,j, ii +! real(dp) xs,xb,ys,yb,a,b,ss,sb,v3_vec(8) +! real(dp), dimension(23) :: shift,scal +! real(dp), parameter:: tol = 1.0d-9 +! +! xs=q(5) +! ys=q(6) +! xb=q(7) +! yb=q(8) +! a=q(4) +! b=q(9) +! +! id = 11 +! +! call init_dip_planar_data() +! scal = 1.0d-3 +! shift =1.0d0 +! ii = 1 +! do i = 11 ,np ! pes parameter key index +! if( abs(p(i)) .gt. tol ) then +! p(i) = p(i)*(shift(ii)+ scal(ii)*nn_out(ii)) +! ii = ii + 1 +! endif +! enddo +! +! id = 11 +! +! ss=xs**2+ys**2 ! totaly symmetric term +! sb=xb**2+yb**2 +! +! v3_vec( 1) = xs*(xs**2-3*ys**2) +! v3_vec( 2) = xb*(xb**2-3*yb**2) +! v3_vec( 3) = xb*(xs**2-ys**2) - 2*yb*xs*ys +! v3_vec( 4) = xs*(xb**2-yb**2) - 2*ys*xb*yb +! v3_vec( 5) = ys*(3*xs**2-ys**2) +! v3_vec( 6) = yb*(3*xb**2-yb**2) +! v3_vec( 7) = yb*(xs**2-ys**2)+2*xb*xs*ys +! v3_vec( 8) = ys*(xb**2-yb**2)+2*xs*xb*yb +! +! +! +! +! +! e=0.0d0 +! ! V-term +! !id=key !1 +! e(1,1)=e(1,1)+p(pst(1,id))*ys+p(pst(1,id)+1)*yb +! +! id=id+1 !2 +! e(2,2)=e(2,2)+p(pst(1,id))*ys+p(pst(1,id)+1)*yb +! e(3,3)=e(3,3)+p(pst(1,id))*ys+p(pst(1,id)+1)*yb +! id=id+1 !3 +! e(4,4)=e(4,4)+p(pst(1,id))*ys+p(pst(1,id)+1)*yb +! ! order 2 +! id=id+1 !4 +! e(1,1)=e(1,1)-p(pst(1,id))*(2*xs*ys)-p(pst(1,id)+1)*(2*xb*yb) & +! -p(pst(1,id)+2)*(xs*yb+xb*ys) +! id=id+1 !5 +! e(2,2)=e(2,2)-p(pst(1,id))*(2*xs*ys)-p(pst(1,id)+1)*(2*xb*yb) & +! -p(pst(1,id)+2)*(xs*yb+xb*ys) +! +! +! e(3,3)=e(3,3)-p(pst(1,id))*(2*xs*ys)-p(pst(1,id)+1)*(2*xb*yb) & +! -p(pst(1,id)+2)*(xs*yb+xb*ys) +! id=id+1 !6 +! e(4,4)=e(4,4)-p(pst(1,id))*(2*xs*ys)-p(pst(1,id)+1)*(2*xb*yb) & +! -p(pst(1,id)+2)*(xs*yb+xb*ys) +! ! order 3 +! id=id+1 !7 +! e(1,1)=e(1,1)+p(pst(1,id))*ys*ss+p(pst(1,id)+1)*yb*sb +! id=id+1 !8 +! e(2,2)=e(2,2)+p(pst(1,id))*ys*ss+p(pst(1,id)+1)*yb*sb +! e(3,3)=e(3,3)+p(pst(1,id))*ys*ss+p(pst(1,id)+1)*yb*sb +! id=id+1 !9 +! e(4,4)=e(4,4)+p(pst(1,id))*ys*ss+p(pst(1,id)+1)*yb*sb +! +! ! V- term + totally symmetric coord a +! +! ! JAHN TELLER COUPLING TERM +! ! order 0 +! id=id+1 !10 +! e(2,3)=e(2,3)+p(pst(1,id)) +! ! order 1 +! +! id=id+1 !11 +! e(2,2)=e(2,2)-p(pst(1,id))*ys-p(pst(1,id)+1)*yb +! e(3,3)=e(3,3)+p(pst(1,id))*ys+p(pst(1,id)+1)*yb +! e(2,3)=e(2,3)-p(pst(1,id))*xs-p(pst(1,id)+1)*xb +! !id=id+1 !12 +! ! order 2 +! id=id+1 !12 +! e(2,2)=e(2,2)+p(pst(1,id))*2*xs*ys+p(pst(1,id)+1)*2*xb*yb+p(pst(1,id)+2)*(xs*yb+xb*ys) +! e(3,3)=e(3,3)-p(pst(1,id))*2*xs*ys-p(pst(1,id)+1)*2*xb*yb-p(pst(1,id)+2)*(xs*yb+xb*ys) +! e(2,3)=e(2,3)-(p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2)) & +! -p(pst(1,id)+2)*(xs*xb-ys*yb)+p(pst(1,id)+3)*ss+p(pst(1,id)+4)*sb +! ! order 3 +! id=id+1 !13 +! do i=1,4 +! j=i-1 +! e(2,2)=e(2,2)+(p(pst(1,id)+j)-p(pst(1,id)+j+4))*v3_vec(i+4) +! e(3,3)=e(3,3)-(p(pst(1,id)+j)-p(pst(1,id)+j+4))*v3_vec(i+4) +! e(2,3)=e(2,3)+(p(pst(1,id)+j)+p(pst(1,id)+j+4))*v3_vec(i) +! enddo +! e(2,2)=e(2,2)-p(pst(1,id)+8)*ys*ss-p(pst(1,id)+9)*yb*sb +! e(3,3)=e(3,3)+p(pst(1,id)+8)*ys*ss+p(pst(1,id)+9)*yb*sb +! e(2,3)=e(2,3)-p(pst(1,id)+8)*xs*ss-p(pst(1,id)+1)*xb*sb +! ! PSEUDO JAHN TELLER +! ! ORDER 0 +! ! THE COUPLING OF A2 GROUND STATE WITH E +! ! ################################################### +! ! ################################################### +! ! order 0 +! id=id+1 !14 +! e(1,3)=e(1,3)-b*(p(pst(1,id))) +! ! order 1 +! id=id+1 !15 +! e(1,2)=e(1,2)-b*(p(pst(1,id))*ys+p(pst(1,id)+1)*yb) +! e(1,3)=e(1,3)+b*(p(pst(1,id))*xs+p(pst(1,id)+1)*xb) +! +! ! order 2 +! id=id+1 !16 +! e(1,2)=e(1,2)+b*(p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)& +! +p(pst(1,id)+2)*(xs*yb+xb*ys)) +! e(1,3)=e(1,3)+b*(p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2)& +! +p(pst(1,id)+2)*(xs*xb-ys*yb) - p(pst(1,id)+3)*(xs**2+ys**2)) +! +! ! order 3 +! id = id+1 ! 17 +! do i=1,4 +! e(1,2)=e(1,2)+b*(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+3)))*v3_vec(i+4) +! e(1,3)=e(1,3)-b*(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3_vec(i) +! enddo +! +! +! ! THE COUPLING OF A2 WITH A1 +! !#################################################### +! !#################################################### +! ! order 1 +! id=id+1 !17 +! e(1,4)=e(1,4)+b*(p(pst(1,id))*ys+p(pst(1,id)+1)*yb) +! ! order 2 +! id=id+1 !18 +! e(1,4)=e(1,4)-b*(p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb)& +! +p(pst(1,id)+2)*(xs*yb+xb*ys)) +! +! +! ! THE COUPLING OF A1 WITH E +! !#################################################### +! !#################################################### +! ! order 0 +! id=id+1 !19 +! e(3,4)=e(3,4)-p(pst(1,id)) +! ! order 1 +! id=id+1 !20 +! e(2,4)=e(2,4)-p(pst(1,id))*ys-p(pst(1,id)+1)*yb +! e(3,4)=e(3,4)+p(pst(1,id))*xs+p(pst(1,id)+1)*xb +! ! order 2 +! id=id+1 !21 +! e(2,4)=e(2,4)+p(pst(1,id))*(2*xs*ys)+p(pst(1,id)+1)*(2*xb*yb) & +! +p(pst(1,id)+2)*(xs*yb+xb*ys) +! e(3,4)=e(3,4)+p(pst(1,id))*(xs**2-ys**2)+p(pst(1,id)+1)*(xb**2-yb**2) & +! +p(pst(1,id)+2)*(xs*xb-ys*yb) - p(pst(1,id)+3)*(xs**2+ys**2) +! +! id =id+1 ! 23 +! ! order 3 +! do i=1,4 +! e(2,4)=e(2,4)+(p(pst(1,id)+(i-1))-p(pst(1,id)+(i+3)))*v3_vec(i+4) +! e(3,4)=e(3,4)-(p(pst(1,id)+(i-1))+p(pst(1,id)+(i+3)))*v3_vec(i) +! enddo +! +! ! end of the model +! e(2,1)=e(1,2) +! e(3,1)=e(1,3) +! e(3,2)=e(2,3) +! e(4,1)=e(1,4) +! e(4,2)=e(2,4) +! e(4,3)=e(3,4) +! ! change Ex and Ey +!end subroutine diab_y + +! potential nh3 +! parth + + +!subroutine copy_2_lower_triangle(mat) +! real(dp), intent(inout) :: mat(:, :) +! integer :: m, n +! write lower triangle of matrix symmetrical +! do n = 2, size(mat, 1) +! do m = 1, n - 1 +! mat(n, m) = mat(m, n) +! end do +! end do +! end subroutine copy_2_lower_triangle + +end module diabmodel diff --git a/src/model/fit_genetic.f90 b/src/model/fit_genetic.f90 new file mode 100644 index 0000000..b1c0bc0 --- /dev/null +++ b/src/model/fit_genetic.f90 @@ -0,0 +1,914 @@ + Module dip_param + IMPLICIT NONE + Integer,parameter :: np=101 + Double precision :: p(101) + integer :: pst(2,400) + ! Non zero parameters are 17 + !$omp threadprivate(p,pst) + contains + + SUBROUTINE init_dip_planar_data() + implicit none + p( 1)= -0.561433980D+02 + p( 2)= 0.000000000D+00 + p( 3)= 0.000000000D+00 + p( 4)= -0.558830090D+02 + p( 5)= 0.000000000D+00 + p( 6)= 0.000000000D+00 + p( 7)= -0.557220030D+02 + p( 8)= 0.000000000D+00 + p( 9)= 0.000000000D+00 + p( 10)= 0.000000000D+00 + p( 11)= 0.334452655D-02 + p( 12)= 0.000000000D+00 + p( 13)= 0.000000000D+00 + p( 14)= 0.000000000D+00 + p( 15)= 0.000000000D+00 + p( 16)= 0.000000000D+00 + p( 17)= 0.000000000D+00 + p( 18)= 0.000000000D+00 + p( 19)= 0.000000000D+00 + p( 20)= 0.000000000D+00 + p( 21)= -0.532590808D-03 + p( 22)= 0.000000000D+00 + p( 23)= 0.000000000D+00 + p( 24)= 0.000000000D+00 + p( 25)= 0.000000000D+00 + p( 26)= 0.000000000D+00 + p( 27)= 0.000000000D+00 + p( 28)= -0.226116045D-01 + p( 29)= 0.000000000D+00 + p( 30)= -0.363599361D-01 + p( 31)= 0.000000000D+00 + p( 32)= 0.962100323D-01 + p( 33)= 0.000000000D+00 + p( 34)= 0.111336127D-03 + p( 35)= 0.000000000D+00 + p( 36)= 0.000000000D+00 + p( 37)= -0.433685770D-04 + p( 38)= 0.000000000D+00 + p( 39)= 0.000000000D+00 + p( 40)= -0.548870572D-02 + p( 41)= 0.000000000D+00 + p( 42)= 0.000000000D+00 + p( 43)= 0.000000000D+00 + p( 44)= 0.000000000D+00 + p( 45)= 0.000000000D+00 + p( 46)= 0.000000000D+00 + p( 47)= 0.000000000D+00 + p( 48)= 0.000000000D+00 + p( 49)= 0.217598103D+00 + p( 50)= -0.113909871D-01 + p( 51)= 0.000000000D+00 + p( 52)= -0.123184224D-03 + p( 53)= 0.000000000D+00 + p( 54)= 0.000000000D+00 + p( 55)= 0.000000000D+00 + p( 56)= 0.000000000D+00 + p( 57)= 0.000000000D+00 + p( 58)= 0.000000000D+00 + p( 59)= 0.000000000D+00 + p( 60)= 0.000000000D+00 + p( 61)= 0.000000000D+00 + p( 62)= 0.000000000D+00 + p( 63)= 0.000000000D+00 + p( 64)= 0.000000000D+00 + p( 65)= 0.000000000D+00 + p( 66)= 0.000000000D+00 + p( 67)= 0.000000000D+00 + p( 68)= 0.000000000D+00 + p( 69)= 0.000000000D+00 + p( 70)= 0.000000000D+00 + p( 71)= 0.000000000D+00 + p( 72)= 0.000000000D+00 + p( 73)= 0.000000000D+00 + p( 74)= 0.000000000D+00 + p( 75)= 0.000000000D+00 + p( 76)= 0.000000000D+00 + p( 77)= 0.000000000D+00 + p( 78)= 0.000000000D+00 + p( 79)= 0.000000000D+00 + p( 80)= 0.000000000D+00 + p( 81)= 0.000000000D+00 + p( 82)= 0.000000000D+00 + p( 83)= 0.000000000D+00 + p( 84)= 0.000000000D+00 + p( 85)= 0.000000000D+00 + p( 86)= 0.000000000D+00 + p( 87)= -0.567206500D-02 + p( 88)= -0.613490432D-02 + p( 89)= 0.000000000D+00 + p( 90)= 0.303022045D-03 + p( 91)= 0.000000000D+00 + p( 92)= 0.000000000D+00 + p( 93)= 0.000000000D+00 + p( 94)= 0.000000000D+00 + p( 95)= 0.000000000D+00 + p( 96)= 0.000000000D+00 + p( 97)= 0.000000000D+00 + p( 98)= 0.000000000D+00 + p( 99)= 0.000000000D+00 + p(100)= 0.000000000D+00 + p(101)= 0.000000000D+00 + pst(1, 1)= 1 + pst(2, 1)= 3 + pst(1, 2)= 4 + pst(2, 2)= 3 + pst(1, 3)= 7 + pst(2, 3)= 4 + pst(1, 4)= 11 + pst(2, 4)= 2 + pst(1, 5)= 13 + pst(2, 5)= 3 + pst(1, 6)= 16 + pst(2, 6)= 2 + pst(1, 7)= 18 + pst(2, 7)= 3 + pst(1, 8)= 21 + pst(2, 8)= 3 + pst(1, 9)= 24 + pst(2, 9)= 3 + pst(1, 10)= 27 + pst(2, 10)= 1 + pst(1, 11)= 28 + pst(2, 11)= 2 + pst(1, 12)= 30 + pst(2, 12)= 2 + pst(1, 13)= 32 + pst(2, 13)= 2 + pst(1, 14)= 34 + pst(2, 14)= 3 + pst(1, 15)= 37 + pst(2, 15)= 3 + pst(1, 16)= 40 + pst(2, 16)= 3 + pst(1, 17)= 43 + pst(2, 17)= 2 + pst(1, 18)= 45 + pst(2, 18)= 2 + pst(1, 19)= 47 + pst(2, 19)= 2 + pst(1, 20)= 49 + pst(2, 20)= 1 + pst(1, 21)= 50 + pst(2, 21)= 2 + pst(1, 22)= 52 + pst(2, 22)= 5 + pst(1, 23)= 57 + pst(2, 23)= 10 + pst(1, 24)= 67 + pst(2, 24)= 1 + pst(1, 25)= 68 + pst(2, 25)= 2 + pst(1, 26)= 70 + pst(2, 26)= 4 + pst(1, 27)= 74 + pst(2, 27)= 8 + pst(1, 28)= 82 + pst(2, 28)= 2 + pst(1, 29)= 84 + pst(2, 29)= 3 + pst(1, 30)= 87 + pst(2, 30)= 1 + pst(1, 31)= 88 + pst(2, 31)= 2 + pst(1, 32)= 90 + pst(2, 32)= 4 + pst(1, 33)= 94 + pst(2, 33)= 8 + pst(1, 34)= 0 + pst(2, 34)= 0 + pst(1, 35)= 0 + pst(2, 35)= 0 + pst(1, 36)= 0 + pst(2, 36)= 0 + pst(1, 37)= 0 + pst(2, 37)= 0 + pst(1, 38)= 0 + pst(2, 38)= 0 + pst(1, 39)= 0 + pst(2, 39)= 0 + pst(1, 40)= 0 + pst(2, 40)= 0 + pst(1, 41)= 0 + pst(2, 41)= 0 + pst(1, 42)= 0 + pst(2, 42)= 0 + pst(1, 43)= 0 + pst(2, 43)= 0 + pst(1, 44)= 0 + pst(2, 44)= 0 + pst(1, 45)= 0 + pst(2, 45)= 0 + pst(1, 46)= 0 + pst(2, 46)= 0 + pst(1, 47)= 0 + pst(2, 47)= 0 + pst(1, 48)= 0 + pst(2, 48)= 0 + pst(1, 49)= 0 + pst(2, 49)= 0 + pst(1, 50)= 0 + pst(2, 50)= 0 + pst(1, 51)= 0 + pst(2, 51)= 0 + pst(1, 52)= 0 + pst(2, 52)= 0 + pst(1, 53)= 0 + pst(2, 53)= 0 + pst(1, 54)= 0 + pst(2, 54)= 0 + pst(1, 55)= 0 + pst(2, 55)= 0 + pst(1, 56)= 0 + pst(2, 56)= 0 + pst(1, 57)= 0 + pst(2, 57)= 0 + pst(1, 58)= 0 + pst(2, 58)= 0 + pst(1, 59)= 0 + pst(2, 59)= 0 + pst(1, 60)= 0 + pst(2, 60)= 0 + pst(1, 61)= 0 + pst(2, 61)= 0 + pst(1, 62)= 0 + pst(2, 62)= 0 + pst(1, 63)= 0 + pst(2, 63)= 0 + pst(1, 64)= 0 + pst(2, 64)= 0 + pst(1, 65)= 0 + pst(2, 65)= 0 + pst(1, 66)= 0 + pst(2, 66)= 0 + pst(1, 67)= 0 + pst(2, 67)= 0 + pst(1, 68)= 0 + pst(2, 68)= 0 + pst(1, 69)= 0 + pst(2, 69)= 0 + pst(1, 70)= 0 + pst(2, 70)= 0 + pst(1, 71)= 0 + pst(2, 71)= 0 + pst(1, 72)= 0 + pst(2, 72)= 0 + pst(1, 73)= 0 + pst(2, 73)= 0 + pst(1, 74)= 0 + pst(2, 74)= 0 + pst(1, 75)= 0 + pst(2, 75)= 0 + pst(1, 76)= 0 + pst(2, 76)= 0 + pst(1, 77)= 0 + pst(2, 77)= 0 + pst(1, 78)= 0 + pst(2, 78)= 0 + pst(1, 79)= 0 + pst(2, 79)= 0 + pst(1, 80)= 0 + pst(2, 80)= 0 + pst(1, 81)= 0 + pst(2, 81)= 0 + pst(1, 82)= 0 + pst(2, 82)= 0 + pst(1, 83)= 0 + pst(2, 83)= 0 + pst(1, 84)= 0 + pst(2, 84)= 0 + pst(1, 85)= 0 + pst(2, 85)= 0 + pst(1, 86)= 0 + pst(2, 86)= 0 + pst(1, 87)= 0 + pst(2, 87)= 0 + pst(1, 88)= 0 + pst(2, 88)= 0 + pst(1, 89)= 0 + pst(2, 89)= 0 + pst(1, 90)= 0 + pst(2, 90)= 0 + pst(1, 91)= 0 + pst(2, 91)= 0 + pst(1, 92)= 0 + pst(2, 92)= 0 + pst(1, 93)= 0 + pst(2, 93)= 0 + pst(1, 94)= 0 + pst(2, 94)= 0 + pst(1, 95)= 0 + pst(2, 95)= 0 + pst(1, 96)= 0 + pst(2, 96)= 0 + pst(1, 97)= 0 + pst(2, 97)= 0 + pst(1, 98)= 0 + pst(2, 98)= 0 + pst(1, 99)= 0 + pst(2, 99)= 0 + pst(1,100)= 0 + pst(2,100)= 0 + pst(1,101)= 0 + pst(2,101)= 0 + pst(1,102)= 0 + pst(2,102)= 0 + pst(1,103)= 0 + pst(2,103)= 0 + pst(1,104)= 0 + pst(2,104)= 0 + pst(1,105)= 0 + pst(2,105)= 0 + pst(1,106)= 0 + pst(2,106)= 0 + pst(1,107)= 0 + pst(2,107)= 0 + pst(1,108)= 0 + pst(2,108)= 0 + pst(1,109)= 0 + pst(2,109)= 0 + pst(1,110)= 0 + pst(2,110)= 0 + pst(1,111)= 0 + pst(2,111)= 0 + pst(1,112)= 0 + pst(2,112)= 0 + pst(1,113)= 0 + pst(2,113)= 0 + pst(1,114)= 0 + pst(2,114)= 0 + pst(1,115)= 0 + pst(2,115)= 0 + pst(1,116)= 0 + pst(2,116)= 0 + pst(1,117)= 0 + pst(2,117)= 0 + pst(1,118)= 0 + pst(2,118)= 0 + pst(1,119)= 0 + pst(2,119)= 0 + pst(1,120)= 0 + pst(2,120)= 0 + pst(1,121)= 0 + pst(2,121)= 0 + pst(1,122)= 0 + pst(2,122)= 0 + pst(1,123)= 0 + pst(2,123)= 0 + pst(1,124)= 0 + pst(2,124)= 0 + pst(1,125)= 0 + pst(2,125)= 0 + pst(1,126)= 0 + pst(2,126)= 0 + pst(1,127)= 0 + pst(2,127)= 0 + pst(1,128)= 0 + pst(2,128)= 0 + pst(1,129)= 0 + pst(2,129)= 0 + pst(1,130)= 0 + pst(2,130)= 0 + pst(1,131)= 0 + pst(2,131)= 0 + pst(1,132)= 0 + pst(2,132)= 0 + pst(1,133)= 0 + pst(2,133)= 0 + pst(1,134)= 0 + pst(2,134)= 0 + pst(1,135)= 0 + pst(2,135)= 0 + pst(1,136)= 0 + pst(2,136)= 0 + pst(1,137)= 0 + pst(2,137)= 0 + pst(1,138)= 0 + pst(2,138)= 0 + pst(1,139)= 0 + pst(2,139)= 0 + pst(1,140)= 0 + pst(2,140)= 0 + pst(1,141)= 0 + pst(2,141)= 0 + pst(1,142)= 0 + pst(2,142)= 0 + pst(1,143)= 0 + pst(2,143)= 0 + pst(1,144)= 0 + pst(2,144)= 0 + pst(1,145)= 0 + pst(2,145)= 0 + pst(1,146)= 0 + pst(2,146)= 0 + pst(1,147)= 0 + pst(2,147)= 0 + pst(1,148)= 0 + pst(2,148)= 0 + pst(1,149)= 0 + pst(2,149)= 0 + pst(1,150)= 0 + pst(2,150)= 0 + pst(1,151)= 0 + pst(2,151)= 0 + pst(1,152)= 0 + pst(2,152)= 0 + pst(1,153)= 0 + pst(2,153)= 0 + pst(1,154)= 0 + pst(2,154)= 0 + pst(1,155)= 0 + pst(2,155)= 0 + pst(1,156)= 0 + pst(2,156)= 0 + pst(1,157)= 0 + pst(2,157)= 0 + pst(1,158)= 0 + pst(2,158)= 0 + pst(1,159)= 0 + pst(2,159)= 0 + pst(1,160)= 0 + pst(2,160)= 0 + pst(1,161)= 0 + pst(2,161)= 0 + pst(1,162)= 0 + pst(2,162)= 0 + pst(1,163)= 0 + pst(2,163)= 0 + pst(1,164)= 0 + pst(2,164)= 0 + pst(1,165)= 0 + pst(2,165)= 0 + pst(1,166)= 0 + pst(2,166)= 0 + pst(1,167)= 0 + pst(2,167)= 0 + pst(1,168)= 0 + pst(2,168)= 0 + pst(1,169)= 0 + pst(2,169)= 0 + pst(1,170)= 0 + pst(2,170)= 0 + pst(1,171)= 0 + pst(2,171)= 0 + pst(1,172)= 0 + pst(2,172)= 0 + pst(1,173)= 0 + pst(2,173)= 0 + pst(1,174)= 0 + pst(2,174)= 0 + pst(1,175)= 0 + pst(2,175)= 0 + pst(1,176)= 0 + pst(2,176)= 0 + pst(1,177)= 0 + pst(2,177)= 0 + pst(1,178)= 0 + pst(2,178)= 0 + pst(1,179)= 0 + pst(2,179)= 0 + pst(1,180)= 0 + pst(2,180)= 0 + pst(1,181)= 0 + pst(2,181)= 0 + pst(1,182)= 0 + pst(2,182)= 0 + pst(1,183)= 0 + pst(2,183)= 0 + pst(1,184)= 0 + pst(2,184)= 0 + pst(1,185)= 0 + pst(2,185)= 0 + pst(1,186)= 0 + pst(2,186)= 0 + pst(1,187)= 0 + pst(2,187)= 0 + pst(1,188)= 0 + pst(2,188)= 0 + pst(1,189)= 0 + pst(2,189)= 0 + pst(1,190)= 0 + pst(2,190)= 0 + pst(1,191)= 0 + pst(2,191)= 0 + pst(1,192)= 0 + pst(2,192)= 0 + pst(1,193)= 0 + pst(2,193)= 0 + pst(1,194)= 0 + pst(2,194)= 0 + pst(1,195)= 0 + pst(2,195)= 0 + pst(1,196)= 0 + pst(2,196)= 0 + pst(1,197)= 0 + pst(2,197)= 0 + pst(1,198)= 0 + pst(2,198)= 0 + pst(1,199)= 0 + pst(2,199)= 0 + pst(1,200)= 0 + pst(2,200)= 0 + pst(1,201)= 0 + pst(2,201)= 0 + pst(1,202)= 0 + pst(2,202)= 0 + pst(1,203)= 0 + pst(2,203)= 0 + pst(1,204)= 0 + pst(2,204)= 0 + pst(1,205)= 0 + pst(2,205)= 0 + pst(1,206)= 0 + pst(2,206)= 0 + pst(1,207)= 0 + pst(2,207)= 0 + pst(1,208)= 0 + pst(2,208)= 0 + pst(1,209)= 0 + pst(2,209)= 0 + pst(1,210)= 0 + pst(2,210)= 0 + pst(1,211)= 0 + pst(2,211)= 0 + pst(1,212)= 0 + pst(2,212)= 0 + pst(1,213)= 0 + pst(2,213)= 0 + pst(1,214)= 0 + pst(2,214)= 0 + pst(1,215)= 0 + pst(2,215)= 0 + pst(1,216)= 0 + pst(2,216)= 0 + pst(1,217)= 0 + pst(2,217)= 0 + pst(1,218)= 0 + pst(2,218)= 0 + pst(1,219)= 0 + pst(2,219)= 0 + pst(1,220)= 0 + pst(2,220)= 0 + pst(1,221)= 0 + pst(2,221)= 0 + pst(1,222)= 0 + pst(2,222)= 0 + pst(1,223)= 0 + pst(2,223)= 0 + pst(1,224)= 0 + pst(2,224)= 0 + pst(1,225)= 0 + pst(2,225)= 0 + pst(1,226)= 0 + pst(2,226)= 0 + pst(1,227)= 0 + pst(2,227)= 0 + pst(1,228)= 0 + pst(2,228)= 0 + pst(1,229)= 0 + pst(2,229)= 0 + pst(1,230)= 0 + pst(2,230)= 0 + pst(1,231)= 0 + pst(2,231)= 0 + pst(1,232)= 0 + pst(2,232)= 0 + pst(1,233)= 0 + pst(2,233)= 0 + pst(1,234)= 0 + pst(2,234)= 0 + pst(1,235)= 0 + pst(2,235)= 0 + pst(1,236)= 0 + pst(2,236)= 0 + pst(1,237)= 0 + pst(2,237)= 0 + pst(1,238)= 0 + pst(2,238)= 0 + pst(1,239)= 0 + pst(2,239)= 0 + pst(1,240)= 0 + pst(2,240)= 0 + pst(1,241)= 0 + pst(2,241)= 0 + pst(1,242)= 0 + pst(2,242)= 0 + pst(1,243)= 0 + pst(2,243)= 0 + pst(1,244)= 0 + pst(2,244)= 0 + pst(1,245)= 0 + pst(2,245)= 0 + pst(1,246)= 0 + pst(2,246)= 0 + pst(1,247)= 0 + pst(2,247)= 0 + pst(1,248)= 0 + pst(2,248)= 0 + pst(1,249)= 0 + pst(2,249)= 0 + pst(1,250)= 0 + pst(2,250)= 0 + pst(1,251)= 0 + pst(2,251)= 0 + pst(1,252)= 0 + pst(2,252)= 0 + pst(1,253)= 0 + pst(2,253)= 0 + pst(1,254)= 0 + pst(2,254)= 0 + pst(1,255)= 0 + pst(2,255)= 0 + pst(1,256)= 0 + pst(2,256)= 0 + pst(1,257)= 0 + pst(2,257)= 0 + pst(1,258)= 0 + pst(2,258)= 0 + pst(1,259)= 0 + pst(2,259)= 0 + pst(1,260)= 0 + pst(2,260)= 0 + pst(1,261)= 0 + pst(2,261)= 0 + pst(1,262)= 0 + pst(2,262)= 0 + pst(1,263)= 0 + pst(2,263)= 0 + pst(1,264)= 0 + pst(2,264)= 0 + pst(1,265)= 0 + pst(2,265)= 0 + pst(1,266)= 0 + pst(2,266)= 0 + pst(1,267)= 0 + pst(2,267)= 0 + pst(1,268)= 0 + pst(2,268)= 0 + pst(1,269)= 0 + pst(2,269)= 0 + pst(1,270)= 0 + pst(2,270)= 0 + pst(1,271)= 0 + pst(2,271)= 0 + pst(1,272)= 0 + pst(2,272)= 0 + pst(1,273)= 0 + pst(2,273)= 0 + pst(1,274)= 0 + pst(2,274)= 0 + pst(1,275)= 0 + pst(2,275)= 0 + pst(1,276)= 0 + pst(2,276)= 0 + pst(1,277)= 0 + pst(2,277)= 0 + pst(1,278)= 0 + pst(2,278)= 0 + pst(1,279)= 0 + pst(2,279)= 0 + pst(1,280)= 0 + pst(2,280)= 0 + pst(1,281)= 0 + pst(2,281)= 0 + pst(1,282)= 0 + pst(2,282)= 0 + pst(1,283)= 0 + pst(2,283)= 0 + pst(1,284)= 0 + pst(2,284)= 0 + pst(1,285)= 0 + pst(2,285)= 0 + pst(1,286)= 0 + pst(2,286)= 0 + pst(1,287)= 0 + pst(2,287)= 0 + pst(1,288)= 0 + pst(2,288)= 0 + pst(1,289)= 0 + pst(2,289)= 0 + pst(1,290)= 0 + pst(2,290)= 0 + pst(1,291)= 0 + pst(2,291)= 0 + pst(1,292)= 0 + pst(2,292)= 0 + pst(1,293)= 0 + pst(2,293)= 0 + pst(1,294)= 0 + pst(2,294)= 0 + pst(1,295)= 0 + pst(2,295)= 0 + pst(1,296)= 0 + pst(2,296)= 0 + pst(1,297)= 0 + pst(2,297)= 0 + pst(1,298)= 0 + pst(2,298)= 0 + pst(1,299)= 0 + pst(2,299)= 0 + pst(1,300)= 0 + pst(2,300)= 0 + pst(1,301)= 0 + pst(2,301)= 0 + pst(1,302)= 0 + pst(2,302)= 0 + pst(1,303)= 0 + pst(2,303)= 0 + pst(1,304)= 0 + pst(2,304)= 0 + pst(1,305)= 0 + pst(2,305)= 0 + pst(1,306)= 0 + pst(2,306)= 0 + pst(1,307)= 0 + pst(2,307)= 0 + pst(1,308)= 0 + pst(2,308)= 0 + pst(1,309)= 0 + pst(2,309)= 0 + pst(1,310)= 0 + pst(2,310)= 0 + pst(1,311)= 0 + pst(2,311)= 0 + pst(1,312)= 0 + pst(2,312)= 0 + pst(1,313)= 0 + pst(2,313)= 0 + pst(1,314)= 0 + pst(2,314)= 0 + pst(1,315)= 0 + pst(2,315)= 0 + pst(1,316)= 0 + pst(2,316)= 0 + pst(1,317)= 0 + pst(2,317)= 0 + pst(1,318)= 0 + pst(2,318)= 0 + pst(1,319)= 0 + pst(2,319)= 0 + pst(1,320)= 0 + pst(2,320)= 0 + pst(1,321)= 0 + pst(2,321)= 0 + pst(1,322)= 0 + pst(2,322)= 0 + pst(1,323)= 0 + pst(2,323)= 0 + pst(1,324)= 0 + pst(2,324)= 0 + pst(1,325)= 0 + pst(2,325)= 0 + pst(1,326)= 0 + pst(2,326)= 0 + pst(1,327)= 0 + pst(2,327)= 0 + pst(1,328)= 0 + pst(2,328)= 0 + pst(1,329)= 0 + pst(2,329)= 0 + pst(1,330)= 0 + pst(2,330)= 0 + pst(1,331)= 0 + pst(2,331)= 0 + pst(1,332)= 0 + pst(2,332)= 0 + pst(1,333)= 0 + pst(2,333)= 0 + pst(1,334)= 0 + pst(2,334)= 0 + pst(1,335)= 0 + pst(2,335)= 0 + pst(1,336)= 0 + pst(2,336)= 0 + pst(1,337)= 0 + pst(2,337)= 0 + pst(1,338)= 0 + pst(2,338)= 0 + pst(1,339)= 0 + pst(2,339)= 0 + pst(1,340)= 0 + pst(2,340)= 0 + pst(1,341)= 0 + pst(2,341)= 0 + pst(1,342)= 0 + pst(2,342)= 0 + pst(1,343)= 0 + pst(2,343)= 0 + pst(1,344)= 0 + pst(2,344)= 0 + pst(1,345)= 0 + pst(2,345)= 0 + pst(1,346)= 0 + pst(2,346)= 0 + pst(1,347)= 0 + pst(2,347)= 0 + pst(1,348)= 0 + pst(2,348)= 0 + pst(1,349)= 0 + pst(2,349)= 0 + pst(1,350)= 0 + pst(2,350)= 0 + pst(1,351)= 0 + pst(2,351)= 0 + pst(1,352)= 0 + pst(2,352)= 0 + pst(1,353)= 0 + pst(2,353)= 0 + pst(1,354)= 0 + pst(2,354)= 0 + pst(1,355)= 0 + pst(2,355)= 0 + pst(1,356)= 0 + pst(2,356)= 0 + pst(1,357)= 0 + pst(2,357)= 0 + pst(1,358)= 0 + pst(2,358)= 0 + pst(1,359)= 0 + pst(2,359)= 0 + pst(1,360)= 0 + pst(2,360)= 0 + pst(1,361)= 0 + pst(2,361)= 0 + pst(1,362)= 0 + pst(2,362)= 0 + pst(1,363)= 0 + pst(2,363)= 0 + pst(1,364)= 0 + pst(2,364)= 0 + pst(1,365)= 0 + pst(2,365)= 0 + pst(1,366)= 0 + pst(2,366)= 0 + pst(1,367)= 0 + pst(2,367)= 0 + pst(1,368)= 0 + pst(2,368)= 0 + pst(1,369)= 0 + pst(2,369)= 0 + pst(1,370)= 0 + pst(2,370)= 0 + pst(1,371)= 0 + pst(2,371)= 0 + pst(1,372)= 0 + pst(2,372)= 0 + pst(1,373)= 0 + pst(2,373)= 0 + pst(1,374)= 0 + pst(2,374)= 0 + pst(1,375)= 0 + pst(2,375)= 0 + pst(1,376)= 0 + pst(2,376)= 0 + pst(1,377)= 0 + pst(2,377)= 0 + pst(1,378)= 0 + pst(2,378)= 0 + pst(1,379)= 0 + pst(2,379)= 0 + pst(1,380)= 0 + pst(2,380)= 0 + pst(1,381)= 0 + pst(2,381)= 0 + pst(1,382)= 0 + pst(2,382)= 0 + pst(1,383)= 0 + pst(2,383)= 0 + pst(1,384)= 0 + pst(2,384)= 0 + pst(1,385)= 0 + pst(2,385)= 0 + pst(1,386)= 0 + pst(2,386)= 0 + pst(1,387)= 0 + pst(2,387)= 0 + pst(1,388)= 0 + pst(2,388)= 0 + pst(1,389)= 0 + pst(2,389)= 0 + pst(1,390)= 0 + pst(2,390)= 0 + pst(1,391)= 0 + pst(2,391)= 0 + pst(1,392)= 0 + pst(2,392)= 0 + pst(1,393)= 0 + pst(2,393)= 0 + pst(1,394)= 0 + pst(2,394)= 0 + pst(1,395)= 0 + pst(2,395)= 0 + pst(1,396)= 0 + pst(2,396)= 0 + pst(1,397)= 0 + pst(2,397)= 0 + pst(1,398)= 0 + pst(2,398)= 0 + pst(1,399)= 0 + pst(2,399)= 0 + pst(1,400)= 0 + pst(2,400)= 0 +End SUBROUTINE init_dip_planar_data +End Module dip_param diff --git a/src/model/fit_param_dip_pes.f90 b/src/model/fit_param_dip_pes.f90 new file mode 100644 index 0000000..372283a --- /dev/null +++ b/src/model/fit_param_dip_pes.f90 @@ -0,0 +1,914 @@ + Module dip_param + IMPLICIT NONE + Integer,parameter :: np=101 + Double precision :: p(101) + integer :: pst(2,400) + ! Non zero parameters are 16 + !$omp threadprivate(p,pst) + contains + + SUBROUTINE init_dip_planar_data() + implicit none + p( 1)= -0.561433980D+02 + p( 2)= 0.000000000D+00 + p( 3)= 0.000000000D+00 + p( 4)= -0.558830090D+02 + p( 5)= 0.000000000D+00 + p( 6)= 0.000000000D+00 + p( 7)= -0.557220030D+02 + p( 8)= 0.000000000D+00 + p( 9)= 0.000000000D+00 + p( 10)= 0.000000000D+00 + p( 11)= 0.333624014D-02 + p( 12)= 0.000000000D+00 + p( 13)= 0.000000000D+00 + p( 14)= 0.000000000D+00 + p( 15)= 0.000000000D+00 + p( 16)= 0.000000000D+00 + p( 17)= 0.000000000D+00 + p( 18)= 0.000000000D+00 + p( 19)= 0.000000000D+00 + p( 20)= 0.000000000D+00 + p( 21)= -0.532590808D-03 + p( 22)= 0.000000000D+00 + p( 23)= 0.000000000D+00 + p( 24)= 0.000000000D+00 + p( 25)= 0.000000000D+00 + p( 26)= 0.000000000D+00 + p( 27)= 0.000000000D+00 + p( 28)= -0.226073502D-01 + p( 29)= 0.000000000D+00 + p( 30)= -0.363395355D-01 + p( 31)= 0.000000000D+00 + p( 32)= 0.939930347D-01 + p( 33)= 0.000000000D+00 + p( 34)= 0.111364489D-03 + p( 35)= 0.000000000D+00 + p( 36)= 0.000000000D+00 + p( 37)= 0.000000000D+00 + p( 38)= 0.000000000D+00 + p( 39)= 0.000000000D+00 + p( 40)= -0.545384229D-02 + p( 41)= 0.000000000D+00 + p( 42)= 0.000000000D+00 + p( 43)= 0.000000000D+00 + p( 44)= 0.000000000D+00 + p( 45)= 0.000000000D+00 + p( 46)= 0.000000000D+00 + p( 47)= 0.000000000D+00 + p( 48)= 0.000000000D+00 + p( 49)= 0.217598103D+00 + p( 50)= -0.113772250D-01 + p( 51)= 0.000000000D+00 + p( 52)= -0.122160662D-03 + p( 53)= 0.000000000D+00 + p( 54)= 0.000000000D+00 + p( 55)= 0.000000000D+00 + p( 56)= 0.000000000D+00 + p( 57)= 0.000000000D+00 + p( 58)= 0.000000000D+00 + p( 59)= 0.000000000D+00 + p( 60)= 0.000000000D+00 + p( 61)= 0.000000000D+00 + p( 62)= 0.000000000D+00 + p( 63)= 0.000000000D+00 + p( 64)= 0.000000000D+00 + p( 65)= 0.000000000D+00 + p( 66)= 0.000000000D+00 + p( 67)= 0.000000000D+00 + p( 68)= 0.000000000D+00 + p( 69)= 0.000000000D+00 + p( 70)= 0.000000000D+00 + p( 71)= 0.000000000D+00 + p( 72)= 0.000000000D+00 + p( 73)= 0.000000000D+00 + p( 74)= 0.000000000D+00 + p( 75)= 0.000000000D+00 + p( 76)= 0.000000000D+00 + p( 77)= 0.000000000D+00 + p( 78)= 0.000000000D+00 + p( 79)= 0.000000000D+00 + p( 80)= 0.000000000D+00 + p( 81)= 0.000000000D+00 + p( 82)= 0.000000000D+00 + p( 83)= 0.000000000D+00 + p( 84)= 0.000000000D+00 + p( 85)= 0.000000000D+00 + p( 86)= 0.000000000D+00 + p( 87)= -0.567206500D-02 + p( 88)= -0.565873672D-02 + p( 89)= 0.000000000D+00 + p( 90)= 0.336524505D-03 + p( 91)= 0.000000000D+00 + p( 92)= 0.000000000D+00 + p( 93)= 0.000000000D+00 + p( 94)= 0.000000000D+00 + p( 95)= 0.000000000D+00 + p( 96)= 0.000000000D+00 + p( 97)= 0.000000000D+00 + p( 98)= 0.000000000D+00 + p( 99)= 0.000000000D+00 + p(100)= 0.000000000D+00 + p(101)= 0.000000000D+00 + pst(1, 1)= 1 + pst(2, 1)= 3 + pst(1, 2)= 4 + pst(2, 2)= 3 + pst(1, 3)= 7 + pst(2, 3)= 4 + pst(1, 4)= 11 + pst(2, 4)= 2 + pst(1, 5)= 13 + pst(2, 5)= 3 + pst(1, 6)= 16 + pst(2, 6)= 2 + pst(1, 7)= 18 + pst(2, 7)= 3 + pst(1, 8)= 21 + pst(2, 8)= 3 + pst(1, 9)= 24 + pst(2, 9)= 3 + pst(1, 10)= 27 + pst(2, 10)= 1 + pst(1, 11)= 28 + pst(2, 11)= 2 + pst(1, 12)= 30 + pst(2, 12)= 2 + pst(1, 13)= 32 + pst(2, 13)= 2 + pst(1, 14)= 34 + pst(2, 14)= 3 + pst(1, 15)= 37 + pst(2, 15)= 3 + pst(1, 16)= 40 + pst(2, 16)= 3 + pst(1, 17)= 43 + pst(2, 17)= 2 + pst(1, 18)= 45 + pst(2, 18)= 2 + pst(1, 19)= 47 + pst(2, 19)= 2 + pst(1, 20)= 49 + pst(2, 20)= 1 + pst(1, 21)= 50 + pst(2, 21)= 2 + pst(1, 22)= 52 + pst(2, 22)= 5 + pst(1, 23)= 57 + pst(2, 23)= 10 + pst(1, 24)= 67 + pst(2, 24)= 1 + pst(1, 25)= 68 + pst(2, 25)= 2 + pst(1, 26)= 70 + pst(2, 26)= 4 + pst(1, 27)= 74 + pst(2, 27)= 8 + pst(1, 28)= 82 + pst(2, 28)= 2 + pst(1, 29)= 84 + pst(2, 29)= 3 + pst(1, 30)= 87 + pst(2, 30)= 1 + pst(1, 31)= 88 + pst(2, 31)= 2 + pst(1, 32)= 90 + pst(2, 32)= 4 + pst(1, 33)= 94 + pst(2, 33)= 8 + pst(1, 34)= 0 + pst(2, 34)= 0 + pst(1, 35)= 0 + pst(2, 35)= 0 + pst(1, 36)= 0 + pst(2, 36)= 0 + pst(1, 37)= 0 + pst(2, 37)= 0 + pst(1, 38)= 0 + pst(2, 38)= 0 + pst(1, 39)= 0 + pst(2, 39)= 0 + pst(1, 40)= 0 + pst(2, 40)= 0 + pst(1, 41)= 0 + pst(2, 41)= 0 + pst(1, 42)= 0 + pst(2, 42)= 0 + pst(1, 43)= 0 + pst(2, 43)= 0 + pst(1, 44)= 0 + pst(2, 44)= 0 + pst(1, 45)= 0 + pst(2, 45)= 0 + pst(1, 46)= 0 + pst(2, 46)= 0 + pst(1, 47)= 0 + pst(2, 47)= 0 + pst(1, 48)= 0 + pst(2, 48)= 0 + pst(1, 49)= 0 + pst(2, 49)= 0 + pst(1, 50)= 0 + pst(2, 50)= 0 + pst(1, 51)= 0 + pst(2, 51)= 0 + pst(1, 52)= 0 + pst(2, 52)= 0 + pst(1, 53)= 0 + pst(2, 53)= 0 + pst(1, 54)= 0 + pst(2, 54)= 0 + pst(1, 55)= 0 + pst(2, 55)= 0 + pst(1, 56)= 0 + pst(2, 56)= 0 + pst(1, 57)= 0 + pst(2, 57)= 0 + pst(1, 58)= 0 + pst(2, 58)= 0 + pst(1, 59)= 0 + pst(2, 59)= 0 + pst(1, 60)= 0 + pst(2, 60)= 0 + pst(1, 61)= 0 + pst(2, 61)= 0 + pst(1, 62)= 0 + pst(2, 62)= 0 + pst(1, 63)= 0 + pst(2, 63)= 0 + pst(1, 64)= 0 + pst(2, 64)= 0 + pst(1, 65)= 0 + pst(2, 65)= 0 + pst(1, 66)= 0 + pst(2, 66)= 0 + pst(1, 67)= 0 + pst(2, 67)= 0 + pst(1, 68)= 0 + pst(2, 68)= 0 + pst(1, 69)= 0 + pst(2, 69)= 0 + pst(1, 70)= 0 + pst(2, 70)= 0 + pst(1, 71)= 0 + pst(2, 71)= 0 + pst(1, 72)= 0 + pst(2, 72)= 0 + pst(1, 73)= 0 + pst(2, 73)= 0 + pst(1, 74)= 0 + pst(2, 74)= 0 + pst(1, 75)= 0 + pst(2, 75)= 0 + pst(1, 76)= 0 + pst(2, 76)= 0 + pst(1, 77)= 0 + pst(2, 77)= 0 + pst(1, 78)= 0 + pst(2, 78)= 0 + pst(1, 79)= 0 + pst(2, 79)= 0 + pst(1, 80)= 0 + pst(2, 80)= 0 + pst(1, 81)= 0 + pst(2, 81)= 0 + pst(1, 82)= 0 + pst(2, 82)= 0 + pst(1, 83)= 0 + pst(2, 83)= 0 + pst(1, 84)= 0 + pst(2, 84)= 0 + pst(1, 85)= 0 + pst(2, 85)= 0 + pst(1, 86)= 0 + pst(2, 86)= 0 + pst(1, 87)= 0 + pst(2, 87)= 0 + pst(1, 88)= 0 + pst(2, 88)= 0 + pst(1, 89)= 0 + pst(2, 89)= 0 + pst(1, 90)= 0 + pst(2, 90)= 0 + pst(1, 91)= 0 + pst(2, 91)= 0 + pst(1, 92)= 0 + pst(2, 92)= 0 + pst(1, 93)= 0 + pst(2, 93)= 0 + pst(1, 94)= 0 + pst(2, 94)= 0 + pst(1, 95)= 0 + pst(2, 95)= 0 + pst(1, 96)= 0 + pst(2, 96)= 0 + pst(1, 97)= 0 + pst(2, 97)= 0 + pst(1, 98)= 0 + pst(2, 98)= 0 + pst(1, 99)= 0 + pst(2, 99)= 0 + pst(1,100)= 0 + pst(2,100)= 0 + pst(1,101)= 0 + pst(2,101)= 0 + pst(1,102)= 0 + pst(2,102)= 0 + pst(1,103)= 0 + pst(2,103)= 0 + pst(1,104)= 0 + pst(2,104)= 0 + pst(1,105)= 0 + pst(2,105)= 0 + pst(1,106)= 0 + pst(2,106)= 0 + pst(1,107)= 0 + pst(2,107)= 0 + pst(1,108)= 0 + pst(2,108)= 0 + pst(1,109)= 0 + pst(2,109)= 0 + pst(1,110)= 0 + pst(2,110)= 0 + pst(1,111)= 0 + pst(2,111)= 0 + pst(1,112)= 0 + pst(2,112)= 0 + pst(1,113)= 0 + pst(2,113)= 0 + pst(1,114)= 0 + pst(2,114)= 0 + pst(1,115)= 0 + pst(2,115)= 0 + pst(1,116)= 0 + pst(2,116)= 0 + pst(1,117)= 0 + pst(2,117)= 0 + pst(1,118)= 0 + pst(2,118)= 0 + pst(1,119)= 0 + pst(2,119)= 0 + pst(1,120)= 0 + pst(2,120)= 0 + pst(1,121)= 0 + pst(2,121)= 0 + pst(1,122)= 0 + pst(2,122)= 0 + pst(1,123)= 0 + pst(2,123)= 0 + pst(1,124)= 0 + pst(2,124)= 0 + pst(1,125)= 0 + pst(2,125)= 0 + pst(1,126)= 0 + pst(2,126)= 0 + pst(1,127)= 0 + pst(2,127)= 0 + pst(1,128)= 0 + pst(2,128)= 0 + pst(1,129)= 0 + pst(2,129)= 0 + pst(1,130)= 0 + pst(2,130)= 0 + pst(1,131)= 0 + pst(2,131)= 0 + pst(1,132)= 0 + pst(2,132)= 0 + pst(1,133)= 0 + pst(2,133)= 0 + pst(1,134)= 0 + pst(2,134)= 0 + pst(1,135)= 0 + pst(2,135)= 0 + pst(1,136)= 0 + pst(2,136)= 0 + pst(1,137)= 0 + pst(2,137)= 0 + pst(1,138)= 0 + pst(2,138)= 0 + pst(1,139)= 0 + pst(2,139)= 0 + pst(1,140)= 0 + pst(2,140)= 0 + pst(1,141)= 0 + pst(2,141)= 0 + pst(1,142)= 0 + pst(2,142)= 0 + pst(1,143)= 0 + pst(2,143)= 0 + pst(1,144)= 0 + pst(2,144)= 0 + pst(1,145)= 0 + pst(2,145)= 0 + pst(1,146)= 0 + pst(2,146)= 0 + pst(1,147)= 0 + pst(2,147)= 0 + pst(1,148)= 0 + pst(2,148)= 0 + pst(1,149)= 0 + pst(2,149)= 0 + pst(1,150)= 0 + pst(2,150)= 0 + pst(1,151)= 0 + pst(2,151)= 0 + pst(1,152)= 0 + pst(2,152)= 0 + pst(1,153)= 0 + pst(2,153)= 0 + pst(1,154)= 0 + pst(2,154)= 0 + pst(1,155)= 0 + pst(2,155)= 0 + pst(1,156)= 0 + pst(2,156)= 0 + pst(1,157)= 0 + pst(2,157)= 0 + pst(1,158)= 0 + pst(2,158)= 0 + pst(1,159)= 0 + pst(2,159)= 0 + pst(1,160)= 0 + pst(2,160)= 0 + pst(1,161)= 0 + pst(2,161)= 0 + pst(1,162)= 0 + pst(2,162)= 0 + pst(1,163)= 0 + pst(2,163)= 0 + pst(1,164)= 0 + pst(2,164)= 0 + pst(1,165)= 0 + pst(2,165)= 0 + pst(1,166)= 0 + pst(2,166)= 0 + pst(1,167)= 0 + pst(2,167)= 0 + pst(1,168)= 0 + pst(2,168)= 0 + pst(1,169)= 0 + pst(2,169)= 0 + pst(1,170)= 0 + pst(2,170)= 0 + pst(1,171)= 0 + pst(2,171)= 0 + pst(1,172)= 0 + pst(2,172)= 0 + pst(1,173)= 0 + pst(2,173)= 0 + pst(1,174)= 0 + pst(2,174)= 0 + pst(1,175)= 0 + pst(2,175)= 0 + pst(1,176)= 0 + pst(2,176)= 0 + pst(1,177)= 0 + pst(2,177)= 0 + pst(1,178)= 0 + pst(2,178)= 0 + pst(1,179)= 0 + pst(2,179)= 0 + pst(1,180)= 0 + pst(2,180)= 0 + pst(1,181)= 0 + pst(2,181)= 0 + pst(1,182)= 0 + pst(2,182)= 0 + pst(1,183)= 0 + pst(2,183)= 0 + pst(1,184)= 0 + pst(2,184)= 0 + pst(1,185)= 0 + pst(2,185)= 0 + pst(1,186)= 0 + pst(2,186)= 0 + pst(1,187)= 0 + pst(2,187)= 0 + pst(1,188)= 0 + pst(2,188)= 0 + pst(1,189)= 0 + pst(2,189)= 0 + pst(1,190)= 0 + pst(2,190)= 0 + pst(1,191)= 0 + pst(2,191)= 0 + pst(1,192)= 0 + pst(2,192)= 0 + pst(1,193)= 0 + pst(2,193)= 0 + pst(1,194)= 0 + pst(2,194)= 0 + pst(1,195)= 0 + pst(2,195)= 0 + pst(1,196)= 0 + pst(2,196)= 0 + pst(1,197)= 0 + pst(2,197)= 0 + pst(1,198)= 0 + pst(2,198)= 0 + pst(1,199)= 0 + pst(2,199)= 0 + pst(1,200)= 0 + pst(2,200)= 0 + pst(1,201)= 0 + pst(2,201)= 0 + pst(1,202)= 0 + pst(2,202)= 0 + pst(1,203)= 0 + pst(2,203)= 0 + pst(1,204)= 0 + pst(2,204)= 0 + pst(1,205)= 0 + pst(2,205)= 0 + pst(1,206)= 0 + pst(2,206)= 0 + pst(1,207)= 0 + pst(2,207)= 0 + pst(1,208)= 0 + pst(2,208)= 0 + pst(1,209)= 0 + pst(2,209)= 0 + pst(1,210)= 0 + pst(2,210)= 0 + pst(1,211)= 0 + pst(2,211)= 0 + pst(1,212)= 0 + pst(2,212)= 0 + pst(1,213)= 0 + pst(2,213)= 0 + pst(1,214)= 0 + pst(2,214)= 0 + pst(1,215)= 0 + pst(2,215)= 0 + pst(1,216)= 0 + pst(2,216)= 0 + pst(1,217)= 0 + pst(2,217)= 0 + pst(1,218)= 0 + pst(2,218)= 0 + pst(1,219)= 0 + pst(2,219)= 0 + pst(1,220)= 0 + pst(2,220)= 0 + pst(1,221)= 0 + pst(2,221)= 0 + pst(1,222)= 0 + pst(2,222)= 0 + pst(1,223)= 0 + pst(2,223)= 0 + pst(1,224)= 0 + pst(2,224)= 0 + pst(1,225)= 0 + pst(2,225)= 0 + pst(1,226)= 0 + pst(2,226)= 0 + pst(1,227)= 0 + pst(2,227)= 0 + pst(1,228)= 0 + pst(2,228)= 0 + pst(1,229)= 0 + pst(2,229)= 0 + pst(1,230)= 0 + pst(2,230)= 0 + pst(1,231)= 0 + pst(2,231)= 0 + pst(1,232)= 0 + pst(2,232)= 0 + pst(1,233)= 0 + pst(2,233)= 0 + pst(1,234)= 0 + pst(2,234)= 0 + pst(1,235)= 0 + pst(2,235)= 0 + pst(1,236)= 0 + pst(2,236)= 0 + pst(1,237)= 0 + pst(2,237)= 0 + pst(1,238)= 0 + pst(2,238)= 0 + pst(1,239)= 0 + pst(2,239)= 0 + pst(1,240)= 0 + pst(2,240)= 0 + pst(1,241)= 0 + pst(2,241)= 0 + pst(1,242)= 0 + pst(2,242)= 0 + pst(1,243)= 0 + pst(2,243)= 0 + pst(1,244)= 0 + pst(2,244)= 0 + pst(1,245)= 0 + pst(2,245)= 0 + pst(1,246)= 0 + pst(2,246)= 0 + pst(1,247)= 0 + pst(2,247)= 0 + pst(1,248)= 0 + pst(2,248)= 0 + pst(1,249)= 0 + pst(2,249)= 0 + pst(1,250)= 0 + pst(2,250)= 0 + pst(1,251)= 0 + pst(2,251)= 0 + pst(1,252)= 0 + pst(2,252)= 0 + pst(1,253)= 0 + pst(2,253)= 0 + pst(1,254)= 0 + pst(2,254)= 0 + pst(1,255)= 0 + pst(2,255)= 0 + pst(1,256)= 0 + pst(2,256)= 0 + pst(1,257)= 0 + pst(2,257)= 0 + pst(1,258)= 0 + pst(2,258)= 0 + pst(1,259)= 0 + pst(2,259)= 0 + pst(1,260)= 0 + pst(2,260)= 0 + pst(1,261)= 0 + pst(2,261)= 0 + pst(1,262)= 0 + pst(2,262)= 0 + pst(1,263)= 0 + pst(2,263)= 0 + pst(1,264)= 0 + pst(2,264)= 0 + pst(1,265)= 0 + pst(2,265)= 0 + pst(1,266)= 0 + pst(2,266)= 0 + pst(1,267)= 0 + pst(2,267)= 0 + pst(1,268)= 0 + pst(2,268)= 0 + pst(1,269)= 0 + pst(2,269)= 0 + pst(1,270)= 0 + pst(2,270)= 0 + pst(1,271)= 0 + pst(2,271)= 0 + pst(1,272)= 0 + pst(2,272)= 0 + pst(1,273)= 0 + pst(2,273)= 0 + pst(1,274)= 0 + pst(2,274)= 0 + pst(1,275)= 0 + pst(2,275)= 0 + pst(1,276)= 0 + pst(2,276)= 0 + pst(1,277)= 0 + pst(2,277)= 0 + pst(1,278)= 0 + pst(2,278)= 0 + pst(1,279)= 0 + pst(2,279)= 0 + pst(1,280)= 0 + pst(2,280)= 0 + pst(1,281)= 0 + pst(2,281)= 0 + pst(1,282)= 0 + pst(2,282)= 0 + pst(1,283)= 0 + pst(2,283)= 0 + pst(1,284)= 0 + pst(2,284)= 0 + pst(1,285)= 0 + pst(2,285)= 0 + pst(1,286)= 0 + pst(2,286)= 0 + pst(1,287)= 0 + pst(2,287)= 0 + pst(1,288)= 0 + pst(2,288)= 0 + pst(1,289)= 0 + pst(2,289)= 0 + pst(1,290)= 0 + pst(2,290)= 0 + pst(1,291)= 0 + pst(2,291)= 0 + pst(1,292)= 0 + pst(2,292)= 0 + pst(1,293)= 0 + pst(2,293)= 0 + pst(1,294)= 0 + pst(2,294)= 0 + pst(1,295)= 0 + pst(2,295)= 0 + pst(1,296)= 0 + pst(2,296)= 0 + pst(1,297)= 0 + pst(2,297)= 0 + pst(1,298)= 0 + pst(2,298)= 0 + pst(1,299)= 0 + pst(2,299)= 0 + pst(1,300)= 0 + pst(2,300)= 0 + pst(1,301)= 0 + pst(2,301)= 0 + pst(1,302)= 0 + pst(2,302)= 0 + pst(1,303)= 0 + pst(2,303)= 0 + pst(1,304)= 0 + pst(2,304)= 0 + pst(1,305)= 0 + pst(2,305)= 0 + pst(1,306)= 0 + pst(2,306)= 0 + pst(1,307)= 0 + pst(2,307)= 0 + pst(1,308)= 0 + pst(2,308)= 0 + pst(1,309)= 0 + pst(2,309)= 0 + pst(1,310)= 0 + pst(2,310)= 0 + pst(1,311)= 0 + pst(2,311)= 0 + pst(1,312)= 0 + pst(2,312)= 0 + pst(1,313)= 0 + pst(2,313)= 0 + pst(1,314)= 0 + pst(2,314)= 0 + pst(1,315)= 0 + pst(2,315)= 0 + pst(1,316)= 0 + pst(2,316)= 0 + pst(1,317)= 0 + pst(2,317)= 0 + pst(1,318)= 0 + pst(2,318)= 0 + pst(1,319)= 0 + pst(2,319)= 0 + pst(1,320)= 0 + pst(2,320)= 0 + pst(1,321)= 0 + pst(2,321)= 0 + pst(1,322)= 0 + pst(2,322)= 0 + pst(1,323)= 0 + pst(2,323)= 0 + pst(1,324)= 0 + pst(2,324)= 0 + pst(1,325)= 0 + pst(2,325)= 0 + pst(1,326)= 0 + pst(2,326)= 0 + pst(1,327)= 0 + pst(2,327)= 0 + pst(1,328)= 0 + pst(2,328)= 0 + pst(1,329)= 0 + pst(2,329)= 0 + pst(1,330)= 0 + pst(2,330)= 0 + pst(1,331)= 0 + pst(2,331)= 0 + pst(1,332)= 0 + pst(2,332)= 0 + pst(1,333)= 0 + pst(2,333)= 0 + pst(1,334)= 0 + pst(2,334)= 0 + pst(1,335)= 0 + pst(2,335)= 0 + pst(1,336)= 0 + pst(2,336)= 0 + pst(1,337)= 0 + pst(2,337)= 0 + pst(1,338)= 0 + pst(2,338)= 0 + pst(1,339)= 0 + pst(2,339)= 0 + pst(1,340)= 0 + pst(2,340)= 0 + pst(1,341)= 0 + pst(2,341)= 0 + pst(1,342)= 0 + pst(2,342)= 0 + pst(1,343)= 0 + pst(2,343)= 0 + pst(1,344)= 0 + pst(2,344)= 0 + pst(1,345)= 0 + pst(2,345)= 0 + pst(1,346)= 0 + pst(2,346)= 0 + pst(1,347)= 0 + pst(2,347)= 0 + pst(1,348)= 0 + pst(2,348)= 0 + pst(1,349)= 0 + pst(2,349)= 0 + pst(1,350)= 0 + pst(2,350)= 0 + pst(1,351)= 0 + pst(2,351)= 0 + pst(1,352)= 0 + pst(2,352)= 0 + pst(1,353)= 0 + pst(2,353)= 0 + pst(1,354)= 0 + pst(2,354)= 0 + pst(1,355)= 0 + pst(2,355)= 0 + pst(1,356)= 0 + pst(2,356)= 0 + pst(1,357)= 0 + pst(2,357)= 0 + pst(1,358)= 0 + pst(2,358)= 0 + pst(1,359)= 0 + pst(2,359)= 0 + pst(1,360)= 0 + pst(2,360)= 0 + pst(1,361)= 0 + pst(2,361)= 0 + pst(1,362)= 0 + pst(2,362)= 0 + pst(1,363)= 0 + pst(2,363)= 0 + pst(1,364)= 0 + pst(2,364)= 0 + pst(1,365)= 0 + pst(2,365)= 0 + pst(1,366)= 0 + pst(2,366)= 0 + pst(1,367)= 0 + pst(2,367)= 0 + pst(1,368)= 0 + pst(2,368)= 0 + pst(1,369)= 0 + pst(2,369)= 0 + pst(1,370)= 0 + pst(2,370)= 0 + pst(1,371)= 0 + pst(2,371)= 0 + pst(1,372)= 0 + pst(2,372)= 0 + pst(1,373)= 0 + pst(2,373)= 0 + pst(1,374)= 0 + pst(2,374)= 0 + pst(1,375)= 0 + pst(2,375)= 0 + pst(1,376)= 0 + pst(2,376)= 0 + pst(1,377)= 0 + pst(2,377)= 0 + pst(1,378)= 0 + pst(2,378)= 0 + pst(1,379)= 0 + pst(2,379)= 0 + pst(1,380)= 0 + pst(2,380)= 0 + pst(1,381)= 0 + pst(2,381)= 0 + pst(1,382)= 0 + pst(2,382)= 0 + pst(1,383)= 0 + pst(2,383)= 0 + pst(1,384)= 0 + pst(2,384)= 0 + pst(1,385)= 0 + pst(2,385)= 0 + pst(1,386)= 0 + pst(2,386)= 0 + pst(1,387)= 0 + pst(2,387)= 0 + pst(1,388)= 0 + pst(2,388)= 0 + pst(1,389)= 0 + pst(2,389)= 0 + pst(1,390)= 0 + pst(2,390)= 0 + pst(1,391)= 0 + pst(2,391)= 0 + pst(1,392)= 0 + pst(2,392)= 0 + pst(1,393)= 0 + pst(2,393)= 0 + pst(1,394)= 0 + pst(2,394)= 0 + pst(1,395)= 0 + pst(2,395)= 0 + pst(1,396)= 0 + pst(2,396)= 0 + pst(1,397)= 0 + pst(2,397)= 0 + pst(1,398)= 0 + pst(2,398)= 0 + pst(1,399)= 0 + pst(2,399)= 0 + pst(1,400)= 0 + pst(2,400)= 0 +End SUBROUTINE init_dip_planar_data +End Module dip_param diff --git a/src/model/invariants_nh3.f90 b/src/model/invariants_nh3.f90 new file mode 100644 index 0000000..b42dddd --- /dev/null +++ b/src/model/invariants_nh3.f90 @@ -0,0 +1,172 @@ +Module invariants_mod + implicit none + contains + !---------------------------------------------------- + subroutine invariants(a,xs,ys,xb,yb,inv) + implicit none + !include "nnparams.incl" + double precision, intent(in) :: a, xs, ys, xb, yb + double precision, intent(out) ::inv(3) + double precision:: invar(23) + !double precision:: invar(24) + complex(8) :: q1, q2 + LOGICAL,PARAMETER:: debg =.FALSE. + integer :: i + ! express the coordinate in complex + + q1 = dcmplx(xs, ys) + q2 = dcmplx(xb, yb) + + + ! compute the invariants + !inv( 4) = a + !inv( 4) = b**2 + + ! INVARIANTS OF KIND II + !------------------------ + + invar(1) = dreal( q1 * conjg(q1) ) ! r11 + invar(2) = dreal( q1 * conjg(q2) ) ! r12 + invar(3) = dreal( q2 * conjg(q2) ) ! r22 + invar(4) = (dimag(q1 * conjg(q2)) )**2 ! rho 12**2 + + + !INVATIANTS OF KIND III + !------------------------ + + invar(5) = dreal( q1 * q1 * q1 ) ! r111 + invar(6) = dreal( q1 * q1 * q2 ) ! r112 + invar(7) = dreal( q1 * q2 * q2 ) ! r122 + invar(8) = dreal( q2 * q2 * q2 ) ! r222 + invar(9) = (dimag( q1 * q1 * q1 ))**2 ! rho111**2 + invar(10) = (dimag( q1 * q1 * q2 ))**2 ! rho112 **2 + invar(11) = (dimag( q1 * q2 * q2 ))**2 ! rho122**2 + invar(12) = (dimag( q2 * q2 * q2 ))**2 ! rho222 + + ! INVARIANTS OF KIND IV + !------------------------- + + invar(13) = (dimag( q1 * conjg(q2)) * dimag( q1 * q1 * q1 )) + invar(14) = (dimag( q1 * conjg(q2)) * dimag( q1 * q1 * q2 )) + invar(15) = (dimag( q1 * conjg(q2)) * dimag( q1 * q2 * q2 )) + invar(16) = (dimag( q1 * conjg(q2)) * dimag( q2 * q2 * q2 )) + + ! INVARIANTS OF KIND V + !---------------------- + + invar(17) = (dimag( q1 * q1 * q1 ) * dimag( q1 * q1 * q2 )) + invar(18) = (dimag( q1 * q1 * q1 ) * dimag( q1 * q2 * q2 )) + invar(19) = (dimag( q1 * q1 * q1 ) * dimag( q2 * q2 * q2 )) + invar(20) = (dimag( q1 * q1 * q2 ) * dimag( q1 * q2 * q2 )) + invar(21) = (dimag( q1 * q1 * q2 ) * dimag( q2 * q2 * q2 )) + invar(22) = (dimag( q1 * q2 * q2 ) * dimag( q2 * q2 * q2 )) + invar(23) = a + + ! the only non zero invariant for bend pure cuts + + inv(1) = invar( 1) + inv(2) = invar( 5) + inv(3) = invar( 9) + ! inv(4) = invar(1) + ! inv(5) = invar(5) + ! inv(6) = invar(9) + !inv(17)=invar(18) + !inv(19) = invar() + !inv(2) = invar(5) + !inv(3) = invar(9) + !inv(1:22)=invar(1:22) + !inv(4:8) = invar(5:9) + !inv(9)=invar(12) + + + if (debg) then + write(14,"(A,*(f10.5))")"Invar II", (invar(i),i=1,4) + write(14,"(A,*(f10.5))") "Invar III", (invar(i),i=5,12) + write(14,"(A,*(f10.5))")"Invar IV", (invar(i),i=13,16) + write(14,"(A,*(f10.5))")"Invar V", (invar(i),i=17,22) + + write(14,*)"THE INPUT COORDINATE IN COMPLEX REPRES" + write(14,*)"---------------------------------------" + write(14,*)"xs =",dreal(q1), "ys=",dimag(q1) + endif + ! modify the invariants to only consider few of them + ! + !invar(13:22)=0.0d0 + end subroutine invariants + + +! subroutine invariants_ch(a, xs, ys, xb, yb, invar) +! implicit none +! double precision, intent(in) :: a, xs, ys, xb, yb +! double precision, intent(out) :: invar(25) +! +! complex(8) :: q1, q2 +! double precision :: r11, r22, r12, eta +! double precision :: I1, I2, I3, I4 +! +! ! Define complex coordinates +! q1 = dcmplx(xs, ys) +! q2 = dcmplx(xb, yb) +! +! ! Quadratic invariants +! r11 = dreal(q1*conjg(q1)) +! r22 = dreal(q2*conjg(q2)) +! r12 = dreal(q1*conjg(q2)) +! eta = dimag(q1*conjg(q2)) +! +! ! Cubic imag parts (used many times) +! I1 = dimag(q1*q1*q1) +! I2 = dimag(q1*q1*q2) +! I3 = dimag(q1*q2*q2) +! I4 = dimag(q2*q2*q2) +! ! the totally symmetric invariant 25 +! invar(25) = a +! ! Store invariants +! invar(1) = r11 +! invar(2) = r12 +! invar(3) = r22 +! invar(4) = eta*eta +! +! invar(5) = dreal(q1*q1*q1) +! invar(6) = dreal(q1*q1*q2) +! invar(7) = dreal(q1*q2*q2) +! invar(8) = dreal(q2*q2*q2) +! +! invar(9) = I1*I1 +! invar(10) = I2*I2 +! invar(11) = I3*I3 +! invar(12) = I4*I4 +! +! invar(13) = eta * I1 +! invar(14) = eta * I2 +! invar(15) = eta * I3 +! invar(16) = eta * I4 +! +! ! Pure quartic invariants +! invar(17) = r11*r11 + r22*r22 +! invar(18) = r11*r22 - r12*r12 - eta*eta +! +! ! Cubic-imag bilinear invariants (minimal independent set) +! invar(19) = I1*I2 +! invar(20) = I1*I3 +! invar(21) = I1*I4 +! invar(22) = I2*I3 +! invar(23) = I2*I4 +! +! ! Odd cubic invariant +! invar(24) = eta**3 +! +! if (debg) then +! write(14,"(A,*(f10.5))")"Invar II", (invar(i),i=1,4) +! write(14,"(A,*(f10.5))") "Invar III", (invar(i),i=5,12) +! write(14,"(A,*(f10.5))")"Invar IV", (invar(i),i=13,16) +! write(14,"(A,*(f10.5))")"Invar V", (invar(i),i=17,22) +! +! write(14,*)"THE INPUT COORDINATE IN COMPLEX REPRES" +! write(14,*)"---------------------------------------" +! write(14,*)"xs =",dreal(q1), "ys=",dimag(q1) +! endif +! +! end subroutine + +end module invariants_mod diff --git a/src/model/newmodes.f b/src/model/newmodes.f new file mode 100644 index 0000000..1dfb0f7 --- /dev/null +++ b/src/model/newmodes.f @@ -0,0 +1,87 @@ +! Author: jnshuti +! Created: 2025-10-24 16:45:07 +! Last modified: 2025-10-24 16:45:27 jnshuti +! Modes: +! Mode 1 + mode( 1, 1) = 0.0000000000d0 + mode( 2, 1) = 0.0000000000d0 + mode( 3, 1) = 0.0000000000d0 + mode( 4, 1) = 0.5773502692d0 + mode( 5, 1) = 0.0000000000d0 + mode( 6, 1) = 0.0000000000d0 + mode( 7, 1) = -0.2886751346d0 + mode( 8, 1) = 0.5000000000d0 + mode( 9, 1) = 0.0000000000d0 + mode(10, 1) = -0.2886751346d0 + mode(11, 1) = -0.5000000000d0 + mode(12, 1) = 0.0000000000d0 + +! Mode 2 + mode( 1, 2) = 0.3121511560d0 + mode( 2, 2) = 0.0000000000d0 + mode( 3, 2) = 0.0000000000d0 + mode( 4, 2) = -0.7756982471d0 + mode( 5, 2) = 0.0000000000d0 + mode( 6, 2) = 0.0000000000d0 + mode( 7, 2) = -0.1939245618d0 + mode( 8, 2) = 0.3358871938d0 + mode( 9, 2) = 0.0000000000d0 + mode(10, 2) = -0.1939245618d0 + mode(11, 2) = -0.3358871938d0 + mode(12, 2) = 0.0000000000d0 + +! Mode 3 + mode( 1, 3) = 0.0000000000d0 + mode( 2, 3) = 0.3121511560d0 + mode( 3, 3) = 0.0000000000d0 + mode( 4, 3) = 0.0000000000d0 + mode( 5, 3) = 0.0000000000d0 + mode( 6, 3) = 0.0000000000d0 + mode( 7, 3) = 0.3358871938d0 + mode( 8, 3) = -0.5817736853d0 + mode( 9, 3) = 0.0000000000d0 + mode(10, 3) = -0.3358871938d0 + mode(11, 3) = -0.5817736853d0 + mode(12, 3) = 0.0000000000d0 + +! Mode 4 + mode( 1, 4) = 0.2830826954d0 + mode( 2, 4) = 0.0000000000d0 + mode( 3, 4) = 0.0000000000d0 + mode( 4, 4) = 0.0759441281d0 + mode( 5, 4) = 0.0000000000d0 + mode( 6, 4) = 0.0000000000d0 + mode( 7, 4) = -0.5655692225d0 + mode( 8, 4) = -0.3703779057d0 + mode( 9, 4) = 0.0000000000d0 + mode(10, 4) = -0.5655692225d0 + mode(11, 4) = 0.3703779057d0 + mode(12, 4) = 0.0000000000d0 + +! Mode 5 + mode( 1, 5) = 0.0000000000d0 + mode( 2, 5) = 0.2830826954d0 + mode( 3, 5) = 0.0000000000d0 + mode( 4, 5) = 0.0000000000d0 + mode( 5, 5) = -0.7794070061d0 + mode( 6, 5) = 0.0000000000d0 + mode( 7, 5) = -0.3703779057d0 + mode( 8, 5) = -0.1378936554d0 + mode( 9, 5) = 0.0000000000d0 + mode(10, 5) = 0.3703779057d0 + mode(11, 5) = -0.1378936554d0 + mode(12, 5) = 0.0000000000d0 + +! Mode 6 + mode( 1, 6) = 0.0000000000d0 + mode( 2, 6) = 0.0000000000d0 + mode( 3, 6) = 0.4213954872d0 + mode( 4, 6) = 0.0000000000d0 + mode( 5, 6) = 0.0000000000d0 + mode( 6, 6) = -0.5235856642d0 + mode( 7, 6) = 0.0000000000d0 + mode( 8, 6) = 0.0000000000d0 + mode( 9, 6) = -0.5235856642d0 + mode(10, 6) = 0.0000000000d0 + mode(11, 6) = 0.0000000000d0 + mode(12, 6) = -0.5235856642d0 diff --git a/src/model/nnadia_nh3.f b/src/model/nnadia_nh3.f new file mode 100644 index 0000000..d9cc935 --- /dev/null +++ b/src/model/nnadia_nh3.f @@ -0,0 +1,87 @@ + subroutine nninit_mod() + use nn_params + implicit none + + end subroutine + + + subroutine nnadia(coords,coeffs,adiaoutp) + USE pesmod, only: potential_nh3_low + Use diabmodel, only: diab_x + + use nn_params + use nncommons + implicit none + ! returns THE DIABATIC MATRIX UPPER MATRIX OF BOTH X AND Y COMPONENT OF DIPOLE +! +! coords: vector containing symmetry-adapted coordinates. +! coeffs: vector containing coeffs of diab dipole matrix + +! adiaoutp: upper diab matrix of dipole +! x component come first and then y component +! +! dmat_x & dmat_y: analytic model of dipole, x and y +! +! matdim: dimension of hamiltoniam matrix +! mkeigen: integer: no eigenvectors if =0 +! eigenvs: dummy storage for eigenvectors + + !include 'JTmod.incl' + DOUBLE PRECISION,intent(in):: coords(maxnin) + DOUBLE PRECISION,INTENT(INOUT)::coeffs(maxnout) + DOUBLE PRECISION,INTENT(OUT):: adiaoutp(maxpout) + DOUBLE PRECISION, DIMENSION(ndiab,ndiab):: v,U,ex,temp + double precision, dimension(ndiab):: e + Double precision, allocatable:: mat(:,:) + integer i, ij, j, max_row + + ! variable for lapack + integer,parameter :: lwork = 1000 + double precision work(lwork) + integer info + + call potential_nh3_low(V,coords,coeffs) + + ! diagonalize the pes + u=0.0d0 + allocate(mat,source=V) + call DSYEV('V','U',ndiab,mat,ndiab,e,work,lwork, info) + + if (info .ne. 0) then + write(6,*)"The diagonalizing routine failed", info + stop + end if + U(:,:)= mat(:,:) + deallocate(mat) + do i =1,ndiab + adiaoutp(i)=e(i) + enddo + + ! Fix the phase of U matrix + ! fix phas of U + do i =1,ndiab + max_row=maxloc(abs(U(:,i)),1) + if(U(max_row,i) .lt. 0) then + U(:,i) = -1.0d0*U(:,i) + endif + enddo + + call diab_x(ex,coords,coeffs) ! ex is the dipole x component + + ! transforrm the dipole + + temp = matmul(transpose(U),ex) + ex = matmul(temp,U) + ij = 4 + do i =1,ndiab + do j = i,ndiab + ij = ij+1 + adiaoutp(ij) = ex(i,j) + !adiaoutp(ij) = 0.0d0 + enddo + enddo + + END SUBROUTINE + + + diff --git a/src/model/nncoords_nh3.f90 b/src/model/nncoords_nh3.f90 new file mode 100644 index 0000000..f70883e --- /dev/null +++ b/src/model/nncoords_nh3.f90 @@ -0,0 +1,91 @@ + module trans_coord + implicit none + contains + + subroutine cart2mode(qq) + use invariants_mod, only: invariants + use nn_params + use nncommons + implicit none + double precision, intent(inout):: qq(maxnin) + double precision :: q(12),inv(3),qm(6) + double precision, parameter :: m_N=25526.04237518618d0 + double precision, parameter :: m_H=1837.152647439619d0 + double precision, parameter :: Ang2Bohr=1.889726124565d0 + + double precision diff(12), ref_geom(12) + double precision q_mod(12) +! transformation matrix + double precision mode(12,6) + integer i +! final internal coord vector + + + include 'newmodes.f' + + ref_geom(1:12)=0.d0 + ref_geom( 4 )=1.022871078d0 + ref_geom( 7 )=-.5d0*ref_geom(4) + !ref_geom( 8 )=sqrt(1.5d0)*ref_geom(4) + ref_geom( 8)=0.5d0*sqrt(3.0d0)*ref_geom(4) + ref_geom(10 )=-.5d0*ref_geom(4) + !ref_geom(11 )=-sqrt(1.5d0)*ref_geom(4) + ref_geom(11)=-0.5d0*sqrt(3.0d0)*ref_geom(4) + + !massN=25526.04237518618 + !massH=1837.152647439619 + ! + q(1:12)=qq(1:12) + q_mod = (1.0d0/Ang2Bohr)*q + +! difference vector + diff=q_mod-ref_geom + +! mass weighting + diff(1:3)=diff(1:3)*sqrt(m_N) + diff(4:12)=diff(4:12)*sqrt(m_H) + + qm=matmul(transpose(mode),diff) + do i =1,size(qm) + if (abs(qm(i)) .lt. 1.0d-6) qm(i)=0.0d0 + enddo + !qm(3) = -qm(3) + call invariants(qm(1),qm(2),qm(3),qm(4),qm(5),inv) + qq =0.0d0 + qq(1:len_in)=inv(1:len_in) + qq(len_in+1:len_in+6)=qm(1:6) + + + end subroutine cart2mode + end module trans_coord +!**** Define coordinate transformation applied to the input before fit. +!*** +!*** +!****Conventions: +!*** +!*** ctrans: subroutine transforming a single point in coordinate space + + subroutine trans_in(pat_in) + !use ctrans_mod, only: ctrans + use trans_coord, only: cart2mode + use nn_params + use nncommons + implicit none + + !include 'nndbg.incl' + + double precision pat_in(maxnin,maxpats) + !integer ntot + + integer j,i,jj + jj=1 + do j=1,sets + !write(62,*)"Scan ",j + do i =1,ndata(j) + call cart2mode(pat_in(:,jj)) + ! FIRST ELEMENT OF PAT-IN ARE USED BY NEURON NETWORK + !write(62,'(*(ES16.8))') pat_in(:,jj) + jj = jj +1 + enddo + enddo + end diff --git a/src/model/pes_model.f90 b/src/model/pes_model.f90 new file mode 100644 index 0000000..be53d68 --- /dev/null +++ b/src/model/pes_model.f90 @@ -0,0 +1,172 @@ +module pesmod + !use dim_parameter,only:qn,ndiab,pst + use iso_fortran_env, only: idp => int32, dp => real64 + use dip_param + + use nn_params + use nncommons, only: len_in + implicit none + + integer(idp),parameter:: ndiab=4 + private + public :: potential_nh3_low + contains + + + subroutine potential_nh3_low(e,q,nn_out) + implicit none + real(dp),intent(in)::q(maxnin) + real(dp),intent(out)::e(:,:) + real(dp),intent(inout):: nn_out(maxnout) + !logical,intent(in):: sym + !integer(idp),intent(in)::key + integer(idp) id,i, ii + real(dp) tmp,xs,xb,ys,yb,a,b,ss,sb + logical, parameter:: switch = .false. ! parameter to switch when you want to know Ex and Ey + logical, parameter:: sym = .false. ! to include r**2 in the Genetic fitting + real(dp),parameter:: tol = 1.0d-9 + real(dp),dimension(16):: scal, shift + !real(dp),dimension(17):: shi,scalee + !include "shift-scale-70N.incl" + !include "sh-scal-50.incl" + xs=q(len_in+2) + ys=q(len_in+3) + xb=q(len_in+4) + yb=q(len_in+5) + a=q(len_in+1) + b=q(len_in+6) + + ss= xs**2+ys**2 + sb= xb**2+yb**2 + call init_dip_planar_data() + shift =1.0d0 + scal = 1.0d-3 + !scal = 1.0d-3 + !scal(1:3) = 1.0d-3 + ii = 1 + do i =1 ,27 ! pes parameter key index + if( abs(p(i)) .gt. tol ) then + p(i) = p(i)*(shift(ii)+ scal(ii)*nn_out(ii)) + ii = ii + 1 + + endif + enddo + !write(6,*)" PES non zero", ii-1 + + + e = 0.0_dp + id = 1 ! 1 + ! v -term + ! oth order only + ! A2" + e(1,1) = e(1,1) + p(pst(1,id)) !- p(pst(1,1)) + if (sym) then + e(1,1)=e(1,1) + p(pst(1,id)+1)*ss +p(pst(1,id)+2)*sb + endif + id = id +1 !2 + ! E block + e(2,2) = e(2,2)+ p(pst(1,id))! - p(pst(1,1)) + e(3,3) = e(3,3)+ p(pst(1,id))! - p(pst(1,1)) + if (sym) then + e(2,2)=e(2,2)+p(pst(1,id)+1)*ss +p(pst(1,id)+2)*ss**2 + e(3,3)=e(3,3)+p(pst(1,id)+1)*ss +p(pst(1,id)+2)*ss**2 + endif + + id = id +1 ! 3 + + !A1' + e(4,4) = e(4,4) + p(pst(1,id))! - p(pst(1,1)) + if (sym) then + e(4,4)=e(4,4) + p(pst(1,id)+1)*ss +p(pst(1,id)+2)*ss**2 & + + p(pst(1,id)+3)*ss**3 + endif + + ! W and z of JT block + + ! first order + id = id +1 !4 + + e(2,2) = e(2,2) + p(pst(1,id))*xs + p(pst(1,id)+1)*xb + e(3,3) = e(3,3) - p(pst(1,id))*xs - p(pst(1,id)+1)*xb + e(2,3) = e(2,3) + p(pst(1,id))*ys + p(pst(1,id)+1)*yb + + ! order 2 + id = id +1 ! 5 + e(2,2) = e(2,2) + p(pst(1,id))*(xs**2-ys**2) & + + p(pst(1,id)+1)*(xb**2-yb**2) & + + p(pst(1,id)+2)*(xs*xb - ys*yb) + e(3,3) = e(3,3) - p(pst(1,id))*(xs**2-ys**2) & + - p(pst(1,id)+1)*(xb**2-yb**2) & + - p(pst(1,id)+2)*(xs*xb - ys*yb) + e(2,3) = e(2,3) - p(pst(1,id))*(2*xs*ys) & + - p(pst(1,id)+1)*(2*xb*yb) & + - p(pst(1,id)+2)*(xs*yb+xb*ys) + + ! the coupling of A2' and E' + ! order 1 + id = id +1 !6 + + e(1,2) = e(1,2) + b*(p(pst(1,id))*xs + p(pst(1,id)+1)*yb) + e(1,3) = e(1,3) - b*(p(pst(1,id))*ys + p(pst(1,id)+1)*yb) + ! order 2 + id =id +1 ! 7 + e(1,2) = e(1,2) +b*(p(pst(1,id))*(xs**2-ys**2) & + + p(pst(1,id)+1)*(xb**2-yb**2) & + + p(pst(1,id)+2)*(xs*xb -ys*yb)) + e(1,3) = e(1,3) +b*(p(pst(1,id))*(2*xs*ys) & + + p(pst(1,id)+1)*(2*xb*yb) & + + p(pst(1,id)+2)*(xs*yb + xb*ys)) + + ! the coupling of A1' and E' + id = id +1 ! 8 + e(2,4) = e(2,4) + p(pst(1,id))*xs + p(pst(1,id)+1)*xb + e(3,4) = e(3,4) - p(pst(1,id))*ys - p(pst(1,id)+1)*yb + if (sym) then + e(2,4) = e(2,4)+ p(pst(1,id)+2)*xs*ss + e(3,4) = e(3,4)- p(pst(1,id)+2)*ys*ss + endif + + ! order 2 + id = id +1 ! 9 + e(2,4) = e(2,4) + p(pst(1,id))*(xs**2-ys**2) & + + p(pst(1,id)+1)*(xb**2-yb**2) & + + p(pst(1,id)+2)*(xs*xb -ys*yb) + e(3,4) = e(3,4) + p(pst(1,id))*(2*xs*ys) & + + p(pst(1,id)+1)*(2*xb*yb) & + + p(pst(1,id)+2)*(xs*yb + xb*ys) + ! the couplign between A + id = id +1 ! 10 + e(1,4) = e(1,4) + b*p(pst(1,id)) + !write(*,*) 'Id = ',id + + call copy_2_lower_triangle(e) + if (switch) then + write( 6,*)" EX AND EY ARE SWITCHED" + tmp = e(2,2) + e(2,2) = e(3,3) + e(3,3) = tmp + + ! the coupling + + tmp = e(2,4) + e(2,4) = e(3,4) + e(3,4) = tmp + e(4,2) = e(2,4) + e(4,3) = e(3,4) + endif + end subroutine potential_nh3_low + + + subroutine copy_2_lower_triangle(mat) + real(dp), intent(inout) :: mat(:, :) + integer :: m, n + ! write lower triangle of matrix symmetrical + do n = 2, size(mat, 1) + do m = 1, n - 1 + mat(n, m) = mat(m, n) + end do + end do + end subroutine copy_2_lower_triangle + + +end module diff --git a/src/model/red_invariants.f90 b/src/model/red_invariants.f90 new file mode 100644 index 0000000..278051f --- /dev/null +++ b/src/model/red_invariants.f90 @@ -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 diff --git a/src/model/sh-scal-50.incl b/src/model/sh-scal-50.incl new file mode 100644 index 0000000..8001743 --- /dev/null +++ b/src/model/sh-scal-50.incl @@ -0,0 +1,9 @@ + +! shift and scale for 70N structrure +! Real(dp),parameter:: scal(17) = 1.0d0 ,shift(17) = 1.0d0 + Real(dp),parameter:: scal(17) = & + [0.00434,0.00239,0.00201,4.13538,9.04704,1.07732,0.79253, & + 1.86682,1.87266,0.58857,0.90899,2.07755,1.81564,1.31957,1.68503,1.48391,1.79901] + Real(dp),parameter:: shift(17) = & + [-0.00016,-0.00020, 0.00008,-0.04261,13.00281,-0.44002,-0.18611, & + 0.73999, 0.34618,-0.44183,-0.06997, 0.39988,-1.42376, 0.77752,-1.23819,-0.22926, 0.82597] diff --git a/src/model/shift-scale-70N.incl b/src/model/shift-scale-70N.incl new file mode 100644 index 0000000..31d948e --- /dev/null +++ b/src/model/shift-scale-70N.incl @@ -0,0 +1,11 @@ + +! shift and scale for 70N structrure +! Real(dp),parameter:: scal(17) = 1.0d0 ,shift(17) = 1.0d0 + Real(dp),parameter:: scal(17) = & + [0.00401, 0.00265, 0.00335, 1.19496, 3.79876, 0.32139, 0.46267, & + 1.36249, 0.90118, 0.94406, 0.29014, 0.72172, 1.25435, 2.09880, & + 0.93696, 1.69131, 0.75050 ] + Real(dp),parameter:: shift(17) = & + [-0.00018,-0.00018,-0.00002,-0.03463,-0.74584, 0.09806, 0.16350, & + -0.96733,-0.62850, 0.57182,-0.00110, 0.10584, 0.29949,-0.82418, & + 0.57450, 0.04471, 0.28142 ] diff --git a/src/model/without_symm_dip_pes.f90 b/src/model/without_symm_dip_pes.f90 new file mode 100644 index 0000000..4d36cf8 --- /dev/null +++ b/src/model/without_symm_dip_pes.f90 @@ -0,0 +1,913 @@ + Module dip_param + IMPLICIT NONE + Integer,parameter :: np=101 + Double precision :: p(101) + integer :: pst(2,400) + ! Non zero parameters are 20 + contains + + SUBROUTINE init_dip_planar_data() + implicit none + p( 1)= -0.561433980D+02 + p( 2)= 0.000000000D+00 + p( 3)= 0.000000000D+00 + p( 4)= -0.558830090D+02 + p( 5)= 0.000000000D+00 + p( 6)= 0.000000000D+00 + p( 7)= -0.557220030D+02 + p( 8)= 0.000000000D+00 + p( 9)= 0.000000000D+00 + p( 10)= 0.000000000D+00 + p( 11)= 0.346660755D-02 + p( 12)= 0.000000000D+00 + p( 13)= 0.745842871D-04 + p( 14)= 0.000000000D+00 + p( 15)= 0.000000000D+00 + p( 16)= 0.000000000D+00 + p( 17)= 0.000000000D+00 + p( 18)= 0.000000000D+00 + p( 19)= 0.000000000D+00 + p( 20)= 0.000000000D+00 + p( 21)= -0.532590808D-03 + p( 22)= 0.000000000D+00 + p( 23)= 0.000000000D+00 + p( 24)= 0.000000000D+00 + p( 25)= 0.000000000D+00 + p( 26)= 0.000000000D+00 + p( 27)= 0.000000000D+00 + p( 28)= -0.226326661D-01 + p( 29)= 0.000000000D+00 + p( 30)= -0.369184193D-01 + p( 31)= 0.000000000D+00 + p( 32)= 0.107573698D+00 + p( 33)= 0.000000000D+00 + p( 34)= 0.115472219D-03 + p( 35)= 0.000000000D+00 + p( 36)= 0.000000000D+00 + p( 37)= 0.188753347D-04 + p( 38)= 0.000000000D+00 + p( 39)= 0.000000000D+00 + p( 40)= -0.761215310D-02 + p( 41)= 0.000000000D+00 + p( 42)= 0.000000000D+00 + p( 43)= 0.000000000D+00 + p( 44)= 0.000000000D+00 + p( 45)= 0.000000000D+00 + p( 46)= 0.000000000D+00 + p( 47)= 0.000000000D+00 + p( 48)= 0.000000000D+00 + p( 49)= 0.217598103D+00 + p( 50)= -0.107350386D-01 + p( 51)= 0.000000000D+00 + p( 52)= 0.103908437D-03 + p( 53)= 0.000000000D+00 + p( 54)= 0.000000000D+00 + p( 55)= 0.000000000D+00 + p( 56)= 0.000000000D+00 + p( 57)= 0.000000000D+00 + p( 58)= 0.000000000D+00 + p( 59)= 0.000000000D+00 + p( 60)= 0.000000000D+00 + p( 61)= 0.000000000D+00 + p( 62)= 0.000000000D+00 + p( 63)= 0.000000000D+00 + p( 64)= 0.000000000D+00 + p( 65)= 0.000000000D+00 + p( 66)= 0.000000000D+00 + p( 67)= 0.000000000D+00 + p( 68)= 0.000000000D+00 + p( 69)= 0.000000000D+00 + p( 70)= 0.000000000D+00 + p( 71)= 0.000000000D+00 + p( 72)= 0.000000000D+00 + p( 73)= 0.000000000D+00 + p( 74)= 0.000000000D+00 + p( 75)= 0.000000000D+00 + p( 76)= 0.000000000D+00 + p( 77)= 0.000000000D+00 + p( 78)= 0.000000000D+00 + p( 79)= 0.000000000D+00 + p( 80)= 0.000000000D+00 + p( 81)= 0.000000000D+00 + p( 82)= 0.000000000D+00 + p( 83)= 0.000000000D+00 + p( 84)= 0.000000000D+00 + p( 85)= 0.000000000D+00 + p( 86)= 0.000000000D+00 + p( 87)= -0.567206500D-02 + p( 88)= 0.342983596D-02 + p( 89)= 0.000000000D+00 + p( 90)= 0.000000000D+00 + p( 91)= 0.000000000D+00 + p( 92)= 0.000000000D+00 + p( 93)= 0.000000000D+00 + p( 94)= 0.000000000D+00 + p( 95)= 0.000000000D+00 + p( 96)= 0.000000000D+00 + p( 97)= 0.000000000D+00 + p( 98)= 0.000000000D+00 + p( 99)= 0.000000000D+00 + p(100)= 0.000000000D+00 + p(101)= 0.000000000D+00 + pst(1, 1)= 1 + pst(2, 1)= 3 + pst(1, 2)= 4 + pst(2, 2)= 3 + pst(1, 3)= 7 + pst(2, 3)= 4 + pst(1, 4)= 11 + pst(2, 4)= 2 + pst(1, 5)= 13 + pst(2, 5)= 3 + pst(1, 6)= 16 + pst(2, 6)= 2 + pst(1, 7)= 18 + pst(2, 7)= 3 + pst(1, 8)= 21 + pst(2, 8)= 3 + pst(1, 9)= 24 + pst(2, 9)= 3 + pst(1, 10)= 27 + pst(2, 10)= 1 + pst(1, 11)= 28 + pst(2, 11)= 2 + pst(1, 12)= 30 + pst(2, 12)= 2 + pst(1, 13)= 32 + pst(2, 13)= 2 + pst(1, 14)= 34 + pst(2, 14)= 3 + pst(1, 15)= 37 + pst(2, 15)= 3 + pst(1, 16)= 40 + pst(2, 16)= 3 + pst(1, 17)= 43 + pst(2, 17)= 2 + pst(1, 18)= 45 + pst(2, 18)= 2 + pst(1, 19)= 47 + pst(2, 19)= 2 + pst(1, 20)= 49 + pst(2, 20)= 1 + pst(1, 21)= 50 + pst(2, 21)= 2 + pst(1, 22)= 52 + pst(2, 22)= 5 + pst(1, 23)= 57 + pst(2, 23)= 10 + pst(1, 24)= 67 + pst(2, 24)= 1 + pst(1, 25)= 68 + pst(2, 25)= 2 + pst(1, 26)= 70 + pst(2, 26)= 4 + pst(1, 27)= 74 + pst(2, 27)= 8 + pst(1, 28)= 82 + pst(2, 28)= 2 + pst(1, 29)= 84 + pst(2, 29)= 3 + pst(1, 30)= 87 + pst(2, 30)= 1 + pst(1, 31)= 88 + pst(2, 31)= 2 + pst(1, 32)= 90 + pst(2, 32)= 4 + pst(1, 33)= 94 + pst(2, 33)= 8 + pst(1, 34)= 0 + pst(2, 34)= 0 + pst(1, 35)= 0 + pst(2, 35)= 0 + pst(1, 36)= 0 + pst(2, 36)= 0 + pst(1, 37)= 0 + pst(2, 37)= 0 + pst(1, 38)= 0 + pst(2, 38)= 0 + pst(1, 39)= 0 + pst(2, 39)= 0 + pst(1, 40)= 0 + pst(2, 40)= 0 + pst(1, 41)= 0 + pst(2, 41)= 0 + pst(1, 42)= 0 + pst(2, 42)= 0 + pst(1, 43)= 0 + pst(2, 43)= 0 + pst(1, 44)= 0 + pst(2, 44)= 0 + pst(1, 45)= 0 + pst(2, 45)= 0 + pst(1, 46)= 0 + pst(2, 46)= 0 + pst(1, 47)= 0 + pst(2, 47)= 0 + pst(1, 48)= 0 + pst(2, 48)= 0 + pst(1, 49)= 0 + pst(2, 49)= 0 + pst(1, 50)= 0 + pst(2, 50)= 0 + pst(1, 51)= 0 + pst(2, 51)= 0 + pst(1, 52)= 0 + pst(2, 52)= 0 + pst(1, 53)= 0 + pst(2, 53)= 0 + pst(1, 54)= 0 + pst(2, 54)= 0 + pst(1, 55)= 0 + pst(2, 55)= 0 + pst(1, 56)= 0 + pst(2, 56)= 0 + pst(1, 57)= 0 + pst(2, 57)= 0 + pst(1, 58)= 0 + pst(2, 58)= 0 + pst(1, 59)= 0 + pst(2, 59)= 0 + pst(1, 60)= 0 + pst(2, 60)= 0 + pst(1, 61)= 0 + pst(2, 61)= 0 + pst(1, 62)= 0 + pst(2, 62)= 0 + pst(1, 63)= 0 + pst(2, 63)= 0 + pst(1, 64)= 0 + pst(2, 64)= 0 + pst(1, 65)= 0 + pst(2, 65)= 0 + pst(1, 66)= 0 + pst(2, 66)= 0 + pst(1, 67)= 0 + pst(2, 67)= 0 + pst(1, 68)= 0 + pst(2, 68)= 0 + pst(1, 69)= 0 + pst(2, 69)= 0 + pst(1, 70)= 0 + pst(2, 70)= 0 + pst(1, 71)= 0 + pst(2, 71)= 0 + pst(1, 72)= 0 + pst(2, 72)= 0 + pst(1, 73)= 0 + pst(2, 73)= 0 + pst(1, 74)= 0 + pst(2, 74)= 0 + pst(1, 75)= 0 + pst(2, 75)= 0 + pst(1, 76)= 0 + pst(2, 76)= 0 + pst(1, 77)= 0 + pst(2, 77)= 0 + pst(1, 78)= 0 + pst(2, 78)= 0 + pst(1, 79)= 0 + pst(2, 79)= 0 + pst(1, 80)= 0 + pst(2, 80)= 0 + pst(1, 81)= 0 + pst(2, 81)= 0 + pst(1, 82)= 0 + pst(2, 82)= 0 + pst(1, 83)= 0 + pst(2, 83)= 0 + pst(1, 84)= 0 + pst(2, 84)= 0 + pst(1, 85)= 0 + pst(2, 85)= 0 + pst(1, 86)= 0 + pst(2, 86)= 0 + pst(1, 87)= 0 + pst(2, 87)= 0 + pst(1, 88)= 0 + pst(2, 88)= 0 + pst(1, 89)= 0 + pst(2, 89)= 0 + pst(1, 90)= 0 + pst(2, 90)= 0 + pst(1, 91)= 0 + pst(2, 91)= 0 + pst(1, 92)= 0 + pst(2, 92)= 0 + pst(1, 93)= 0 + pst(2, 93)= 0 + pst(1, 94)= 0 + pst(2, 94)= 0 + pst(1, 95)= 0 + pst(2, 95)= 0 + pst(1, 96)= 0 + pst(2, 96)= 0 + pst(1, 97)= 0 + pst(2, 97)= 0 + pst(1, 98)= 0 + pst(2, 98)= 0 + pst(1, 99)= 0 + pst(2, 99)= 0 + pst(1,100)= 0 + pst(2,100)= 0 + pst(1,101)= 0 + pst(2,101)= 0 + pst(1,102)= 0 + pst(2,102)= 0 + pst(1,103)= 0 + pst(2,103)= 0 + pst(1,104)= 0 + pst(2,104)= 0 + pst(1,105)= 0 + pst(2,105)= 0 + pst(1,106)= 0 + pst(2,106)= 0 + pst(1,107)= 0 + pst(2,107)= 0 + pst(1,108)= 0 + pst(2,108)= 0 + pst(1,109)= 0 + pst(2,109)= 0 + pst(1,110)= 0 + pst(2,110)= 0 + pst(1,111)= 0 + pst(2,111)= 0 + pst(1,112)= 0 + pst(2,112)= 0 + pst(1,113)= 0 + pst(2,113)= 0 + pst(1,114)= 0 + pst(2,114)= 0 + pst(1,115)= 0 + pst(2,115)= 0 + pst(1,116)= 0 + pst(2,116)= 0 + pst(1,117)= 0 + pst(2,117)= 0 + pst(1,118)= 0 + pst(2,118)= 0 + pst(1,119)= 0 + pst(2,119)= 0 + pst(1,120)= 0 + pst(2,120)= 0 + pst(1,121)= 0 + pst(2,121)= 0 + pst(1,122)= 0 + pst(2,122)= 0 + pst(1,123)= 0 + pst(2,123)= 0 + pst(1,124)= 0 + pst(2,124)= 0 + pst(1,125)= 0 + pst(2,125)= 0 + pst(1,126)= 0 + pst(2,126)= 0 + pst(1,127)= 0 + pst(2,127)= 0 + pst(1,128)= 0 + pst(2,128)= 0 + pst(1,129)= 0 + pst(2,129)= 0 + pst(1,130)= 0 + pst(2,130)= 0 + pst(1,131)= 0 + pst(2,131)= 0 + pst(1,132)= 0 + pst(2,132)= 0 + pst(1,133)= 0 + pst(2,133)= 0 + pst(1,134)= 0 + pst(2,134)= 0 + pst(1,135)= 0 + pst(2,135)= 0 + pst(1,136)= 0 + pst(2,136)= 0 + pst(1,137)= 0 + pst(2,137)= 0 + pst(1,138)= 0 + pst(2,138)= 0 + pst(1,139)= 0 + pst(2,139)= 0 + pst(1,140)= 0 + pst(2,140)= 0 + pst(1,141)= 0 + pst(2,141)= 0 + pst(1,142)= 0 + pst(2,142)= 0 + pst(1,143)= 0 + pst(2,143)= 0 + pst(1,144)= 0 + pst(2,144)= 0 + pst(1,145)= 0 + pst(2,145)= 0 + pst(1,146)= 0 + pst(2,146)= 0 + pst(1,147)= 0 + pst(2,147)= 0 + pst(1,148)= 0 + pst(2,148)= 0 + pst(1,149)= 0 + pst(2,149)= 0 + pst(1,150)= 0 + pst(2,150)= 0 + pst(1,151)= 0 + pst(2,151)= 0 + pst(1,152)= 0 + pst(2,152)= 0 + pst(1,153)= 0 + pst(2,153)= 0 + pst(1,154)= 0 + pst(2,154)= 0 + pst(1,155)= 0 + pst(2,155)= 0 + pst(1,156)= 0 + pst(2,156)= 0 + pst(1,157)= 0 + pst(2,157)= 0 + pst(1,158)= 0 + pst(2,158)= 0 + pst(1,159)= 0 + pst(2,159)= 0 + pst(1,160)= 0 + pst(2,160)= 0 + pst(1,161)= 0 + pst(2,161)= 0 + pst(1,162)= 0 + pst(2,162)= 0 + pst(1,163)= 0 + pst(2,163)= 0 + pst(1,164)= 0 + pst(2,164)= 0 + pst(1,165)= 0 + pst(2,165)= 0 + pst(1,166)= 0 + pst(2,166)= 0 + pst(1,167)= 0 + pst(2,167)= 0 + pst(1,168)= 0 + pst(2,168)= 0 + pst(1,169)= 0 + pst(2,169)= 0 + pst(1,170)= 0 + pst(2,170)= 0 + pst(1,171)= 0 + pst(2,171)= 0 + pst(1,172)= 0 + pst(2,172)= 0 + pst(1,173)= 0 + pst(2,173)= 0 + pst(1,174)= 0 + pst(2,174)= 0 + pst(1,175)= 0 + pst(2,175)= 0 + pst(1,176)= 0 + pst(2,176)= 0 + pst(1,177)= 0 + pst(2,177)= 0 + pst(1,178)= 0 + pst(2,178)= 0 + pst(1,179)= 0 + pst(2,179)= 0 + pst(1,180)= 0 + pst(2,180)= 0 + pst(1,181)= 0 + pst(2,181)= 0 + pst(1,182)= 0 + pst(2,182)= 0 + pst(1,183)= 0 + pst(2,183)= 0 + pst(1,184)= 0 + pst(2,184)= 0 + pst(1,185)= 0 + pst(2,185)= 0 + pst(1,186)= 0 + pst(2,186)= 0 + pst(1,187)= 0 + pst(2,187)= 0 + pst(1,188)= 0 + pst(2,188)= 0 + pst(1,189)= 0 + pst(2,189)= 0 + pst(1,190)= 0 + pst(2,190)= 0 + pst(1,191)= 0 + pst(2,191)= 0 + pst(1,192)= 0 + pst(2,192)= 0 + pst(1,193)= 0 + pst(2,193)= 0 + pst(1,194)= 0 + pst(2,194)= 0 + pst(1,195)= 0 + pst(2,195)= 0 + pst(1,196)= 0 + pst(2,196)= 0 + pst(1,197)= 0 + pst(2,197)= 0 + pst(1,198)= 0 + pst(2,198)= 0 + pst(1,199)= 0 + pst(2,199)= 0 + pst(1,200)= 0 + pst(2,200)= 0 + pst(1,201)= 0 + pst(2,201)= 0 + pst(1,202)= 0 + pst(2,202)= 0 + pst(1,203)= 0 + pst(2,203)= 0 + pst(1,204)= 0 + pst(2,204)= 0 + pst(1,205)= 0 + pst(2,205)= 0 + pst(1,206)= 0 + pst(2,206)= 0 + pst(1,207)= 0 + pst(2,207)= 0 + pst(1,208)= 0 + pst(2,208)= 0 + pst(1,209)= 0 + pst(2,209)= 0 + pst(1,210)= 0 + pst(2,210)= 0 + pst(1,211)= 0 + pst(2,211)= 0 + pst(1,212)= 0 + pst(2,212)= 0 + pst(1,213)= 0 + pst(2,213)= 0 + pst(1,214)= 0 + pst(2,214)= 0 + pst(1,215)= 0 + pst(2,215)= 0 + pst(1,216)= 0 + pst(2,216)= 0 + pst(1,217)= 0 + pst(2,217)= 0 + pst(1,218)= 0 + pst(2,218)= 0 + pst(1,219)= 0 + pst(2,219)= 0 + pst(1,220)= 0 + pst(2,220)= 0 + pst(1,221)= 0 + pst(2,221)= 0 + pst(1,222)= 0 + pst(2,222)= 0 + pst(1,223)= 0 + pst(2,223)= 0 + pst(1,224)= 0 + pst(2,224)= 0 + pst(1,225)= 0 + pst(2,225)= 0 + pst(1,226)= 0 + pst(2,226)= 0 + pst(1,227)= 0 + pst(2,227)= 0 + pst(1,228)= 0 + pst(2,228)= 0 + pst(1,229)= 0 + pst(2,229)= 0 + pst(1,230)= 0 + pst(2,230)= 0 + pst(1,231)= 0 + pst(2,231)= 0 + pst(1,232)= 0 + pst(2,232)= 0 + pst(1,233)= 0 + pst(2,233)= 0 + pst(1,234)= 0 + pst(2,234)= 0 + pst(1,235)= 0 + pst(2,235)= 0 + pst(1,236)= 0 + pst(2,236)= 0 + pst(1,237)= 0 + pst(2,237)= 0 + pst(1,238)= 0 + pst(2,238)= 0 + pst(1,239)= 0 + pst(2,239)= 0 + pst(1,240)= 0 + pst(2,240)= 0 + pst(1,241)= 0 + pst(2,241)= 0 + pst(1,242)= 0 + pst(2,242)= 0 + pst(1,243)= 0 + pst(2,243)= 0 + pst(1,244)= 0 + pst(2,244)= 0 + pst(1,245)= 0 + pst(2,245)= 0 + pst(1,246)= 0 + pst(2,246)= 0 + pst(1,247)= 0 + pst(2,247)= 0 + pst(1,248)= 0 + pst(2,248)= 0 + pst(1,249)= 0 + pst(2,249)= 0 + pst(1,250)= 0 + pst(2,250)= 0 + pst(1,251)= 0 + pst(2,251)= 0 + pst(1,252)= 0 + pst(2,252)= 0 + pst(1,253)= 0 + pst(2,253)= 0 + pst(1,254)= 0 + pst(2,254)= 0 + pst(1,255)= 0 + pst(2,255)= 0 + pst(1,256)= 0 + pst(2,256)= 0 + pst(1,257)= 0 + pst(2,257)= 0 + pst(1,258)= 0 + pst(2,258)= 0 + pst(1,259)= 0 + pst(2,259)= 0 + pst(1,260)= 0 + pst(2,260)= 0 + pst(1,261)= 0 + pst(2,261)= 0 + pst(1,262)= 0 + pst(2,262)= 0 + pst(1,263)= 0 + pst(2,263)= 0 + pst(1,264)= 0 + pst(2,264)= 0 + pst(1,265)= 0 + pst(2,265)= 0 + pst(1,266)= 0 + pst(2,266)= 0 + pst(1,267)= 0 + pst(2,267)= 0 + pst(1,268)= 0 + pst(2,268)= 0 + pst(1,269)= 0 + pst(2,269)= 0 + pst(1,270)= 0 + pst(2,270)= 0 + pst(1,271)= 0 + pst(2,271)= 0 + pst(1,272)= 0 + pst(2,272)= 0 + pst(1,273)= 0 + pst(2,273)= 0 + pst(1,274)= 0 + pst(2,274)= 0 + pst(1,275)= 0 + pst(2,275)= 0 + pst(1,276)= 0 + pst(2,276)= 0 + pst(1,277)= 0 + pst(2,277)= 0 + pst(1,278)= 0 + pst(2,278)= 0 + pst(1,279)= 0 + pst(2,279)= 0 + pst(1,280)= 0 + pst(2,280)= 0 + pst(1,281)= 0 + pst(2,281)= 0 + pst(1,282)= 0 + pst(2,282)= 0 + pst(1,283)= 0 + pst(2,283)= 0 + pst(1,284)= 0 + pst(2,284)= 0 + pst(1,285)= 0 + pst(2,285)= 0 + pst(1,286)= 0 + pst(2,286)= 0 + pst(1,287)= 0 + pst(2,287)= 0 + pst(1,288)= 0 + pst(2,288)= 0 + pst(1,289)= 0 + pst(2,289)= 0 + pst(1,290)= 0 + pst(2,290)= 0 + pst(1,291)= 0 + pst(2,291)= 0 + pst(1,292)= 0 + pst(2,292)= 0 + pst(1,293)= 0 + pst(2,293)= 0 + pst(1,294)= 0 + pst(2,294)= 0 + pst(1,295)= 0 + pst(2,295)= 0 + pst(1,296)= 0 + pst(2,296)= 0 + pst(1,297)= 0 + pst(2,297)= 0 + pst(1,298)= 0 + pst(2,298)= 0 + pst(1,299)= 0 + pst(2,299)= 0 + pst(1,300)= 0 + pst(2,300)= 0 + pst(1,301)= 0 + pst(2,301)= 0 + pst(1,302)= 0 + pst(2,302)= 0 + pst(1,303)= 0 + pst(2,303)= 0 + pst(1,304)= 0 + pst(2,304)= 0 + pst(1,305)= 0 + pst(2,305)= 0 + pst(1,306)= 0 + pst(2,306)= 0 + pst(1,307)= 0 + pst(2,307)= 0 + pst(1,308)= 0 + pst(2,308)= 0 + pst(1,309)= 0 + pst(2,309)= 0 + pst(1,310)= 0 + pst(2,310)= 0 + pst(1,311)= 0 + pst(2,311)= 0 + pst(1,312)= 0 + pst(2,312)= 0 + pst(1,313)= 0 + pst(2,313)= 0 + pst(1,314)= 0 + pst(2,314)= 0 + pst(1,315)= 0 + pst(2,315)= 0 + pst(1,316)= 0 + pst(2,316)= 0 + pst(1,317)= 0 + pst(2,317)= 0 + pst(1,318)= 0 + pst(2,318)= 0 + pst(1,319)= 0 + pst(2,319)= 0 + pst(1,320)= 0 + pst(2,320)= 0 + pst(1,321)= 0 + pst(2,321)= 0 + pst(1,322)= 0 + pst(2,322)= 0 + pst(1,323)= 0 + pst(2,323)= 0 + pst(1,324)= 0 + pst(2,324)= 0 + pst(1,325)= 0 + pst(2,325)= 0 + pst(1,326)= 0 + pst(2,326)= 0 + pst(1,327)= 0 + pst(2,327)= 0 + pst(1,328)= 0 + pst(2,328)= 0 + pst(1,329)= 0 + pst(2,329)= 0 + pst(1,330)= 0 + pst(2,330)= 0 + pst(1,331)= 0 + pst(2,331)= 0 + pst(1,332)= 0 + pst(2,332)= 0 + pst(1,333)= 0 + pst(2,333)= 0 + pst(1,334)= 0 + pst(2,334)= 0 + pst(1,335)= 0 + pst(2,335)= 0 + pst(1,336)= 0 + pst(2,336)= 0 + pst(1,337)= 0 + pst(2,337)= 0 + pst(1,338)= 0 + pst(2,338)= 0 + pst(1,339)= 0 + pst(2,339)= 0 + pst(1,340)= 0 + pst(2,340)= 0 + pst(1,341)= 0 + pst(2,341)= 0 + pst(1,342)= 0 + pst(2,342)= 0 + pst(1,343)= 0 + pst(2,343)= 0 + pst(1,344)= 0 + pst(2,344)= 0 + pst(1,345)= 0 + pst(2,345)= 0 + pst(1,346)= 0 + pst(2,346)= 0 + pst(1,347)= 0 + pst(2,347)= 0 + pst(1,348)= 0 + pst(2,348)= 0 + pst(1,349)= 0 + pst(2,349)= 0 + pst(1,350)= 0 + pst(2,350)= 0 + pst(1,351)= 0 + pst(2,351)= 0 + pst(1,352)= 0 + pst(2,352)= 0 + pst(1,353)= 0 + pst(2,353)= 0 + pst(1,354)= 0 + pst(2,354)= 0 + pst(1,355)= 0 + pst(2,355)= 0 + pst(1,356)= 0 + pst(2,356)= 0 + pst(1,357)= 0 + pst(2,357)= 0 + pst(1,358)= 0 + pst(2,358)= 0 + pst(1,359)= 0 + pst(2,359)= 0 + pst(1,360)= 0 + pst(2,360)= 0 + pst(1,361)= 0 + pst(2,361)= 0 + pst(1,362)= 0 + pst(2,362)= 0 + pst(1,363)= 0 + pst(2,363)= 0 + pst(1,364)= 0 + pst(2,364)= 0 + pst(1,365)= 0 + pst(2,365)= 0 + pst(1,366)= 0 + pst(2,366)= 0 + pst(1,367)= 0 + pst(2,367)= 0 + pst(1,368)= 0 + pst(2,368)= 0 + pst(1,369)= 0 + pst(2,369)= 0 + pst(1,370)= 0 + pst(2,370)= 0 + pst(1,371)= 0 + pst(2,371)= 0 + pst(1,372)= 0 + pst(2,372)= 0 + pst(1,373)= 0 + pst(2,373)= 0 + pst(1,374)= 0 + pst(2,374)= 0 + pst(1,375)= 0 + pst(2,375)= 0 + pst(1,376)= 0 + pst(2,376)= 0 + pst(1,377)= 0 + pst(2,377)= 0 + pst(1,378)= 0 + pst(2,378)= 0 + pst(1,379)= 0 + pst(2,379)= 0 + pst(1,380)= 0 + pst(2,380)= 0 + pst(1,381)= 0 + pst(2,381)= 0 + pst(1,382)= 0 + pst(2,382)= 0 + pst(1,383)= 0 + pst(2,383)= 0 + pst(1,384)= 0 + pst(2,384)= 0 + pst(1,385)= 0 + pst(2,385)= 0 + pst(1,386)= 0 + pst(2,386)= 0 + pst(1,387)= 0 + pst(2,387)= 0 + pst(1,388)= 0 + pst(2,388)= 0 + pst(1,389)= 0 + pst(2,389)= 0 + pst(1,390)= 0 + pst(2,390)= 0 + pst(1,391)= 0 + pst(2,391)= 0 + pst(1,392)= 0 + pst(2,392)= 0 + pst(1,393)= 0 + pst(2,393)= 0 + pst(1,394)= 0 + pst(2,394)= 0 + pst(1,395)= 0 + pst(2,395)= 0 + pst(1,396)= 0 + pst(2,396)= 0 + pst(1,397)= 0 + pst(2,397)= 0 + pst(1,398)= 0 + pst(2,398)= 0 + pst(1,399)= 0 + pst(2,399)= 0 + pst(1,400)= 0 + pst(2,400)= 0 +End SUBROUTINE init_dip_planar_data +End Module dip_param diff --git a/src/model/write_error.f90 b/src/model/write_error.f90 new file mode 100644 index 0000000..d8f2ddd --- /dev/null +++ b/src/model/write_error.f90 @@ -0,0 +1,235 @@ +module print_error + use iso_fortran_env, only: idp => int32, dp => real64 + use nn_params + use nncommons + implicit none + + +contains + + !======================================================================= + ! Compute and print error summary (RMS) for PES energies and dipole moments + ! Separately for total, weighted, energies (1:4), dipoles (5:inp_out) + !======================================================================= + subroutine print_ErrorSummary(par, pat_in, pat_out,ref_in,ref_out, & + wterr, typop, laystr, weistr, nlay, & + npat, nref) + + real(dp), intent(in) :: pat_in(maxnin, maxpats) + real(dp), intent(in) :: pat_out(maxpout, maxpats) + real(dp), intent(in) :: par(wbcap, maxset) + real(dp), intent(in) :: wterr(maxpout, maxpats) + real(dp), intent(in) :: ref_in(maxnin,maxpats), ref_out(maxpout,maxpats) + integer(idp), intent(in) :: laystr(3, maxlay) + integer(idp), intent(in) :: typop(maxtypes, maxlay) + integer(idp), intent(in) :: weistr(2, maxlay, 2) + integer(idp), intent(in) :: nlay, npat, nref + + ! Local variables + integer(idp) :: pt, k,i + + integer(idp) :: ntot + integer(idp),dimension(maxpout) :: cnt_tot,cnt_fit,cnt_val + real(dp), dimension(maxpout) :: total_rms_fit, total_rms_val,wrms_fit,wrms_val + real(dp) :: nnoutp(maxnout) + real(dp) :: ymod(maxpout, maxpats) + real(dp) :: wsum_fit + real(dp) :: rms_total, rms_weight + real(dp) :: en_rms, dip_rms + Real(dp) :: rms_total_fit, rms_w_fit + Real(dp) :: rms_total_val, rms_w_val + Real(dp) :: en_rms_fit,en_rms_val,dip_rms_fit,dip_rms_val + integer(idp), parameter :: std_out = 6 + + ! Total number of points (fitting + validation/reference) + + + ntot = npat + nref + + ! keep in mind that npat is the total number of point fit + ref + + !write(6,*)"Npat in the error summary", npat,nref + write(11,'(*(ES16.7))')par(:,1) + + ! Initialize accumulators + cnt_fit = 0 + cnt_tot = 0 + cnt_val = 0 + wsum_fit =0.0_dp + total_rms_fit(:) = 0.0_dp + wrms_fit(:) = 0.0_dp + total_rms_val (:) = 0.0_dp + wrms_val(:) = 0.0_dp + !write(11,'(*(ES18.6))')ref_in(1:3,:) + + ! Generate model predictions and accumulate squared errors + pt = 0 + + do pt =1, npat + if (pt > maxpats) then + write(std_out, *) "ERROR: pt exceeds maxpats!" + stop + end if + + ! Get network output + call neunet(pat_in(:, pt), nnoutp, par,typop, laystr, weistr, nlay) + + ! Transform to adiabatic representation (energies + dipoles) + call nnadia(pat_in(:, pt), nnoutp, ymod(:, pt)) + + ! Accumulate errors only for components with positive weight + do k = 1, inp_out + if (wterr(k, pt) > 0.0_dp) then + !cnt_tot(k) = cnt_tot(k) + 1 + ! Fitting / training set + cnt_fit(k) = cnt_fit(k) + 1 + total_rms_fit(k) = total_rms_fit(k) + (ymod(k,pt) - pat_out(k,pt))**2 + wrms_fit(k) = wrms_fit(k) + ((ymod(k,pt) - pat_out(k,pt))**2 & + * (wterr(k,pt))) + wsum_fit = wsum_fit + wterr(k,pt) + + + end if + end do + end do + ! validation set + do i =1, nref + !if (pt > maxpats) stop "Error pt exceeds maxpats" + pt = npat + i + call neunet(ref_in(:,i),nnoutp,par,typop,laystr,weistr,nlay) + + ! call the model + call nnadia(ref_in(:,i),nnoutp,ymod(:,pt)) + + ! calculate the errors + do k=1,inp_out + if (wterr(k,pt) > 0.0_dp) then + cnt_val (k) = cnt_val(k) + 1 + total_rms_val(k) = total_rms_val(k) + (ymod(k,pt) - ref_out(k,i))**2 + wrms_val(k) = wrms_val(k) + ((ymod(k,pt) - ref_out(k,i))**2 * & + (wterr(k,pt))) + !write(6,*)" IN here wter" + endif + enddo + !write(11,'(*(ES18.6))')wterr(:,pt) + + enddo + + + + ! Safety check: did we process the expected number of points? + + + ! Compute RMS values + ! TOTAL FIT +REF + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + rms_total = 0.0_dp + if ((sum(cnt_fit(1:inp_out)) + sum(cnt_val(1:inp_out))) > 0) then + rms_total = dsqrt( sum(total_rms_fit + total_rms_val) / & + real((sum(cnt_fit(1:inp_out))+sum(cnt_val(1:inp_out))), dp) ) + end if + + rms_weight = 0.0_dp + if (sum(wterr(1:inp_out, 1:npat+nref)) > 1.0e-12_dp) then ! avoid div-by-zero + rms_weight = dsqrt( sum(wrms_fit) + sum(wrms_val)) / sum(wterr(1:inp_out, 1:npat+nref)) + + !rms_weight = dsqrt(wt_rms /weighted_wt ) + end if + + en_rms = 0.0_dp + if ((sum(cnt_fit(1:4)) + sum(cnt_val(1:4))) > 0) then + + en_rms = sqrt( ( sum(total_rms_fit(1:4)) + sum(total_rms_val(1:4)) ) / & + real(sum(cnt_fit(1:4)) + sum(cnt_val(1:4)), dp) ) + + end if + + dip_rms = 0.0_dp + if ((sum(cnt_fit(5:inp_out)) + sum(cnt_val(5:inp_out)))> 0) then + dip_rms = sqrt( (sum(total_rms_fit(5:inp_out)) + sum(total_rms_val(5:inp_out))) / & + real((sum(cnt_fit(5:inp_out))+sum(cnt_val(5:inp_out))), dp) ) + end if + + rms_total_fit = 0.0_dp + if (sum(cnt_fit(1:inp_out)) > 0) then + rms_total_fit = dsqrt( sum(total_rms_fit(1:inp_out)) / real(sum(cnt_fit(1:inp_out)), dp) ) + endif + + rms_w_fit = 0.0_dp + if (wsum_fit > 1.0e-12_dp) then + rms_w_fit = sqrt( sum(wrms_fit(1:inp_out)) / wsum_fit ) + endif + + ! validation + rms_total_val = 0.0_dp + if (sum(cnt_val(1:inp_out)) > 0) then + rms_total_val = sqrt( sum(total_rms_val(1:inp_out)) / real(sum(cnt_val(1:inp_out)), dp) ) + endif + + rms_w_val = 0.0_dp + if (sum(wterr(1:inp_out,npat+1:npat+nref)) > 1.0e-12_dp) then + rms_w_val = sqrt( sum(wrms_val(1:inp_out)) / sum(wterr(1:inp_out,npat+1:npat+nref)) ) + endif + + ! compute each quantity error + en_rms_fit = merge( sqrt(sum(total_rms_fit(1:4))/real(sum(cnt_fit(1:4)),dp)),& + 0.0_dp, sum(cnt_fit(1:4))>0 ) + en_rms_val = merge( sqrt(sum(total_rms_val(1:4))/real(sum(cnt_val(1:4)),dp)), & + 0.0_dp, sum(cnt_val(1:4))>0 ) + + dip_rms_fit = merge( sqrt(sum(total_rms_fit(5:inp_out))/real(sum(cnt_fit(5:inp_out)),dp)), & + 0.0_dp, sum(cnt_fit(5:inp_out))>0 ) + dip_rms_val = merge( sqrt(sum(total_rms_val(5:inp_out))/real(sum(cnt_val(5:inp_out)),dp)), & + 0.0_dp, sum(cnt_val(5:inp_out))>0 ) + + ! Output + write(std_out, '(A)') " " + write(std_out, '(A)') "USER DEFINED ERROR METRIC" + write(std_out, '(A)') "######################################" + !write(std_out, '(A,ES18.8,A)') & + ! "Total RMS (all fitted components, unweighted) : ", rms_total * unit_con, & + ! " [ha]" + !write(std_out, '(A,ES18.8,A)') & + ! "Total Weighted RMS (fit + Ref) : ", rms_weight * unit_con + !write(std_out, '(A,ES18.8,A)') & + ! "Energy RMS : ", en_rms * unit_con, " [ha] " + !write(std_out, '(A,ES18.8,A)') & + ! "Dipole RMS : ", dip_rms * unit_con, " [ha] " + + ! compute the metric for fit data + + write(std_out, '(A)') "FITTING / TRAINING SET" + write(std_out, '(A)') "#############################" + write(std_out,'(A,ES14.6,A)') " Total RMS (unweighted) = ", rms_total_fit * unit_con + write(std_out,'(A,ES14.6,A)') " Weighted RMS = ", rms_w_fit * unit_con + write(std_out,'(A,ES14.6,A)') " Energy RMS = ", en_rms_fit * unit_con + write(std_out,'(A,ES14.6,A)') " Dipole RMS = ", dip_rms_fit * unit_con + write(std_out, '(A)') " " + + write(std_out, '(A)') "VALIDATION / REFERENCE SET" + write(std_out, '(A)') "##################################" + write(std_out,'(A,ES14.6,A)') " Total RMS (unweighted) = ", rms_total_val * unit_con + write(std_out,'(A,ES14.6,A)') " Weighted RMS = ", rms_w_val * unit_con + write(std_out,'(A,ES14.6,A)') " Energy RMS = ", en_rms_val * unit_con + write(std_out,'(A,ES14.6,A)') " Dipole RMS = ", dip_rms_val * unit_con + write(std_out, '(A)') " " + + write(std_out, '(A)') "COMBINED (FIT + VALIDATION)" + write(std_out, '(A)') "------------------------------" + write(std_out,'(A,ES14.6,A)') " Total RMS (unweighted) = ", rms_total * unit_con + write(std_out,'(A,ES14.6,A)') " Weighted RMS = ", rms_weight * unit_con + write(std_out,'(A,ES14.6,A)') " Energy RMS = ", en_rms * unit_con + write(std_out,'(A,ES14.6,A)') " Dipole RMS = ", dip_rms * unit_con + write(std_out,'(A)')" END OF ERROR SUMMARY" + !write(std_out, '(A)') repeat("-", 70) + ! Optional: add more detailed per-component output if desired + ! do k = 1, inp_out + ! if (cnt(k) > 0) then + ! write(std_out,'(A,I0,A,ES12.5)') "Output ",k," RMS = ", & + ! sqrt(total_rms(k)/real(cnt(k),dp)) * unit_con + ! end if + ! end do + + end subroutine print_ErrorSummary + +end module print_error \ No newline at end of file diff --git a/src/neuron_types.f b/src/neuron_types.f new file mode 100644 index 0000000..c316041 --- /dev/null +++ b/src/neuron_types.f @@ -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 +* +* +* include 'nnparams.incl' +* +* double precision L(*) +* integer ntype +* +* integer i +* +* do i=1,ntype +* L(i)= f(L(i)) +* enddo +* +* end +*************************************************************************** + + + subroutine neuron1(L,ntype) + use nn_params + implicit none +! logistic sigmoid curve +! f = N*tanh(a*x) +! where a=atanh(1/sqrt(3)) and N=sqrt(3) +! This way, f(1)=1 and f'' maximal at 1. + + + double precision L(*) + integer ntype + + double precision alpha, norm + + parameter (norm=dsqrt(3.0d0)) + parameter (alpha=(dlog(norm+1.0d0)-dlog(norm-1.0d0))/2.0d0) + + integer i + + do i=1,ntype + L(i)=norm*dtanh(alpha*L(i)) + enddo + + end + + subroutine deriv1(L,deriv,ntype) + use nn_params + implicit none +! logistic sigmoid curve +! f'(x)=N*(1-tanh^2(a*x))*(a) +! where a=atanh(1/sqrt(3)) and N=sqrt(3) +! This way, f(1)=1 and f'' maximal at 1. + + + double precision L(*),deriv(*) + integer ntype + + double precision alpha, norm + parameter (norm=dsqrt(3.0d0)) + parameter (alpha=(dlog(norm+1.0d0)-dlog(norm-1.0d0))/2.0d0) + + integer i + + do i=1,ntype + deriv(i)=alpha*norm*(1.0D0 - dtanh(alpha*L(i))**2) + enddo + + end + +********************** + + subroutine neuron2(L,ntype) + use nn_params + implicit none +! linear activation function + + + double precision L(*) + integer ntype + + integer i + + do i=1,ntype + L(i)=L(i) + enddo + + end + + subroutine deriv2(deriv,ntype) + use nn_params + implicit none +! linear activation function + + + integer ntype + double precision deriv(*) + + integer i + + do i=1,ntype + deriv(i)=1.0D0 + enddo + + end + +********************** diff --git a/src/nn_common_param.f90 b/src/nn_common_param.f90 new file mode 100644 index 0000000..7ba8dc6 --- /dev/null +++ b/src/nn_common_param.f90 @@ -0,0 +1,119 @@ +module nncommons + use accuracy_constants + use nn_params, only: maxnin, maxpats + use io_parameters, only: maxoutp, maxdat, klen, maxkeys, maxerrors + implicit none + private :: dp, idp, maxnin, maxpats + private :: maxoutp, maxdat, klen, maxkeys, maxerrors + + ! General parameter and parser state formerly declared in common.incl. + integer(idp) :: npar, pst(2,100) + integer(idp) :: keynum, datpos(3,maxdat) + character(len=klen) :: keylist(2,maxkeys) + character(len=64) :: errcat(maxerrors) + + !**** Basic data structures and special constants for ANN + !*** + !*** + !*** /nngene/: fundamental constants for gene manipulation + !*** + !*** /nnprop/: basic fitting info (iternation numbers etc.) + !*** + !*** /nnio/: constants for translating input variables/function values + !*** into NN input/output + !*** + !*** /nnopt/: information for convergence acceleration + !*** + !*** /nnunits/: unit transformations for output + !*** + !*** /nnplot/: information relevant to plotting + !*** + !*** /nnpartial/: information to organize partial runs (e.g. restarts) + !*** + !*** maxbpit: max. number of iterations for ML-learning + !*** maxfails: maximum number of failed microiterations + !*** maxref_fails: maximum number of times the reference pattern + !*** set fails to improve + !*** lambda_initial: initial value for Marquardt-Levenberg parameter + !*** mqfact_default: factor by which lambda is changed during MQL-fit + !*** + !*** inp_in: number of coordinates in input (not implemented) + !*** inp_out: number of values in output + !*** len_in: number of input neurons + !*** len_out: number of output neurons + !*** + !*** unit_string: name of output unit + !*** unit_con: conversion factor from internal to output unit + !*** + !*** continued/partial run parameters + !*** + !*** from_fit: MQL-fit to start from + !*** to_fit: MQL-fit to end at (instead of nset) + !*** use_record: whether to interact with records at all. + !*** record_state: Whether to read/write from the record (see RECORD: key) + !*** + !*** plotting parameters + !*** + !*** sets: number of data sets for plotting + !*** ndata: contains the number of data points for each block for plot + !*** + !*** genetic parameters + !*** + !*** wspread: spread of new, random weights around 0 + !*** bspread: spread of new, random biases around 0 + !*** ipmut: chance of point mutation per gene on ichrom + !*** dpmut: chance of point mutation per gene on dchrom + !*** ipins: chance of a gene insertion/deletion on ichrom + !*** dpins: chance of a gene insertion/deletion on dchrom + !*** + !*** convergence Acceleration parameters + !*** wb_arad: trust radius (maximum allowed total stepsize) + !*** wei_alim: threshold for switching stepsize limit for weights + !*** bi_alim: threshold for switching stepsize limit for biases + !*** wei_amax: absolute maximum step size for |weights| <= wei_alim + !*** bi_amax: absolute maximum step size for |biases| <= bi_alim + !*** wei_ascale: relative maximum step size for |weights| > wei_alim + !*** bi_ascale: relative maximum step size for |biases| > bi_alim + !*** + !*** shift_in: mean of the fitting input set + !*** fact_in: standard deviation of the input set + !*** norm_inp: if true, normalize input + !*** pres_inp: if true, preserve shift_in and fact_in from input, + !*** otherwise normalize destructively + !*** nbr_fit_set: number of fiting set + + Real(dp):: wei_alim,bi_alim,wei_amax,bi_amax + Real(dp):: wei_ascale,bi_ascale,wb_arad + Real(dp):: shift_in(maxnin),fact_in(maxnin) + Real(dp):: wspread,bspread + Real(dp):: ipmut, dpmut,ipins,dpins + Real(dp):: unit_con + Real(dp):: lambda_initial, mqfact_default + integer(idp):: len_in,len_out,inp_out,inp_in + integer(idp):: maxbpit,maxfails,maxref_fails + integer(idp):: from_fit, to_fit + integer(idp):: npoints(maxpats), ndata(maxpats) + integer(idp):: sets + integer(idp):: record_state + integer(idp):: ndiab + logical:: limstep,pres_inp,norm_inp + logical:: use_record + character(len=4):: unit_string + integer(idp):: nbr_fit_set + + !****************************************************************************** + !**** Misc. fit modifiers + !*** + !*** zero_par: set all fitting parameters to zero + !*** legacy_wt: WT:-cards are expected for each output component + !*** individually + !*** walk_scan: if true, map scans to the unit interval [0,1] + !*** otherwise, dump full coordinate vector instead. + + logical :: zero_par, legacy_wt + logical :: walk_scan + real(dp) :: cutoff(maxoutp), cutwei(maxoutp) + logical :: showcut + + +end module diff --git a/src/nn_params.f90 b/src/nn_params.f90 new file mode 100644 index 0000000..6cce35f --- /dev/null +++ b/src/nn_params.f90 @@ -0,0 +1,163 @@ +module nn_params + use accuracy_constants + implicit none + private :: dp, idp + ! module to hold the parameters + ! to replace nnparams.incl + ! define all the parameter + !********************************************************** + !**** Parameters + !*** maxneu: max. number of neurons per hidden layer + !*** maxnin: max. number of neurons in input layer + !*** maxnout: max. number of neurons in output layer + !*** maxset: max. number of neural networks to fit + !*** maxpout: max. number of values in output pattern + !*** maxlay: max. number of layers (always >2) + !*** maxtypes: max. number of neuron types + !*** maxtpar: max. number of parameters for each neuron type + !*** maxpats: max. number of learning patterns + !*** maxxrmeta: max. number of metadata-blocks in xranges + + + !********************************************************** + !**** Inferred Parameters + !*** maxwei: max. total number of weight matrix elements + !*** neucap: max. total number of neurons + !*** wbcap: max. total number of weights and biases + !*** xrcap: max. total number of used dimensions in xranges + + !*** WARNING: maxwei may fail for 2-layered networks + !*** if maxnin*maxnout is sufficiently large! + + !********************************************************** + !**** Numerical Parameters + !*** infty: largest possible double precision real value. + !*** iinfty: largest possible integer value. + !*** zero: sets what is considered an irrelevant difference + !*** in size. use for comarison of reals, to determine + !*** 'dangerously small' values, etc + !*** scan_res: maximum precision for geometric boundary algorithm + + integer(idp),parameter:: maxneu=150,maxlay=3,maxtypes=2,maxtpar=1 + integer(idp),parameter:: maxpats=10000 + integer(idp),parameter:: maxnin=15,maxnout=25,maxpout=15 + integer(idp),parameter:: maxwei=(maxlay-3)*maxneu**2+maxneu*(maxnin+maxnout) + integer(idp),parameter:: neucap=(maxlay-2)*maxneu+maxnin+maxnout + integer(idp),parameter:: wbcap=maxwei+neucap + integer(idp),parameter:: maxset=1000, maxnnkeys=4*maxlay + integer(idp),parameter:: maxxrmeta=3,xrcap=2+maxxrmeta + + ! NUMERICAL PARAMETER + real(dp),parameter:: pi = acos(-1.0_dp) + real(dp),parameter:: infty=huge(1.0_dp) + integer(idp),parameter:: iinfty=huge(1) + real(dp),parameter:: zero =1.0d-8, scan_res=1.0d-8 + + ! unit conversion parameter + real(dp),parameter:: hart2eV=27.211385d0 + real(dp),parameter:: eV2hart=1.0d0/hart2eV + real(dp),parameter:: hart2icm=219474.69d0 + real(dp),parameter:: icm2hart=1.0_dp/hart2icm + real(dp),parameter:: eV2icm=hart2icm/hart2eV + real(dp),parameter:: icm2eV=1.0_dp/eV2icm + real(dp),parameter:: deg2rad=pi/180.0_dp, rad2deg=1.0_dp/deg2rad + + !********************************************************** + !**** I/O Parameters + !*** iout: standard output for vranf error messages + !*** nnunit: temporary UNIT for misc. output files + !*** nnuit + [0..99] are reserved for futher + !*** unspecific misc. files. + !*** perfunit: UNIT for performance logfile + !*** fitunit: UNIT added to random positive integer + !*** identifying a single core fit UNIQUELY + !*** + !*** lrfmt: format for long real output + !*** lifmt: format for long integer output + !*** + !*** nndatfile: filename for DATA-files + !*** (without file extension) + !*** nnreffile: filename for reference DATA-blocks + !*** (without file extension) + !*** nnparfile: filename for best fitted parameters to be + !*** written on (without file extension) + !*** nnp10file: filename for the 10th percentile parameters to + !*** be written on (without file extension) + !*** nnexpfile: filename for modified neural network parameters + !*** (without file extension) + !*** sampfile: filename for displaying sampled points in + !*** configuration space + !*** nndmpfile: filename for dumping data point pairs + !*** nnrecfile: filename for writing parameter records. + !*** perfile: filename for logged fitting performances. + !*** nntag: infix for various filenames to mark their origin + !*** program should end with a trailing '_' if nonempty. + !*** prim_tag: tag added to the '***' line of primitive par-files + !*** nnfdir: directory for dumping fit files + !*** nnsdir: directory for dumping scans. + !*** nnldir: directory for dumping logfiles for each fit + character(len=32),parameter:: nndatfile='DATA_ANN' + character(len=32),parameter:: nnreffile='REF_ANN' + character(len=32),parameter:: nnparfile='../nnfits/fit_pars' + character(len=32),parameter:: nnp10file='../nnfits/fit_10p' + character(len=32),parameter:: nnexpfile='../nnfits/exp_pars' + character(len=32),parameter:: nndmpfile='../nnfits/fit_dump.dat' + character(len=32),parameter:: sampfile='../scans/samples.dat' + character(len=32),parameter:: perfile='../logs/performance.log' + character(len=32),parameter:: nnrecfile='../nnfits/record' + character(len=16),parameter:: nnfdir='../nnfits/',nnsdir='../scans/' + character(len=8), parameter:: nnldir='../logs/' + character(len=8), parameter::nntag='' + character(len=16),parameter:: prim_tag=' Time-stamp: " "' + character(len=16),parameter:: lrfmt='(ES20.12)',lifmt='(I12)' + integer(idp),parameter :: iout=6,perfunit=700,nnunit=800,fitunit=8000 + + + !********************************************************** + !**** Debugging Parameters + !*** sline: separation line + !*** asline: alternative sep. line + !*** hline: simple horizontal line + !*** newline: a single blank line + !*** mform: standard form for matrix output + !*** miform: standard form for integer matrix output + !*** smform: shortened form for matrix output + !*** stdfmt: standard format for strings + + character(len=16),parameter:: sline='(75("*"))',asline='(75("#"))' + character(len=16),parameter:: hline='(75("-"))' + character(len=2) ,parameter:: newline='()' + character(len=16),parameter:: mform='(5ES12.4)',smform='(5ES10.2)' + character(len=16),parameter:: miform='(5I12)' + character(len=8) ,parameter:: stdfmt='(A)' + + !********************************************************** + !**** Continuation Parameters + !*** record_*: Various possible values for the common block variable + !*** record_state. See the parser for more. + + integer(idp),parameter :: record_read=0,record_write=1,record_overwrite=-1 + integer(idp),parameter :: record_update=-2 + + !********************************************************** + !**** Error Codes + !*** Codes should be powers of 2. Binary representation of return value + !*** should correspond to all exceptions invoked. ec_error should never + !*** be invoked with any other. + !*** + !*** ec_error: generic error (catch-all, avoid!) + !*** ec_read: parsing error during les() + !*** ec_dim: dimensioning error + !*** ec_log: logic error + !*** + !**** Inferred error codes + !*** ec_dimrd: ec_dim+ec_read + + + integer(idp),parameter:: ec_error=1,ec_read=2,ec_dim=4,ec_log=8 + integer(idp),parameter:: ec_dimrd=ec_dim+ec_read + + + + +END module nn_params diff --git a/src/nndbg.f90 b/src/nndbg.f90 new file mode 100644 index 0000000..92ee1d4 --- /dev/null +++ b/src/nndbg.f90 @@ -0,0 +1,30 @@ +module nndbg_mod + implicit none + !**** Parameters + !*** dbg: enables debugging features. + !*** vbs: enables verbose mode + !*** rats: enables mass calculation mode + !*** conlog: enables convergence logs + !*** + + !logical,parameter:: (dbg=.false.,vbs=.false.,rats=.false.) + !logical,parameter:: (dbg=.false.,vbs=.false.,rats=.true.) + !logical,parameter:: (dbg=.false.,vbs=.true.,rats=.false.) + !logical,parameter:: (dbg=.true.,vbs=.false.,rats=.false.) + !logical,parameter:: (dbg=.true.,vbs=.true.,rats=.false.) + !logical,parameter:: (dbg=.true.,vbs=.false.,rats=.true.) + logical,parameter:: dbg=.false.,vbs=.true.,rats=.true. + logical,parameter:: conlog=.true. + ! logical,parame nlog=.fals + + !**** Inferred Parameters + !*** ldbg: "long dbg": enables massive information + !*** dumps if rats is not present. Best for + !*** small data sets. + + logical,parameter:: ldbg=(dbg.and.(.not.rats)) + + + + +END MODULE \ No newline at end of file diff --git a/src/nnmqo.f b/src/nnmqo.f new file mode 100644 index 0000000..44d2dfc --- /dev/null +++ b/src/nnmqo.f @@ -0,0 +1,982 @@ +!-------------------------------------------------------------------------------------- + + subroutine nnmarq(rms,ref_rms,mqpar,mqfact,W,B,act,wterr, + > pat_in,pat_out,ref_in,ref_out, + > typop,laystr,weistr,nlay, + > rmsopt,npat,nref,mingrad,minwbstep,fit_id,skip) + use nn_params + use nncommons + use nndbg_mod + implicit none +! Optimizes weights and biases using least squares errors +! and Marquard Levenberg +! +! fit_id: unique identifying integer for a given fit +! log_unit: unique file unit for given fit +! +! nlay: number of given layers +! npat: number of given pattern pairs +! nref: number of reference patterns +! rms: (weighted) root mean square error +! ref_rms: rms of reference data +! gradnorm: norm of error gradient +! wbnorm: norm of steps +! last: rms of prev. iteration +! rmsopt: error threshold +! mingrad: error gradient threshold +! minwbstep: threshold for wbnorm +! update: Decides whether or not jsquare and grad need to be reevaluated. +! ref_conv: true if reference set seized improving despite fit +! grad_conv: true if gradient converged +! step_conv: true if stepsize converged +! fails: number of unsuccessful steps +! skip: indicates fatal error having occured +! act: decides which weights and biases are actually updated + +! macroit: number of J-updates +! +! pat_in: input patterns +! pat_out: desired output patterns +! pat_*(i,N): value of ith in-/output neuron for pattern N +! ref_*: in analogy to pat_in/out for reference data +! (convergence tests) +! +! wterr: weight factors for each element of the error vector e +! +! J: Jacobian matrix. A single row consists of matrix elements +! corresponding to all Weights as they are kept in memory (W), +! followed by all Biases. It is never fully kept in memory. +! Instead, required matrix elements are generated when needed. +! +! e: Error vector. It consists of the differences between the NN's +! output-vector and the desired output patterns, for all patterns. +! Like J it is never really kept in memory. +! +! jsquare: J^T J +! wbsteps: Steps for weights and biases, same order as a single jacobian-row. +! mqpar: initial parameter (lambda) for Marquard-Levenberg +! mqfact: factor by which lambda is multiplied/divided after each iteration +! wsave: saves W with best outcome +! bsave: saves B with best outcome +! skip: indicates whether fit is broken and needs to be ignored. +! +! grad: total error vector transformed by transposed jacobian +! W: weight matrix vector +! B: bias vector +! typop: type population matrix +! laystr: layer structure matrix + + + integer npat,nref + integer fit_id + double precision W(maxwei),B(neucap) + double precision pat_in(maxnin,maxpats),pat_out(maxpout,maxpats) + double precision ref_in(maxnin,maxpats),ref_out(maxpout,maxpats) + double precision wterr(maxpout,maxpats) + double precision rms,ref_rms + double precision rmsopt,mqfact,mqpar,mingrad,minwbstep + integer laystr(3,maxlay),typop(maxtypes,maxlay) + integer weistr(2,maxlay,2) + integer nlay + integer act(wbcap) + logical skip + + double precision wsave(maxwei),bsave(neucap),wbsteps(wbcap) + double precision wsave_ref(maxwei),bsave_ref(neucap) + double precision grad(wbcap) + double precision jsquare + allocatable jsquare(:,:) + double precision lambda,last,ref_last,gradnorm,wbnorm,wbnorm_old + integer pos_out,len_err + integer lay_end,wei_end,jac_end + integer fails,macroit + integer ref_fails + integer log_unit + character*32 nnlogfile + logical ref_conv,grad_conv,step_conv + logical update + + integer j + +! Initialize values + lambda=mqpar + allocate(jsquare(wbcap,wbcap)) + + pos_out=laystr(2,nlay)-1 !increment leading to output layer pos. + +! position of last defined neuron/W-matrix element + lay_end=pos_out+len_out + wei_end=weistr(2,nlay-1,1) + + len_err=npat*len_out !length of error vector + jac_end=wei_end+lay_end-len_in !width of jacobian matrix + +! evaluate initial jsquare and gradient, initialize last + + if (dbg) then + write(iout,'(A)') 'Building first Jacobian..' + endif + call mkjsq(W,B,wterr,jsquare,last,grad,gradnorm, + > jac_end,pat_in,pat_out,wei_end, + > typop,laystr,nlay,npat) + + if (dbg) then + write(iout,'(A)') 'done.' + write(iout,asline) + write(iout,'(A)') 'INITIAL WEIGHTS:' + write(iout,mform) W(1:wei_end) + write(iout,'(A)') 'INITIAL BIASES:' + write(iout,mform) B(len_in+1:lay_end) + endif + + call mkerr(W,B,wterr(1,npat+1),ref_rms,ref_in,ref_out, + > typop,laystr,nlay,nref) + + rms=last + ref_last=ref_rms + + wsave(1:wei_end)=W(1:wei_end) + bsave(1:lay_end)=B(1:lay_end) + fails=0 + ref_fails=0 + macroit=0 + wbnorm=-1.0d0 + update=.true. + ref_conv=.false. + grad_conv=.false. + step_conv=.false. + + if (conlog) then +! generate file displaying convergence behavior. + log_unit=fitunit+fit_id + nnlogfile=trim(nnldir) // 'convergence_' + write(nnlogfile,'(A,I4.4,".log")') trim(nnlogfile),fit_id + + if (dbg.or.vbs) then + write(iout,'(A)') 'logging convergence in ''' + > // trim(nnlogfile) // '''...' + endif + + open(log_unit,file=trim(nnlogfile),status='replace') + + write(log_unit,'(A)') '# UNIT: ' // trim(unit_string) + write(log_unit,'(A1,A8,6A15,1A18)') '#','ITER','RMS', + > 'RMS(REF)','GRADNORM','STEP','LAMBDA','{ORIGSTEP}' + + write(unit=log_unit,fmt='(I9,4ES15.3)') 0, rms*unit_con, + > ref_rms*unit_con, gradnorm*unit_con, lambda + + else if (vbs) then + write(iout,'(A)') '#UNITS: '//trim(unit_string) + write(iout,'(A1,A8,5A15)') '#','ITER','RMS','RMS(REF)', + > 'GRADNORM','WBNORM','LAMBDA' + + write(iout,'(I9,4ES15.3,ES15.2)') 0, rms*unit_con, + > ref_rms*unit_con, gradnorm*unit_con, + > wbnorm, lambda + + endif + + +! Iterates up to a maximum number of allowed microiterations +! (backpropagations) + do j=1,maxbpit +! evaluate step + call marqstep(jsquare,wbsteps,lambda,jac_end,grad,wbnorm,skip) + if (skip) then + exit + endif + +! copy old step norm + wbnorm_old=wbnorm + +! apply changes + call mqupdate(W,B,wbsteps,act,lay_end,wei_end) + +! TODO: consider pulling this into check_mqstep. +! check for improvement + call mkerr(W,B,wterr,rms,pat_in,pat_out, + > typop,laystr,nlay,npat) + + if (conlog.and.rats) then + write(log_unit,'(I9,5ES15.3)',advance='no') j, rms*unit_con, + > ref_rms*unit_con, gradnorm*unit_con, wbnorm, lambda + if (limstep) then + write(log_unit,'(ES15.3,2I6)',advance='no') wbnorm_old + endif + else if (vbs) then + write(iout,'(I9,3ES15.3,2ES15.2)') j, rms*unit_con, + > ref_rms*unit_con, gradnorm*unit_con, + > wbnorm, lambda + endif + + if (dbg) then + write(iout,sline) + write(iout,*) 'LAST:',last,'RMS:',rms + write(iout,*) 'LAMBDA:', lambda + write(iout,*) 'GRADNORM:', gradnorm + write(iout,*) 'WBNORM:', wbnorm + endif + + call check_mqstep(W,B,wterr,rms,ref_rms,last,ref_last, + > wsave,bsave,wsave_ref,bsave_ref, + > fails,ref_fails,lambda,update,ref_conv, + > mqfact,ref_in,ref_out,wei_end, + > typop,laystr,weistr, + > nlay,npat,nref) + +! check for convergence + step_conv=(wbnorm <= minwbstep) + grad_conv=(gradnorm <= mingrad) + if (step_conv.or.grad_conv) then + exit + endif + + if (rmsopt.gt.0.0d0) then +! if considered relevant, check absolute error + if (rms <= rmsopt) exit + endif + + if (fails > maxfails) then + if (dbg) write(iout,'(A)') 'MAXFAILS REACHED, GIVE UP' + exit + else if (ref_conv) then + if (dbg) write(iout,'(A)') 'MAXREFFAILS REACHED, GIVE UP' + exit + endif + + if (conlog) then + if (update) then + write(log_unit,'(3X,A)') '#ACCEPTED' + else + write(log_unit,'(3X,A,ES12.3)') '#WORSE: ΔRMS=', + > (rms-last)*unit_con + endif + endif + + if (update) then +! reevaluate jacobian + last=rms + macroit=macroit+1 + + call mkjsq(W,B,wterr,jsquare,rms,grad,gradnorm, + > jac_end,pat_in,pat_out,wei_end, + > typop,laystr,nlay,npat) + + endif + + if (dbg) then + write(iout,'(A)') 'WEIGHTS:' + write(iout,mform) W(1:wei_end) + write(iout,'(A)') 'BIASES:' + write(iout,mform) B(len_in+1:lay_end) + endif + enddo + +! overwrite rms with best result + rms=last + ref_rms=ref_last + + if (skip) then + if (dbg.or.vbs) then + write(iout,'(A)') '#CONVERGENCE ERROR: ' + > // 'FATAL ERROR OCCURED.' + endif + if (rats) then + write(unit=perfunit,fmt=400) rms*unit_con, ref_rms*unit_con, + > wbnorm, gradnorm*unit_con, macroit, j-1, fit_id, + > '#CRASHED' + endif + else if (j >= maxbpit) then + if (dbg.or.vbs) then + write(iout,'(A)') '#CONVERGENCE ERROR: ' + > // 'ITERATIONS EXCEEDED MAXBPIT' + endif + if (rats) then + write(unit=perfunit,fmt=401) rms*unit_con, ref_rms*unit_con, + > wbnorm, gradnorm*unit_con, macroit,j-1, fit_id + endif + else if (fails > maxfails) then + if (dbg) then + write(iout,'(A)') '#CONVERGENCE ERROR: MAXFAILS REACHED.' + endif + if (rats) then + write(unit=perfunit,fmt=400) rms*unit_con, ref_rms*unit_con, + > wbnorm, gradnorm*unit_con, macroit, j-1, fit_id, + > '#FAILED' + endif + else + if (vbs) then + if (ref_conv) then + write(iout,'(A)') '#CONVERGED VALIDATION SET.' + endif + if (wbnorm <= minwbstep) then + if (gradnorm <= mingrad) then + write(iout,'(A)') '#CONVERGENCE REACHED.' + > // ' (GRADIENT & STEP)' + endif + write(iout,'(A)') '#CONVERGED STEPSIZE ONLY.' + else if (gradnorm <= mingrad) then + write(iout,'(A)') '#CONVERGED GRADIENT ONLY.' + endif + endif + if (rats) then + write(unit=perfunit,fmt=400,advance='no') + > rms*unit_con, + > ref_rms*unit_con, wbnorm, + > gradnorm*unit_con, macroit, j-1, fit_id, + > '#CONVERGED' + if (ref_conv) then + write(perfunit,'(A)') ' [REF]' + else if (grad_conv.and.step_conv) then + write(perfunit,'(A)') ' [GRAD & STEP]' + else if (grad_conv) then + write(perfunit,'(A)') ' [GRAD]' + else if (step_conv) then + write(perfunit,'(A)') ' [STEP]' + else + write(unit=perfunit,fmt=newline) + endif + endif + endif + + 400 format(4ES10.2,4X,I6,"/",I6,I8,4X,A) + 401 format(4ES10.2,4X,I6,"/",I6,I8) + + if (conlog) then + close(log_unit) + endif + + deallocate(jsquare) + + + if (dbg) then + j=j-1 + write(iout,asline) + write(iout,'(A)') 'OPT END.' + write(iout,'(A12,I9)') 'ITERATIONS:',j + write(iout,'(A9,I12)') 'MACROIT:', macroit + write(iout,'(A26,3(I6,'' :''),F6.2,''%'')') + > 'SAVED:UNDONE:TOTAL:%SAVED', + > macroit, j-macroit, j, + > 1.0D2*dble(macroit)/dble(j) + write(iout,'(A)') 'NEUPOP:' + write(iout,miform) laystr(1,1:nlay) + write(iout,'(A)') 'INSHIFT:' + write(iout,mform) shift_in(1:laystr(1,1)) + write(iout,'(A)') 'INSCALE:' + write(iout,mform) fact_in(1:laystr(1,1)) + write(iout,'(A)') 'FINAL W:' + write(iout,mform) W(1:wei_end) + write(iout,'(A)') 'FINAL B:' + write(iout,mform) B(1:lay_end) + write(iout,*) 'FINAL RMS:', rms + write(iout,*) 'FINAL RMS(REF):', ref_rms + write(iout,*) 'FINAL LAMBDA',lambda*mqfact + write(iout,asline) + endif + + end + +!-------------------------------------------------------------------------------------- + + subroutine check_mqstep(W,B,wterr,rms,ref_rms,last,ref_last, + > wsave,bsave,wsave_ref,bsave_ref, + > fails,ref_fails,lambda,update,ref_conv,mqfact, + > ref_in,ref_out,wei_end, + > typop,laystr,weistr, + > nlay,npat,nref) + + use nn_params + use nncommons + use nndbg_mod + implicit none +! Compare current parameter set's performance with current best and +! revert if necessary. + + + integer npat,nref + double precision W(maxwei),B(neucap) + double precision wsave(maxwei),bsave(neucap) + double precision wsave_ref(maxwei),bsave_ref(neucap) + double precision ref_in(maxnin,maxpats),ref_out(maxpout,maxpats) + double precision wterr(maxpout,maxpats) + double precision rms,ref_rms,last,ref_last + double precision lambda,mqfact + integer fails,ref_fails + integer laystr(3,maxlay),typop(maxtypes,maxlay) + integer weistr(2,maxlay,2) + integer nlay + logical update,ref_conv + + integer lay_end,wei_end + + wei_end=weistr(2,nlay-1,1) + lay_end=laystr(2,nlay)-1+len_out + +! First, check fitting data set + if (last.lt.rms) then +! Revert parameter changes + W(1:wei_end)=wsave(1:wei_end) + B(1:lay_end)=bsave(1:lay_end) + + lambda=lambda*mqfact + update=.false. + fails=fails+1 + + return + else + if (lambda.gt.zero) then + lambda=lambda/mqfact + endif + update=.true. + fails=0 + + endif + +! Evaluate error of reference data set + call mkerr(W,B,wterr(1,npat+1),ref_rms,ref_in,ref_out, + > typop,laystr,nlay,nref) + + if (dbg) then + write(iout,*) 'LAST(REF):',ref_last,'RMS(REF):', ref_rms + endif + +! Next, check reference data set + if (ref_last.lt.ref_rms) then + if (dbg) then + write(iout,'(A)') 'VALIDATION SET ERROR INCREASED.' + endif + +! keep backup of old parameter set but continue fit + ref_fails=ref_fails+1 + if (ref_fails.eq.1) then + wsave_ref(1:wei_end)=wsave(1:wei_end) + bsave_ref(1:lay_end)=bsave(1:lay_end) + endif + + if (ref_fails.ge.maxref_fails) then + ref_conv=.true. +! if reference rms increased despite fit improving, +! discard changes and exit + W(1:wei_end)=wsave_ref(1:wei_end) + B(1:lay_end)=bsave_ref(1:lay_end) + if (dbg) then + write(iout,'(A)') 'VALIDATION SEIZED IMPROVING, GIVE UP' + endif + return + endif + + else + ref_last=ref_rms + ref_fails=0 + endif + +! save changes disregarding reference set + wsave(1:wei_end)=W(1:wei_end) + bsave(1:lay_end)=B(1:lay_end) + + end + +!-------------------------------------------------------------------------------------- + + subroutine mkjsq(W,B,wterr,jsquare,rms,grad,gradnorm,jac_end, + > pat_in,pat_out,wei_end, + > typop,laystr,nlay,npat) + use axel, only: init_input + use nn_params + use nncommons + use nndbg_mod + implicit none +! Directly evaluates J^T J and gradient. +! Since jsquare is symmetric, only the upper triangle is evaluated. +! +! nlay: number of given layers +! npat: number of given pattern pairs +! rms: (weighted) root mean square error +! wei_end: position of last defined W-matrix-element in W-vector! +! jac_end: number of all weights and biases together +! +! pat_in: input patterns +! pat_out: desired output patterns +! pat_*(i,N): value of ith in-/output neuron for pattern N +! +! wterr: weight factors for each element of the error vector e +! +! jacrow: One row of the jacobian matrix. It consists of matrix elements +! corresponding to all Weights as they are kept in memory (W), +! followed by all Biases. +! +! jsquare: J^T J +! outgrads: the derivatives of the arbitrary error function with respect to +! the neuronal outputs. +! +! grad: total error vector transformed by transposed jacobian +! gradnorm: norm of gradient grad +! +! del: neuron error vector +! pat_err: segment of the total error vector for one pattern. +! deriv: activation function derivatives +! W: weight matrix vector +! B: bias vector +! L: layer vector +! typop: type population matrix +! laystr: layer structure matrix +! laystr(1,N): number of neurons in layer N +! laystr(2,N): starting pos. for layer N +! laystr(3,N): starting pos. for weight matrix from layer N to N+1 + + + integer npat,nlay,wei_end,jac_end + double precision W(maxwei),B(neucap) + double precision jsquare(wbcap,wbcap),grad(wbcap) + double precision pat_in(maxnin,maxpats),pat_out(maxpout,maxpats) + double precision wterr(maxpout,maxpats) + double precision rms,gradnorm + integer laystr(3,maxlay),typop(maxtypes,maxlay) + + double precision L(neucap),jacrow(wbcap) + double precision del(neucap),deriv(neucap),pat_err(maxpout) + double precision outgrads(maxnout,maxpout) + integer pos_out,pos_jac + integer j,k,n,m + + pos_out=laystr(2,nlay)-1 !increment leading to output layer pos. + + rms=0.0D0 + del=0.0D0 + + do j=1,jac_end + do m=j,jac_end + jsquare(m,j)=0.0d0 + enddo + grad(j)=0.0d0 + enddo + + do n=1,npat + + call init_input(L,pat_in(1,n),shift_in,fact_in,len_in) + + call propagate(W,B,L,deriv,typop,laystr,nlay) + pos_jac=(n-1)*inp_out !increment for err-vector pos. + +! evaluate pat_err + call nnerror(pat_err,pat_in(1,n),pat_out(1,n),L(pos_out+1)) +! evaluate output value derivatives + call nnoutgrad(outgrads,pat_in(1,n),L(pos_out+1)) + + do k=1,inp_out + rms=rms+wterr(k,n)*pat_err(k)**2 +! prepare sensitivity vector + del=0.0D0 + do j=1,len_out + del(pos_out+j)=-deriv(pos_out+j)*outgrads(j,k) + > * dsqrt(wterr(k,n)) + enddo +! evaluate J-Matrix elements for a single row + call backprop(del,W,deriv,laystr,nlay) + call nnjacob(del,L,jacrow,wei_end,laystr,nlay) +! build up jsquare and gradient + do j=1,jac_end + do m=j,jac_end + jsquare(m,j)=jsquare(m,j)+jacrow(j)*jacrow(m) + enddo + grad(j)=grad(j)+jacrow(j)*pat_err(k)*dsqrt(wterr(k,n)) + enddo + enddo + enddo + + do j=1,jac_end + do m=j+1,jac_end + jsquare(j,m)=jsquare(m,j) + enddo + enddo + + rms=dsqrt(rms) + gradnorm=dsqrt(dot_product(grad(1:jac_end),grad(1:jac_end))) + + end + +!-------------------------------------------------------------------------------------- + + subroutine nnjacob(del,L,jacrow,wei_end,laystr,nlay) + use nn_params + use nncommons + use nndbg_mod + implicit none +! Evaluates one row of the Jacobian +! +! nlay: number of given layers +! nprop: number of single-layer propagations +! neu_io: number of neurons in giv./prev. layer +! neu_oi: number of neurons in prev./giv. layer +! poslay: starting position of layer in L- and B-vector +! poswei: starting position of weight-matrix in W-vector +! wei_end: position of last defined W-matrix-element in W-vector +! +! del: neuron error vector +! L: layer vector +! jacrow: A single row of the jacobian matrix. It consists of all weights as they +! are kept in memory (W), followed by all biases. +! laystr: layer structure matrix +! +! laystr(1,N): number of neurons in layer N +! laystr(2,N): starting pos. for layer N +! laystr(3,N): starting pos. for Weight Matrix from layer N to N+1 + + + integer wei_end + double precision del(neucap),L(neucap),jacrow(wbcap) + integer laystr(3,maxlay) + integer nlay + + + integer poslay,poswei,nprop,neu_io,neu_oi + integer k + + nprop=nlay-1 + + neu_io=laystr(1,1) !number of input neurons ('layer N') + poslay=laystr(2,1) + poswei=laystr(3,1) + do k=2,2*(nprop/2),2 + neu_oi=laystr(1,k) !number of output neurons ('layer N+1') + +! input neurons have no bias (no J-elements), hence -len_in + call jalay(neu_io,neu_oi,del(poslay),L(poslay),jacrow(poswei), + > jacrow(wei_end+poslay-len_in)) + + poslay=laystr(2,k) + poswei=laystr(3,k) + neu_io=laystr(1,k+1) !new number of output neurons ('layer N') + +! former output neurons are now input, _io and _oi switch places! +! (done for efficiency) + + call jalay(neu_oi,neu_io,del(poslay),L(poslay),jacrow(poswei), + > jacrow(wei_end+poslay-len_in)) + + poslay=laystr(2,k+1) + poswei=laystr(3,k+1) + enddo + + do k=1,mod(nprop,2) !for odd nprop one iteration is left + neu_oi=laystr(1,nlay) + call jalay(neu_io,neu_oi,del(poslay),L(poslay),jacrow(poswei), + > jacrow(wei_end+poslay-len_in)) + enddo + + end + +!-------------------------------------------------------------------------------------- + + subroutine jalay(neu_in,neu_out,del,L,welems,belems) + use nn_params + use nndbg_mod + implicit none +! Evaluates Matrix-elements corresponding to one NN-layer. +! +! neu_in: number of neurons in layer N +! neu_out: number of neurons in layer N+1 +! +! del: neuron error vector +! L: layer vector (beginning at layer N) +! welems: elements corresponding to W-matrix +! belems: elements corresponding to B-vector +! + + integer neu_in,neu_out + double precision L(neu_in),del(neu_in+neu_out) + double precision welems(neu_in,neu_out),belems(neu_in+neu_out) + + integer neu_tot,pos_out + integer j,k + + neu_tot=neu_in+neu_out !total number of neurons in both layers + pos_out=neu_in+1 !position of first element in layer N+1 + + do j=pos_out,neu_tot + belems(j)=del(j) + enddo + do j=1,neu_out + do k=1,neu_in + welems(k,j)=L(k)*del(neu_in+j) + enddo + enddo + + end + +!-------------------------------------------------------------------------------------- + + subroutine mkerr(W,B,wterr,rms,pat_in,pat_out, + > typop,laystr,nlay,npat) + use nn_params + use nncommons + use nndbg_mod + implicit none +! Evaluates rms only. +! nlay: number of given layers +! npat: number of given pattern pairs +! rms: (weighted) root mean square error +! +! pat_in: input patterns +! pat_out: desired output patterns +! pat_*(i,N): value of ith in-/output neuron for pattern N +! +! wterr: weight factors for each element of the error vector e +! pat_err: segment of the total error vector for one pattern. +! +! deriv: activation function derivatives (discarded) +! W: weight matrix vector +! B: bias vector +! L: layer vector +! typop: type population matrix +! laystr: layer structure matrix +! laystr(1,N): number of neurons in layer N +! laystr(2,N): starting pos. for layer N +! laystr(3,N): starting pos. for weight matrix from layer N to N+1 + + + integer npat + double precision W(maxwei),B(neucap) + double precision pat_in(maxnin,maxpats),pat_out(maxpout,maxpats) + double precision wterr(maxpout,npat) + double precision rms + integer laystr(3,maxlay),typop(maxtypes,maxlay) + integer nlay + + + double precision pat_err(maxpout) + integer n,k + + rms=0.0D0 + + do n=1,npat + + call mkerrvec(W,B,pat_err,pat_in(1,n),pat_out(1,n), + > typop,laystr,nlay) + + do k=1,inp_out + rms=rms+wterr(k,n)*pat_err(k)**2 + enddo + enddo + + rms=dsqrt(rms) + + end +!-------------------------------------------------------------------------------------- + + subroutine mkerrvec(W,B,pat_err,pat_in,pat_out, + > typop,laystr,nlay) + use axel, only: init_input + use nn_params + use nncommons + use nndbg_mod + implicit none +! Generates error vector pat_err out of given ANN parameters +! for a *single* pattern pair. +! +! pat_in: input pattern +! pat_out: desired output pattern +! pat_*(i): value of ith in-/output neuron +! +! pat_err: error vector for one pattern. +! +! deriv: activation function derivatives (discarded) +! W: weight matrix vector +! B: bias vector +! L: layer vector +! typop: type population matrix +! laystr: layer structure matrix +! laystr(1,N): number of neurons in layer N +! laystr(2,N): starting pos. for layer N +! laystr(3,N): starting pos. for weight matrix from layer N to N+1 + + + double precision W(maxwei),B(neucap) + double precision pat_in(maxnin),pat_out(maxpout) + integer laystr(3,maxlay),typop(maxtypes,maxlay) + integer nlay + + + double precision L(neucap),deriv(neucap),pat_err(maxpout) + integer pos_out + + pos_out=laystr(2,nlay)-1 !increment leading to output layer pos. + + L=0.0d0 + + call init_input(L,pat_in,shift_in,fact_in,len_in) + call propagate(W,B,L,deriv,typop,laystr,nlay) +! evaluate pat_err + call nnerror(pat_err,pat_in,pat_out,L(pos_out+1)) + + end + + +!-------------------------------------------------------------------------------------- + + subroutine marqstep(jsquare,wbsteps,lambda,jac_end,grad,wbnorm, + > skip) + use nn_params + use nndbg_mod + implicit none +! Evaluates steps for W and B using the equation +! (J^T J + lambda*1) wbsteps = -J^T e, +! where "J^T e" is already given as grad and "J^T J" as jsquare, +! +! wbsteps: Steps for weights and biases, same order as a single jacobian-row. +! lambda: parameter for Marquard-Levenberg +! jac_end: number of all weights and biases together +! grad: error vector transformed by transposed jacobian +! jsquare: J^T J. Only the upper triangle of it is required, +! that is jsquare(i,j) needs only to be defined for i>=j. +! jscop: working copy of jsquare +! skip: true if fatal error has occured +! + + + double precision jsquare(wbcap,wbcap),grad(wbcap),wbsteps(wbcap) + double precision lambda,wbnorm + integer jac_end + logical skip + + double precision jscop + allocatable jscop(:,:) + integer k,j + + allocate(jscop(wbcap,wbcap)) + do k=1,jac_end + do j=1,jac_end + jscop(j,k)=jsquare(j,k) !brutally inefficient. + enddo + enddo + + do k=1,jac_end + jscop(k,k)=jscop(k,k)+lambda + enddo + +! solve for wbsteps using Cholesky decomposition + call choldcsol(jscop,grad,wbsteps,jac_end,wbcap,skip) +! call mqinvertsol(jscop,grad,wbsteps,jac_end) + + deallocate(jscop) + + if (skip) then + return + endif + + wbnorm=sqrt(dot_product(wbsteps(1:jac_end),wbsteps(1:jac_end))) + + end + +!-------------------------------------------------------------------------------------- + + subroutine mqupdate(W,B,wbsteps,act,lay_end,wei_end) + use nn_params + use nncommons + use nndbg_mod + implicit none +! Updates W and B according to wbsteps. +! +! wei_end: position of last defined weight in W-vector +! lay_end: position of last defined bias in B-vector +! len_in: number of input-neurons. Since they have no biases +! B(1:len_in) is meaningless. +! +! W: weight matrix vector +! B: bias vector +! wbsteps: steps for weights and biases, same order as a single jacobian-row. +! act: decides which weights and biases are actually updated (1=active) + + + double precision W(maxwei),B(neucap),wbsteps(wbcap) + integer act(wbcap) + integer lay_end,wei_end + integer k + + do k=1,wei_end + if (act(k).eq.1) then + W(k)=W(k)-wbsteps(k) + endif + enddo + + do k=len_in+1,lay_end + if (act(wei_end+k-len_in).eq.1) then + B(k)=B(k)-wbsteps(wei_end+k-len_in) + endif + enddo + + end + +!-------------------------------------------------------------------------------------- + + subroutine mqinvertsol(jscop,grad,wbsteps,jac_end) + use nn_params + use nndbg_mod + implicit none +! Generate step not from using cholesky decomposition, but by directly +! inverting the matrix jscop. +! +! wbsteps: Steps for weights and biases, same order as a single jacobian-row. +! jac_end: number of all weights and biases together +! grad: error vector transformed by transposed jacobian +! jscop: J^T J + lambda. Only the upper triangle of it is written, +! that is jsquare(i,j) needs only to be defined for i>=j. +! js_trans: eigenvectors (equivalent to transformation matrix) +! js_eigen: eigenvalues + + + double precision jscop(wbcap,wbcap),grad(wbcap),wbsteps(wbcap) + integer jac_end + + double precision js_eigen + double precision js_trans,js_inv + allocatable js_eigen(:) + allocatable js_trans(:,:),js_inv(:,:) + + integer k,j,n + + allocate(js_eigen(wbcap)) + allocate(js_trans(wbcap,wbcap)) + allocate(js_inv(wbcap,wbcap)) + + +! fill the lower triangle of the matrix +! DW: FIXME: probably useless now. + do k=1,jac_end + do j=k+1,jac_end + jscop(j,k)=jscop(k,j) + enddo + enddo + +! solve wbsteps by diagonalizing + call ddiag(jscop,js_eigen,js_trans,wbcap,jac_end) + + js_inv=0.0d0 + +! invert hessian + do n=1,jac_end + do k=1,jac_end + do j=1,jac_end + js_inv(j,k)=js_inv(j,k) + > + js_trans(j,n)*js_trans(k,n)/js_eigen(n) + enddo + enddo + enddo + +! apply inverted hessian to grad + do j=1,jac_end + wbsteps(j)=0.0d0 + do k=1,jac_end + wbsteps(j)=wbsteps(j)+js_inv(k,j)*grad(k) + enddo + enddo + + deallocate(js_eigen) + deallocate(js_trans) + deallocate(js_inv) + + + + end diff --git a/src/nnread.f b/src/nnread.f new file mode 100644 index 0000000..d64b368 --- /dev/null +++ b/src/nnread.f @@ -0,0 +1,131 @@ + subroutine read_net_prim(fname,par,nlay,laystr,weistr,typop) + use nn_params + use nndbg_mod + implicit none +! Subroutine reading ANN-parameters as generated by punch_net_prim + + + integer nlay + integer laystr(3,maxlay),typop(maxtypes,maxlay) + integer weistr(2,maxlay,2) + double precision par(*) + character*32 fname + + character*2048 full_fname, net_id + integer neupop(maxlay) + integer par_end,len_out + integer file_maxtypes + + integer j + + + full_fname = trim(fname) // '.par' + + open(nnunit,file=trim(full_fname),status='old',action='read') + + write(6,'(4096A)') '# READING ''' // trim(full_fname) // '''...' + +! read structure parameters + read(nnunit,*,end=800) nlay + read(nnunit,*,end=801) file_maxtypes +! Nobody needs segfaults from corrupted input files. + if ((file_maxtypes.gt.maxtypes).or.(file_maxtypes.le.0)) then + write(6,'(A,I12)') 'ERROR: READ_NET_PRIM: ' + > //'VARIABLE MAXTYPES OUT OF BOUNDS:',maxtypes + stop 1 + else if ((nlay.gt.maxlay).or.(nlay.le.0)) then + write(6,'(A,I12)') 'ERROR: READ_NET_PRIM: ' + > //'VARIABLE NLAY OUT OF BOUNDS:',nlay + stop 1 + endif + read(nnunit,*,end=802) neupop(1:nlay) + read(nnunit,*,end=803) typop(1:file_maxtypes,1:nlay) + + len_out=neupop(nlay) + + net_id=' ' + read(nnunit,'(2048A)',end=804) net_id + + if (.not.(len_trim(net_id).eq.0)) then + write(6,'(4096A)') '# MODEL ID: ' // trim(net_id(4:)) + endif + +! initialize laystr + call mknet(laystr,weistr,neupop,nlay) + + par_end=laystr(3,nlay)-1 !final W-position + +! move to final bias + do j=2,nlay + par_end=par_end + neupop(j) + enddo + + read(nnunit,*,end=805) par(1:par_end) + + close(nnunit) + return + + 800 write(6,'(A)') 'ERROR: READ_NET_PRIM: BROKEN OR MISSING NLAY' + 801 write(6,'(A)') 'ERROR: READ_NET_PRIM: BROKEN OR MISSING' + > // ' MAXTYPE' + 802 write(6,'(A)') 'ERROR: READ_NET_PRIM: BROKEN OR MISSING NEUPOP' + 803 write(6,'(A)') 'ERROR: READ_NET_PRIM: BROKEN OR MISSING TYPOP' + 804 write(6,'(A)') 'ERROR: READ_NET_PRIM: BROKEN MODEL-ID' + 805 write(6,'(A)') 'ERROR: READ_NET_PRIM: BROKEN OR MISSING PARAMS' + + end + +!-------------------------------------------------------------------------------- + + subroutine read_record(par,weistr,nlay,nset) + use nn_params + use nncommons + use io_parameters + use nndbg_mod + implicit none + + + double precision par(wbcap,maxset) + integer weistr(2,maxlay,2) + integer nlay,nset + + integer wb_end, wb_end_rec + integer nset_rec + character*64 fname + + integer k,k_rec + + fname=trim(nnrecfile) // '.rec' + + wb_end=weistr(2,nlay,2) + + write(6,'(A)') 'RECORD: Reading record from file ''' + > // trim(fname) // '''...' + open(nnunit,file=trim(fname),action='READ') + + read(nnunit,*) nset_rec + if (nset_rec.ne.nset) then + write(6,'(A)') 'ERROR: INCONSISTENT NUMBER OF PARAMETER SETS.' + write(6,'("(",I4," vs.",I4,")")') + stop 1 + endif + read(nnunit,*) wb_end_rec + if (wb_end_rec.ne.wb_end) then + write(6,'(A)') 'ERROR: INCONSISTENT NUMBER OF PARAMETER SETS.' + write(6,'("(",I4," vs.",I4,")")') + stop 1 + endif + + do k=1,nset + read(nnunit,*) k_rec, par(1:wb_end,k) + if (k.ne.k_rec) then + write(6,'(A,I05,A)') 'ERROR: MISSING PARAMETER SET: ', k + write(6,'(A,I05,A)') 'FOUND ', k_rec, ' INSTEAD' + stop 1 + endif + enddo + close(nnunit) + write(6,'(A,I5)') 'Done. Read ',nset, ' parameter sets in total.' + + + end diff --git a/src/parser/errcat.incl b/src/parser/errcat.incl new file mode 100644 index 0000000..5cdd0ef --- /dev/null +++ b/src/parser/errcat.incl @@ -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)= diff --git a/src/parser/keylist.incl b/src/parser/keylist.incl new file mode 100644 index 0000000..49790cc --- /dev/null +++ b/src/parser/keylist.incl @@ -0,0 +1,309 @@ +**** KEYLIST -- this defines what kind of keys genANN is able to process syntactially + + keylist=' ' + +! The only "special" key in the sense that it terminates input + keylist(1, 1)='DATA:' + keylist(2, 1)='E!' + + keylist(1, 2)='SEED:' + keylist(2, 2)='+I1' + + keylist(1, 3)='NSET:' + keylist(2, 3)='+I1' + + keylist(1, 4)='SETS:' + keylist(2, 4)='+IN' + + keylist(1, 5)='NPAT:' + keylist(2, 5)='+I1' + + keylist(1, 6)='NPOINTS:' + keylist(2, 6)='+IN' + + keylist(1, 7)='VALIDATION:' + keylist(2, 7)='+I1' + + keylist(1, 8)='RANDOM:' + keylist(2, 8)='E' + + keylist(1, 9)='FREEZE:' + keylist(2, 9)='E' + + keylist(1,10)='DRYRUN:' + keylist(2,10)='E' + + keylist(1,11)='RECORD:' + keylist(2,11)='C1' + + keylist(1,12)='NLAY:' + keylist(2,12)='+I!1' + + keylist(1,13)='NEUPOP:' + keylist(2,13)='+I!N' + + keylist(1,14)='TYPOP:' + keylist(2,14)='+I!N' + + keylist(1,15)='DEPRECATED:' + keylist(2,15)='E' + + keylist(1,16)='DEPRECATED:' + keylist(2,16)='E' + + keylist(1,17)='INPUTS:' + keylist(2,17)='+I1' + + keylist(1,18)='OUTPUTS:' + keylist(2,18)='+I1' + + keylist(1,19)='MAXFAILS:' + keylist(2,19)='+I1' + + keylist(1,20)='NOMAXFAILS:' + keylist(2,20)='E' + + keylist(1,21)='REFFAILS:' + keylist(2,21)='+I1' + + keylist(1,22)='NOREFFAILS:' + keylist(2,22)='E' + + keylist(1,23)='DEPRECATED:' + keylist(2,23)='E' + + keylist(1,24)='MICIT:' + keylist(2,24)='+I1' + + keylist(1,25)='MAXBPIT:' + keylist(2,25)='+I1' + + keylist(1,26)='GSPREAD:' + keylist(2,26)='+D1' + + keylist(1,27)='WSPREAD:' + keylist(2,27)='+D1' + + keylist(1,28)='BSPREAD:' + keylist(2,28)='+D1' + + keylist(1,29)='HART2EV:' + keylist(2,29)='E' + + keylist(1,30)='HART2ICM:' + keylist(2,30)='E' + + keylist(1,31)='ARBUNITS:' + keylist(2,31)='+D1' + + keylist(1,32)='UCUSTOM:' + keylist(2,32)='C2' + + keylist(1,33)='RMSOPT:' + keylist(2,33)='+D1' + + keylist(1,34)='MINGRAD:' + keylist(2,34)='+D1' + + keylist(1,35)='MINWBSTEP:' + keylist(2,35)='+D1' + + keylist(1,36)='DEPRECATED:' + keylist(2,36)='E' + + keylist(1,37)='ECHO:' + keylist(2,37)='CN' + + keylist(1,38)='ERRCUT:' + keylist(2,38)='DN' + + keylist(1,39)='CUTWT:' + keylist(2,39)='+DN' + + keylist(1,40)='INSHIFT:' + keylist(2,40)='DN' + + keylist(1,41)='INSCALE:' + keylist(2,41)='DN' + + keylist(1,42)='NORMINP:' + keylist(2,42)='E' + + keylist(1,43)='ZERO:' + keylist(2,43)='E' + + keylist(1,44)='VALPER:' + keylist(2,44)='+D1' + + keylist(1,45)='DEPRECATED:' + keylist(2,45)='E' + + keylist(1,46)='RUNCHUNK:' + keylist(2,46)='+I2' + + keylist(1,47)='RUNFROM:' + keylist(2,47)='+I1' + + keylist(1,48)='RUNTO:' + keylist(2,48)='+I1' + + keylist(1,49)='LEGACY-WT:' + keylist(2,49)='E' + + keylist(1,50)='INCLUDE-DATA:' + keylist(2,50)='C1' + + keylist(1,51)='NOSCANWALK:' + keylist(2,51)='E' + + keylist(1,52)='LAMBDA:' + keylist(2,52)='+D1' + + keylist(1,53)='MQFACT:' + keylist(2,53)='+D1' + + keylist(1,54)='NDIAB:' + keylist(2,54)='+I1' +! +! keylist(1,55)= +! keylist(2,55)= +! +! keylist(1,56)= +! keylist(2,56)= +! +! keylist(1,57)= +! keylist(2,57)= +! +! keylist(1,58)= +! keylist(2,58)= +! +! keylist(1,59)= +! keylist(2,59)= +! +! keylist(1,60)= +! keylist(2,60)= + +! keylist(1,61)= +! keylist(2,61)= +! +! keylist(1,62)= +! keylist(2,62)= +! +! keylist(1,63)= +! keylist(2,63)= +! +! keylist(1,64)= +! keylist(2,64)= +! +! keylist(1,65)= +! keylist(2,65)= +! +! keylist(1,66)= +! keylist(2,66)= +! +! keylist(1,67)= +! keylist(2,67)= +! +! keylist(1,68)= +! keylist(2,68)= +! +! keylist(1,69)= +! keylist(2,69)= +! +! keylist(1,70)= +! keylist(2,70)= +! +! keylist(1,71)= +! keylist(2,71)= +! +! keylist(1,72)= +! keylist(2,72)= +! +! keylist(1,73)= +! keylist(2,73)= +! +! keylist(1,74)= +! keylist(2,74)= +! +! keylist(1,75)= +! keylist(2,75)= +! +! keylist(1,76)= +! keylist(2,76)= +! +! keylist(1,77)= +! keylist(2,77)= +! +! keylist(1,78)= +! keylist(2,78)= +! +! keylist(1,79)= +! keylist(2,79)= +! +! keylist(1,80)= +! keylist(2,80)= +! +! keylist(1,81)= +! keylist(2,81)= +! +! keylist(1,82)= +! keylist(2,82)= +! +! keylist(1,83)= +! keylist(2,83)= +! +! keylist(1,84)= +! keylist(2,84)= +! +! keylist(1,85)= +! keylist(2,85)= +! +! keylist(1,86)= +! keylist(2,86)= +! +! keylist(1,87)= +! keylist(2,87)= +! +! keylist(1,88)= +! keylist(2,88)= +! +! keylist(1,89)= +! keylist(2,89)= +! +! keylist(1,90)= +! keylist(2,90)= +! +! keylist(1,91)= +! keylist(2,91)= +! +! keylist(1,92)= +! keylist(2,92)= +! +! keylist(1,93)= +! keylist(2,93)= +! +! keylist(1,94)= +! keylist(2,94)= +! +! keylist(1,95)= +! keylist(2,95)= +! +! keylist(1,96)= +! keylist(2,96)= +! +! keylist(1,97)= +! keylist(2,97)= +! +! keylist(1,98)= +! keylist(2,98)= +! +! keylist(1,99)= +! keylist(2,99)= + + do j=1,maxkeys + if (keylist(1,j)(1:1).eq.' ') then + keynum=j-1 + write(6,'("Number of accepted input keys: ",I3)') keynum + exit + endif + enddo diff --git a/src/parser/nndata_new.f b/src/parser/nndata_new.f new file mode 100644 index 0000000..0c19825 --- /dev/null +++ b/src/parser/nndata_new.f @@ -0,0 +1,265 @@ +! This is a rewrite of the original nndata. Consider debugging it. +!--------------------------------------------------------------------------- + + subroutine nndata(infile,pat_in,pat_out,ref_in,ref_out,wterr, + > dat_start,linenum,npat,nref,llen) + use nn_params + use nncommons + use io_parameters, only: nstat,nmeta,maxoutp,dnlen,maxlines, + > maxdat,clen,klen,maxkeys,maxerrors,mprun + use nndbg_mod + implicit none +! Routine reading DATA-block. +! If npat is nonzero, only the first npat pattern pairs are read. +! +! infile: input file as string vector +! infile(n) nth line of input file +! linenum: number of lines in input file +! dat_start: starting position of DATA-block +! llen: maximum length of a single input line +! +!.....ANN-specific variables +! nlay: number of given layers +! npat: number of given pattern pairs +! nref: number of reference patterns +! wterr: weight factors for each element of the error vector e +! +! pat_in: input patterns +! pat_out: desired output patterns +! pat_*(i,N): value of ith in-/output neuron for pattern N +! +! ref_*: in analogy to pat_in/out for reference data (convergence tests) +! +! expected format (for one pattern pair): +!.. y1 x1 x2 x3 ... xM +!.. y2 x1 x2 x3 ... xM +!.. .. .. .. .. ... .. +!.. yN x1 x2 x3 ... xM +!.. +!.. WT: w1 w2 ... wN +! +!... wt-legacy mode format: +!.. y1 x1 x2 x3 ... xM +!.. WT: w1 +!.. y2 x1 x2 x3 ... xM +!.. WT: w2 +!.. .. .. .. .. ... .. +!.. yN x1 x2 x3 ... xM +!.. WT: wN +! +! where N=inp_out and M=inp_in + + + double precision pat_in(maxnin,maxpats),pat_out(maxpout,maxpats) + double precision ref_in(maxnin,maxpats),ref_out(maxpout,maxpats) + double precision wterr(maxpout,maxpats) + integer npat,nref,dat_start,linenum,llen + character infile(*)*(llen) + + double precision norm + double precision xtest(maxnin) + integer pat_count,line + integer yval_count + + integer k,j + + pat_count=1 +! count the lines of y-values. inp_out y-values = 1 pattern + yval_count=0 + +! We will initialize wterr for each new pattern. + wterr(1:inp_out,1)=1.0D0 + + do line=dat_start,linenum +! Treat WT: lines differently + if (infile(line)(1:3).eq.'WT:') then + if (yval_count.eq.0) then + write(6,'(A)') 'ERROR: WT: KEY PRECEDES ACTUAL DATA.' + write(6,'("(Line #",I06,")")') line + stop ec_read + else if (legacy_wt) then + read(in(line)(4:llen),*,err=515,end=514) + > wterr(yval_count,pat_count) + cycle + 514 write(6,419) pat_count + write(6,'(A)') '(broken WT: input)' + stop ec_read + 515 write(6,418) pat_count + write(6,'(A)') 'LINE DUMP:' + write(6,'(A)') trim(in(line)(4:llen)) + stop ec_read + else if (yval_count.eq.inp_out) then + read(infile(line)(4:llen),*,err=511,end=508) + > wterr(1:inp_out,pat_count) + cycle + 508 write(6,419) pat_count + write(6,'(A)') '(broken WT: input)' + stop ec_read + 511 write(6,418) pat_count + write(6,'(A)') 'LINE DUMP:' + write(6,'(A)') trim(in(line)(4:llen)) + stop ec_read + else + write(6,'(A)') 'ERROR: UNEXPECTED WT: KEY' + write(6,'(A)') 'Consider using LEGACY-WT:.' + stop ec_read + endif + cycle + endif + +! Check whether a new pattern begins + if (yval_count.lt.inp_out) then + yval_count=yval_count+1 + else +! If npat patterns are completed, finish + if (pat_count.eq.npat) then + exit + endif + if (pat_count.ge.maxpats) then + write(6,418) pat_count,maxpats + stop ec_dimrd + endif + pat_count=pat_count+1 + yval_count=1 + wterr(1:inp_out,pat_count)=1.0D0 + endif + +! Read line + read(infile(line)(1:llen),*,err=513,end=510) + > pat_out(yval_count,pat_count),xtest(1:inp_in) +! I CAN DO DATA TRANSFORM HERE +! BY TRANSFORMING PAT_OUT INTO THE DESIRED SHAPE +! TRANSFORM DATA TO ADIABATIC REPRESANTATION. + +! Copy x vector from first entry. +! Compare all others to first. + if (yval_count.eq.1) then + pat_in(1:inp_in,pat_count)=xtest(1:inp_in) + else if ( + > any(xtest(1:inp_in).ne.pat_in(1:inp_in,pat_count)) + > ) then + write(6,421) pat_count, line + write(6,'(A)') '(x values inconsistent with ' + > //'previous line)' + stop ec_read + endif + + cycle + 510 write(6,419) pat_count + stop ec_read + 513 write(6,421) pat_count, line + write(6,'(A)') 'LINE DUMP:' + write(6,'(A)') trim(in(line)(1:llen)) + stop ec_read + enddo + +! Did the data file end abruptly? + if (yval_count.ne.inp_out) then + write(6,419) pat_count + write(6,'(A)') '(Unexpected EOF)' + stop ec_read + endif + +! pat_count is now actual number of patterns + + if (pat_count.le.0) then + write(6,419) 1 + stop ec_read + else if (npat.le.0) then +! set npat dynamically + npat=pat_count + else if (npat.ne.pat_count) then + write(6,420) npat,pat_count + stop ec_read + endif + +! Rescale weights based on a predefined scheme + call mkweights(wterr,npat,pat_out) +! Split current dataset into actual fitting sets and reference + call mkrefset_tail(pat_in,pat_out,ref_in,ref_out,npat,nref) + + norm=0.0D0 +! normalize weights of fitting data + do k=1,npat + do j=1,inp_out + wterr(j,k)=dabs(wterr(j,k)) + norm=norm+wterr(j,k) + enddo + enddo + do k=1,npat + wterr(1:inp_out,k)=wterr(1:inp_out,k)/norm + enddo + + norm=0.0D0 +! normalize weights of reference data + do k=npat+1,npat+nref + do j=1,inp_out + wterr(j,k)=dabs(wterr(j,k)) + norm=norm+wterr(j,k) + enddo + enddo + do k=npat+1,npat+nref + wterr(1:inp_out,k)=wterr(1:inp_out,k)/norm + enddo + + 417 format('ERROR: CORRUPTED WEIGHT INPUT (SET #',I9,')') + 418 format('ERROR: NPAT EXCEEDING MAXPATS (',I9,' vs.',I9,')') + 419 format('ERROR: INCOMPLETE OR MISSING DATA SET. SET #',I9) + 420 format('ERROR: NUMBER OF DATA POINTS INCONSISTENT WITH NPAT CARD', + > '(',I9,' vs.',I9,')') + 421 format('ERROR: CORRUPTED DATA POINT INPUT (SET #',I9,', LINE,', + > I9,')') + + end + +!--------------------------------------------------------------------------- + + subroutine infer_npat(infile,dat_start,linenum,npat,llen) + use nn_params + use nncommons + use io_parameters, only: nstat,nmeta,maxoutp,dnlen,maxlines, + > maxdat,clen,klen,maxkeys,maxerrors,mprun + use nndbg_mod + implicit none +! Count the number of input patterns the DATA block has if it is +! free of errors. No safety checks are done here as they are done +! later. + + + double precision pat_in(maxnin,maxpats),pat_out(maxpout,maxpats) + double precision ref_in(maxnin,maxpats),ref_out(maxpout,maxpats) + double precision wterr(maxpout,maxpats) + integer npat,nref,dat_start,linenum,llen + character infile(*)*(llen) + + double precision norm + double precision xtest(maxnin) + integer pat_count,line,line_count + logical dvecne + + integer k,j + + pat_count=0 + line=dat_start !count lines + line_count=0 + + do line=dat_start,linenum + if (in(line)(1:3).eq.'WT:') then + cycle + else + line_count=line_count+1 + endif + enddo + + pat_count=line_count/inp_out + +! set npat dynamically + npat=pat_count + if (npat.gt.maxpats) then + write(6,500) npat,maxpats + stop ec_dimrd + endif + + 500 format('ERROR: NPAT EXCEEDING MAXPATS (',I9,' vs.',I9,')') + + end diff --git a/src/parser/parse_errors.f b/src/parser/parse_errors.f new file mode 100644 index 0000000..51eeb79 --- /dev/null +++ b/src/parser/parse_errors.f @@ -0,0 +1,154 @@ + module parse_errors + implicit none + + contains + +!-------------------------------------------------------------------------------- + + subroutine signal_p_error(key_id,msg) +! Signal generic error with user-defined message MSG. + use nn_params + use nncommons, only: keylist + implicit none + + + integer key_id + character*(*) msg + + write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id)) + > // ' ' // trim(msg) + stop 1 + + end subroutine + +!-------------------------------------------------------------------------------- + + subroutine signal_dim_error(key_id,msg_code,value,expval) +! Signals errors where one specific dimensioning value is ill-set. +! If the optional parameter EXPVAL is given, return it as expected +! dimensioning value. + use nn_params + use nncommons, only: keylist,errcat + implicit none + + + integer key_id, msg_code, value + integer, optional :: expval + +! optional expval + + character*16 int2string + + write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id)) + > // ' ' // trim(errcat(msg_code)) + write(6,'(A)') 'OFFENDING VALUE: ' // trim(int2string(value)) + if (present(expval)) then + write(6,'(A)') 'EXPECTED: ' // trim(int2string(expval)) + endif + stop ec_dim + + end subroutine + +!-------------------------------------------------------------------------------- + + subroutine signal_log_error(key_id,msg_code,alt_key) +! Signals errors where contradictory settings are provided which +! the program cannot resolve. If the optional parameter ALT_KEY +! is given, name the explicit key current settings clash with. + use nn_params + use nncommons, only: keylist,errcat + implicit none + + + integer key_id + integer, optional :: alt_key + integer msg_code + +! optional expval + + write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id)) + > // ' ' // trim(errcat(msg_code)) + if (present(alt_key)) then + write(6,'(A)') 'OFFENDING KEY: ' // trim(keylist(1,alt_key)) + endif + + stop ec_log + + end subroutine + +!-------------------------------------------------------------------------------- + + subroutine signal_val_error(key_id,msg_code,value,expval) +! Signals errors where a given value makes no sense in it's given context. +! If the optional parameter EXPVAL is given, return it as expected +! dimensioning value. + use nn_params + use nncommons, only: keylist,errcat + implicit none + + + integer key_id, msg_code, value,expval + + optional expval + + character*16 int2string + + write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id)) + > // ' ' // trim(errcat(msg_code)) + write(6,'(A)') 'OFFENDING VALUE: ' // trim(int2string(value)) + if (present(expval)) then + write(6,'(A)') 'EXPECTED: ' // trim(int2string(expval)) + endif + stop ec_read + + end subroutine + +!-------------------------------------------------------------------------------- + + subroutine signal_dval_error(key_id,msg_code,value,expval) +! Signals errors where a given value makes no sense in it's given context. +! If the optional parameter EXPVAL is given, return it as expected +! dimensioning value. + use nn_params + use nncommons, only: keylist,errcat + implicit none + + + integer key_id + double precision value,expval + integer msg_code + + optional expval + + character*16 shortdble2string + + write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id)) + > // ' ' // trim(errcat(msg_code)) + write(6,'(A)') 'OFFENDING VALUE: ' + > // trim(shortdble2string(value)) + if (present(expval)) then + write(6,'(A)') 'EXPECTED: ' // trim(shortdble2string(expval)) + endif + stop ec_read + + end subroutine + end module + +!-------------------------------------------------------------------------------- + + subroutine signal_meta_error(key_id,msg_code) +! Signals errors where a key (or key combinations) is/are not +! supported or maintained for reasons outside of the program's +! scope (e.g.: deprecation). + use nn_params + use nncommons, only: keylist,errcat + implicit none + + + integer key_id,msg_code + + write(6,'(A)') 'ERROR: ' // trim(keylist(1,key_id)) + > // ' ' // trim(errcat(msg_code)) + stop ec_read + + end subroutine diff --git a/src/parser/parser.f b/src/parser/parser.f new file mode 100644 index 0000000..974c093 --- /dev/null +++ b/src/parser/parser.f @@ -0,0 +1,1641 @@ + + subroutine read_input(wterr,par,act,seed,nset, + > spread,lrnd,dry_run,npat,nref, + > pat_in,pat_out,ref_in,ref_out, + > typop,laystr,weistr,nlay, + > rmsopt,mingrad,minwbstep,freeze) + use parse_errors + use nn_params + use nncommons + use io_parameters + use nndbg_mod + implicit none + + +! input variables + double precision, intent(out) :: par(wbcap,maxset) + double precision, intent(out) :: spread(wbcap) + double precision, intent(out) :: wterr(maxpout,maxpats) + integer, intent(out) :: act(wbcap) + integer, intent(out) :: nset + integer, intent(out) :: seed + logical, intent(out) :: freeze,lrnd + +! ANN specific input variables + double precision, intent(out) :: rmsopt,mingrad,minwbstep + double precision, intent(out) :: pat_in(maxnin,maxpats) + double precision, intent(out) :: pat_out(maxpout,maxpats) + double precision, intent(out) :: ref_in(maxnin,maxpats) + double precision, intent(out) :: ref_out(maxpout,maxpats) + integer typop(maxtypes,maxlay),laystr(3,maxlay) + integer weistr(2,maxlay,2) + integer nlay + integer npat,nref + logical dry_run + character*(clen) record_argument + +! internal variables + double precision rdum(1),gspread,valper + integer maxnref + integer key_id,dat_start + integer npat_key + integer linenum + integer chunk_num, chunk_size + integer neupop(maxlay) + integer nnkeynum + character*2048 errmsg + character*(dnlen) datnam + character*(klen) nnkeylist(2,maxnnkeys) + character*(llen), dimension(:), allocatable :: infile + + integer fmtlen + parameter (fmtlen=8) + character*(fmtlen) dblefmt + character*(dnlen+16) dbgdatnam + parameter (dblefmt='(ES12.4)') + +! data arrays + integer idat + double precision ddat + character*(clen) cdat + + allocatable idat(:),ddat(:),cdat(:) + + + integer j,k + + + allocate(infile(maxlines)) + allocate(idat(maxdat)) + allocate(ddat(maxdat)) + allocate(cdat(maxdat)) + include 'keylist.incl' !this defines all special input keys + include 'errcat.incl' !this defines generic parser error messages +!############################################################ +! Read input file +!############################################################ + + call get_datfile(datnam,dnlen) + + if (dbg) then + write(6,'(A)') 'Converting data file to internal format..' + endif + + call internalize_datfile(datnam,infile,linenum,llen,maxlines, + > dnlen) + + if (dbg.or.vbs) then + dbgdatnam=' ' + dbgdatnam='.internal_'//datnam + write(6,'(A)') 'Writing internalized version of input to ''' + > // trim(dbgdatnam) // '''..' + open(nnunit,file=trim(dbgdatnam)) + do j=1,linenum + write(nnunit,'(A)') trim(infile(j)) + enddo + close(nnunit) + write(6,'(A)') ' Parsing keys..' + endif + + call keyread(keylist,infile,keynum,idat,ddat,cdat,datpos, + > klen,llen,clen,linenum,maxdat) + + if (dbg) then + write(6,'(A)') 'Done.' + endif + + +!############################################################ +! Read individual keys +!############################################################ + +!************************************************************************ +! DATA: +!************************************************************************ +! This card separates the data to be fitted from the rest of the +! file. +!************************************************************************ + key_id=1 +! Find where in the input file the DATA:-block begins and +! exclude the line of the card itself + dat_start=datIdx(2,key_id) + +!************************************************************************ +! SEED: +!************************************************************************ +! Random seed for the RNG. +!************************************************************************ + key_id=2 + seed=8236475 + + if (is_present(key_id)) then + seed=idat(datIdx(1,key_id)) + endif + + if (seed.lt.10**5) then + call signal_val_error(key_id,5,seed) + endif + + write(6,'("Random seed set to: ",I12)') seed + + seed=-iabs(seed) +! initialize RNG + call vranf(rdum,0,seed,iout) + +!************************************************************************ +! NSET: +!************************************************************************ +! The number of ANNs to be fitted. +!************************************************************************ + key_id=3 + nset=1 + + if (is_present(key_id)) then + nset=idat(datIdx(1,key_id)) + endif + + if (nset.gt.maxset) then + call signal_dim_error(key_id,2,nset) + endif + + write(6,'("Number of parameter sets: ",I12)') nset + +!************************************************************************ +! SETS: +!************************************************************************ +! Number of seperatly grouped geometries. +! With more than one argument, total sets = sum of all entries. +!************************************************************************ + key_id=4 + sets=1 + + if (is_present(key_id)) then + sets=idat(datIdx(1,key_id)) + do j=2,datlen(key_id) + sets=sets+idat(datIdx(j,key_id)) + enddo + endif + + if (sets.gt.maxpats) then + call signal_dim_error(key_id,2,sets) + endif + + write(6,'("Number of data sets: ",I12)') sets + +!************************************************************************ +! NPAT: +!************************************************************************ + key_id=5 + npat_key=key_id + + if (is_present(key_id)) then + npat=idat(datIdx(1,key_id)) + if (npat.eq.0) then + call signal_val_error(key_id,1,npat) + endif + write(6,'("Total number of indiv. data points: ",I12)') + > npat + else + write(6,'(A)') 'Data point number will be inferred from ' + > // 'input.' +! set negative value to express undefined state + npat=-1 + endif + + if (npat.gt.maxpats) then + call signal_dim_error(key_id,2,npat) + endif + +!************************************************************************ +! NPOINTS: +!************************************************************************ + key_id=6 + ndata=0 + ndata(1)=npat + + if (is_present(key_id)) then + if (datlen(key_id).ne.sets) then + call signal_dim_error(key_id,3,datlen(key_id),sets) + endif + do j=1,sets + ndata(j)=idat(datIdx(j,key_id)) + enddo + if (npat.eq.-1) then + npat=sum(ndata(1:sets)) + write(6,'("Total number of indiv. data points: ",I12)') + > npat + else if (sum(ndata(1:sets)).ne.npat) then + call signal_dim_error(key_id,3,sum(ndata(1:sets)),npat) + endif + else + if (sets.ne.1) then + call signal_dim_error(key_id,3,1,sets) + else if (npat.eq.-1) then + write(6,'(A)') 'WARNING: NPOINTS: and NPAT: missing. ' + > // 'Number of data points will be inferred ' + > // 'from DATA: block.' +! !?FIXME: I cleaned up some code for this. + stop 1 + endif + write(6,'(A)') 'Points will not be arranged to sets.' + endif + +!************************************************************************ +! VALIDATION: +!************************************************************************ +! Number of points (out of the number given by NPAT:) to constitute +! the reference data set. This particular data set is not used for +! fitting explicitly, but implicitly: For each successful MQL step +! the deviation from the validation set is evaluated and compared to +! the last successful step. If the validation set does not improve +! along the fitting data points, the algorithm may terminate. +! +! If convergence is reached this way, the corresponding fit will be +! marked with the tag "#CONVERGED [REF]" in performance.log. +! See also: +! +! VALPER: +!************************************************************************ + key_id=7 + nref=0 + + if (is_present(key_id)) then + nref=idat(datIdx(1,key_id)) + endif + +! check nref, unless npat is inferred later + if ((npat.gt.0).and.(nref.ge.npat)) then + call signal_dim_error(key_id,6,nref) + endif + + if (is_present(key_id,.true.)) then + write(6,'("Number of reference data points: ",I12)') + > nref + endif + +!************************************************************************ +! RANDOM: +!************************************************************************ +! If present, generate parameters using the random number generator. +! The number of parameters is determined by NSET:. +! +! See also: +! NSET: +! SEED: +! FREEZE: +!************************************************************************ + key_id=8 + lrnd=is_present(key_id,.true.) + + if (lrnd) then + write(6,'(A)') 'RANDOM: Random parameters will be chosen.' + else + write(6,'(A)') 'RANDOM: not found. Ignoring NSET:.' + nset=1 + endif + +!************************************************************************ +! FREEZE: +!************************************************************************ +! Instead of fitting, compute the error of a given parameter set, +! run all available analysis and statistics routines and exit. +! Together with RANDOM: analysis tools are run on a randomly +! generated parameter set. +! +! See also: +! RANDOM: +!************************************************************************ + key_id=9 + freeze=is_present(key_id,.true.) + + if (freeze) then + write(6,'(A)') 'FREEZE: All parameters frozen.' + endif + if (freeze .and. lrnd) then + write(6,'(A)') 'FREEZE: & RANDOM: DISPLAYING RANDOMLY' + > // ' GENERATED PARAMETER SET.' + nset=1 + endif + if ((.not.freeze) .and. (.not.lrnd)) then + write(6,'(A)') 'FREEZE: & RANDOM: neither found. ' + > // 'Read single ANN and fit.' + endif + +!************************************************************************ +! DRYRUN: +!************************************************************************ +! Read network parameters, run model for each point and exit. +! The weighted rms is computed, but ignored. +! +! This may be useful if the specific model has useful side effects, +! but makes no sense to fit (for example, input processing or +! debugging). This card implies FREEZE: for consistency reasons, +! but all except for the barest minimum of routines normally invoked +! by FREEZE: will be skipped. +! +! See also: +! FREEZE: +!************************************************************************ + key_id=10 + dry_run=is_present(key_id,.true.) + + if (dry_run.and.(.not.freeze)) then + write(6,'(A)') 'DRYRUN: ' + > // 'FREEZE: not found. ' + > // 'Parameters are frozen regardless.' + freeze=.true. + endif + if (dry_run) then + write(6,'(A)') 'DRYRUN: Skipping fit and all enabled tools.' + endif + +!************************************************************************ +! RECORD: +!************************************************************************ +! Write to or read from a parameter record (.rec) file. +! +! This file contains parameter sets which will be used instead of +! randomly generated parameters. Consequently, this key overrides +! RANDOM:. The key takes one string argument. The following +! arguments are legal (case does not matter): +! +! read Reads from the default .rec file. +! overwrite Writes the default .rec file (destructively). +! write Writes a .rec file, by default the default file. +! If that file already exists, it tries to write +! a numerical alternative file (_01.rec,...) instead. +! +! The default file corresponds to the value of the parameter +! nnrecfile, with '.rec' appended to it. Currently there is no way +! to specify an alternate filename for reading. +! +! Which keyword was chosen is stored in the variable record_state. +! The possible values are stored in constants of the same name as +! the corresponding keyword, prefixed with "record_". +!************************************************************************ + key_id=11 + use_record=is_present(key_id,.true.) + record_state=record_read + + if (use_record) then + record_argument=adjustl(cdat(datIdx(1,key_id))) + if (index(record_argument,'overwrite').eq.1) then + write(6,'(A)') 'RECORD: OVERWRITE: ' + > // 'Writing finished parameter sets destructively.' + record_state=record_overwrite + else if (index(record_argument,'write').eq.1) then + write(6,'(A)') 'RECORD: WRITE: ' + > // 'Writing finished parameter sets.' + record_state=record_write + else if (index(record_argument,'read').eq.1) then + write(6,'(A)') 'RECORD: READ: ' + > // 'Reading parameter sets.' + record_state=record_read + if (lrnd) then + write(6,'(A)') 'RECORD: & RANDOM: key present. ' + > // 'Ignored, reading record instead.' + lrnd=.false. + endif + else if (index(record_argument,'update').eq.1) then + write(6,'(A)') 'RECORD: UPDATE: ' + > // 'Reading parameter sets and overwriting ' + > // 'the current record.' + record_state=record_update + if (lrnd) then + write(6,'(A)') 'RECORD: & RANDOM: key present. ' + > // 'Ignored, reading record instead.' + lrnd=.false. + endif + else + errmsg='Unknown argument: '''//trim(record_argument)//'''' + call signal_p_error(key_id,errmsg) + endif + endif + +!************************************************************************ +! NLAY: +!************************************************************************ +! Number of layers the neural network is supposed to have, including +! input- and output layer. +!************************************************************************ + key_id=12 + nlay=idat(datIdx(1,key_id)) + + if (nlay.lt.2) then + call signal_dim_error(key_id,1,nlay) + else if (nlay.gt.maxlay) then + call signal_dim_error(key_id,2,nlay) + endif + + write(6,'("Number of Layers:",I4)') nlay + +!************************************************************************ +! NEUPOP: +!************************************************************************ +! Neuronal population, meaning the number of neurons per layer. +! The general format is +! NEUPOP: #I #H1 #H2 .. #O +! where #I/O is the number of input and output neurons, +! #Hj the number of hidden layer neurons in the jth hidden layer. +!************************************************************************ + key_id=13 + + if (datlen(key_id).ne.nlay) then + call signal_dim_error(key_id,3,datlen(key_id)) + endif + + do j=1,nlay + neupop(j)=idat(datIdx(j,key_id)) + enddo + + if (neupop(1).gt.maxnin) then + call signal_dim_error(key_id,2,neupop(1)) + else if (neupop(nlay).gt.maxnout) then + call signal_dim_error(key_id,2,neupop(nlay)) + endif + + do j=2,nlay-1 + if (neupop(j).gt.maxneu) then + call signal_dim_error(key_id,2,neupop(j)) + endif + enddo + + do j=1,nlay + if (neupop(j).eq.0) then + call signal_dim_error(key_id,1,neupop(j)) + endif + enddo + + write(6,'(A)') 'Set neuronal population:' + write(6,'(100(I5,:,":"))') neupop(1:nlay) + + len_in=neupop(1) + len_out=neupop(nlay) + + write(6,'(A)') 'Initializing network structure..' + call mknet(laystr,weistr,neupop,nlay) + write(6,'(A)') 'Done.' + write(6,'("Total number of ANN weights and biases: ",I4)') + > weistr(2,nlay,2) + + write(6,'(A)') 'Generating automated ANN keys..' + call NNkeygen(nnkeylist,nnkeynum,nlay,(.not.lrnd)) + write(6,'(A)') 'Done.' + + write(6,'(A,I6)') 'Total number of parameters: ', weistr(2,nlay,2) + +!************************************************************************ +! TYPOP: +!************************************************************************ +! read type population card: +! Layout: +! TYPOP: Layer2 type 1, Layer2 type2,...,L3 t1, L3 t2,... +! Type information for the first layer +! (the input layer) is meaningless +! and therefor not required in input. +!************************************************************************ + key_id=14 + + typop=0 +! give input layer linear type for consistency + typop(1,1)=len_in + + if (datlen(key_id).ne.(maxtypes*(nlay-1))) then + call signal_dim_error(key_id,3,datlen(key_id)) + endif + + do j=1,nlay-1 + do k=1,maxtypes + typop(k,j+1)=idat(datSIdx2(k,j,maxtypes,key_id)) + enddo + enddo + + write(6,'(A)') 'Given type population:' + do j=1,nlay + write(6,'("Layer #",I3.3,":",10(I5,:))') j, typop(:,j) + if (sum(typop(:,j)).ne.neupop(j)) then + call signal_dim_error(key_id,4,sum(typop(:,j)),neupop(j)) + endif + enddo + + +!************************************************************************ +! OUTSHIFT: +!************************************************************************ +! ! DEPRECATED, USE ANN STATISTICS TO MANUALLY GENERATE THIS ! +!************************************************************************ + key_id=15 + +!************************************************************************ +! OUTSCALE: +!************************************************************************ +! ! DEPRECATED, USE ANN STATISTICS TO MANUALLY GENERATE THIS ! +!************************************************************************ + key_id=16 + +!************************************************************************ +! INPUTS: +!************************************************************************ +! Number of actual input coordinates before arbitrary coordinate +! transformation. This allows the inclusion of coordinates and +! information in the input the network does not "see". +!************************************************************************ + key_id=17 + + inp_in=len_in + + if (is_present(key_id,.true.)) then + inp_in=idat(datIdx(1,key_id)) + endif + + if (inp_in.gt.maxnin) then + call signal_dim_error(key_id,2,inp_in) + endif + if (inp_in.eq.0) then + call signal_dim_error(key_id,1,inp_in) + endif + + write(6,'(A,I4)') 'Number of input coordinates: ', inp_in + +!************************************************************************ +! OUTPUTS: +!************************************************************************ +! Number of actual output values per data point after evaluation of +! the arbitrary model taking the network output as input. +!************************************************************************ + key_id=18 + + inp_out=len_out + + if (is_present(key_id,.true.)) then + inp_out=idat(datIdx(1,key_id)) + endif + + if (inp_out.gt.maxpout) then + call signal_dim_error(key_id,2,inp_out) + else if (inp_out.eq.0) then + call signal_dim_error(key_id,1,inp_out) + endif + + write(6,'(A,I4)') 'Number of output values: ', inp_out + +!************************************************************************ +! (NO)MAXFAILS: +!************************************************************************ + key_id=19 + + maxfails=5 + + if (is_present(key_id+1,.true.)) then +! If NOMAXFAILS: is present, MAXFAILS: is ignored. +! set maxfails stupidly high + maxfails=iinfty + write(6,'(A)') 'NOMAXFAILS: Convergence testing ignores ' + > // 'number of failed MQL steps.' + else if (is_present(key_id)) then +! If REFFAILS: is present, set value + maxfails=idat(datIdx(1,key_id)) + write(6,'(A,I5)') 'MQL step failure threshold:', + > maxfails + else + write(6,'(A,I5)') 'Default MQL step failure threshold:', + > maxfails + endif + +!************************************************************************ +! (NO)REFFAILS: +!************************************************************************ + key_id=21 + + if (is_present(key_id+1,.true.)) then +! If NOREFFAILS: is present, REFFAILS: is ignored. +! set maxref_fails stupidly high + maxref_fails=iinfty + write(6,'(A)') 'Early stopping feature disabled.' + else if (is_present(key_id)) then +! If REFFAILS: is present, set value + maxref_fails=idat(datIdx(1,key_id)) + write(6,'(A,I5)') 'Reference data set failure threshold:', + > maxref_fails + else + maxref_fails=1 + write(6,'(A)') 'Early stopping will be strictly enforced.' + endif + +!************************************************************************ +! RNG: +!************************************************************************ +! ! DEPRECATED ! +!************************************************************************ + key_id=23 + +!************************************************************************ +! MICIT: & MAXBPIT: +!************************************************************************ +! For legacy compatibility, these two keys are synonymous. +! MAXBPIT: will overwrite any present MICIT: card. +!************************************************************************ + key_id=24 + + maxbpit=600 + + if (is_present(key_id+1)) then + maxbpit=idat(datIdx(1,key_id+1)) + else if (is_present(key_id)) then + maxbpit=idat(datIdx(1,key_id)) + endif + + write(6,'(A,I5)') 'Maximum number of MQL micro iterations:', + > maxbpit + + +!************************************************************************ +! GSPREAD: +!************************************************************************ + key_id=26 + + gspread=1.d0 + + if (is_present(key_id)) then + gspread=ddat(datIdx(1,key_id)) + endif + + write(6,'("General parameter spread set to: ",ES12.2)') gspread + +!************************************************************************ +! WSPREAD: +!************************************************************************ + key_id=27 + + wspread=gspread + + if (is_present(key_id)) then + wspread=ddat(datIdx(1,key_id)) + endif + + write(6,'("General weight matrix spread set to: ",ES12.2)') + > wspread + +!************************************************************************ +! BSPREAD: +!************************************************************************ + key_id=28 + + bspread=gspread + + if (is_present(key_id)) then + bspread=ddat(datIdx(1,key_id)) + endif + + write(6,'("General bias vector spread set to: ",ES12.2)') + > bspread + +!************************************************************************ +! UNIT2UNIT: cards +!************************************************************************ +! Convert internal units (assumed ha) to some external +! unit. UCUSTOM:, while currently not implemented, will +! allow custom unit names and conversion factors. +!************************************************************************ + key_id=29 + + unit_con=1.0d0 + unit_string='ha' + + if (is_present(key_id,.true.)) then +! HART2EV: + unit_con=hart2eV + unit_string='eV' + else if (is_present(key_id+1,.true.)) then +! HART2ICM + unit_con=hart2icm + unit_string='icm' + else if (is_present(key_id+2,.true.)) then +! ARBUNITS: + unit_con=ddat(datIdx(1,key_id+2)) + unit_string='a.u.' + else if (is_present(key_id+3,.true.)) then +! UCUSTOM: + if (datlen(key_id).ne.2) then + call signal_dim_error(key_id,3,datlen(key_id),2) + endif + unit_string=trim(cdat(datIdx(2,key_id))) + read(cdat(datIdx(1,key_id)),*,err=301,end=301) unit_con + goto 302 + errmsg='Non-numeric unit conversion factor: "' + > //trim(cdat(datIdx(1,key_id)))//'"' + 301 call signal_p_error(key_id,errmsg) + else + write(6,'(A)') 'No unit specifyer found. Assuming Hartree.' + endif + + 302 write(6,'(A)') 'External units set to: ' // unit_string + write(6,'(A,ES14.6)') 'Unit conversion factor: ', unit_con + + +!************************************************************************ +! RMSOPT: +!************************************************************************ +! If set, consider a fit below the given threshold as converged. +!************************************************************************ + key_id=33 + + rmsopt=-1.0d0 + + if (is_present(key_id)) then + rmsopt=ddat(datIdx(1,key_id)) + write(6,'("Converged RMSE threshold: ",ES12.2,X,A)') + > rmsopt, trim(unit_string) + rmsopt=rmsopt/unit_con + else + write(6,'(A)') 'Convergence testing ingores RMSE.' + endif + + +!************************************************************************ +! MINGRAD: +!************************************************************************ + key_id=34 + + mingrad=1.0d-4 + + if (is_present(key_id)) then + mingrad=ddat(datIdx(1,key_id)) + endif + + write(6,'("Converged gradient threshold: ",ES12.2,X,A)') + > mingrad, trim(unit_string) + + mingrad=mingrad/unit_con + +!************************************************************************ +! MINWBSTEP: +!************************************************************************ + key_id=35 + + minwbstep=1.0d-4 + + if (is_present(key_id)) then + minwbstep=ddat(datIdx(1,key_id)) + endif + + write(6,'("Converged step length threshold: ",ES12.2)') + > minwbstep + + minwbstep=minwbstep + +!************************************************************************ +! SELECT: +!************************************************************************ +! ! DEPRECATED ! +!************************************************************************ + key_id=36 + +!************************************************************************ +! ECHO: +!************************************************************************ +! Read an arbitrary amount of text from input and display it +! (stdout). This key can be used to document the specific context +! of a fit. Each argument corresponds to one written line. All +! lines produced by echo will be prefixed by the character sequence +! "#>", making them easily grepable. +!************************************************************************ + key_id=37 + + if (is_present(key_id,.true.)) then + write(6,'(A)') "ECHO: Printing message.." + write(6,asline) + do j=1,datpos(3,key_id) + write(6,'(A)') "#> " // trim(cdat(datIdx(j,key_id))) + enddo + write(6,asline) + endif + +!************************************************************************ +! ERRCUT: +!************************************************************************ +! Evaluate an unweighted rms error of all outputs that lie below a +! given threshold depending on the output. Unlike most input values, +! these are assumed to be in *internal units*, meaning no conversion +! takes place. +!************************************************************************ + + key_id=38 + showcut=is_present(key_id,.true.) + + if (showcut) then + if (datlen(key_id).ne.inp_out) then + call signal_dim_error(key_id,3,datlen(key_id),inp_out) + endif + do j=1,inp_out + cutoff(j)=ddat(datIdx(j,key_id)) + enddo + write(6,'(A)') 'Cutoff values [i.u.] set to:' + call printvec_full(cutoff,dblefmt,fmtlen,inp_out,5) + endif + +!************************************************************************ +! CUTWT: +!************************************************************************ + key_id=39 + + if (showcut.and.is_present(key_id)) then + if (datlen(key_id).ne.inp_out) then + call signal_dim_error(key_id,3,datlen(key_id),inp_out) + endif + do j=1,inp_out + cutwei(j)=ddat(datIdx(j,key_id)) + enddo + write(6,'(A)') 'Cutoff weighting scheme set to:' + call printvec_full(cutwei,dblefmt,fmtlen,inp_out,5) + else if (showcut) then + write(6,'(A)') 'No weighting between cut output errors.' + cutwei=1.0d0 + endif + +!************************************************************************ +! INSHIFT: +!************************************************************************ +! It is usually preferrable for the network to have input values +! within an approximate range of [-1,1] as opposed to values of +! arbitrary size. Hence input values are usually normalized to +! accomodate for that. See also: +! +! INSCALE: +! NORMINP: +!************************************************************************ + key_id=40 + + pres_inp=is_present(key_id,.true.) + shift_in=0.0d0 + + if (is_present(key_id,.true.)) then + if (datlen(key_id).ne.len_in) then + call signal_dim_error(key_id,4,datlen(key_id),len_in) + endif + do j=1,len_in + shift_in(j)=ddat(datIdx(j,key_id)) + enddo + write(6,'(A)') 'Given input shift: ' + call printvec_full(shift_in,dblefmt,fmtlen,len_in,5) + endif + +!************************************************************************ +! INSCALE: +!************************************************************************ +! It is usually preferrable for the network to have input values +! within an approximate range of [-1,1] as opposed to values of +! arbitrary size. Hence input values are usually normalized in +! analogy to OUTSCALE:. See also: +! +! INSHIFT: +! NORMINP: +!************************************************************************ + key_id=41 + + pres_inp=(pres_inp.or.(is_present(key_id,.true.))) + fact_in=1.0d0 + + if (is_present(key_id,.true.)) then + if (datlen(key_id).ne.len_in) then + call signal_dim_error(key_id,4,datlen(key_id),len_in) + endif + do j=1,len_in + fact_in(j)=ddat(datIdx(j,key_id)) + enddo + write(6,'(A)') 'Given input scaling: ' + call printvec_full(fact_in,dblefmt,fmtlen,len_in,5) + endif + +!************************************************************************ +! NORMINP: +!************************************************************************ +! Disregard INSCALE: and INSHIFT: and evaluate them from input data +! using mean and standard deviation +! +! The lack of both INSCALE and INSHIFT is +! treated the same as the presence of NORMINP: +! See also: +! +! INSHIFT: +! INSCALE: +!************************************************************************ + key_id=42 + pres_inp=(pres_inp.and.(.not.is_present(key_id,.true.))) + + if (is_present(key_id,.true.)) then + write(6,'(A)') 'NORMINP: Input coordinates will be' + > // ' (re-)normalized.' + else if (.not.pres_inp) then + write(6,'(A)') 'INSHIFT & INSCALE: Neither cards found.' + > // ' Input will be (re-)normalized.' + endif + +!************************************************************************ +! ZERO: +!************************************************************************ +! If present, this key sets all ANN parameters to 0, ingnoring the +! actually given input parameters, if present. This card implicitly +! sets FREEZE:, if it has not been set already. +! See also: +! +! FREEZE: +!************************************************************************ + key_id=43 + zero_par=is_present(key_id,.not.freeze) + + if (zero_par) then + if (lrnd) then + errmsg='Card incompatible with RANDOM:.' + call signal_p_error(key_id,errmsg) + else if (use_record) then + errmsg='Card incompatible with RECORD:.' + call signal_p_error(key_id,errmsg) + endif + if ((.not. freeze) .and. zero_par) then + write(6,'(A)') 'ZERO: ' + > // 'FREEZE: not found. ' + > // 'Parameters are frozen regardless.' + freeze=.true. + endif + + write(6,'(A)') 'ZERO: Input parameters ignored, ' + > // 'setting all parameters to 0.' + endif + +!************************************************************************ +! VALPER: +!************************************************************************ +! Number of validation data points relative to total number +! of points, given as float between 0 (0%) and 1 (100%). +! Points will be rounded down to not split data sets. +! If VALIDATION: is present, this key takes higher priority. +! See also: +! +! VALIDATION: +!************************************************************************ + key_id=44 + + if (is_present(key_id,.true.).and.(sets.eq.1)) then + valper=ddat(datIdx(1,key_id)) + + write(6,'(A,F7.2,"%")') 'VALPER: Relative amount of ' + > // 'data points used for validation:', 100.0d0*valper + + nref=floor(dble(npat)*valper) + else if (is_present(key_id,.true.)) then +! Round down to nearest full data set + valper=ddat(datIdx(1,key_id)) + maxnref=floor(dble(npat)*valper) + nref=0 + + do j=sets,1,-1 + nref=nref+ndata(j) + if (nref.gt.maxnref) then + nref=nref-ndata(j) + write(6,'(A,I6.6)') 'Rounded percentage down to' + > // ' nearest data set: #',j+1 + nbr_fit_set=j ! define the number of fit set JP + exit + endif + enddo + + valper=dble(nref)/dble(npat) + write(6,'(A,F7.2,"%")') 'Actual relative amount of ' + > // 'data points used for validation:', 100.0d0*valper + endif + + if (nref.ge.npat) then + call signal_dim_error(key_id,6,nref) + endif + + write(6,'("Number of reference data points: ",I12)') nref + write(6,'("Number of fitting data points:",I12)') npat-nref + +!************************************************************************ +! NOINPNORM: +!************************************************************************ +! ! DEPRECATED ! +!************************************************************************ + key_id=45 + norm_inp=.true. + +!************************************************************************ +! RUNCHUNK: +!************************************************************************ +! Instead of attempting a complete fit, run only a subset ("chunk"). +! The first key argument is the chunk number (starting from one), +! the second is the size of each chunk. +!************************************************************************ + key_id=46 + + from_fit=1 + to_fit=nset + if (is_present(key_id,.true.)) then + chunk_num=idat(datIdx(1,key_id)) + chunk_size=idat(datIdx(2,key_id)) + if (chunk_num.eq.0) then + call signal_val_error(key_id,5,chunk_num) + else if (chunk_size.eq.0) then + call signal_val_error(key_id,5,chunk_size) + endif + from_fit=min(1+(chunk_num-1)*chunk_size,nset) + to_fit=min(chunk_num*chunk_size,nset) + write(6,'("RUNCHUNK: Only run fit #",I4.4," to #",I4.4)') + > from_fit,to_fit + endif + +!************************************************************************ +! RUNFROM: & RUNTO: +!************************************************************************ +! Instead of attempting a complete fit, run only a subset. RUNFROM: +! specifies the beginning of the subset (inclusive), RUNTO: the end. +! +! This overrides RUNCHUNK:. +!************************************************************************ + key_id=47 + if (is_present(key_id,.true.)) then + from_fit=idat(datIdx(1,key_id)) + if (from_fit.eq.0) then + call signal_val_error(key_id,5,from_fit) + else if (from_fit.gt.nset) then + call signal_val_error(key_id,2,from_fit) + endif + endif + key_id=48 + if (is_present(key_id,.true.)) then + to_fit=idat(datIdx(1,key_id)) + if (from_fit.eq.0) then + call signal_val_error(key_id,5,to_fit) + else if (to_fit.gt.nset) then + call signal_val_error(key_id,2,to_fit) + endif + endif + +!************************************************************************ +! LEGACY-WT: +!************************************************************************ +! Fallback to legacy mode for WT:-card reading. +! Instead of expecting one WT:-card for each data point, the parser +! expects one per output value, meaning roughly speaking "every +! second line". +! +!************************************************************************ + key_id=49 + legacy_wt=is_present(key_id,.true.) + + if (legacy_wt) then + write(6,'(A)') 'LEGACY-WT: WT: cards are read in legacy mode.' + endif + +!************************************************************************ +! INCLUDE-DATA: +!************************************************************************ +! Instead of reading the DATA: block, ignore it and read from the +! specified input file instead. +! +! This card is not yet implemented. +!************************************************************************ + key_id=50 + + if (is_present(key_id,.true.)) then + write(6,'(A)') 'INCLUDE-DATA: NOT IMPLEMENTED.' + stop + endif + +!************************************************************************ +! NOSCANWALK: +!************************************************************************ +! Instead of mapping scans to the unit interval [0,1] for plotting, +! dump the full coordinate vector. +!************************************************************************ + key_id=51 + walk_scan=.true. + + if (is_present(key_id,.true.)) then + write(6,'(A)') 'NOSCANWALK: Dumping full coordinate ' + > // 'vector to plotfiles.' + walk_scan=.false. + endif + +!************************************************************************ +! LAMBDA: +!************************************************************************ +! Initial Marquardt-Levenberg parameter lambda. +!************************************************************************ + key_id=52 + lambda_initial=1.0D-2 + + if (is_present(key_id)) then + lambda_initial=ddat(datIdx(1,key_id)) + write(6,'(A)') 'LAMBDA: Adjusted initial Marquardt-Levenberg ' + > // 'parameter' + write(6,'(A,ES12.2)') 'New value:', lambda_initial + else + write(6,'(A,ES12.2)') 'Set initial Marquart-Levenberg ' + > // 'parameter to:', lambda_initial + endif + + +!************************************************************************ +! MQFACT: +!************************************************************************ +! Factor by which Marquardt-Levenberg parameter is +! increased/decreased. +!************************************************************************ + key_id=53 + mqfact_default=(10.0D0)**(1.0d0/6.0d0) + + if (is_present(key_id,.true.)) then + mqfact_default=ddat(datIdx(1,key_id)) + write(6,'(A,SP,F4.2,A)') 'MQFACT: MQL-factor set to: 10**(', + > dlog10(mqfact_default),')' + if (mqfact_default.lt.1.0d0) then + call signal_dval_error(key_id,1,mqfact_default) + endif + endif + +!************************************************************************ +! NDIAB: +!************************************************************************ +! Size of diabatic space = lenght of adiabatic energies +!************************************************************************ + key_id=54 + ndiab = idat(datIdx(1,key_id)) + write(6,'(A,I9)') "Setting ndiab to:", ndiab + + + +!############################################################ +! Read autogenerated keys and data section +!############################################################ + + call parse_autokeys(nnkeylist,infile,nnkeynum,linenum, + > par,act,spread, + > weistr,nlay, + > lrnd,zero_par) + + call nndata(infile,pat_in,pat_out,ref_in,ref_out,wterr,dat_start, + > linenum,npat,nref,llen) + + deallocate(infile) + deallocate(idat) + deallocate(ddat) + deallocate(cdat) + +!-------------------------------------------------------------------------------- + contains +!-------------------------------------------------------------------------------- +! Here follow convenience functions defined for this subroutine only. + + integer function datIdx(j,key_id) + use nncommons, only: datpos + implicit none +! Locate Jth value of KEY_IDth data block on *dat vector(s). + + + integer j,key_id + + integer IdxShift + + datIdx=IdxShift(j,datpos(2,key_id)) + end function + +!-------------------------------------------------------------------------------- + + integer function datSIdx2(j,k,rowdim,key_id) + use nncommons, only: datpos + implicit none +! Locate matrix element M(J,K) of matrix on KEY_IDth data block on +! *dat vector(s). + + + integer j,k,key_id + integer rowdim + + integer IdxShift,SIndex2 + + datSIdx2=IdxShift(SIndex2(j,k,rowdim),datpos(2,key_id)) + end function + +!-------------------------------------------------------------------------------- + + logical function is_present(key_id,quiet) + use nncommons, only: datpos,keylist + implicit none +! Checks whether optional key has been given in input file. +! If optional argument QUIET is missing or false, print a message +! if the key wasn't found. + + integer key_id + logical quiet + optional quiet + + + is_present=(datpos(2,key_id).ne.-1) + + if (present(quiet)) then + if(quiet) return + endif + if (.not.is_present) then + write(6,'(A)') 'No '//trim(keylist(1,key_id))//' card found.' + endif + + end function + +!---------------------------------------------------------------------------------- + + integer function datlen(key_id) + implicit none + integer key_id + datlen=datpos(3,key_id) + end function + + end subroutine + +!--------------------------------------------------------------------------- + + subroutine nndata(in,pat_in,pat_out,ref_in,ref_out,wterr,st,lauf, + > npat,nref,sl) + use data_transf_mod, only: data_transform + use nn_params + use nncommons + use io_parameters + use nndbg_mod + implicit none +! Routine reading DATA-block. +! If npat is nonzero, only the first npat pattern pairs are read. +! +! in: input file as string vector +! in(n) nth line of input file +! lauf: number of lines in input file +! st: starting position of DATA-block +! sl: maximum length of a single input line +! +!.....ANN-specific variables +! nlay: number of given layers +! npat: number of given pattern pairs +! nref: number of reference patterns +! wterr: weight factors for each element of the error vector e +! +! pat_in: input patterns +! pat_out: desired output patterns +! pat_*(i,N): value of ith in-/output neuron for pattern N +! +! ref_*: in analogy to pat_in/out for reference data (convergence tests) +! +! expected format (for one pattern pair): +!.. y1 x1 x2 x3 ... xM +!.. y2 x1 x2 x3 ... xM +!.. .. .. .. .. ... .. +!.. yN x1 x2 x3 ... xM +!.. +!.. WT: w1 w2 ... wN +! +!... wt-legacy mode format: +!.. y1 x1 x2 x3 ... xM +!.. WT: w1 +!.. y2 x1 x2 x3 ... xM +!.. WT: w2 +!.. .. .. .. .. ... .. +!.. yN x1 x2 x3 ... xM +!.. WT: wN +! +! where N=inp_out and M=inp_in + + + double precision pat_in(maxnin,maxpats),pat_out(maxpout,maxpats) + double precision ref_in(maxnin,maxpats),ref_out(maxpout,maxpats) + double precision wterr(maxpout,maxpats) + integer npat,nref,st,lauf,sl + character in(*)*(sl) + + double precision norm + integer pat_count,line + + integer k,j + + pat_count=0 + line=st !count lines + + do while (line.le.lauf) + if (in(line)(1:3).eq.'WT:') then + + if (legacy_wt .or. (pat_count.eq.0)) then + write(6,419) 1 + write(6,'(A)') '(preceding WT-block)' + stop ec_read + endif + + read(in(line)(4:sl),*,err=511,end=508) + > wterr(1:inp_out,pat_count) + + line=line+1 + + if (pat_count.eq.npat) exit + + cycle + 508 write(6,419) pat_count + write(6,'(A)') '(broken WT: input)' + stop ec_read + 511 write(6,418) pat_count + write(6,'(A)') 'LINE DUMP:' + write(6,'(A)') trim(in(line)(4:sl)) + stop ec_read + else +! stop reading if desired number of patterns is read + if ((npat.gt.0).and.(pat_count.eq.npat)) exit + +! new input set begins + pat_count=pat_count+1 + wterr(1:inp_out,pat_count)=1.0D0 + + read(in(line)(1:sl),*,err=513,end=510) pat_out(1,pat_count), + > pat_in(1:inp_in,pat_count) + line=line+1 +! EOF reached? + if (line.le.lauf) then +! wt-legacy-mode: read single weight + if (legacy_wt .and. (in(line)(1:3).eq.'WT:')) then + read(in(line)(4:sl),*,err=515,end=514) + > wterr(1:1,pat_count) + line=line+1 + endif + endif + if ((line.gt.lauf).and.(inp_out.gt.1)) then + write(6,419) pat_count + write(6,'(A)') '(reached EOF before completion)' + stop ec_read + endif + + do k=2,inp_out +! read pat_out(k,pat_count) and copy x-vector for comparison + read(in(line)(1:sl),*,err=512,end=509) + > pat_out(k,pat_count) + + if (line.lt.lauf) then + line=line+1 + if (legacy_wt .and. (in(line)(1:3).eq.'WT:')) then + read(in(line)(4:sl),*,err=515,end=514) + > wterr(k:k,pat_count) + line=line+1 + endif + if (line.le.lauf) then + cycle + endif + endif + if (k.eq.inp_out) then + exit + endif + 509 write(6,419) pat_count + write(6,'(A)') '(reached EOF before completion)' + stop ec_read + 512 write(6,421) pat_count, line + write(6,'(A)') 'LINE DUMP:' + write(6,'(A)') trim(in(line)(1:sl)) + stop ec_read + enddo + + cycle + 510 write(6,419) pat_count + stop ec_read + 513 write(6,421) pat_count, line + write(6,'(A)') 'LINE DUMP:' + write(6,'(A)') trim(in(line)(1:sl)) + stop ec_read + 514 write(6,419) pat_count + write(6,'(A)') '(broken WT: input)' + stop ec_read + 515 write(6,418) pat_count + write(6,'(A)') 'LINE DUMP:' + write(6,'(A)') trim(in(line)(4:sl)) + stop ec_read + endif + enddo +! pat_count is now actual number of patterns + + if (pat_count.le.0) then + write(6,419) 1 + stop ec_read + else if (npat.le.0) then +! set npat dynamically + npat=pat_count + if (npat.gt.maxpats) then + write(6,418) npat,maxpats + stop ec_dimrd + endif + 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) + ! pre-process the data + ! Fix phase issue. + call data_transform(pat_out,npat) +! 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 + !write(6,*) "NPAT in normalized weight",npat,nref + do k=1,npat ! here npat is the number of fitting data JP + 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 + + 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 parse_autokeys(nnkeylist,infile,nnkeynum,linenum, + > par,act,spread, + > weistr,nlay, + > lrnd,zero_par) + use nn_params + use nncommons, only: wspread,bspread,use_record + use io_parameters + use nndbg_mod + implicit none +! Read keys encoding the ANN-parameters (weights and biases). +! The expected format for the keys (as produced by NNkeygen()) +! looks as follws: +! +! 'W(N,N+1):' for weight matrix elements (layer N->N+1) +! Order of matrix elements as usual in fortran: +! a(1,1) a(2,1) a(3,1) .... a(1,2) a(2,2) ... a(1,N) .... +! 'B(N):' bias vector elements for layer N +! +! 'SW(N,N+1):' spread for all entries of the matrix. +! 'SB(N):' spread for all entries of the vector. +! +! N is expected to be a 2 digit number; +! ex.: 'W(01,02):', 'B(04)', 'W(11,12)',... +! +! The position of a neuron in the layer is type-dependent. +! keep that in mind for the order of the matrix and vector-elements +! Type 1 come first, type 2 second etc + + +!.. input variables + double precision par(wbcap),spread(wbcap) + integer act(wbcap) + integer weistr(2,maxlay,2) + integer linenum, nnkeynum + character*(llen) infile(linenum) + character*(klen) nnkeylist(2,nnkeynum) + integer nlay + logical lrnd,zero_par + +! max data array length for ANN keys + integer nn_maxdat + +! array for memory management + integer, dimension(:,:), allocatable :: datpos + +! temporary storage vectors + integer dumlen + parameter (dumlen=1) + integer idat + double precision ddat + character*(dumlen) :: cdat ! unused dummy + allocatable idat(:), ddat(:), cdat(:) + +! variables to check indiv. keys + integer key_id, datlen, arglen + +! actual expected number of parameters + integer wb_end +! total number of neurons / W-matrix elements in vector par + integer wei_end +! starting position of Bias vector in par + integer bi_pos +! end of the weight and bias keys + integer wbkeynum + + integer k,j + + nn_maxdat=2*wbcap + allocate(datpos(3,nn_maxdat)) + allocate(idat(nn_maxdat)) + allocate(ddat(nn_maxdat)) + allocate(cdat(nn_maxdat)) + + wb_end=weistr(2,nlay,2) + wei_end=weistr(2,nlay-1,1) + bi_pos=weistr(1,1,2) + wbkeynum=2*(nlay-1)+1 + + write(6,'(A,I6)') 'Total number of parameters: ', wb_end + + if (zero_par) then + par(1:wb_end)=0.0d0 + act(1:wb_end)=0 + spread(1:wb_end)=0.0d0 + write(6,'(A)') 'ZERO: Overriding input. ' + > // 'All parameters set to 0.' + return + else +! activities are currently not properly supported. + write(6,'(A)') 'Setting all weights and biases to active.' + act(1:wb_end)=1 + spread(1:weistr(1,2,2)-1)=wspread + spread(weistr(1,2,2):wb_end)=bspread + endif + + if (use_record) then + write(6,'(A)') 'RECORD: Skipping parameter (W,B) keys.' + par(1:wb_end)=0.0d0 + return + endif + + if (dbg) then + write(6,'(A)') 'Reading parameters from input..' + endif + +! Use generic parser for reading autokeys + call keyread(nnkeylist,infile,nnkeynum,idat,ddat,cdat,datpos, + > klen,llen,dumlen,linenum,2*wbcap) + + if (dbg) then + write(6,'(A)') 'Paramerers read.' + endif + +!.. determine start and end points of parameter blocks: + +! skip first (DATA:) key + key_id=1 + +! check weights & biases + if (.not.lrnd) then + do j=1,2 + ! Weights count from 1 to nlay-1, + ! Biases count from 2 to nlay. + do k=j,nlay-2+j + key_id=key_id+1 +! expected number of parameters + arglen=weistr(2,k,j)-weistr(1,k,j)+1 +! number of parameters read + datlen=datpos(3,key_id) + if (datlen.ne.arglen) then + write(6,'(A)') 'ERROR: ' + > // trim(nnkeylist(1,key_id)) + > // ' INCONSISTENT DIMENSIONING' + write(6,'(I5,A,I5)') datlen, ' vs. ', arglen + stop 1 + endif + enddo + enddo +! Copy ddat to par. This is possible because ddat has the correct +! memory layout, it's kind of a hack though. + par(1:wb_end)=ddat(1:wb_end) + else + write(6,'(A)') 'RANDOM: Ignoring parameter (W,B) keys.' + par(1:wb_end)=0.0d0 + key_id=wbkeynum + endif + +! read weight and bias spreads + do j=1,2 +! Weights count from 1 to nlay-1, +! Biases count from 2 to nlay. + do k=j,nlay-2+j + key_id=key_id+1 + if (datpos(2,key_id).ne.-1) then + spread(weistr(1,k,j):weistr(2,k,j))= + > ddat(datpos(2,key_id)) + endif + enddo + enddo + + deallocate(datpos) + deallocate(idat) + deallocate(ddat) + deallocate(cdat) + + end subroutine diff --git a/src/puNNch.f b/src/puNNch.f new file mode 100644 index 0000000..698a839 --- /dev/null +++ b/src/puNNch.f @@ -0,0 +1,816 @@ +************************************************************************ +*** puNNch +*** printing (punching) ANN data structures +*** +************************************************************************ + + subroutine punch_data(pat_in,pat_out,npat,append) + use nn_params + use nncommons + use nndbg_mod + implicit none +! Subroutine generating geNNetic DATA: block for ANN fitting. +! +! nlay: number of given layers +! npat: number of pattern-pairs desired +! pat_in: input patterns +! pat_out: desired output patterns +! inp_in: number of coordinates written into input. +! inp_out: number of values written to output +! +! inp_format: format used for datapoints +! scans_fmt: format used for sample-visualisation-file +! nndatfile: filename for analytically generated DATA-blocks +! (see nnparams) +! append: if true, append to given file if it exists + + + + double precision pat_in(maxnin,*),pat_out(maxpout,*) + integer npat + logical append + + character*16 inp_format,scans_fmt + character*35 full_fname + + logical alive + + integer k,j + + if (inp_in.ge.10**6) then + stop 'ERROR: NUMBER OF COORDINATES TOO LARGE TO HANDLE' + endif + +! generate format string + write(inp_format,'(I6,A7)') inp_in+1,'ES23.14' + inp_format = '(' // trim(inp_format) // ')' + + full_fname = trim(nndatfile) // '.in' + + write(6,'(A)') "generating DATA-file '" // trim(full_fname) + > // "'..." + +! write file + if (.not.append) then + open(nnunit,file=trim(full_fname),status='REPLACE') + else + inquire(file=trim(full_fname),exist=alive) + if (alive) then +! open existing file and append + open(nnunit,file=trim(full_fname),status='old', + > position='append') + else +! file does not exist; make it + open(nnunit,file=trim(full_fname),status='new') + endif + endif + + write(nnunit,'(A5)') 'DATA:' + write(nnunit,*) '' + write(unit=nnunit,advance='no',fmt='("!")') + write(nnunit,sline) + write(nnunit,*) '' + + do k=1,npat + do j=1,inp_out + write(nnunit,inp_format) pat_out(j,k), pat_in(1:inp_in,k) + enddo + write(nnunit,'(A4)') '!WT:' + write(nnunit,*) '' + enddo + + close(nnunit) + +! generate sample format string + write(scans_fmt,'(I6,A7)') inp_in,'ES23.14' + scans_fmt = '(' // trim(scans_fmt) // ')' + +! write file + open(nnunit,file=trim(sampfile),status='REPLACE') + + write(6,'(A)') "dumping sampled points in '" // trim(sampfile) + > // "'..." + + write(nnunit,'(A)') '# This file shows all sampled points in ' + > // 'the given configuration space.' + + do k=1,npat + write(nnunit,scans_fmt) pat_in(1:inp_in,k) + enddo + + close(nnunit) + + end subroutine + +!-------------------------------------------------------------------------------------- + + subroutine punch_net(funit,fname,par, + > typop,laystr,weistr,nlay,append,noprim) + use nn_params + use nncommons + use io_parameters + use nndbg_mod + implicit none +! Subroutine writing all relevant structural NN information +! to file. +! +! funit: file unit to be used. If negative or 0, use nnunit. +! fname: name of the file +! append: if true, append to given file if it exists +! noprim: if true, do not generate primitive representation + + + character*32 fname + double precision par(wbcap) + integer laystr(3,maxlay),typop(maxtypes,maxlay) + integer weistr(2,maxlay,2) + integer nlay + integer funit + logical append, noprim + + integer file_unit + integer wbnum,plen + integer nnkeynum + character*35 full_fname + character*(klen) nnkeylist(2,maxnnkeys) + logical alive + + integer j + + if (funit.le.0) then + file_unit=nnunit + else + file_unit=funit + endif + + full_fname = trim(fname) // '.in' + + if (.not.append) then + open(file_unit,file=trim(full_fname),status='replace') + else + inquire(file=trim(full_fname),exist=alive) + if (alive) then +! open existing file and append + open(file_unit,file=trim(full_fname),status='old', + > position='append') + else +! file does not exist; make it + open(file_unit,file=trim(full_fname),status='new') + endif + endif + +! recover information to construct ANN + + write(file_unit,'("NLAY:",I4)') nlay + write(file_unit,'(/,"NEUPOP:",100(I6,:))') laystr(1,1:nlay) + write(file_unit,'("TYPOP:",100(I6,:),//)') typop(:,2:nlay) + + write(file_unit,'(A)') 'INSHIFT: &' + call write_longreal(file_unit,shift_in,len_in,lrfmt,5) + + write(file_unit,'(A)') 'INSCALE: &' + call write_longreal(file_unit,fact_in,len_in,lrfmt,5) + + +! write out parameter set + write(file_unit,'(A)') '!.....NEURAL NETWORK PARAMETERS:' + +! number of weights (and biases) + wbnum=nlay-1 + +! construct keys + call NNkeygen(nnkeylist,nnkeynum,nlay,.false.) + +! write weight matrices + do j=1,wbnum + write(file_unit,newline) + write(file_unit,'(A," &")') trim(nnkeylist(1,1+j)) + plen=1+weistr(2,j,1)-weistr(1,j,1) + call write_longreal(file_unit,par(weistr(1,j,1)),plen,lrfmt,5) + enddo + +! write bias vectors + do j=1,wbnum + write(file_unit,newline) + write(file_unit,'(A," &")') trim(nnkeylist(1,1+wbnum+j)) + plen=1+weistr(2,j+1,2)-weistr(1,j+1,2) + call write_longreal(file_unit,par(weistr(1,j+1,2)),plen, + > lrfmt,5) + enddo + + close(file_unit) + + if (.not.noprim) then + call punch_net_prim(funit,fname,par, + > typop,laystr,weistr,nlay) + endif + + end subroutine + +!-------------------------------------------------------------------------------------- + + subroutine punch_net_prim(funit,fname,par, + > typop,laystr,weistr,nlay) + use axel, only: unnorm_input + use nn_params + use nncommons + use io_parameters + use nndbg_mod + implicit none +! Subroutine writing all relevant structural NN information +! to a primitively readable file. The resulting parameters no longer +! assume a pre-normalized input +! +! funit: file unit to be used. If negative or 0, use nnunit. +! fname: name of the file + + + character*32 fname + double precision par(*) + integer funit + integer laystr(3,maxlay),typop(maxtypes,maxlay) + integer weistr(2,maxlay,2) + integer nlay + + + character*36 full_fname + double precision par_copy(wbcap) + integer par_pos,par_end,par_len + integer file_unit + + integer j + + if (funit.le.0) then + file_unit=nnunit + else + file_unit=funit + endif + + full_fname = trim(fname) // '.par' + + open(file_unit,file=trim(full_fname),status='replace') + + par_pos=weistr(1,1,1) + par_end=weistr(2,nlay,2) + par_len=1+par_end-par_pos + + write(file_unit,*) nlay + write(file_unit,*) maxtypes + write(file_unit,'(100(I6,:))') laystr(1,1:nlay) + write(file_unit,'(100(I6,:),//)') typop(:,1:nlay) + write(file_unit,'(A)') '***'//trim(prim_tag) + +! copy parameter set and unddo norm + do j=par_pos,par_end + par_copy(1+j-par_pos)=par(j) + enddo + call unnorm_input(par_copy,laystr,shift_in,fact_in,weistr,.true.) + +! write par-vector + do j=1,par_len + write(unit=file_unit,fmt=lrfmt,advance='NO') par_copy(j) + enddo + + close(file_unit) + + end subroutine +!-------------------------------------------------------------------------------------- + + subroutine punch_scans(pat_in,pat_out) + use nn_params + use nncommons + use io_parameters + use nndbg_mod + implicit none +! Subroutine writing plot files for random scans from input. +! pat_in: input patterns +! pat_out: desired output patterns +! inp_in: number of coordinates written into input. +! inp_out: number of values written to output + + + double precision pat_in(maxnin,*),pat_out(maxpout,*) + + integer total + character*64 fname + + integer k,j + + if (sets.ge.10**4) then + write(6,'(A)') 'WARNING: punch_scans: Too many scan files' + > // ' to generate.' + write(6,'(A)') 'Garbage file ' // trim(nnsdir) + > // '''scan_****.dat'' will be created.' + endif + +! count number of data points written to file + total=0 + + do k=1,sets +! generate filename + write(fname,'(A32)') '' + write(fname,'(I4.4)') k + fname = trim(nnsdir) // 'scan_' // trim(fname) // '.dat' + + if (dbg) write(*,*) 'writing ''' // trim(fname) // '''...' + open(unit=nnunit,status='replace',file=trim(fname)) + +! dump scan into file + do j=1,ndata(k) + total = total+1 + write(nnunit,'(1000(ES23.15,:))') pat_in(1:inp_in,total), + > pat_out(1:inp_out,total) + enddo + close(nnunit) + enddo + + end subroutine + + + +!-------------------------------------------------------------------------------------- + + subroutine punch_fitscans(par,pat_in,pat_out,wterr, + > typop,laystr,weistr, + > nlay,walk) + use nn_params + use nncommons + use io_parameters + use nndbg_mod + implicit none +! Subroutine writing plot files for fitted random scans. +! For now only output in terms of diabatic energies is supported. +! +! walk: determines how coordinate-dependency is +! written to files +! true -- write scans as functions of t in [0,1] (walk along the scan) +! false -- dump full coordinate vector to file +! +! pat_in: input patterns +! pat_out: desired output patterns +! inp_in: number of coordinates written into input. +! inp_out: number of values written to output +! +! laystr: layer structure matrix +! typop: type population matrix +! nlay: number of given layers +! + + double precision par(*) + double precision pat_in(maxnin,*),pat_out(maxpout,*) + double precision wterr(maxpout,maxpats) + integer laystr(3,maxlay),typop(maxtypes,maxlay) + integer weistr(2,maxlay,2) + integer nlay + logical walk + + double precision nnoutp(maxnout),adiaoutp(maxpout) + double precision max_err,err_vec(maxpout) + double precision x_diff(maxnin) + double precision walktime,walknorm + integer total + character*64 fname + + integer k,j + integer end_int, bgn_int +! the coordianate in pat_in is order in the following way +! pat_In(INPUTS,INTERNAL COORDIANATE) + bgn_int = typop(1,1)+1 ! the begin of theinternal coordiante + end_int = typop(1,1)+6 + if (sets.ge.10**4) then + write(6,'(A)') 'WARNING: punch_fitscans: Too many scan files' + > // ' to generate.' + write(6,'(A)') 'Garbage file ''' // trim(nnsdir) + > // 'fit_scan_****.dat'' will be created.' + endif + +! count number of data points written to file + total=0 + + do k=1,sets +! generate filename + write(fname,'(A32)') '' + write(fname,'(I4.4)') k + fname = trim(nnsdir) // 'fit_scan_' // trim(fname) // '.dat' + + if (dbg) write(*,*) 'writing ''' // trim(fname) // '''...' + open(unit=nnunit,status='replace',file=trim(fname)) + + if (walk) then + write(nnunit,'("# SCAN",I4.4, + >"[t,F(NN(x(t))),f(x(t)),NN(x(t)),We(x(t))]")') k + write(nnunit,'("# XDIM:",I6)') 1 + else + write(nnunit, + > '("# SCAN",I4.4,"[x,F(NN(x)),f(x),NN(x),We(x)]")') k + write(nnunit,'("# XDIM:",I6)') inp_in + endif + + write(nnunit,'("# OUTPUT VALUES:",I6)') inp_out + write(nnunit,'("# DATA POINTS:",I6,/)') ndata(k) + write(nnunit,'(A)') '# UNIT: ' // trim(unit_string) + + walknorm=0.0d0 + walktime=0.0d0 + if (walk) then + do j=2,ndata(k) + x_diff(bgn_int:end_int)= pat_in(bgn_int:end_int, + > total+j) - pat_in(bgn_int: + > end_int,total+j-1) + + walknorm=walknorm +dsqrt(sum(x_diff(bgn_int:end_int)**2)) + enddo + endif + +! dump scan into file + max_err=0 + do j=1,ndata(k) + total = total+1 + max_err=0.0d0 + +! generate model energies + nnoutp=0.0d0 + call neunet(pat_in(1,total),nnoutp,par, + > typop,laystr,weistr,nlay) + + call nnadia(pat_in(1,total),nnoutp,adiaoutp) + + if (walk) then + + if (j.eq.1) then + x_diff=0.0d0 + else + x_diff(bgn_int:end_int)= + > pat_in(bgn_int:end_int,total) + > - pat_in(bgn_int:end_int,total-1) + endif + + walktime = walktime + > + dsqrt(sum(x_diff(bgn_int:end_int)**2))/walknorm + + write(nnunit,'(1000(ES23.15,:))') walktime, + > adiaoutp(1:inp_out)*unit_con, + > pat_out(1:inp_out,total)*unit_con, + > nnoutp(1:len_out), + > wterr(1:inp_out,total) + else + write(nnunit,'(1000(ES23.15,:))') pat_in(bgn_int: + > end_int,total), + > adiaoutp(1:inp_out)*unit_con, + > pat_out(1:inp_out,total)*unit_con, + > nnoutp(1:len_out), + > wterr(1:inp_out,total) + endif + + err_vec=dabs(adiaoutp-pat_out(:,total)) + max_err=max(max_err,sum(err_vec(1:inp_out)**2)) + enddo + write(nnunit,'(/,"## SUP NORM:",E23.15,A)') + > dsqrt(max_err)*unit_con, trim(unit_string) + close(nnunit) + enddo + + end subroutine + + +!-------------------------------------------------------------------------------------- + + subroutine punch_fitpoints(par,pat_in,pat_out, + > typop,laystr,weistr,nlay,npat,fname) + use nn_params + use nncommons + use nndbg_mod + implicit none +! Subroutine dumping all reference data points into a single file. +! Also produces unweighted (!!) errors for each point +! +! nlay: number of given layers +! npat: number of given pattern pairs +! fname: name of output-file +! +! pat_in: input patterns +! pat_out: desired output patterns +! pat_*(i,N): value of ith in-/output neuron for pattern N +! +! del: neuron error vector +! pat_err: error of the network output for a single pattern +! deriv: activation function derivatives +! deriv: activation function derivatives +! typop: type population matrix +! laystr: layer structure matrix +! + + + integer npat + double precision par(*) + double precision pat_in(maxnin,*),pat_out(maxpout,*) + integer laystr(3,maxlay),typop(maxtypes,maxlay) + integer weistr(2,maxlay,2) + integer nlay + character*32 fname + + double precision nn_out(maxnout) + double precision pat_err(maxpout),abs_err + integer len_form + integer n,k + character*32 form + + + len_form=1+len_in+2*len_out !number of value blocks to be written + + if (dbg.or.vbs) then + write(6,'(A)') 'dumping pointwise errors into ''' + > // trim(fname) // '''...' + endif + + open(unit=nnunit,status='replace',file=trim(fname)) + + write(nnunit,'(A)') '#DATA POINT DUMP ' + > //'[x,NN(x),f(x),sqrt((F(NN)-f)^2)]' + + + write(form,'("(",I6,A,")")') len_form,'ES25.8' + + do n=1,npat +! propagate nth input pattern + call neunet(pat_in(1,n),nn_out,par,typop,laystr,weistr,nlay) +! evaluate error + call nnerror(pat_err,pat_in(1,n),pat_out(1,n),nn_out) + abs_err=0.0D0 + do k=1,inp_out + abs_err=abs_err+pat_err(k)**2 + enddo + abs_err=dsqrt(abs_err) + + +!? valgrind does not like variable format strings + write(nnunit,'(10000(ES25.8,:))') pat_in(1:len_in,n), + > nn_out(1:len_out), + > pat_out(1:inp_out,n), abs_err + + enddo + + close(nnunit) + + end subroutine + +!-------------------------------------------------------------------------------------- + + subroutine punch_fitstat(fname,par,pat_in,pat_out,err_vec,npat, + > typop,laystr,weistr, + > nlay,append) + use nn_params + use nncommons + use io_parameters + use nndbg_mod + implicit none +! Subroutine providing a complete vector over all root mean square +! errors over all points from 1 to npat in a single file. +! +! This routine is used to construct errors_*.out files. +! +! fname: name of the file to be written +! pat_in: input patterns +! pat_out: desired output patterns +! npat: number of given pattern pairs +! inp_in: number of coordinates written into input. +! inp_out: number of values written to output +! err_vec: vector containing all abs. pattern errors (sorted) +! append: if true, append to given file if it exists +! + + + character*32 fname + integer npat + double precision par(wbcap) + double precision pat_in(maxnin,*),pat_out(maxpout,*) + double precision err_vec(npat) + integer laystr(3,maxlay),typop(maxtypes,maxlay) + integer weistr(2,maxlay,2) + integer nlay + logical append + + double precision pat_err(maxpout) + integer, dimension(:), allocatable :: err_pos + logical alive + + integer n + + if (.not.append) then + open(nnunit,file=trim(fname),status='replace') + else + inquire(file=trim(fname),exist=alive) + if (alive) then +! open existing file and append + open(nnunit,file=trim(fname),status='old', + > position='append') + write(nnunit,asline) + else +! file does not exist; make it + open(nnunit,file=trim(fname),status='new') + endif + endif + +! accumulate errors to long vector + allocate(err_pos(maxpats)) + do n=1,npat + call NNerrvec(par,pat_err,pat_in(1,n),pat_out(1,n), + > typop,laystr,weistr,nlay) + err_vec(n)=dsqrt(sum(pat_err(1:inp_out)**2)) + err_pos(n)=n + enddo + +! sort vector + call reverse_dqsort2(npat,err_vec,err_pos) + + write(nnunit,'("#",A12,2A13)') 'RANK','ERROR [' // + > trim(unit_string) // ']','PAT#' + + do n=1,npat + write(nnunit,'(I13,ES13.4,I13)') n, err_vec(n)*unit_con, + > err_pos(n) + enddo + close(nnunit) + deallocate(err_pos) + + end subroutine + +!-------------------------------------------------------------------------------------- + + subroutine punch_netdistrib(fdir,par,pat_in,typop,laystr, + > weistr,nlay,npat,ftag) + use nn_params + use nncommons + use io_parameters + use nndbg_mod + implicit none +! Subroutine evaluating the activity of all neurons for each data +! point. Also returns information about the network to construct it. +! +! fdir: directory for files to be written in +! pat_in: input patterns +! npat: number of given pattern pairs +! inp_in: number of coordinates written into input. +! inp_out: number of values written to output +! err_vec: vector containing all abs. pattern errors (sorted) +! ftag: prefix for generated filenames + + + character*16 fdir + integer npat + double precision par(wbcap) + double precision pat_in(maxnin,npat) + integer laystr(3,maxlay),typop(maxtypes,maxlay) + integer weistr(2,maxlay,2) + integer nlay + character*8 ftag + + character*128 fname + double precision deriv(neucap),L(neucap) + double precision, dimension(:,:), allocatable :: neurons, derivs + double precision median(len_out), rec_scale(len_out) + integer med_pos(2) + integer lay_end,poslay + + integer n,j + + poslay=laystr(2,nlay) + lay_end=poslay-1+len_out + + allocate(neurons(npat,len_out),derivs(npat,len_out)) + +! evaluate ANN for each pattern + do n=1,npat + L=0.0d0 + deriv=0.0d0 + call neunet_full(pat_in(1,n),L,deriv,par, + > typop,laystr,weistr,nlay) + neurons(n,1:len_out)=L(poslay:lay_end) + enddo + +! compute location of median + if (1.eq.modulo(npat,2)) then + med_pos = (npat+1)/2 + else + med_pos(1) = npat/2 + med_pos(2) = med_pos(1) + 1 + endif + + do n=1,len_out + call dqsort(npat,neurons(1,n)) + median(n)=(neurons(med_pos(1),n)+neurons(med_pos(2),n))/2.0d0 + neurons(:,n)=neurons(:,n) + rec_scale(n)=(neurons(npat,n)-neurons(1,n))/2.0d0 + enddo + +! file containing the real ANN outputs + fname=trim(fdir)// trim(ftag) //'netdist-med.dat' + + write(6,'(A)') 'Writing distribution of (shifted) ' + > // 'ANN output values to ''' // trim(fname) // '''..' + + open(nnunit,file=trim(fname),status='replace') + + write(nnunit,'(A)') '# ANN OUTPUT VALUES' + write(nnunit,'(A)') '# SORT INDEX, OUTPUT NEURON(S) 1,2,.. ,' + > // ' (MINUS MEDIAN)' + write(nnunit,'(A,1000(F10.5,:))') '# Recommended rescaling: ', + > rec_scale(:) + write(nnunit,'(A,1000(F10.5,:))') '# Computed median: ', + > median(:) + + do n=1,npat + write(nnunit,'(I11, 10000(ES11.2,:))') n, + > (neurons(n,j)-median(j), j=1,len_out) + enddo + + close(nnunit) + +! file containing outputs shifted by median + fname=trim(fdir)// trim(ftag) //'netdist.dat' + + write(6,'(A)') 'Writing distribution of ANN output values ' + > // 'to ''' // trim(fname) // '''..' + + open(nnunit,file=trim(fname),status='replace') + + write(nnunit,'(A)') '# ANN OUTPUT VALUES' + write(nnunit,'(A)') '# SORT INDEX, OUTPUT NEURON(S) 1,2,..' + write(nnunit,'(A,1000(F10.5,:))') '# Recommended rescaling: ', + > rec_scale(:) + write(nnunit,'(A,1000(F10.5,:))') '# Computed median: ', + > median(:) + + do n=1,npat + write(nnunit,'(I11, 10000(ES11.2,:))') n, neurons(n,:) + enddo + + close(nnunit) + + deallocate(neurons,derivs) + + end subroutine + +!-------------------------------------------------------------------------------------- + subroutine punch_record(par,weistr,nlay,nset,preserve) + use nn_params + use nncommons + use io_parameters + use nndbg_mod + implicit none + + + double precision par(wbcap,maxset) + integer weistr(2,maxlay,2) + integer nlay,nset + logical preserve + + integer wb_end + logical file_exists + character*64 fname + + integer k,j + + fname=trim(nnrecfile) // '.rec' + + wb_end=weistr(2,nlay,2) + + if (preserve) then + inquire(file=trim(fname),exist=file_exists) + if (file_exists) then +! File exists already, try an alternative file name + write(6,'(A)') 'WARNING: File ''' // + > trim(fname) // ''' already exists.' + write(6,'(A)') 'Attempting to create an alternative file..' + k=1 + do while ((k.le.99).and.file_exists) + write(fname,'("_",I2.2)') k + fname=trim(nnrecfile) // trim(fname) // '.rec' + inquire(file=trim(fname),exist=file_exists) + k=k+1 + enddo +! File STILL exists? + if (file_exists) then + write(6,'(A)') 'WARNING: No safe backup could be made.' + fname=trim(nnrecfile) // '_XX.rec' + endif + endif + endif + write(6,'(A)') 'RECORD: Writing record to file ''' + > // trim(fname) // '''...' + open(nnunit,file=trim(fname),action='WRITE') + + write(nnunit,*) nset + write(nnunit,*) wb_end + do k=1,nset + write(nnunit,'(I0)',advance='no') k + do j=1,wb_end + write(nnunit,'(ES23.15)',advance='no') par(j,k) + enddo + write(nnunit,newline) + enddo + close(nnunit) + write(6,'(A)') 'Done.' + + + end subroutine diff --git a/src/scans.f b/src/scans.f new file mode 100644 index 0000000..03b1e53 --- /dev/null +++ b/src/scans.f @@ -0,0 +1,385 @@ +!-------------------------------------------------------------------------------------- + + subroutine lscan_bounds(bounds,refp,dvec,xmin,xmax,dim,backwd) + use nn_params + implicit none +! Determine how far a scan can progress within a box-shaped boundary +! in terms of the length of the scan starting from the reference +! point. +! +! dim: dimension of coordinate space to be scanned +! xmin/max: minimum/maximum allowed value in each coordinate +! refp: reference point at which linear scan begins +! dvec: (normalized) vector pointing into the direction of the scan +! backwd: if true, evaluate boundary also in -dvec-direction +! bounds: maximum distance(s) from reference point +! bounds(1): in dvec-direction +! bounds(2): in -dvec-direction (default 0.0D0) +! res: resolution -- maximum error in bound estimates + + + integer dim + double precision refp(dim),dvec(dim) + double precision xmin(dim),xmax(dim) + double precision bounds(2) + logical backwd + + double precision min_len,step_len,box_diag + + integer j + +! begin at a resolution of 10% the box diagonal + box_diag=0.0D0 + do j=1,dim + box_diag=box_diag+(xmax(j)-xmin(j))**2 + enddo + box_diag=sqrt(box_diag) + step_len=0.1D0*box_diag + + min_len=0.0D0 + do while (step_len.ge.scan_res) +! find lower boundary given current resolution + call lscan_estim_bound(min_len,step_len,refp,dvec, + > xmin,xmax,dim) +! refine resolution + step_len=0.5D0*step_len + enddo + + bounds(1)=min_len + bounds(2)=0.0D0 + if (backwd) then +! follow vector in a negative direction + step_len=-0.1D0*box_diag + min_len=0.0D0 + do while (dabs(step_len).ge.scan_res) +! find lower boundary given current resolution +! this could be further numerically refined; since the step distance +! is halved, we know that no more than 1 step can be successful. + call lscan_estim_bound(min_len,step_len,refp,dvec, + > xmin,xmax,dim) +! refine resolution + step_len=0.5D0*step_len + enddo + bounds(2)=abs(min_len) + endif + + end + +!-------------------------------------------------------------------------------------- + + subroutine lscan_estim_bound(min_len,step_len,refp,dvec,xmin,xmax, + > dim) + implicit none +! Estimate a lower bound min_len for the length a linear scan can progress +! within a box-shaped boundary, given an inital guess which +! is also a lower bound and a step resolution step_len. +! +! dim: dimension of coordinate space to be scanned +! xmin/max: minimum/maximum allowed value in each coordinate +! refp: reference point at which linear scan begins +! dvec: (normalized) vector pointing into the direction of the scan +! min_len: estimate for minimal length of scan (will be overwritten +! with refined result) +! step_len: interval at which the algorithm checks for boundary violation + + integer dim + double precision refp(dim),dvec(dim) + double precision xmin(dim),xmax(dim) + double precision step_len,min_len + + double precision test_vec(dim) + logical in_bound + logical dbetween + + integer j + + in_bound=.true. + do while (.true.) + do j=1,dim + test_vec(j)=refp(j)+(min_len+step_len)*dvec(j) + in_bound=in_bound.and.dbetween(xmin(j),test_vec(j),xmax(j)) + enddo + if (in_bound) then + min_len=min_len+step_len + else + exit + endif + enddo + end + +!-------------------------------------------------------------------------------------- + + subroutine mkescans(pat_in,neu_in,npat,scans,xranges) + use nn_params + use nndbg_mod + implicit none +! Generate input patterns for elliptic random scans. Datapoints +! on scans are arranged in concentric ellipsoids around the +! origin. The outermost ellipsoid is bounded by xranges(i,2) as it's +! principal axes. The innermost ellipsoid is the smallest one where +! no possible point violates the smallest allowed value in any +! dimension. +! +! For the sake of simplicity, the coordinate system is effectively +! rescaled such that the outer ellipsoid becomes a unit sphere +! and then transfomed back. +! +! npat: number points on the scan +! scans: number of scans +! pat_in: input patterns +! pat_*(i,N): value of ith in-/output neuron for pattern N +! rmin: radius of the smallest sphere enclosing all forbidden areas +! in the rescaled coordinate system +! len_step: radius step size for rescaled coordinate system +! +! xranges: range for (random) input distribution: +! |xranges(:,1)| < |pat_in(:,k)| < |xranges(i,2)| forall k +! xranges(i,3) : if it's absolute value is >=1, +! dimension i will always have the same sign as xranges(i,3). + + + + integer npat,scans + integer neu_in + double precision xranges(maxnin,xrcap) + double precision pat_in(maxnin,npat,scans) + + double precision rvec(maxnin) + double precision rmin,len_step + + double precision dum + integer n,k,j + +! rescale minimum distances such that corresponding +! outer ellipsoid transforms to a unit sphere and +! pick the largest of these minimal radii to actually use. + rmin=0.0d0 + do k=1,neu_in + dum=dabs(xranges(k,1)/xranges(k,2)) + if (dum.gt.rmin) rmin=dum + enddo + + if (dbg.or.vbs) then + write(*,*) 'MINIMAL EFFECTIVE RADIUS:', rmin + endif + +! evaluate step size + len_step=(1.0d0-rmin)/dble(npat-1) + + do n=1,scans +! generate normalized isotropic random vector + call normal_grv(rvec,neu_in,1) + +! adjust signs + do j=1,neu_in + if (dabs(xranges(j,3)).ge.1.0d0) then + rvec(j)=sign(rvec(j),xranges(j,3)) + endif + enddo + + do k=1,npat + do j=1,neu_in +! make equidistant steps along that direction + pat_in(j,k,n) = (rmin + (k-1)*len_step)*rvec(j) +! rescale + pat_in(j,k,n) = pat_in(j,k,n)*xranges(j,2) + enddo + enddo + enddo + +! update npat to actual number of patterns + npat=npat*scans + + + end + +!-------------------------------------------------------------------------------------- + + subroutine mklscan(pat_in,neu_in,npat,xranges) + use nn_params + use nndbg_mod + implicit none +! Generate a single set of input patterns forming a single linear +! scan going through both specified points +! +! npat: number points on the scan +! pat_in: input patterns +! pat_*(i,N): value of ith in-/output neuron for pattern N +! xranges: starting point and end point of linear scan +! xranges(i,1) : starting point in coordinate space (r0) +! xranges(i,2) : end point in coordinate space (r1) +! +! dvec: direction vector pointing from r0 to r1. + + + double precision xranges(maxnin,xrcap) + double precision pat_in(maxnin,maxpats) + integer npat + integer neu_in + + double precision dvec(maxnin) + + integer n,j + +! determine direction vector pointing from r0 to r1 + do j=1,neu_in + dvec(j)=xranges(j,2)-xranges(j,1) + enddo + + do n=1,npat + do j=1,neu_in + pat_in(j,n)=dble(n-1)/dble(npat-1)*dvec(j) + xranges(j,1) + enddo + enddo + + end + +!-------------------------------------------------------------------------------------- + + subroutine mklscans(pat_in,neu_in,npat,scans,xranges) + use nn_params + use nndbg_mod + implicit none +! Generate input patterns for linear random scans inside a +! box-shaped coordinate subspace. Reference point is NOT included +! in the scan. +! +! npat: number points on the scan +! scans: number of scans +! pat_in: input patterns +! pat_*(i,N): value of ith in-/output neuron for pattern N +! +! xranges: ranges specifying scan properties (bounds etc) +! xranges(i,1) < pat_in(i,k) < xranges(i,2) forall i,k +! xranges(i,3) : reference point from which all scans originate +! +! res: convergence parameter for bound finding algorithm + + + integer npat,scans + integer neu_in + double precision xranges(maxnin,xrcap) + double precision pat_in(maxnin,npat,scans) + + double precision bounds(2) + double precision rvec(neu_in) + double precision len_step + logical backwd + + parameter (backwd=.false.) + + integer n,k,j + + do n=1,scans +! generate normalized isotropic random vector + call normal_grv(rvec,neu_in,1) + +! numerically determine distance from box boundary + call lscan_bounds(bounds,xranges(1,3),rvec, + > xranges(1,1),xranges(1,2),neu_in,backwd) + +! determine length of a single step + len_step=bounds(1)/dble(npat) + +! generate scan + do k=1,npat + do j=1,neu_in + pat_in(j,k,n) = xranges(j,3) + len_step*dble(k)*rvec(j) + enddo + enddo + enddo + +! update npat to actual number of patterns + npat=npat*scans + + end + +!-------------------------------------------------------------------------------------- + + subroutine mktscans(pat_in,neu_in,npat,scans,xranges) + use nn_params + use io_parameters + use nndbg_mod + implicit none +! Generate scans touching a sphere of fixed width and origin +! with random orientation. They are bounded within a box +! defined by xranges. +! +! npat: number points on the scan +! scans: number of scans +! pat_in: input patterns +! pat_*(i,N): value of ith in-/output neuron for pattern N +! +! xranges: ranges specifying scan properties (bounds etc) +! xranges(i,1) < pat_in(i,k) < xranges(i,2) forall i,k +! xranges(i,3) : center of the sphere +! xranges(1,4) : radius of the sphere + + + integer npat,scans + integer neu_in + double precision pat_in(maxnin,npat,scans) + double precision xranges(maxnin,xrcap) + + double precision rvec(maxnin),rtang(maxnin) + double precision rtnorm,overlap,radius + double precision bounds(2),len_step + logical backwd + + parameter (backwd=.true.) + + integer n,k,j + +! determine radius of the sphere + radius=xranges(1,4) + + do n=1,scans +! generate normalized isotropic random vector + call normal_grv(rvec,neu_in,1) + +! generate another one orthogonal to the first using +! Grahm-Schmidt + rtnorm=0.0D0 + do while (rtnorm.le.zero) + call normal_grv(rtang,neu_in,1) + rtnorm=0.0D0 + overlap=dot_product(rvec(1:neu_in),rtang(1:neu_in)) + do j=1,neu_in + rtang(j)=rtang(j)-overlap*rvec(j) + rtnorm = rtnorm + rtang(j)**2 + enddo + rtnorm=dsqrt(rtnorm) + enddo + +! reposition and scale rvec to rest on the desired sphere +! normalize rtang + do j=1,neu_in + rvec(j)=radius*rvec(j) + xranges(j,3) + rtang(j)=rtang(j)/rtnorm + enddo + +! numerically determine distance from box boundary in both +! directions + call lscan_bounds(bounds,rvec,rtang, + > xranges(1,1),xranges(1,2),neu_in,backwd) + +! determine step length + len_step=(bounds(1)+bounds(2))/dble(npat-1) +! set the scan to begin at an end point instead of in the middle +! of the tangent + do j=1,neu_in + rvec(j)=rvec(j)-rtang(j)*bounds(2) + enddo + +! generate random scan + do k=1,npat + do j=1,neu_in + pat_in(j,k,n) = rvec(j) + len_step*dble(k-1)*rtang(j) + enddo + enddo + enddo + +! evaluate true number of patterns + npat=npat*scans + + end