lukasplevac/easyconfigs-it4i
1
0
Fork 0
mirror of https://code.it4i.cz/sccs/easyconfigs-it4i.git synced 2025-04-17 04:00:49 +01:00
Code Issues Packages Projects Releases Wiki Activity
easyconfigs-it4i/m/MRCC/mrcc_files/optim.f90
Lukas Krupcik eb1ea94130 merge master
2024-07-25 10:27:17 +02:00

9447 lines
321 KiB
Fortran
Raw Blame History

! TODO: Remove build_projection and use dgelss if possible
!************************************************************************
module optim
!************************************************************************
! OPTIMIZATION MODULE
! for basis set and geometry optimization procedures
! The calling routines are in basopt.f and geomopt.f
!************************************************************************
double precision, parameter :: ang2bohr = 1.d0/0.52917720859d0
double precision, parameter :: PI = 3.141592653589793d0
integer,parameter :: lstr=512 ! assumed max length of a line in the file MINP
integer,parameter :: iterfile=98 ! file ITER it stores the interation number of geomopt
integer,parameter :: icoordfile = 78 ! file number for COORD.int
integer,parameter :: minptmpf = 79 ! MINP.tmp
integer,parameter :: mheaderf=80, mfooterf=81 ! MINP.header and MINP.footer - temporary files without geom spec
integer,parameter :: cenergies=99 ! COORD.xyz.energies file for MOLDEN
integer,parameter :: crmsforce=97 ! COORD.xyz.rforce file for MOLDEN (rms force)
integer,parameter :: cmaxforce=96 ! COORD.xyz.mforce file for MOLDEN (max force)
integer,parameter :: coordfile=100 ! COORD.xyz.i file current geometry at step i
integer,parameter :: geomsfile=101 ! COORD.xyz.geometries file for MOLDEN it contains all the geoms during the optimization
integer,parameter :: pmatfile=102 ! scr file to hold projection matrix element, PMAT.int
integer,parameter :: ifcfile=20 ! file iface; MRCC interface file
integer, parameter :: bond_code=1 ! Code for regular bonds
integer, parameter :: angle_code=2 ! Code for bond angles
integer, parameter :: dangle_code=3 ! Code for dihedral angles
integer, parameter :: abond_code=4 ! Code for auxiliary bonds
integer, parameter :: fbond_code=5 ! Code for fragment bonds
integer, parameter :: hbond_code=6 ! Code for H-bonds
integer, parameter :: afbond_code=7 ! Code for auxiliary fragment bond
integer, parameter :: improper_code=8 ! Code for improper dihedrals
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! ARRAYS, TYPES
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!************************************************************************
character(len=lstr), dimension(:), allocatable :: alloc_pname ! array of types/parameter names
double precision, dimension(:), allocatable :: alloc_fgopt ! array of parameter values
integer, dimension(:), allocatable :: alloc_igopt ! whether or not the given parameter should be optimized
character(len=2), dimension(:), allocatable :: alloc_cgopt ! to hold the special marks '++', '--', or ' '
integer, dimension(:), allocatable :: alloc_atnums ! array of atomic numbers
character(len=2), dimension(:), allocatable :: alloc_atsymbols! array of atomic symbols
integer, dimension(:,:), allocatable :: alloc_rim ! redundant internal coordinate matrix
double precision, dimension(:,:), allocatable :: alloc_coords ! Cartesian coords
double precision, dimension(:), allocatable :: alloc_intcoords! internal coords
double precision, dimension(:,:), allocatable :: alloc_hessian ! initial Hessian matrix
type fragment_type
integer :: natoms
integer, allocatable :: atom_list(:)
end type
type coord_sys_type
character*16 :: name
integer :: natoms ! number of atoms including dummy atoms
integer :: natoms_original ! number of atoms excluding dummy
integer :: natoms_extra ! number of dummy atoms
integer :: ncoord_ric ! number of redundant internal coordinates
integer :: ncoord ! number of (internal) coordinates
integer :: nonred ! number of nonredundant coordinates
integer :: nfrozen ! number of frozen coordinates
integer, allocatable :: frozen(:) ! frozen coordinates
double precision, allocatable :: cvals(:) ! coordinate constrain values
double precision, allocatable :: coord(:)
double precision, allocatable :: cart_coord(:,:)
double precision, allocatable :: Umatrix(:,:)
!rim=redundant internal matrix
integer, allocatable :: rim(:,:)
end type
contains
!************************************************************************
double precision function epsilon_()
!************************************************************************
! it gives back machine epsilon
!************************************************************************
implicit none
epsilon_ = 1.d0
do while (1.d0 + 0.5d0*epsilon_ .gt. 1.d0)
epsilon_ = 0.5d0*epsilon_
enddo
end function epsilon_
!************************************************************************
!************************************************************************
subroutine cfillzero(str_array,n)
!************************************************************************
! This subroutine initialize a character array *
!************************************************************************
implicit none
integer,intent(in) :: n
character(len=*),dimension(:),intent(inout) :: str_array
!local
integer :: i
do i=1,n
str_array(i) = ''
enddo
return
end subroutine cfillzero
!************************************************************************
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! SIMPLEX ALGORITHM
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!************************************************************************
subroutine simplex(f2min,args,ftol,xtol,maxiter,maxfun,fopt, &
niter,nfeval,plevel,bool)
!************************************************************************
! The downhill simplex algorithm of Nelder and Mead;
! J.A. Nelder, R. Mead: Computer J., 7, 308 (1965);
! written by J Csontos
!
! The implementation is based on that of the numpy project
!
implicit none
double precision, intent(in) :: ftol,xtol
double precision, intent(out) :: fopt
integer, intent(in) :: maxfun,maxiter,plevel
integer, intent(out) :: niter,nfeval
double precision, dimension(:), intent(inout) :: args
logical, intent(out) :: bool
! local variables
logical :: doshrink=.False.
integer :: i,j,ndim
double precision :: functol,argtol,fxr,fxe,fxc,fxcc
! vertj is an array for the function values at the vertices of the simplex
double precision, dimension(:),allocatable :: vertj,xavg,xr,xe,xc
double precision, dimension(:),allocatable :: fsim,xcc
integer, dimension(:),allocatable :: order
double precision, dimension(:,:),allocatable :: sim
double precision, dimension(:,:),allocatable :: tmp
! the parameters for the transformation of the simplex
! rho -> factor of reflection
! psi -> factor of contraction
! chi -> factor of expansion
! del -> factor for generating the initial simplex
! zdel -> factor for generating the initial simplex
double precision, parameter :: rho=1.d0,chi=2.d0, &
psi=0.5d0, sigma=0.5d0
double precision, parameter :: del=0.05d0, zdel=0.00025d0
double precision, parameter :: eps=1d-6
interface
double precision function f2min(z)
double precision, dimension(:), intent(inout) :: z
end function
end interface
! ***
! f2min -> external function to be minimized
! args() -> independent variables of f2min;
! -> as an input: initial guess
! -> as an output: coordinates of the minimum
!
! ftol -> convergence criterion for the function values
! xtol -> convergence criterion for the function arguments
! maxiter -> maximum number of iterations allowed
! maxfun -> maximum number of function evaluations allowed
! fopt -> minimal value of f2min
! niter -> number of iterations performed
! nfeval -> number of function evaluations performed
! plevel -> determine the amount of information to be printed (the larger the more)
! ***
bool = .False.
ndim = size(args) ! dimension of f2min
nfeval = 0
allocate(vertj(ndim))
allocate(xavg(ndim))
allocate(xr(ndim))
allocate(xe(ndim))
allocate(xc(ndim))
allocate(xcc(ndim))
allocate(fsim(ndim+1))
allocate(order(ndim+1))
allocate(sim(ndim,ndim+1))
allocate(tmp(ndim,ndim+1))
do j=1,ndim+1
do i=1,ndim
sim(i,j)=0.d0
enddo
fsim(j)=0.d0 ! array for function values at the vertices
enddo
fsim(1)=f2min(args)
nfeval=nfeval+1
! generation of the initial simplex
! row-index stands for the coordinates of a given vertex (n)
! column index stands for the vertices (n+1)
do i=1,ndim
sim(i,1)=args(i)
vertj(i)=0.d0 ! array for function arguments at the vertices
enddo
do j=2,ndim+1
do i=1,ndim
if(i.eq.(j-1)) then
if(dabs(args(i)-0.d0).lt.eps) then
sim(i,j)=zdel
else
sim(i,j)=(1.d0+del)*args(i)
endif
else
sim(i,j)=args(i)
endif
vertj(i)=sim(i,j)
enddo
fsim(j)=f2min(vertj)
enddo
nfeval=nfeval+ndim
! rearrange the simplex points according to increasing function values
! best point first, worst point last
! the first column of sim contains the coordinates of the best point, etc.
call quick_sort(fsim,order)
call sort_mat(sim,order)
niter=0
if(plevel.gt.1) then
write(*,'(25x,3(a22))') &
'energy of worst point','energy change','step change'
write(*,*)
endif
do while(nfeval<maxfun .and. niter<maxiter)
argtol = fxtol(sim)
functol = fftol(fsim)
if(argtol.le.xtol.and.functol.le.ftol) exit ! convergence reached
! average arguments values without the worst point in the simplex
call fxavg(sim,xavg)
call transform(sim,xavg,xr)
fxr = f2min(xr)
nfeval = nfeval+1
doshrink = .False.
if(fxr.lt.fsim(1)) then
call expansion(sim,xavg,xe)
fxe = f2min(xe)
nfeval = nfeval+1
if(fxe.lt.fxr) then
call columnR(sim,xe)
fsim(ndim+1) = fxe
else
call columnR(sim,xr)
fsim(ndim+1) = fxr
endif
else
if(fxr.lt.fsim(ndim)) then
call columnR(sim,xr)
fsim(ndim+1) = fxr
else
if(fxr.lt.fsim(ndim+1)) then
call contraction(sim,xavg,xc)
fxc = f2min(xc)
nfeval = nfeval+1
if(fxc.le.fxr) then
call columnR(sim,xc)
fsim(ndim+1) = fxc
else
doshrink = .True.
endif
else
call icontraction(sim,xavg,xcc)
fxcc = f2min(xcc)
nfeval = nfeval+1
if(fxcc.lt.fsim(ndim+1)) then
call columnR(sim,xcc)
fsim(ndim+1) = fxcc
else
doshrink = .True.
endif
if(doshrink) then
do i=2,ndim+1
call shrink(sim)
fsim(i) = f2min(sim(1:,i))
enddo
nfeval = nfeval+ndim
endif
endif
endif
endif
! again rearrange the simplex points according to increasing function values
! best point first, worst point last
! the first column of sim contains the coordinates of the best point, etc.
call quick_sort(fsim,order)
call sort_mat(sim,order)
niter = niter+1
if(plevel.gt.1) then
write(*,'(5x,a,i5,3(2x,f20.12))') &
'Iteration info ',niter,fsim(ndim+1),functol,argtol
endif
fopt = minval(fsim)
args = sim(1:,1)
enddo
if(nfeval.ge.maxfun) then
write(*,*) 'Maximum number of function evaluations &
has been exceeded.'
else
if(niter.ge.maxiter) then
write(*,*) 'Maximum number of iterations &
has been exceeded.'
else
write(*,*) 'Optimization terminated successfully.'
bool = .True.
endif
endif
deallocate(vertj)
deallocate(xavg)
deallocate(xr)
deallocate(xe)
deallocate(xc)
deallocate(xcc)
deallocate(fsim)
deallocate(order)
deallocate(sim)
deallocate(tmp)
!************************************************************************
contains
!************************************************************************
!************************************************************************
subroutine sort_mat(A,order)
! A is a (ndim)*(ndim+1) dimension matrix
! the columns of A contains the points of the simplex
! this subroutine rearrange its columns based on the given order
implicit none
double precision, dimension(:,:), intent(inout) :: A
integer, dimension(size(A)+1), intent(in) :: order
! local variables
integer :: i,j,ndim
double precision, dimension(:,:), allocatable :: tmp
ndim=size(A,1)
allocate(tmp(ndim,ndim+1))
do j=1,ndim+1
do i=1,ndim
tmp(i,j) = A(i,order(j))
enddo
enddo
A = tmp
deallocate(tmp)
end subroutine sort_mat
!************************************************************************
subroutine shrink(A)
! A is a (ndim)*(ndim+1) dimension matrix
! the columns of A contains the points of the simplex
! this subroutine shrinks the simplex around the best point
implicit none
double precision, dimension(:,:), intent(inout) :: A
! local variables
integer :: i,j,ndim
ndim=size(A,1)
do j=2,ndim+1
do i=1,ndim
A(i,j) = A(i,1) + sigma*(A(i,j) - A(i,1))
enddo
enddo
if(plevel.gt.2) write(*,*) 'shrink'
end subroutine shrink
!************************************************************************
subroutine columnR(A,column)
! A is a (ndim)*(ndim+1) dimension matrix
! the columns of A contains the points of the simplex
! we only care about the last column - that is the worst point
! this subroutine replaces it with the vector column
implicit none
double precision, dimension(:,:), intent(inout) :: A
double precision, dimension(size(A,1)), intent(in) :: column
! local variables
integer :: i,ndim
ndim=size(A,1)
do i=1,ndim
A(i,ndim+1) = column(i)
enddo
end subroutine columnR
!************************************************************************
subroutine icontraction(A,vec,vertex)
! A is a (ndim)*(ndim+1) dimension matrix
! the columns of A contains the points of the simplex
! we only care about the last column - that is the worst point
! this subroutine transform it using vec to a hopefully better place
! vertex is the new point
implicit none
double precision, dimension(:,:), intent(in) :: A
double precision, dimension(size(A,1)), intent(in) :: vec
double precision, dimension(size(A,1)), intent(out) :: vertex
! local variables
integer :: i,ndim
ndim=size(A,1)
do i=1,ndim
vertex(i) = (1.d0-psi)*vec(i) + psi*A(i,ndim+1)
enddo
if(plevel.gt.2) write(*,*) 'icontraction'
end subroutine icontraction
!************************************************************************
subroutine contraction(A,vec,vertex)
! A is a (ndim)*(ndim+1) dimension matrix
! the columns of A contains the points of the simplex
! we only care about the last column - that is the worst point
! this subroutine transform it using vec to a hopefully better place
! vertex is the new point
implicit none
double precision, dimension(:,:), intent(in) :: A
double precision, dimension(size(A,1)), intent(in) :: vec
double precision, dimension(size(A,1)), intent(out) :: vertex
! local variables
integer :: i,ndim
ndim=size(A,1)
do i=1,ndim
vertex(i) = (1.d0+psi*rho)*vec(i) - psi*rho*A(i,ndim+1)
enddo
if(plevel.gt.2) write(*,*) 'contraction'
end subroutine contraction
!************************************************************************
subroutine expansion(A,vec,vertex)
! A is a (ndim)*(ndim+1) dimension matrix
! the columns of A contains the points of the simplex
! we only care about the last column - that is the worst point
! this subroutine transform it using vec to a hopefully better place
! vertex is the new point
implicit none
double precision, dimension(:,:), intent(in) :: A
double precision, dimension(size(A,1)), intent(in) :: vec
double precision, dimension(size(A,1)), intent(out) :: vertex
! local variables
integer :: i,ndim
ndim=size(A,1)
do i=1,ndim
vertex(i) = (1.d0+rho*chi)*vec(i) - rho*chi*A(i,ndim+1)
enddo
if(plevel.gt.2) write(*,*) 'expansion'
end subroutine expansion
!************************************************************************
subroutine transform(A,vec,vertex)
! A is a (ndim)*(ndim+1) dimension matrix
! the columns of A contains the points of the simplex
! we only care about the last column - that is the worst point
! this subroutine transform it using vec to a hopefully better place
! vertex is the new point
implicit none
double precision, dimension(:,:), intent(in) :: A
double precision, dimension(size(A,1)), intent(in) :: vec
double precision, dimension(size(A,1)), intent(out) :: vertex
! local variables
integer :: i,ndim
ndim=size(A,1)
do i=1,ndim
vertex(i) = (1.d0+rho)*vec(i) - rho*A(i,ndim+1)
enddo
if(plevel.gt.2) write(*,*) 'transform'
end subroutine transform
!************************************************************************
double precision function fftol(y)
! y is a (ndim+1) dimension vector and it contains
! the fucntion values at the vertices
! this function returns the largest difference
! relative to the lowest function value
implicit none
double precision, dimension(:), intent(in) :: y
! local variables
integer :: i,ndim
double precision, dimension(size(y)-1) :: z
ndim=size(y)
do i=2,ndim
z(i-1)=dabs(y(i)-y(1))
enddo
fftol=maxval(z) ! it retuns the maximum of the vector z
return
end function fftol
!************************************************************************
double precision function fxtol(A)
! A is a (ndim)*(ndim+1) dimension matrix
! the columns of A contains the points of the simplex
! this function returns the maximum displacement of the
! x-coordinates relative to the first point
implicit none
double precision, dimension(:,:), intent(in) :: A
! local variables
integer :: i,j,ndim
double precision, dimension(size(A,1),size(A,1)) :: B
ndim=size(A,1)
do j=2,ndim+1
do i=1,ndim
B(i,j-1)=dabs(A(i,j)-A(i,1))
enddo
enddo
fxtol=maxval(B) ! it retuns the maximum of the array B
return
end function fxtol
!************************************************************************
subroutine fxavg(A,avg)
! A is a (ndim)*(ndim+1) dimension matrix
! the columns of A contains the points of the simplex
! we don't care about the last column - that is the worst point
! this subroutine calculates the average of the arguments and
! return the average x-coordinates in vector avg
implicit none
double precision, dimension(:,:), intent(in) :: A
double precision, dimension(size(A,1)), intent(out) :: avg
! local variables
integer :: i,j,ndim
double precision :: sum_j
ndim=size(A,1)
do i=1,ndim
sum_j = 0.d0
do j=1,ndim
sum_j = sum_j + A(i,j)
enddo
avg(i) = sum_j/ndim
enddo
end subroutine fxavg
!************************************************************************
end subroutine simplex
!************************************************************************
!************************************************************************
recursive subroutine quick_sort(list, order)
! Quick sort routine from:
! Brainerd, W.S., Goldberg, C.H. & Adams, J.C. (1990) "Programmer's Guide to
! Fortran 90", McGraw-Hill ISBN 0-07-000248-7, pages 149-150.
! Modified by Alan Miller to include an associated integer array which gives
! the positions of the elements in the original order.
implicit none
double precision, dimension (:), intent(inout) :: list
integer, dimension (:), intent(out) :: order
! local variable
integer :: i
do i = 1, size(list)
order(i) = i
enddo
call quick_sort_1(1, size(list))
!************************************************************************
contains
!************************************************************************
recursive subroutine quick_sort_1(left_end, right_end)
integer, intent(in) :: left_end, right_end
! local variables
integer :: i, j, itemp
double precision :: reference, temp
integer, parameter :: max_simple_sort_size = 6
if (right_end < left_end + max_simple_sort_size) then
! Use interchange sort for small lists
call interchange_sort(left_end, right_end)
else
! Use partition ("quick") sort
reference = list((left_end + right_end)/2)
i = left_end - 1; j = right_end + 1
do
! Scan list from left end until element >= reference is found
do
i = i + 1
if (list(i) >= reference) exit
enddo
! Scan list from right end until element <= reference is found
do
j = j - 1
if (list(j) <= reference) exit
enddo
if (i < j) then
! Swap two out-of-order elements
temp = list(i); list(i) = list(j); list(j) = temp
itemp = order(i); order(i) = order(j); order(j) = itemp
elseif (i == j) then
i = i + 1
exit
else
exit
endif
enddo
if (left_end < j) call quick_sort_1(left_end, j)
if (i < right_end) call quick_sort_1(i, right_end)
endif
end subroutine quick_sort_1
!************************************************************************
!************************************************************************
subroutine interchange_sort(left_end, right_end)
integer, intent(in) :: left_end, right_end
! local variables
integer :: i, j, itemp
double precision :: temp
do i = left_end, right_end - 1
do j = i+1, right_end
if (list(i) > list(j)) then
temp = list(i); list(i) = list(j); list(j) = temp
itemp = order(i); order(i) = order(j); order(j) = itemp
endif
enddo
enddo
end subroutine interchange_sort
!************************************************************************
end subroutine quick_sort
!************************************************************************
!************************************************************************
subroutine build_unit_Hessian(H)
!************************************************************************
implicit none
double precision,dimension(:,:),intent(inout) :: H
!local
integer :: i,j,ndim
ndim = size(H,1)
do j=1,ndim ! initialization of arrays
do i=1,ndim
if(i .eq. j) then
H(i,j) = 1.d0
else
H(i,j) = 0.d0
endif
enddo
enddo
end subroutine build_unit_Hessian
!************************************************************************
!************************************************************************
subroutine get_Lindh_params(natoms,atnums,i,j,alpha,r)
!************************************************************************
implicit none
integer :: natoms
integer, intent(in) :: atnums(natoms)
integer, intent(in) :: i,j
double precision,intent(out) :: alpha,r
!local
double precision, dimension(3,3) :: A_ij,R_ij
A_ij = reshape((/1.0000,0.3949,0.3949,&
0.3949,0.2800,0.2800,&
0.3949,0.2800,0.2800/), shape(A_ij))
R_ij = reshape((/1.35,2.10,2.53,&
2.10,2.87,3.40,&
2.53,3.40,3.40/), shape(R_ij))
if(i.gt.natoms) then
alpha = 0.d0 ! no Lindh parameter for this atom
r = 0.d0 ! no Lindh parameter for this atom
elseif(atnums(i).le.2) then
if(j.gt.natoms) then
alpha = 0.d0 ! no Lindh parameter for this atom
r = 0.d0 ! no Lindh parameter for this atom
elseif(atnums(j).le.2) then
alpha = A_ij(1,1)
r = R_ij(1,1)
elseif(atnums(j).le.10) then
alpha = A_ij(1,2)
r = R_ij(1,2)
elseif(atnums(j).le.18) then
alpha = A_ij(1,3)
r = R_ij(1,3)
else
alpha = 0.d0 ! no Lindh parameter for this atom
r = 0.d0 ! no Lindh parameter for this atom
write(*,*)'No Lindh parameter is available for this atom:', &
atnums(j)
endif
elseif(atnums(i).le.10) then
if(j.gt.natoms) then
alpha = 0.d0 ! no Lindh parameter for this atom
r = 0.d0 ! no Lindh parameter for this atom
elseif(atnums(j).le.2) then
alpha = A_ij(2,1)
r = R_ij(2,1)
elseif(atnums(j).le.10) then
alpha = A_ij(2,2)
r = R_ij(2,2)
elseif(atnums(j).le.18) then
alpha = A_ij(2,3)
r = R_ij(2,3)
else
alpha = 0.d0 ! no Lindh parameter for this atom
r = 0.d0 ! no Lindh parameter for this atom
write(*,*)'No Lindh parameter is available for this atom:', &
atnums(j)
endif
elseif(atnums(i).le.18) then
if(j.gt.natoms) then
alpha = 0.d0 ! no Lindh parameter for this atom
r = 0.d0 ! no Lindh parameter for this atom
elseif(atnums(j).le.2) then
alpha = A_ij(3,1)
r = R_ij(3,1)
elseif(atnums(j).le.10) then
alpha = A_ij(3,2)
r = R_ij(3,2)
elseif(atnums(j).le.18) then
alpha = A_ij(3,3)
r = R_ij(3,3)
else
alpha = 0.d0 ! no Lindh parameter for this atom
r = 0.d0 ! no Lindh parameter for this atom
write(*,*)'No Lindh parameter is available for this atom:', &
atnums(j)
endif
else
alpha = 0.d0 ! no Lindh parameter for this atom
r = 0.d0 ! no Lindh parameter for this atom
write(*,*)'No Lindh parameter is available for this atom:', &
atnums(i)
endif
end subroutine get_Lindh_params
!************************************************************************
!************************************************************************
subroutine build_Lindh_Hessian(H,red_int_matrix,coords,atnums)
!************************************************************************
implicit none
double precision,dimension(:,:),intent(inout) :: H
integer,dimension(:,:),intent(in) :: red_int_matrix
double precision,dimension(:,:),intent(in) :: coords
integer,dimension(:),intent(in) :: atnums
!local
double precision, parameter :: k_r = 0.45 !Lindh et al, CPL, 241, 423 (1995)
double precision, parameter :: k_f = 0.15 !Lindh et al, CPL, 241, 423 (1995)
double precision, parameter :: k_t = 0.005 !Lindh et al, CPL, 241, 423 (1995)
integer :: i,j,k,l,m,ndim,itype,ncol,natoms
double precision :: r_ij,r_jk,r_kl
double precision :: a_ij,a_jk,a_kl
double precision :: rho_ij,rho_jk,rho_kl
double precision :: r_refij,r_refjk,r_refkl
double precision :: tmp
ndim = size(H,1)
ncol = size(H,2)
natoms=size(atnums)
H=0.0d0
do m=1,ndim
itype=red_int_matrix(1,m) ! type of internal coord
i =red_int_matrix(2,m) ! 1st atom
j =red_int_matrix(3,m) ! 2nd atom
k =red_int_matrix(4,m) ! 3rd atom
l =red_int_matrix(5,m) ! 4th atom
if(itype.eq.1 .or. itype.eq.4 .or. itype.eq.6 .or.&
itype.eq.5 .or. itype.eq.7) then ! internal bond
call get_Lindh_params(natoms,atnums,i,j,a_ij,r_refij)
r_ij = distance2(coords(1:3,i),coords(1:3,j))
rho_ij = dexp(a_ij*(r_refij**2 - r_ij**2))
tmp = (k_r*rho_ij)
elseif(itype.eq.2) then ! angle
call get_Lindh_params(natoms,atnums,i,j,a_ij,r_refij)
call get_Lindh_params(natoms,atnums,j,k,a_jk,r_refjk)
r_ij = distance2(coords(1:3,i),coords(1:3,j))
r_jk = distance2(coords(1:3,j),coords(1:3,k))
rho_ij = dexp(a_ij*(r_refij**2 - r_ij**2))
rho_jk = dexp(a_jk*(r_refjk**2 - r_jk**2))
tmp = (k_f*rho_ij*rho_jk)
elseif(itype.eq.3) then ! dihedral
call get_Lindh_params(natoms,atnums,i,j,a_ij,r_refij)
call get_Lindh_params(natoms,atnums,j,k,a_jk,r_refjk)
call get_Lindh_params(natoms,atnums,k,l,a_kl,r_refkl)
r_ij = distance2(coords(1:3,i),coords(1:3,j))
r_jk = distance2(coords(1:3,j),coords(1:3,k))
r_kl = distance2(coords(1:3,k),coords(1:3,l))
rho_ij = dexp(a_ij*(r_refij**2 - r_ij**2))
rho_jk = dexp(a_jk*(r_refjk**2 - r_jk**2))
rho_kl = dexp(a_kl*(r_refkl**2 - r_kl**2))
tmp = (k_t*rho_ij*rho_jk*rho_kl)
else
tmp = 1.0d0
endif
if(tmp .lt. 1.0d-8) tmp=1.0d0
if(ncol==1) then
H(m,1)=tmp
else
H(m,m)=tmp
endif
enddo
end subroutine build_Lindh_Hessian
!************************************************************************
!************************************************************************
subroutine build_initial_Hessian(H,red_int_matrix,coords)
!************************************************************************
implicit none
double precision,dimension(:,:),intent(inout) :: H
integer,dimension(:,:),intent(in) :: red_int_matrix
double precision,dimension(:,:),intent(in) :: coords
!local
integer :: i,j,k,l,m,n,ndim,itype
ndim = size(H,1)
do n=1,ndim ! initialization of arrays
do m=1,ndim
if(m .eq. n) then
itype=red_int_matrix(1,m) ! type of internal coord
i =red_int_matrix(2,m) ! 1st atom
j =red_int_matrix(3,m) ! 2nd atom
k =red_int_matrix(4,m) ! 3rd atom
l =red_int_matrix(5,m) ! 4th atom
if(itype.eq.1) then ! regular bond
H(m,m) = 1/0.5d0
endif
if(itype.eq.2) then ! angle
H(m,m) = 1/0.2d0
endif
if(itype.eq.3) then ! dihedral
H(m,m) = 1/0.1d0
endif
if(itype.eq.4) then ! auxiliary bond
H(m,m) = 1/0.2d0
endif
else
H(m,n) = 0.d0
endif
enddo
enddo
! call print_matrixR(H,9)
! call mrccend(1)
end subroutine build_initial_Hessian
!************************************************************************
!************************************************************************
subroutine get_Schlegel_param(atnums,i,j,B)
!************************************************************************
implicit none
integer,dimension(:),intent(in) :: atnums
integer, intent(in) :: i,j
double precision,intent(out) :: B
!local
integer :: natoms
double precision, dimension(3,3) :: B_ij
B_ij = reshape((/-0.244, 0.352, 0.660,&
0.352, 1.085, 1.522,&
0.660, 1.552, 2.068/), shape(B_ij))
natoms = size(atnums)
if(i.gt.natoms) then
B=0.0d0
elseif(atnums(i).le.2) then
if(j.gt.natoms) then
B = 0.0d0
elseif(atnums(j).le.2) then
B = B_ij(1,1)
elseif(atnums(j).le.10) then
B = B_ij(1,2)
elseif(atnums(j).le.18) then
B = B_ij(1,3)
else
B = 0.d0 ! no Schlegel parameter for this atom
write(*,*) &
'No Schlegel parameter is available for this atom:', &
atnums(j)
endif
elseif(atnums(i).le.10) then
if(j.gt.natoms) then
B=0.0d0
elseif(atnums(j).le.2) then
B = B_ij(2,1)
elseif(atnums(j).le.10) then
B = B_ij(2,2)
elseif(atnums(j).le.18) then
B = B_ij(2,3)
else
B = 0.d0 ! no Schlegel parameter for this atom
write(*,*) &
'No Schlegel parameter is available for this atom:', &
atnums(j)
endif
elseif(atnums(i).le.18) then
if(j.gt.natoms) then
B=0.0d0
elseif(atnums(j).le.2) then
B = B_ij(3,1)
elseif(atnums(j).le.10) then
B = B_ij(3,2)
elseif(atnums(j).le.18) then
B = B_ij(3,3)
else
B = 0.d0 ! no Schlegel parameter for this atom
write(*,*) &
'No Schlegel parameter is available for this atom:', &
atnums(j)
endif
else
B = 0.d0 ! no Schlegel parameter for this atom
write(*,*) &
'No Schlegel parameter is available for this atom:', &
atnums(j)
endif
end subroutine get_Schlegel_param
!************************************************************************
!************************************************************************
subroutine build_Schlegel_Hessian(H,red_int_matrix,coords,atnums)
!************************************************************************
implicit none
double precision,dimension(:,:),intent(inout) :: H
integer,dimension(:,:),intent(in) :: red_int_matrix
double precision,dimension(:,:),intent(in) :: coords
integer,dimension(:),intent(in) :: atnums
!local
integer :: i,j,k,l,m,n,ndim,itype,natoms
double precision :: r,r_cov,B,F
double precision, parameter :: fac = 1.3d0 !Schlegel, TCA, 66, 333 (1984) factror for minimal basis calcs
double precision, parameter :: A = 1.734d0 !Schlegel, TCA, 66, 333 (1984) constant A for bonds
double precision, parameter :: AbH = 0.160d0 !Schlegel, TCA, 66, 333 (1984) constant A for bends with hydrogens
double precision, parameter :: Ab = 0.250d0 !Schlegel, TCA, 66, 333 (1984) constant A for bends
double precision, parameter :: At = 0.0023d0 !Schlegel, TCA, 66, 333 (1984) constant A for torsions
double precision, parameter :: Bt = 0.0700d0 !Schlegel, TCA, 66, 333 (1984) constant B for torsions
double precision, parameter :: Aoup = 0.0450d0 !Schlegel, TCA, 66, 333 (1984) constant A for out of plane motions
! d = 1.d0-r1*(r2 x r3)/(|r1||r2||r3|)
! H = Aoup*d**4
ndim = size(H,1)
natoms=size(atnums)
do n=1,ndim ! initialization of arrays
do m=1,ndim
if(m .eq. n) then
itype=red_int_matrix(1,m) ! type of internal coord
i =red_int_matrix(2,m) ! 1st atom
j =red_int_matrix(3,m) ! 2nd atom
k =red_int_matrix(4,m) ! 3rd atom
l =red_int_matrix(5,m) ! 4th atom
if(itype.eq.bond_code .or. itype.eq.abond_code .or. &
itype.eq.fbond_code .or. itype.eq.afbond_code .or. &
itype.eq.hbond_code) then ! internal bond
call get_Schlegel_param(atnums,i,j,B)
r = distance2(coords(1:3,i),coords(1:3,j))
F = fac*A/((r-B)**3)
H(m,m) = F
endif
if(itype.eq.angle_code) then ! angle
if(i.gt.natoms .or. j.gt.natoms) then
F = fac*Ab
elseif(atnums(i).eq.1 .or. atnums(k).eq.1) then
F = fac*AbH
else
F = fac*Ab
endif
H(m,m) = F
endif
if(itype.eq.dangle_code) then ! dihedral
if(j.gt.natoms) then
r_cov = 0.0d0
else
r_cov = get_cov_radius(atnums(j))
endif
if(k.le.natoms) r_cov = r_cov + get_cov_radius(atnums(k))
r = distance2(coords(1:3,j),coords(1:3,k))
F = fac*(At - Bt*(r - r_cov))
H(m,m) = dabs(F)
endif
else
H(m,n) = 0.d0
endif
enddo
enddo
! call print_matrixR(H,9)
! call mrccend(1)
end subroutine build_Schlegel_Hessian
!************************************************************************
!************************************************************************
subroutine wrt_molden(niter,energy,gnorm,gmax)
! it writes energies and geometries suitable to append to file MOLDEN
implicit none
integer, intent(in) :: niter
double precision, intent(in) :: energy,gnorm,gmax
!local
character(len=512) :: si,scommand
if(niter .eq. 0) then
call ishell('echo "[GEOCONV]" > COORD.xyz.energies')
call ishell('echo "energy" >> COORD.xyz.energies')
open(cenergies,file='COORD.xyz.energies',position='append')
write(cenergies,103) energy
close(cenergies)
call ishell('echo "rms-force" >> COORD.xyz.rforce')
open(crmsforce,file='COORD.xyz.rforce',position='append')
write(crmsforce,103) gnorm
close(crmsforce)
call ishell('echo "max-force" >> COORD.xyz.mforce')
open(cmaxforce,file='COORD.xyz.mforce',position='append')
write(cmaxforce,103) gmax
close(cmaxforce)
call ishell('cp COORD.xyz COORD.xyz.0')
call ishell('echo "[GEOMETRIES] (XYZ)" > COORD.xyz.geometries')
call wrt_xyz_geoms(niter)
else
open(cenergies,file='COORD.xyz.energies',position='append')
write(cenergies,103) energy
close(cenergies)
open(crmsforce,file='COORD.xyz.rforce',position='append')
write(crmsforce,103) gnorm
close(crmsforce)
open(cmaxforce,file='COORD.xyz.mforce',position='append')
write(cmaxforce,103) gmax
close(cmaxforce)
si = int2char(niter)
scommand='cp COORD.xyz COORD.xyz.'//trim(adjustl(si))
call ishell(scommand)
call wrt_xyz_geoms(niter)
endif
103 format(f22.12,a2)
end subroutine wrt_molden
!************************************************************************
subroutine wrt_xyz_geoms(niter)
! it appends the current geometry to the file COORD.xyx.geometries
implicit none
integer, intent(in) :: niter
!local
character(len=512) :: fname,line,s10
integer :: i,natoms,l
fname = 'COORD.xyz.'//trim(adjustl(int2char(niter)))
open(unit=coordfile,file=fname,status='old') ! current geometry at step niter
open(unit=geomsfile,file='COORD.xyz.geometries',position='append')! all geometries concatenated to this file
read(coordfile,'(I10)') natoms ! first line, number of atoms
s10 = int2char(natoms)
l = len_trim(adjustl(s10))
write(geomsfile,'(a)') s10(1:l)
read(coordfile,104) line ! comment line
l = len_trim(adjustl(line))
write(geomsfile,'(a)') line(1:l)
do i=1,natoms
read(coordfile,104) line
l = len_trim(adjustl(line))
write(geomsfile,'(a)') line(1:l)
enddo
close(coordfile)
close(geomsfile)
104 format(a512)
end subroutine wrt_xyz_geoms
!************************************************************************
subroutine wrt_iter(niter)
! it writes the current iteration number into the file ITER
implicit none
integer, intent(in) :: niter
open(unit=iterfile,file='ITER') ! # interations is written in the file ITER
write(iterfile,*) niter
close(iterfile)
end subroutine wrt_iter
!************************************************************************
subroutine read_iter(niter)
!it reads the current iteration number from the file ITER
implicit none
integer, intent(out) :: niter
open(unit=iterfile,file='ITER') ! # interation number is read from the file ITER
read(iterfile,*) niter
close(iterfile)
end subroutine read_iter
!************************************************************************
subroutine outer_product(vecA,vecB,op)
! it returns the outer product, vecA'vecB, of vecA and vecB
! row vectors are assumed, therefore transpose of vecA times vecB will
! be returned (dimA,dimB)
implicit none
double precision, dimension(:), intent(in) :: vecA,vecB
double precision, dimension(size(vecA),size(vecB)) :: op
!local
integer i,j,dimA,dimB
dimA = size(vecA)
dimB = size(vecB)
do j=1,dimB
do i=1,dimA
op(i,j) = vecA(i) * vecB(j)
enddo
enddo
end subroutine outer_product
!************************************************************************
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! GDIIS ALGORITHM
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!************************************************************************
subroutine diis_extrap(niter,ndmax,xk,gk,Hk,sk)
!************************************************************************
! DIIS extrapolation
! nact - iteration step
! nmax - dimension of the vector to be extrapolated
! pvec - the updated vector
! evec - the original vector
! ndmax - maximum no. of iterations
!************************************************************************
implicit none
integer,intent(in) :: niter,ndmax
double precision, dimension(:), intent(inout) :: xk,gk ! geometry and gradient
double precision, dimension(:,:), intent(in) :: Hk ! inverse Hessian matrix
double precision, dimension(:), intent(inout) :: sk ! step(error)
!local
double precision, dimension(:), allocatable :: pvec ! updated vector
double precision, dimension(:), allocatable :: evec ! original vector
integer :: nmax
double precision, dimension(:), allocatable :: cvec ! vector of coefficients
double precision, dimension(:,:), allocatable :: bmat ! scalar product B matrix
double precision, dimension(:,:), allocatable :: invbmat ! inverse of the B matrix
double precision, dimension(:), allocatable :: bvec ! inverse of the B matrix
integer, parameter :: diisfile=110,errfile=111,ifltln=8 !MRCC common file!
integer, parameter :: gdiisfile=112
nmax = size(xk)
allocate(pvec(nmax))
allocate(evec(nmax))
allocate(cvec(ndmax))
allocate(bmat(ndmax,ndmax))
allocate(invbmat(ndmax,ndmax))
allocate(bvec(ndmax*ndmax))
cvec = 0.d0
! evec = -1.d0*matrix_dot_vec(Hk,gk)
call dgemv('n',nmax,nmax,-1.0d0,Hk,nmax,gk,1,0.0d0,evec,1)
write(*,*) 'trust diis evec'
call print_vectorR(evec,9)
! evec = sk
write(*,*) 'trust diis xk'
call print_vectorR(xk,9)
write(*,*) 'trust diis gk'
call print_vectorR(gk,9)
pvec = xk
call diismod(niter,nmax,pvec,evec,gk,ndmax,diisfile,errfile,&
gdiisfile,ifltln,bmat,bvec,invbmat,cvec)
! xk = xk - 1.d0*matrix_dot_vec(Hk,gk)
call dgemv('n',nmax,nmax,-1.0d0,Hk,nmax,gk,1,1.0d0,xk,1)
write(*,*) 'trust diis xk after', cvec
call print_vectorR(xk,9)
write(*,*) 'trust diis gk'
call print_vectorR(gk,9)
deallocate(pvec)
deallocate(evec)
deallocate(cvec)
deallocate(bmat)
deallocate(invbmat)
deallocate(bvec)
end subroutine diis_extrap
!************************************************************************
!************************************************************************
subroutine diismod(nact,nmax,pvec,evec,gvec,ndmax,diisfile,&
errfile,gdiisfile,ifltln,bmat,bvec,invbmat,&
cvec)
!************************************************************************
!* DIIS extrapolation *
!* nact - iteration step
!* nmax - dimension of the vector to be extrapolated
!* pvec - the updated vector
!* evec - the original vector
!* ndmax - maximum no. of iterations
!************************************************************************
implicit none
integer nact,iact,i,j,nmax,ndmax,iact1,iact2,diisfile
integer gdiisfile,errfile,ifltln
integer ipiv(ndmax),ndiis
real*8 bmat(ndmax,ndmax),bvec(ndmax**2),invbmat(ndmax,ndmax),ddot
real*8 cvec(ndmax),sum,sum1,evec(nmax),pvec(nmax)
real*8 gvec(nmax)
real*8, allocatable :: scr(:)
!
allocate(scr(nmax))
ndiis=8
open(diisfile,status='unknown',access='direct',recl=nmax*ifltln)
open(errfile,status='unknown',access='direct',recl=nmax*ifltln)
open(gdiisfile,status='unknown',access='direct',recl=nmax*ifltln)
! Save amplitudes and calculate new error vector
! call dfillzero(pvec,nmax)
write(diisfile,rec=nact) pvec
! do j=1,nmax
! pvec(j)=pvec(j)-evec(j)
! enddo
! write(errfile,rec=nact) pvec
write(errfile,rec=nact) evec
write(gdiisfile,rec=nact) gvec
! Update the scalar product matrix (B matrix)
do iact1=max(1,nact-ndiis+1),nact
read(errfile,rec=iact1) pvec
do iact2=max(1,nact-ndiis+1),iact1
read(errfile,rec=iact2) scr
sum=ddot(nmax,pvec,1,scr,1)
bmat(iact1-max(0,nact-ndiis),iact2-max(0,nact-ndiis))=sum
bmat(iact2-max(0,nact-ndiis),iact1-max(0,nact-ndiis))=sum
enddo
enddo
! Invert B matrix
do j=1,min(nact,ndiis)
do i=1,j
bvec(i+(j-1)*j/2)=bmat(i,j)
enddo
enddo
call dsptrf('U',min(nact,ndiis),bvec,ipiv,invbmat,i)
call dsptri('U',min(nact,ndiis),bvec,ipiv,invbmat,i)
do j=1,min(nact,ndiis)
do i=1,j
invbmat(i,j)=bvec(i+(j-1)*j/2)
invbmat(j,i)=invbmat(i,j)
enddo
enddo
! Denominator
sum=0.d0
do i=1,min(nact,ndiis)
do j=1,min(nact,ndiis)
sum=sum+invbmat(i,j)
enddo
enddo
sum=1.d0/sum
! Coefficients
do i=1,min(nact,ndiis)
sum1=0.d0
do j=1,min(nact,ndiis)
sum1=sum1+invbmat(i,j)
enddo
cvec(i)=sum*sum1
enddo
! New amplitudes
do i=1,nmax
pvec(i)=0.d0
enddo
do iact=1,min(nact,ndiis)
sum=cvec(iact)
read(diisfile,rec=iact+max(0,nact-ndiis)) scr
do j=1,nmax
pvec(j)=pvec(j)+sum*scr(j)
enddo
enddo
! New gradient
! do i=1,nmax
! gvec(i)=0.d0
! enddo
! do iact=1,min(nact,ndiis)
! sum=cvec(iact)
! read(gdiisfile,rec=iact+max(0,nact-ndiis)) scr
! do j=1,nmax
! gvec(j)=gvec(j)+sum*scr(j)
! enddo
! enddo
close(diisfile)
close(errfile)
close(gdiisfile)
!
deallocate(scr)
return
end subroutine diismod
!***********************************************************************
!************************************************************************
subroutine gdiisdel(nact,nmax,ifltln)
!************************************************************************
! this subroutine deletes the last gdiis information
!* DIIS extrapolation *
!* nact - iteration step
!* nmax - dimension of the vector to be extrapolated
!* pvec - the updated vector
!* evec - the original vector
!* ndmax - maximum no. of iterations
!************************************************************************
implicit none
integer, intent(in) :: nact,nmax,ifltln
!local
integer, parameter :: diisfile=110,errfile=111, gdiisfile=112
integer, parameter :: diisftmp=210,errftmp=211, gdiisftmp=212
integer :: i,istat
real*8,allocatable :: pvec(:)
!
#if !defined (gfortran) && !defined (G95)
integer*4 system
external system
#endif
allocate(pvec(nmax))
open(diisfile, file='DIIS.geo', status='unknown',access='direct',recl=nmax*ifltln)
open(diisftmp, file='DIIS.tmp', status='unknown',access='direct',recl=nmax*ifltln)
open(errfile, file='DIISE.geo',status='unknown',access='direct',recl=nmax*ifltln)
open(errftmp, file='DIISE.tmp',status='unknown',access='direct',recl=nmax*ifltln)
open(gdiisfile,file='DIISG.geo',status='unknown',access='direct',recl=nmax*ifltln)
open(gdiisftmp,file='DIISG.tmp',status='unknown',access='direct',recl=nmax*ifltln)
do i=1,nact-1
read (diisfile, rec=i) pvec
write(diisftmp, rec=i) pvec
read (errfile, rec=i) pvec
write(errftmp, rec=i) pvec
read (gdiisfile, rec=i) pvec
write(gdiisftmp, rec=i) pvec
enddo
close(diisfile)
close(diisftmp)
close(errfile)
close(errftmp)
close(gdiisfile)
close(gdiisftmp)
!
istat=system('test -e DIIS.tmp')
if(istat.eq.0) istat=system('mv DIIS.tmp DIIS.geo')
istat=system('test -e DIISE.tmp')
if(istat.eq.0) istat=system('mv DIISE.tmp DIISE.geo')
istat=system('test -e DIISG.tmp')
if(istat.eq.0) istat=system('mv DIISG.tmp DIISG.geo')
deallocate(pvec)
return
end subroutine gdiisdel
!***********************************************************************
!************************************************************************
subroutine gdiismod(nact,nmax,pvec,evec,gvec,ndmax,ifltln,bmat,&
bvec,invbmat,cvec)
!************************************************************************
!* DIIS extrapolation *
!* nact - iteration step
!* nmax - dimension of the vector to be extrapolated
!* pvec - the updated vector
!* evec - the original vector
!* ndmax - maximum no. of iterations
!************************************************************************
implicit none
integer, intent(in) ::nact,nmax,ndmax,ifltln
!local
integer, parameter :: diisfile=110,errfile=111, gdiisfile=112
integer :: iact,i,j,iact1,iact2
integer :: ipiv(ndmax),ndiis
real*8 bmat(ndmax,ndmax),bvec(ndmax**2),invbmat(ndmax,ndmax),ddot
real*8 cvec(ndmax),sum,sum1,evec(nmax),pvec(nmax)
real*8 gvec(nmax)
real*8,allocatable :: scr(:)
!
allocate(scr(nmax))
ndiis=4
open(diisfile, file='DIIS.geo', status='unknown',access='direct',recl=nmax*ifltln)
open(errfile, file='DIISE.geo',status='unknown',access='direct',recl=nmax*ifltln)
open(gdiisfile,file='DIISG.geo',status='unknown',access='direct',recl=nmax*ifltln)
! Save amplitudes and calculate new error vector
! call dfillzero(pvec,nmax)
write(diisfile,rec=nact) pvec
! do j=1,nmax
! pvec(j)=pvec(j)-evec(j)
! enddo
! write(errfile,rec=nact) pvec
write(errfile,rec=nact) evec
write(gdiisfile,rec=nact) gvec
! Update the scalar product matrix (B matrix)
do iact1=max(1,nact-ndiis+1),nact
read(errfile,rec=iact1) pvec
do iact2=max(1,nact-ndiis+1),iact1
read(errfile,rec=iact2) scr
sum=ddot(nmax,pvec,1,scr,1)
bmat(iact1-max(0,nact-ndiis),iact2-max(0,nact-ndiis))=sum
bmat(iact2-max(0,nact-ndiis),iact1-max(0,nact-ndiis))=sum
enddo
enddo
! Invert B matrix
do j=1,min(nact,ndiis)
do i=1,j
bvec(i+(j-1)*j/2)=bmat(i,j)
enddo
enddo
call dsptrf('U',min(nact,ndiis),bvec,ipiv,invbmat,i)
call dsptri('U',min(nact,ndiis),bvec,ipiv,invbmat,i)
do j=1,min(nact,ndiis)
do i=1,j
invbmat(i,j)=bvec(i+(j-1)*j/2)
invbmat(j,i)=invbmat(i,j)
enddo
enddo
! Denominator
sum=0.d0
do i=1,min(nact,ndiis)
do j=1,min(nact,ndiis)
sum=sum+invbmat(i,j)
enddo
enddo
sum=1.d0/sum
! Coefficients
do i=1,min(nact,ndiis)
sum1=0.d0
do j=1,min(nact,ndiis)
sum1=sum1+invbmat(i,j)
enddo
cvec(i)=sum*sum1
enddo
! New amplitudes
do i=1,nmax
pvec(i)=0.d0
enddo
do iact=1,min(nact,ndiis)
sum=cvec(iact)
read(diisfile,rec=iact+max(0,nact-ndiis)) scr
do j=1,nmax
pvec(j)=pvec(j)+sum*scr(j)
enddo
enddo
! New gradient
do i=1,nmax
gvec(i)=0.d0
enddo
do iact=1,min(nact,ndiis)
sum=cvec(iact)
read(gdiisfile,rec=iact+max(0,nact-ndiis)) scr
do j=1,nmax
gvec(j)=gvec(j)+sum*scr(j)
enddo
enddo
write(*,*)'inside gdiismod'
call print_vectorR(gvec,9)
close(diisfile)
close(errfile)
close(gdiisfile)
!
return
deallocate(scr)
end subroutine gdiismod
!***********************************************************************
!************************************************************************
subroutine gdiismod2(nact,nmax,pvec,evec,gvec,ndmax,ifltln,bmat,&
bvec,invbmat,cvec)
!************************************************************************
!* DIIS extrapolation *
!* nact - iteration step
!* nmax - dimension of the vector to be extrapolated
!* pvec - the updated vector
!* evec - the original vector
!* ndmax - maximum no. of iterations
!************************************************************************
implicit none
integer, intent(in) ::nact,nmax,ndmax,ifltln
!local
integer, parameter :: diisfile=110,errfile=111, gdiisfile=112
integer :: iact,i,j,iact1,iact2
integer :: ipiv(ndmax),ndiis
real*8 bmat(ndmax,ndmax),bvec(ndmax**2),invbmat(ndmax,ndmax),ddot
real*8 cvec(ndmax),sum,sum1,evec(nmax),pvec(nmax)
real*8 gvec(nmax)
real*8,allocatable :: scr(:)
!
allocate(scr(nmax))
ndiis=4
open(diisfile, file='DIIS.geo', status='unknown',access='direct',recl=nmax*ifltln)
open(errfile, file='DIISE.geo',status='unknown',access='direct',recl=nmax*ifltln)
open(gdiisfile,file='DIISG.geo',status='unknown',access='direct',recl=nmax*ifltln)
! Save amplitudes and calculate new error vector
! call dfillzero(pvec,nmax)
write(diisfile,rec=nact) pvec
! do j=1,nmax
! pvec(j)=pvec(j)-evec(j)
! enddo
! write(errfile,rec=nact) pvec
write(errfile,rec=nact) evec
write(gdiisfile,rec=nact) gvec
! Update the scalar product matrix (B matrix)
do iact1=max(1,nact-ndiis+1),nact
read(errfile,rec=iact1) pvec
do iact2=max(1,nact-ndiis+1),iact1
read(errfile,rec=iact2) scr
sum=ddot(nmax,pvec,1,scr,1)
bmat(iact1-max(0,nact-ndiis),iact2-max(0,nact-ndiis))=sum
bmat(iact2-max(0,nact-ndiis),iact1-max(0,nact-ndiis))=sum
enddo
enddo
! Invert B matrix
do j=1,min(nact,ndiis)
do i=1,j
bvec(i+(j-1)*j/2)=bmat(i,j)
enddo
enddo
call dsptrf('U',min(nact,ndiis),bvec,ipiv,invbmat,i)
call dsptri('U',min(nact,ndiis),bvec,ipiv,invbmat,i)
do j=1,min(nact,ndiis)
do i=1,j
invbmat(i,j)=bvec(i+(j-1)*j/2)
invbmat(j,i)=invbmat(i,j)
enddo
enddo
! Denominator
sum=0.d0
do i=1,min(nact,ndiis)
do j=1,min(nact,ndiis)
sum=sum+invbmat(i,j)
enddo
enddo
sum=1.d0/sum
! Coefficients
do i=1,min(nact,ndiis)
sum1=0.d0
do j=1,min(nact,ndiis)
sum1=sum1+invbmat(i,j)
enddo
cvec(i)=sum*sum1
enddo
! New amplitudes
do i=1,nmax
pvec(i)=0.d0
enddo
do iact=1,min(nact,ndiis)
sum=cvec(iact)
read(diisfile,rec=iact+max(0,nact-ndiis)) scr
do j=1,nmax
pvec(j)=pvec(j)+sum*scr(j)
enddo
enddo
!csonti print vector differences
do iact=1,min(nact,ndiis)
read(diisfile,rec=iact+max(0,nact-ndiis)) scr
write(*,*)'vec diffs trust', dot_product(pvec-scr,pvec-scr)
enddo
!csonti
! New gradient
do i=1,nmax
gvec(i)=0.d0
enddo
do iact=1,min(nact,ndiis)
sum=cvec(iact)
read(gdiisfile,rec=iact+max(0,nact-ndiis)) scr
do j=1,nmax
gvec(j)=gvec(j)+sum*scr(j)
enddo
enddo
write(*,*)'inside gdiismod'
call print_vectorR(gvec,9)
close(diisfile)
close(errfile)
close(gdiisfile)
!
deallocate(scr)
return
end subroutine gdiismod2
!***********************************************************************
!************************************************************************
subroutine gdiis_del(niter,ndim)
!************************************************************************
implicit none
integer,intent(in) :: niter,ndim
!local
integer, parameter :: ifltln=8 !MRCC common file!
call gdiisdel(niter,ndim,ifltln)
end subroutine gdiis_del
!************************************************************************
!************************************************************************
subroutine gdiis_extrap2(niter,ndmax,xk,gk,ek)
!************************************************************************
implicit none
integer,intent(in) :: niter,ndmax
double precision, dimension(:), intent(inout) :: xk,gk ! geometry and gradient
double precision, dimension(:), intent(in) :: ek ! error vector
!local
integer :: nmax
double precision, dimension(:), allocatable :: cvec ! vector of coefficients
double precision, dimension(:,:), allocatable :: bmat ! scalar product B matrix
double precision, dimension(:,:), allocatable :: invbmat ! inverse of the B matrix
double precision, dimension(:), allocatable :: bvec ! inverse of the B matrix
integer, parameter :: ifltln=8 !MRCC common file!
nmax = size(xk)
allocate(cvec(ndmax))
allocate(bmat(ndmax,ndmax))
allocate(invbmat(ndmax,ndmax))
allocate(bvec(ndmax*ndmax))
cvec = 0.d0
! write(*,*) 'trust before diis ek'
! call print_vectorR(ek,9)
! write(*,*) 'trust before diis xk'
! call print_vectorR(xk,9)
! write(*,*) 'trust before diis gk'
! call print_vectorR(gk,9)
call gdiismod2(niter,nmax,xk,ek,gk,ndmax,ifltln,&
bmat,bvec,invbmat,cvec)
! write(*,*) 'trust after diis ek'
! call print_vectorR(ek,9)
! write(*,*) 'trust after diis xk'
! call print_vectorR(xk,9)
! write(*,*) 'trust after diis gk'
! call print_vectorR(gk,9)
write(*,*) 'trust diis coefficients'
call print_vectorR(cvec,9)
deallocate(cvec)
deallocate(bmat)
deallocate(invbmat)
deallocate(bvec)
end subroutine gdiis_extrap2
!************************************************************************
!************************************************************************
subroutine gdiis_extrap(niter,ndmax,xk,gk,ek)
!************************************************************************
implicit none
integer,intent(in) :: niter,ndmax
double precision, dimension(:), intent(inout) :: xk,gk ! geometry and gradient
double precision, dimension(:), intent(in) :: ek ! error vector
!local
integer :: nmax
double precision, dimension(:), allocatable :: cvec ! vector of coefficients
double precision, dimension(:,:), allocatable :: bmat ! scalar product B matrix
double precision, dimension(:,:), allocatable :: invbmat ! inverse of the B matrix
double precision, dimension(:), allocatable :: bvec ! inverse of the B matrix
integer, parameter :: ifltln=8 !MRCC common file!
nmax = size(xk)
allocate(cvec(ndmax))
allocate(bmat(ndmax,ndmax))
allocate(invbmat(ndmax,ndmax))
allocate(bvec(ndmax*ndmax))
cvec = 0.d0
! write(*,*) 'trust before diis ek'
! call print_vectorR(ek,9)
! write(*,*) 'trust before diis xk'
! call print_vectorR(xk,9)
! write(*,*) 'trust before diis gk'
! call print_vectorR(gk,9)
call gdiismod(niter,nmax,xk,ek,gk,ndmax,ifltln,&
bmat,bvec,invbmat,cvec)
! write(*,*) 'trust after diis ek'
! call print_vectorR(ek,9)
! write(*,*) 'trust after diis xk'
! call print_vectorR(xk,9)
! write(*,*) 'trust after diis gk'
! call print_vectorR(gk,9)
write(*,*) 'trust diis coefficients'
call print_vectorR(cvec,9)
deallocate(cvec)
deallocate(bmat)
deallocate(invbmat)
deallocate(bvec)
end subroutine gdiis_extrap
!************************************************************************
!************************************************************************
subroutine gdiis(fegrad,args,Hk,&
ftol,gtol,xtol,maxiter,maxfun,finit,&
fopt,niter,nfeval,ngeval,plevel,lmolden,bool)
!************************************************************************
! The Broyden-Fletcher-Goldfarb-Shanno algorithm;
! written by J Csontos
!
! Hk is the inverse of the Hessian, see Nocedal and Wright, equation 8.16
implicit none
double precision, intent(in) :: ftol,gtol,xtol
double precision, intent(out) :: finit
double precision, intent(out) :: fopt
integer, intent(in) :: maxfun,maxiter,plevel
integer, intent(out) :: niter,nfeval,ngeval
double precision, dimension(:), intent(inout) :: args
logical, intent(in) :: lmolden ! Is molden file required?
logical, intent(out) :: bool
double precision, parameter :: Delta_0=0.5d0
double precision, parameter :: eta=1.0d-3
! double precision, parameter :: r=1.0d-2
! double precision, parameter :: etol=1.0d-6
! local variables
integer :: i,ndim
double precision :: gnorm,snorm,gmax,smax
double precision :: pred,ared,Delta_k
double precision :: fval,fval_prev
double precision, dimension(:), allocatable :: gfk,gfk_prev,xk,xk_prev
double precision, dimension(:), allocatable :: sk,ek,yk,Bs
double precision, dimension(:), allocatable :: results
double precision, dimension(:,:), allocatable :: Hk,Pmat,Pinv
logical :: notConverged,lBaker
interface
subroutine fegrad(z,fegrad_arr)
double precision, dimension(:), intent(inout) :: z
double precision, dimension(size(z)+1) :: fegrad_arr
end subroutine
end interface
! Atest = reshape((/1,2,4,0,-1,1,2,3,8/), shape(Atest))
! call matrix_inverse(Atest,Ctest)
! Atest = matmul(Atest,Ctest)
! write(*,*) ' matrix test i/o:'
! call print_matrixR(Ctest,3)
! write(*,*) ' matrix test i/o:'
! call print_matrixR(Atest,3)
! call mrccend(1)
! ***
! f2min -> external function to be minimized
! args() -> independent variables of f2min;
! -> as an input: initial guess
! -> as an output: coordinates of the minimum
! grad -> gradient of f2min
!
! gtol -> convergence criterion (largest element of the gradient vector)
! xtol -> convergence criterion for the function arguments
! maxiter -> maximum number of iterations allowed
! maxfun -> maximum number of function evaluations allowed
! finit -> initial value of f2min
! fopt -> minimal value of f2min
! niter -> number of iterations performed
! nfeval -> number of function evaluations performed
! ngeval -> number of gradient evaluations performed
! plevel -> determine the amount of information to be printed (the larger the more)
! ***
allocate(gfk(size(args)))
allocate(gfk_prev(size(args)))
allocate(xk(size(args)))
allocate(xk_prev(size(args)))
allocate(sk(size(args)))
allocate(ek(size(args)))
allocate(yk(size(args)))
allocate(Bs(size(args)))
allocate(results(size(args)+1))
allocate(Hk(size(args),size(args)))
allocate(Pmat(size(args),size(args)))
allocate(Pinv(size(args),size(args)))
ndim = size(args) ! dimension of the grad vector (fegrad(1:ndim)); the energy is stored in fegrad(ndim+1)
nfeval = 0
ngeval = 0
niter = 0
bool = .False.
lBaker = .True. ! Baker's convergence criteria are set
! call print_matrixR(Hk,9)
call print_inverse(Hk)
call fegrad(args,results)
finit = results(ndim+1) ! initial fucntion value
ngeval = ngeval+1
nfeval = nfeval+1
do i=1,ndim
gfk(i) = results(i)
enddo
fval = finit ! current function value
fval_prev = fval + 5000.0d0 ! previous function value
xk = args
gnorm = vecnorm(gfk,2) ! Euclidean
gmax = vecnorm(gfk,1000) ! infinit
call wrt_iter(niter) ! # interations is written in the file ITER
if(lmolden) call wrt_molden(niter,fval,gnorm,gmax)! MOLDEN info
Delta_k = Delta_0
notConverged = .True.
if( gnorm <= gtol) notConverged = .False.
if(.not. notConverged) then
if(plevel.gt.1) then
write(*,'(5x,a,i5,6(2x,f20.12))') &
'Iteration info ',niter,fval,gnorm,gmax,0.d0,0.d0,0.d0
endif
endif
do while(notConverged .and. niter < maxiter)! csonti introduce ftol and xtol here
niter = niter+1
! ek = -1.d0*matrix_dot_vec(Hk,gfk)
call dgemv('n',ndim,ndim,-1.0d0,Hk,ndim,gfk,1,0.0d0,ek,1)
write(*,*)'Iteration info gfk*ek',&
dot_product(gfk,ek),vecnorm(ek,2)
write(*,*)'vector ek:'
call print_vectorR(ek,9)
! alpha = direction_alpha(ek,gfk)
gfk_prev=gfk
xk_prev=xk
call gdiis_extrap(niter,20,xk,gfk,ek) ! xk, gfk are updated
call read_Pmat(ndim,Pmat)
write(*,*) 'Pmat*Pinv i/o:'
! gfk = matrix_dot_vec(Pmat,gfk)
call dgemv('n',ndim,ndim,1.0d0,Pmat,ndim,gfk,1,0.0d0,sk,1)
call dcopy(ndim,sk,1,gfk,1)
! sk = - 1.0d0*matrix_dot_vec(Hk,gfk)
call dgemv('n',ndim,ndim,-1.0d0,Hk,ndim,gfk,1,0.0d0,sk,1)
xk = xk + sk
call quadratic(sk,gfk_prev,Hk,pred,Bs) !csonti test
call fegrad(xk,results)
fval_prev = fval
fval = results(ndim+1)
nfeval = nfeval + 1
ngeval = ngeval + 1
do i=1,ndim
gfk(i)= results(i)
yk(i) = gfk(i) - gfk_prev(i)
enddo
sk = xk - xk_prev
ared = fval_prev - fval ! actual reduction in function value
gnorm = vecnorm(gfk,2) ! Euclidean
gmax = vecnorm(gfk,1000) ! infinit
snorm = vecnorm(sk,2)
smax = vecnorm(sk,1000)
if(lBaker) then !Baker conv criteria; JCC, 14, 1085 (1993)
if( gmax <= 3.d-4 .and. (ared<=1.d-6 .or. smax<=3.d-4) ) then
notConverged = .False.
endif
else
if( gnorm <= gtol) notConverged = .False.
endif
if(.not. notConverged) then
if(plevel.gt.1) then
write(*,'(5x,a,i5,6(2x,f20.12))') &
'Iteration info ',niter,fval,gnorm,gmax,snorm,smax,ared
endif
exit
endif
call wrt_iter(niter)
if(lmolden) call wrt_molden(niter,fval,gnorm,gmax)! MOLDEN info
if(niter.eq.1) then
write(*,'(5x,a)') &
'All quantities are in atomic units.'
write(*,'(5x,a,a5,6(a22))') &
'Iteration info ','step','energy','rms force','max force',&
'rms step','max step','energy change'
endif
if(plevel.gt.1) then
write(*,'(5x,a,i5,6(2x,f20.12))') &
'Iteration info ',niter,fval,gnorm,gmax,snorm,smax,ared
endif
! call bfgs_update_damped(sk,yk,Hk,q,Bs)
! sk = matrix_dot_vec(Pmat,sk)
call dgemv('n',ndim,ndim,1.0d0,Pmat,ndim,sk,1,0.0d0,pinv,1)
call dcopy(ndim,pinv,1,sk,1)
call bfgs_update(sk,yk,Hk)
! write(*,*) 'Projection matrix after i/o:'
! call print_matrixR(Pmat,10)
! write(*,*) 'Projection matrix inverse after i/o:'
! call print_matrixR(Pinv,10)
! One = matmul(Hk,Pinv)
! write(*,*) 'Pmat*Pinv i/o:'
! call print_matrixR(One,10)
! Hk=matmul(Hk,Pmat)
! Hk=matmul(Pmat,Hk)
call matrix_pseudoinverse(Pmat,Pinv)
call dgemm('n','n',ndim,ndim,ndim,1.0d0,Hk,ndim,Pinv,ndim,&
0.0d0,Pmat,ndim)
call dgemm('n','n',ndim,ndim,ndim,1.0d0,Pinv,ndim,Pmat,ndim,&
0.0d0,Hk,ndim)
! Hk=matmul(Hk,Pinv)
! Hk=matmul(Pinv,Hk)
! call matrix_inverse(Pmat,Hk)
! call print_inverse(Hk)
enddo
fopt = fval
args = xk
if(.not. notConverged .and. &
niter .lt. maxiter) then
bool=.True.
if(lmolden) then
call ishell('cat COORD.xyz.energies >> MOLDEN')
call ishell('cat COORD.xyz.rforce >> MOLDEN')
call ishell('cat COORD.xyz.mforce >> MOLDEN')
call ishell('cat COORD.xyz.geometries >> MOLDEN')
call ishell('rm -f COORD.xyz.* COORD.xyz.energies')
call ishell('rm -f COORD.xyz.rforce COORD.xyz.mforce')
call ishell('rm -f COORD.xyz.geometries')
endif
endif
deallocate(gfk)
deallocate(gfk_prev)
deallocate(xk)
deallocate(xk_prev)
deallocate(sk)
deallocate(ek)
deallocate(yk)
deallocate(Bs)
deallocate(results)
deallocate(Hk)
deallocate(Pmat)
deallocate(Pinv)
end subroutine gdiis
!************************************************************************
!************************************************************************
subroutine gdiis2(fegrad,args,Hk,&
ftol,gtol,xtol,maxiter,maxfun,finit,&
fopt,niter,nfeval,ngeval,plevel,lmolden,bool)
!************************************************************************
! The Broyden-Fletcher-Goldfarb-Shanno algorithm;
! written by J Csontos
!
! Hk is the inverse of the Hessian, see Nocedal and Wright, equation 8.16
implicit none
double precision, intent(in) :: ftol,gtol,xtol
double precision, intent(out) :: finit
double precision, intent(out) :: fopt
integer, intent(in) :: maxfun,maxiter,plevel
integer, intent(out) :: niter,nfeval,ngeval
double precision, dimension(:), intent(inout) :: args
logical, intent(in) :: lmolden ! Is molden file required?
logical, intent(out) :: bool
double precision, parameter :: Delta_0=0.5d0
double precision, parameter :: eta=1.0d-3
! double precision, parameter :: r=1.0d-2
! double precision, parameter :: etol=1.0d-6
! local variables
integer :: i,ndim,nditer
double precision :: gnorm,snorm,gmax,smax
double precision :: pred,ared,Delta_k
double precision :: fval,fval_prev
double precision, dimension(:), allocatable :: gfk,gfk_prev,xk
double precision, dimension(:), allocatable :: sk,ek,yk,xk_prev
double precision, dimension(:), allocatable :: results
double precision, dimension(:,:), allocatable :: Hk
logical :: notConverged,lBaker
interface
subroutine fegrad(z,fegrad_arr)
double precision, dimension(:), intent(inout) :: z
double precision, dimension(size(z)+1) :: fegrad_arr
end subroutine
end interface
! ***
! f2min -> external function to be minimized
! args() -> independent variables of f2min;
! -> as an input: initial guess
! -> as an output: coordinates of the minimum
! grad -> gradient of f2min
!
! gtol -> convergence criterion (largest element of the gradient vector)
! xtol -> convergence criterion for the function arguments
! maxiter -> maximum number of iterations allowed
! maxfun -> maximum number of function evaluations allowed
! finit -> initial value of f2min
! fopt -> minimal value of f2min
! niter -> number of iterations performed
! nfeval -> number of function evaluations performed
! ngeval -> number of gradient evaluations performed
! plevel -> determine the amount of information to be printed (the larger the more)
! ***
allocate(gfk(size(args)))
allocate(gfk_prev(size(args)))
allocate(xk(size(args)))
allocate(xk_prev(size(args)))
allocate(sk(size(args)))
allocate(ek(size(args)))
allocate(yk(size(args)))
allocate(results(size(args)+1))
allocate(Hk(size(args),size(args)))
ndim = size(args) ! dimension of the grad vector (fegrad(1:ndim)); the energy is stored in fegrad(ndim+1)
nfeval = 0
ngeval = 0
niter = 0
nditer = 0
bool = .False.
lBaker = .True. ! Baker's convergence criteria are set
! call print_matrixR(Hk,9)
call fegrad(args,results)
finit = results(ndim+1) ! initial fucntion value
ngeval = ngeval+1
nfeval = nfeval+1
do i=1,ndim
gfk(i) = results(i)
enddo
fval = finit ! current function value
fval_prev = fval + 5000.0d0 ! previous function value
xk = args
gnorm = vecnorm(gfk,2) ! Euclidean
gmax = vecnorm(gfk,1000) ! infinit
call wrt_iter(niter) ! # interations is written in the file ITER
if(lmolden) call wrt_molden(niter,fval,gnorm,gmax)! MOLDEN info
Delta_k = Delta_0
notConverged = .True.
if( gnorm <= gtol) notConverged = .False.
if(.not. notConverged) then
if(plevel.gt.1) then
write(*,'(5x,a,i5,6(2x,f20.12))') &
'Iteration info ',niter,fval,gnorm,gmax,0.d0,0.d0,0.d0
endif
endif
do while(notConverged .and. niter < maxiter)! csonti introduce ftol and xtol here
niter = niter+1
nditer = nditer+1
! ek = -1.d0*matrix_dot_vec(Hk,gfk)
call dgemv('n',ndim,ndim,-1.0d0,Hk,ndim,gfk,1,0.0d0,ek,1)
! call dogleg(Delta_k,ek,gfk,Hk,sk,pred,Bs) ! paramater pred is equal to the predicted reduction in the function value
! write(*,*)'Iteration info gfk*ek', dot_product(gfk,ek)
! alpha = direction_alpha(ek,gfk)
gfk_prev=gfk
xk_prev=xk
if(niter>0) call gdiis_extrap2(nditer,20,xk,gfk,ek) ! xk, gfk are updated
! sk = - 1.0d0*matrix_dot_vec(Hk,gfk)
call dgemv('n',ndim,ndim,-1.0d0,Hk,ndim,gfk,1,0.0d0,sk,1)
! if(vecnorm(sk,2)>Delta_k ) then
! sk = (Delta_k/vecnorm(ek,2))*sk
! endif
! write(*,*) 'trust gdiis predicted, s-length', pred,vecnorm(sk,2)
xk = xk + sk
sk = xk - xk_prev
! call quadratic(sk,gfk_prev,Hk,pred,Bs) !csonti test
write(*,*) 'trust gdiis predicted, s-length', pred,vecnorm(sk,2)
! if(vecnorm(xk-xk_prev,2)>Delta_k ) then
! sk = (Delta_k/vecnorm(xk-xk_prev,2))*(xk-xk_prev)
! xk = xk_prev + sk
! endif
call fegrad(xk,results)
fval_prev = fval
fval = results(ndim+1)
nfeval = nfeval + 1
ngeval = ngeval + 1
do i=1,ndim
gfk(i)= results(i)
yk(i) = gfk(i) - gfk_prev(i)
enddo
ared = fval_prev - fval ! actual reduction in function value
! if(ared>0) then
! nditer = nditer + 1
! call gdiis_extrap(nditer,20,sk,yk,ek)
! endif
gnorm = vecnorm(gfk,2) ! Euclidean
gmax = vecnorm(gfk,1000) ! infinit
snorm = vecnorm(sk,2)
smax = vecnorm(sk,1000)
if(lBaker) then !Baker conv criteria; JCC, 14, 1085 (1993)
if( gmax <= 3.d-4 .and. (ared<=1.d-6 .or. smax<=3.d-4) ) then
notConverged = .False.
endif
else
if( gnorm <= gtol) notConverged = .False.
endif
if(.not. notConverged) then
if(plevel.gt.1) then
write(*,'(5x,a,i5,6(2x,f20.12))') &
'Iteration info ',niter,fval,gnorm,gmax,snorm,smax,ared
endif
exit
endif
call wrt_iter(niter)
if(lmolden) call wrt_molden(niter,fval,gnorm,gmax)! MOLDEN info
if(niter.eq.1) then
write(*,'(5x,a)') &
'All quantities are in atomic units.'
write(*,'(5x,a,a5,6(a22))') &
'Iteration info ','step','energy','rms force','max force',&
'rms step','max step','energy change'
endif
if(plevel.gt.1) then
write(*,'(5x,a,i5,6(2x,f20.12))') &
'Iteration info ',niter,fval,gnorm,gmax,snorm,smax,ared
endif
! call quadratic(sk,gfk_prev,Hk,pred,Bs)
! q = ared/pred
! if(q .le. eta) then
! xk = xk_prev
! gfk = gfk_prev
! fval = fval_prev
! call gdiis_del(nditer,size(xk)) ! last step deleted
! nditer = nditer-1
! call trustR_update(ared,pred,Delta_k,snorm)
! if(q<0) then
! call dogleg(Delta_k,ek,gfk,Hk,sk,pred,Bs) ! paramater pred is equal to the predicted reduction in the function value
! xk = xk + ek
! results = fegrad(xk)
! fval_prev = fval
! fval = results(ndim+1)
! write(*,*) 'trust dogleg step energy', fval
! nfeval = nfeval + 1
! ngeval = ngeval + 1
! do i=1,ndim
! gfk(i)= results(i)
! enddo
! ared = fval_prev - fval ! actual reduction in function value
! snorm = vecnorm(sk,2)
! call trustR_update(ared,pred,Delta_k,vecnorm(ek,2))
! call bfgs_update(sk,yk,Hk)
! endif
! else
! call trustR_update(ared,pred,Delta_k,snorm)
if(vecnorm(sk,2)<Delta_k) call bfgs_update(sk,yk,Hk)
! endif
! write(*,*) 'trust skyk',dot_product(sk,yk),&
! 1e-2*dot_product(sk,Bs),ared,pred,ared/pred,nditer
! if(ared > 0) then
! call bfgs_update(sk,yk,Hk)
! endif
enddo
fopt = fval
args = xk
if(.not. notConverged .and. &
niter .lt. maxiter) then
bool=.True.
if(lmolden) then
call ishell('cat COORD.xyz.energies >> MOLDEN')
call ishell('cat COORD.xyz.rforce >> MOLDEN')
call ishell('cat COORD.xyz.mforce >> MOLDEN')
call ishell('cat COORD.xyz.geometries >> MOLDEN')
call ishell('rm -f COORD.xyz.* COORD.xyz.energies')
call ishell('rm -f COORD.xyz.rforce COORD.xyz.mforce')
call ishell('rm -f COORD.xyz.geometries')
endif
endif
deallocate(gfk)
deallocate(gfk_prev)
deallocate(xk)
deallocate(xk_prev)
deallocate(sk)
deallocate(ek)
deallocate(yk)
deallocate(results)
deallocate(Hk)
end subroutine gdiis2
!************************************************************************
!************************************************************************
subroutine gdiis_o(fegrad,args,Hk,&
ftol,gtol,xtol,maxiter,maxfun,finit,&
fopt,niter,nfeval,ngeval,plevel,lmolden,bool)
!************************************************************************
! The Broyden-Fletcher-Goldfarb-Shanno algorithm;
! written by J Csontos
!
! Hk is the inverse of the Hessian, see Nocedal and Wright, equation 8.16
implicit none
double precision, intent(in) :: ftol,gtol,xtol
double precision, intent(out) :: finit
double precision, intent(out) :: fopt
integer, intent(in) :: maxfun,maxiter,plevel
integer, intent(out) :: niter,nfeval,ngeval
double precision, dimension(:), intent(inout) :: args
logical, intent(in) :: lmolden ! Is molden file required?
logical, intent(out) :: bool
double precision, parameter :: Delta_0=0.5d0
double precision, parameter :: eta=1.0d-3
! double precision, parameter :: r=1.0d-2
! double precision, parameter :: etol=1.0d-6
! local variables
integer :: i,ndim
double precision :: gnorm,snorm,gmax,smax
double precision :: ared,Delta_k
double precision :: fval,fval_prev
double precision, dimension(:),allocatable :: gfk,gfk_prev,xk,xk_prev
double precision, dimension(:),allocatable :: sk,ek,yk
double precision, dimension(:),allocatable :: results
double precision, dimension(:,:),allocatable :: Hk
logical :: notConverged,lBaker
interface
subroutine fegrad(z,fegrad_arr)
double precision, dimension(:), intent(inout) :: z
double precision, dimension(size(z)+1) :: fegrad_arr
end subroutine
end interface
! ***
! f2min -> external function to be minimized
! args() -> independent variables of f2min;
! -> as an input: initial guess
! -> as an output: coordinates of the minimum
! grad -> gradient of f2min
!
! gtol -> convergence criterion (largest element of the gradient vector)
! xtol -> convergence criterion for the function arguments
! maxiter -> maximum number of iterations allowed
! maxfun -> maximum number of function evaluations allowed
! finit -> initial value of f2min
! fopt -> minimal value of f2min
! niter -> number of iterations performed
! nfeval -> number of function evaluations performed
! ngeval -> number of gradient evaluations performed
! plevel -> determine the amount of information to be printed (the larger the more)
! ***
allocate(gfk(size(args)))
allocate(gfk_prev(size(args)))
allocate(xk(size(args)))
allocate(xk_prev(size(args)))
allocate(sk(size(args)))
allocate(ek(size(args)))
allocate(yk(size(args)))
allocate(results(size(args)+1))
allocate(Hk(size(args),size(args)))
ndim = size(args) ! dimension of the grad vector (fegrad(1:ndim)); the energy is stored in fegrad(ndim+1)
nfeval = 0
ngeval = 0
niter = 0
bool = .False.
lBaker = .True. ! Baker's convergence criteria are set
! call print_matrixR(Hk,9)
call fegrad(args,results)
finit = results(ndim+1) ! initial fucntion value
ngeval = ngeval+1
nfeval = nfeval+1
do i=1,ndim
gfk(i) = results(i)
enddo
fval = finit ! current function value
fval_prev = fval + 5000.0d0 ! previous function value
xk = args
gnorm = vecnorm(gfk,2) ! Euclidean
gmax = vecnorm(gfk,1000) ! infinit
call wrt_iter(niter) ! # interations is written in the file ITER
if(lmolden) call wrt_molden(niter,fval,gnorm,gmax)! MOLDEN info
Delta_k = Delta_0
notConverged = .True.
if( gnorm <= gtol) notConverged = .False.
if(.not. notConverged) then
if(plevel.gt.1) then
write(*,'(5x,a,i5,6(2x,f20.12))') &
'Iteration info ',niter,fval,gnorm,gmax,0.d0,0.d0,0.d0
endif
endif
do while(notConverged .and. niter < maxiter)! csonti introduce ftol and xtol here
niter = niter+1
! call print_inverse(Hk)
! ek = -1.d0*matrix_dot_vec(Hk,gfk)
call dgemv('n',ndim,ndim,-1.0d0,Hk,ndim,gfk,1,0.0d0,ek,1)
write(*,*)'Iteration info gfk*ek',&
dot_product(gfk,ek),vecnorm(ek,2)
! alpha = direction_alpha(ek,gfk)
gfk_prev=gfk
xk_prev=xk
call gdiis_extrap(niter,20,xk,gfk,ek) ! xk, gfk are updated
! sk = - 1.0d0*matrix_dot_vec(Hk,gfk)
call dgemv('n',ndim,ndim,-1.0d0,Hk,ndim,gfk,1,0.0d0,sk,1)
xk = xk + sk
call fegrad(xk,results)
fval_prev = fval
fval = results(ndim+1)
nfeval = nfeval + 1
ngeval = ngeval + 1
do i=1,ndim
gfk(i)= results(i)
yk(i) = gfk(i) - gfk_prev(i)
enddo
sk = xk - xk_prev
ared = fval_prev - fval ! actual reduction in function value
gnorm = vecnorm(gfk,2) ! Euclidean
gmax = vecnorm(gfk,1000) ! infinit
snorm = vecnorm(sk,2)
smax = vecnorm(sk,1000)
if(lBaker) then !Baker conv criteria; JCC, 14, 1085 (1993)
if( gmax <= 3.d-4 .and. (ared<=1.d-6 .or. smax<=3.d-4) ) then
notConverged = .False.
endif
else
if( gnorm <= gtol) notConverged = .False.
endif
if(.not. notConverged) then
if(plevel.gt.1) then
write(*,'(5x,a,i5,6(2x,f20.12))') &
'Iteration info ',niter,fval,gnorm,gmax,snorm,smax,ared
endif
exit
endif
call wrt_iter(niter)
if(lmolden) call wrt_molden(niter,fval,gnorm,gmax)! MOLDEN info
if(niter.eq.1) then
write(*,'(5x,a)') &
'All quantities are in atomic units.'
write(*,'(5x,a,a5,6(a22))') &
'Iteration info ','step','energy','rms force','max force',&
'rms step','max step','energy change'
endif
if(plevel.gt.1) then
write(*,'(5x,a,i5,6(2x,f20.12))') &
'Iteration info ',niter,fval,gnorm,gmax,snorm,smax,ared
endif
call bfgs_update(sk,yk,Hk)
enddo
fopt = fval
args = xk
if(.not. notConverged .and. &
niter .lt. maxiter) then
bool=.True.
if(lmolden) then
call ishell('cat COORD.xyz.energies >> MOLDEN')
call ishell('cat COORD.xyz.rforce >> MOLDEN')
call ishell('cat COORD.xyz.mforce >> MOLDEN')
call ishell('cat COORD.xyz.geometries >> MOLDEN')
call ishell('rm -f COORD.xyz.* COORD.xyz.energies')
call ishell('rm -f COORD.xyz.rforce COORD.xyz.mforce')
call ishell('rm -f COORD.xyz.geometries')
endif
endif
deallocate(gfk)
deallocate(gfk_prev)
deallocate(xk)
deallocate(xk_prev)
deallocate(sk)
deallocate(ek)
deallocate(yk)
deallocate(results)
deallocate(Hk)
end subroutine gdiis_o
!************************************************************************
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! BFGS ALGORITHM
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!************************************************************************
subroutine bfgs_B(fegrad,args,Bk,ftol,gtol,xtol,maxiter,maxfun,&
finit,fopt,niter,nfeval,ngeval,plevel,lmolden,bool,csys)
!************************************************************************
! The Broyden-Fletcher-Goldfarb-Shanno algorithm;
! written by J Csontos
!
! Bk is the Hessian, see Nocedal and Wright, equation 8.19
! Hessian update is utilized
! (it is not efficient at the moment, it should use Cholesky factors)
implicit none
type(coord_sys_type) :: csys,csys_k
double precision, intent(in) :: ftol,gtol,xtol
double precision, intent(out) :: finit
double precision, intent(out) :: fopt
integer, intent(in) :: maxfun,maxiter,plevel
integer, intent(out) :: niter,nfeval,ngeval
double precision, dimension(:), intent(inout) :: args
logical, intent(in) :: lmolden ! Is molden file required?
logical, intent(out) :: bool
double precision, parameter :: Delta_0=0.5d0
double precision, parameter :: eta=1.0d-3
! double precision, parameter :: r=1.0d-2
! double precision, parameter :: etol=1.0d-6
double precision, dimension(size(args),size(args)) :: Bk
! local variables
integer :: i,ndim,lwork,rank
double precision :: gnorm,snorm,gmax,smax
double precision :: pred,ared,q,Delta_k
double precision :: fval,fval_prev
double precision, dimension(:),allocatable :: gfk
double precision, dimension(:),allocatable :: sk,pk,yk,Bs
double precision, dimension(:),allocatable :: results
double precision, dimension(:),allocatable :: work,sing_vals
double precision, dimension(:,:),allocatable :: Hk
double precision, dimension(:,:),allocatable :: Pmat
logical :: converged,notConverged,lBaker
external fegrad
! ***
! f2min -> external function to be minimized
! args() -> independent variables of f2min;
! -> as an input: initial guess
! -> as an output: coordinates of the minimum
! grad -> gradient of f2min
!
! gtol -> convergence criterion (largest element of the gradient vector)
! xtol -> convergence criterion for the function arguments
! maxiter -> maximum number of iterations allowed
! maxfun -> maximum number of function evaluations allowed
! finit -> initial value of f2min
! fopt -> minimal value of f2min
! niter -> number of iterations performed
! nfeval -> number of function evaluations performed
! ngeval -> number of gradient evaluations performed
! plevel -> determine the amount of information to be printed (the larger the more)
! ***
ndim = size(args) ! dimension of the grad vector (fegrad(1:ndim)); the energy is stored in fegrad(ndim+1)
allocate(gfk(ndim))
allocate(sk(ndim))
allocate(pk(ndim))
allocate(yk(ndim))
allocate(Bs(ndim))
allocate(results(ndim+1))
allocate(Hk(ndim,ndim))
allocate(Pmat(ndim,ndim))
allocate(sing_vals(ndim))
call dgelss(ndim,ndim,1,Hk,ndim,pk,ndim,sing_vals,&
-1.0d0,rank,sing_vals,-1,i)
lwork=int(sing_vals(1))
allocate(work(lwork))
nfeval = 0
ngeval = 0
niter = 0
bool = .False.
lBaker = .False. !.True. ! Baker's convergence criteria are set
snorm = 0.0d0
smax = 0.0d0
ared = 0.0d0
call fegrad(csys,results)
finit = results(ndim+1) ! initial function value
ngeval = ngeval+1
nfeval = nfeval+1
do i=1,ndim
gfk(i) = results(i)
enddo
fval = finit ! current function value
fval_prev = fval + 5000.0d0 ! previous function value
csys_k%ncoord=0
call copy_coord_sys(csys,csys_k)
gnorm = vecnorm(gfk,2) ! Euclidean
gmax = vecnorm(gfk,1000) ! infinit
call wrt_iter(niter) ! # interations is written in the file ITER
if(lmolden) call wrt_molden(niter,fval,gnorm,gmax)! MOLDEN info
Delta_k = Delta_0
notConverged = .True.
if( gnorm <= gtol) notConverged = .False.
if(.not. notConverged) then
if(plevel.gt.1) then
call print_iter_info(niter,fval,gnorm,gmax,snorm,smax,ared)
endif
endif
do while(notConverged .and. niter < maxiter)! csonti introduce ftol and xtol here
call dcopy(ndim*ndim,Bk,1,Hk,1)
if(csys%nfrozen /= 0) then
call get_constrain_term(csys,gfk,pk)
call daxpy(ndim,1.0d0,gfk,1,pk,1)
else
call dcopy(ndim,gfk,1,pk,1)
endif
call dgelss(ndim,ndim,1,Hk,ndim,pk,ndim,sing_vals,&
1.0d-5,rank,work,lwork,i)
call dscal(ndim,-1.0d0,pk,1)
call dogleg_B(Delta_k,pk,gfk,Bk,sk,pred,Bs) ! paramater pred is equal to the predicted reduction in the function value
niter = niter+1
! xk = xk + sk
call update_coordinates(sk,csys_k)
call fegrad(csys_k,results)
fval_prev = fval
fval = results(ndim+1)
nfeval = nfeval + 1
ngeval = ngeval + 1
do i=1,ndim
yk(i) = results(i) - gfk(i)
gfk(i)= results(i)
enddo
ared = fval_prev - fval ! actual reduction in function value
gnorm = vecnorm(gfk,2) ! Euclidean
gmax = vecnorm(gfk,1000) ! infinit
snorm = vecnorm(sk,2)
smax = vecnorm(sk,1000)
! if(lBaker) then !Baker conv criteria; JCC, 14, 1085 (1993)
! if( gmax <= 3.d-4 .and. (dabs(ared)<=1.d-6 .or. smax<=3.d-4) ) then
! notConverged = .False.
! endif
! else
! if( gmax <= gtol .and. (dabs(ared)<=ftol .or. smax <= xtol) ) then
! notConverged = .False.
! endif
! endif
converged=gopt_conv(gmax,ared,smax,gtol,ftol,xtol,lbaker)
notconverged=.not.converged
if(.not. notConverged) then
if(plevel.gt.1) then
call print_iter_info(niter,fval,gnorm,gmax,snorm,smax,ared)
endif
exit
endif
call wrt_iter(niter)
if(lmolden) call wrt_molden(niter,fval,gnorm,gmax)! MOLDEN info
if(plevel.gt.1) then
call print_iter_info(niter,fval,gnorm,gmax,snorm,smax,ared)
endif
q = ared/pred
call trustR_update(ared,pred,Delta_k,snorm)
call bfgs_update_damped_B(sk,yk,Bk,q,Bs)
call read_Pmat(ndim,Pmat)
call dgemm('n','n',ndim,ndim,ndim,1.0d0,Bk,ndim,Pmat,ndim,&
0.0d0,Hk,ndim)
call dgemm('n','n',ndim,ndim,ndim,1.0d0,Pmat,ndim,Hk,ndim,&
0.0d0,Bk,ndim)
enddo
fopt = fval
call copy_coord_sys(csys_k,csys)
args = csys%coord
call dealloc_coord_sys(csys_k)
if(niter .ge. maxiter) then
write(*,*)'ERROR: Maximum number of iterations exceeded.'
endif
if(.not. notConverged .and. niter .lt. maxiter) then
bool=.True.
if(lmolden) call update_molden
endif
deallocate(gfk)
deallocate(sk)
deallocate(pk)
deallocate(yk)
deallocate(Bs)
deallocate(results)
deallocate(Hk)
deallocate(Pmat)
deallocate(work)
deallocate(sing_vals)
end subroutine bfgs_B
!************************************************************************
!************************************************************************
subroutine print_iter_info(niter,fval,gnorm,gmax,snorm,smax,ared)
!************************************************************************
! it prints information about the current geometry optimization step
!************************************************************************
integer,intent(in) :: niter
double precision,intent(in) :: fval,gnorm,gmax,snorm,smax,ared
write(*,*)
write(*,1003)
write(*,'(15x,a,I10)') 'GEOMETRY OPTIMIZATION STEP', niter
write(*,*)
write(*,'(5x,(a22),f20.12)') 'energy',fval
write(*,'(5x,(a22),f20.12)') 'rms force',gnorm
write(*,'(5x,(a22),f20.12)') 'max force',gmax
write(*,'(5x,(a22),f20.12)') 'rms step',snorm
write(*,'(5x,(a22),f20.12)') 'max step',smax
write(*,'(5x,(a22),f20.12)') 'energy change',ared
write(*,*)
write(*,'(14x,a)') &
'All quantities are in atomic units'
write(*,1003)
1003 format(1x,70('@'))
end subroutine print_iter_info
!************************************************************************
!************************************************************************
subroutine bfgs(fegrad,args,Hk,&
ftol,gtol,xtol,maxiter,maxfun,finit,&
fopt,niter,nfeval,ngeval,plevel,lmolden,bool)
!************************************************************************
! The Broyden-Fletcher-Goldfarb-Shanno algorithm;
! written by J Csontos
!
! Hk is the inverse of the Hessian, see Nocedal and Wright, equation 8.16
! inverse Hessian update is utilized
implicit none
double precision, intent(in) :: ftol,gtol,xtol
double precision, intent(out) :: finit
double precision, intent(out) :: fopt
integer, intent(in) :: maxfun,maxiter,plevel
integer, intent(out) :: niter,nfeval,ngeval
double precision, dimension(:), intent(inout) :: args
logical, intent(in) :: lmolden ! Is molden file required?
logical, intent(out) :: bool
double precision, parameter :: Delta_0=0.5d0
double precision, parameter :: eta=1.0d-3
! double precision, parameter :: r=1.0d-2
! double precision, parameter :: etol=1.0d-6
! local variables
integer :: i,ndim
double precision :: gnorm,snorm,gmax,smax,alpha
double precision :: pred,ared,q,Delta_k
double precision :: fval,fval_prev
double precision, dimension(:),allocatable :: gfk,gfk_prev,xk
double precision, dimension(:),allocatable :: sk,pk,yk,Bs
double precision, dimension(:),allocatable :: results
double precision, dimension(:,:),allocatable :: Hk,Hinv
logical :: lmessage,notConverged,lBaker
interface
subroutine fegrad(z,fegrad_arr)
double precision, dimension(:), intent(inout) :: z
double precision, dimension(size(z)+1) :: fegrad_arr
end subroutine
end interface
! ***
! f2min -> external function to be minimized
! args() -> independent variables of f2min;
! -> as an input: initial guess
! -> as an output: coordinates of the minimum
! grad -> gradient of f2min
!
! gtol -> convergence criterion (largest element of the gradient vector)
! xtol -> convergence criterion for the function arguments
! maxiter -> maximum number of iterations allowed
! maxfun -> maximum number of function evaluations allowed
! finit -> initial value of f2min
! fopt -> minimal value of f2min
! niter -> number of iterations performed
! nfeval -> number of function evaluations performed
! ngeval -> number of gradient evaluations performed
! plevel -> determine the amount of information to be printed (the larger the more)
! ***
allocate(gfk(size(args)))
allocate(gfk_prev(size(args)))
allocate(xk(size(args)))
allocate(sk(size(args)))
allocate(pk(size(args)))
allocate(yk(size(args)))
allocate(Bs(size(args)))
allocate(results(size(args)+1))
allocate(Hk(size(args),size(args)))
allocate(Hinv(size(args),size(args)))
ndim = size(args) ! dimension of the grad vector (fegrad(1:ndim)); the energy is stored in fegrad(ndim+1)
nfeval = 0
ngeval = 0
niter = 0
bool = .False.
lBaker = .True. ! Baker's convergence criteria are set
! call print_matrixR(Hk,9)
call matrix_pseudoinverse(Hk,Hinv)
Hk = Hinv
call fegrad(args,results)
finit = results(ndim+1) ! initial fucntion value
ngeval = ngeval+1
nfeval = nfeval+1
do i=1,ndim
gfk(i) = results(i)
enddo
fval = finit ! current function value
fval_prev = fval + 5000.0d0 ! previous function value
xk = args
gnorm = vecnorm(gfk,2) ! Euclidean
gmax = vecnorm(gfk,1000) ! infinit
call wrt_iter(niter) ! # interations is written in the file ITER
if(lmolden) call wrt_molden(niter,fval,gnorm,gmax)! MOLDEN info
Delta_k = Delta_0
notConverged = .True.
if( gnorm <= gtol) notConverged = .False.
if(.not. notConverged) then
if(plevel.gt.1) then
write(*,'(5x,a,i5,6(2x,f20.12))') &
'Iteration info ',niter,fval,gnorm,gmax,0.d0,0.d0,0.d0
endif
endif
do while(notConverged .and. niter < maxiter)! csonti introduce ftol and xtol here
! pk = -1.d0*matrix_dot_vec(Hk,gfk)
call dgemv('n',ndim,ndim,-1.0d0,Hk,ndim,gfk,1,0.0d0,pk,1)
write(*,*)'Iteration info gfk*pk', dot_product(gfk,pk)
call dogleg(Delta_k,pk,gfk,Hk,sk,pred,Bs) ! paramater pred is equal to the predicted reduction in the function value
! call ddogleg(Delta_k,pk,gfk,Hk,sk,pred,Bs) !csonti test
alpha = direction_alpha(sk,gfk)
niter = niter+1
xk = xk + sk
call fegrad(xk,results)
fval_prev = fval
fval = results(ndim+1)
nfeval = nfeval + 1
ngeval = ngeval + 1
do i=1,ndim
yk(i) = results(i) - gfk(i)
gfk_prev(i) = gfk(i)
gfk(i)= results(i)
enddo
ared = fval_prev - fval ! actual reduction in function value
gnorm = vecnorm(gfk,2) ! Euclidean
gmax = vecnorm(gfk,1000) ! infinit
snorm = vecnorm(sk,2)
smax = vecnorm(sk,1000)
if(lBaker) then !Baker conv criteria; JCC, 14, 1085 (1993)
if( gmax <= 3.d-4 .and. (ared<=1.d-6 .or. smax<=3.d-4) ) then
notConverged = .False.
endif
else
if( gnorm <= gtol) notConverged = .False.
endif
if(.not. notConverged) then
if(plevel.gt.1) then
write(*,'(5x,a,i5,6(2x,f20.12))') &
'Iteration info ',niter,fval,gnorm,gmax,snorm,smax,ared
endif
exit
endif
call wrt_iter(niter)
if(lmolden) call wrt_molden(niter,fval,gnorm,gmax)! MOLDEN info
if(niter.eq.1) then
write(*,'(5x,a)') &
'All quantities are in atomic units.'
write(*,'(5x,a,a5,6(a22))') &
'Iteration info ','step','energy','rms force','max force',&
'rms step','max step','energy change'
endif
if(plevel.gt.1) then
write(*,'(5x,a,i5,6(2x,f20.12))') &
'Iteration info ',niter,fval,gnorm,gmax,snorm,smax,ared
endif
q = ared/pred
! if(q .le. eta) then
! xk = xk - sk
! gfk = gfk_prev
! fval = fval_prev
! endif
call trustR_update(ared,pred,Delta_k,snorm)
call bfgs_update_damped(sk,yk,Hk,q,Bs)
! write(*,*) 'Pmat*Pinv i/o:'
! call read_Pmat(ndim,Pmat)
! call print_matrixR(Pmat,10)
! Hk = matmul(Hk,Pmat)
! Hk = matmul(Pmat,Hk)
! write(*,*) 'Hk before inverse:'
! call print_matrixR(Hk,10)
! call matrix_inverse(Hk,Hinv)
! write(*,*) 'Hinv:'
! call print_matrixR(Hinv,10)
! One = matmul(Hk,Hinv)
! write(*,*) 'One:'
! call print_matrixR(One,10)
! Atest = reshape((/1,2,4,0,-1,1,2,3,8/), shape(Atest))
! write(*,*) ' matrix A:'
! call print_matrixR(Atest,3)
! call matrix_inverse(Atest,Ctest)
! write(*,*) ' matrix Ainv:'
! call print_matrixR(Ctest,3)
! Atest = matmul(Atest,Ctest)
! write(*,*) ' matrix test i/o:'
! call print_matrixR(Atest,3)
! call mrccend(1)
! sk = matrix_dot_vec(Pmat,sk)
! call bfgs_update(sk,yk,Hk)
! write(*,*) 'Projection matrix after i/o:'
! call print_matrixR(Pmat,10)
! write(*,*) 'Projection matrix inverse after i/o:'
! call print_matrixR(Pinv,10)
! One = matmul(Hk,Pinv)
! write(*,*) 'Pmat*Pinv i/o:'
! call print_matrixR(One,10)
! Hk=matmul(Hk,Pmat)
! Hk=matmul(Pmat,Hk)
! call matrix_pseudoinverse(Pmat,Pinv)
! Hk=matmul(Hk,Pinv)
! Hk=matmul(Pinv,Hk)
! call matrix_inverse(Pmat,Hk)
! call print_inverse(Hk)
enddo
fopt = fval
args = xk
if(.not. notConverged .and. &
niter .lt. maxiter .and. &
.not.lmessage) then
bool=.True.
if(lmolden) then
call ishell('cat COORD.xyz.energies >> MOLDEN')
call ishell('cat COORD.xyz.rforce >> MOLDEN')
call ishell('cat COORD.xyz.mforce >> MOLDEN')
call ishell('cat COORD.xyz.geometries >> MOLDEN')
call ishell('rm -f COORD.xyz.* COORD.xyz.energies')
call ishell('rm -f COORD.xyz.rforce COORD.xyz.mforce')
call ishell('rm -f COORD.xyz.geometries')
endif
endif
deallocate(gfk)
deallocate(gfk_prev)
deallocate(xk)
deallocate(sk)
deallocate(pk)
deallocate(yk)
deallocate(Bs)
deallocate(results)
deallocate(Hk)
deallocate(Hinv)
end subroutine bfgs
!************************************************************************
subroutine lbfgs(fegrad,args,H0,ftol,gtol,xtol,maxiter,maxfun, &
finit,fopt,niter,nfeval,ngeval,plevel,lmolden,&
bool,mem,csys)
!************************************************************************
! The Broyden-Fletcher-Goldfarb-Shanno algorithm;
!
implicit none
type(coord_sys_type) :: csys,csys_k,csys_prev
double precision, intent(in) :: ftol,gtol,xtol
double precision, intent(out) :: finit
double precision, intent(out) :: fopt
integer, intent(in) :: maxfun,maxiter,plevel,mem
integer, intent(out) :: niter,nfeval,ngeval
double precision, dimension(:), intent(inout) :: args
logical, intent(in) :: lmolden ! Is molden file required?
logical, intent(out) :: bool
double precision, parameter :: Delta_0=0.5d0
double precision, parameter :: Delta_max=5d0
double precision, dimension(size(args),1) :: H0
! local variables
integer :: i,ndim
double precision :: gnorm,snorm,gmax,smax
double precision :: ared,Delta_k
double precision :: fval,fval_prev
double precision :: sn,ddot
double precision, dimension(:),allocatable :: gfk,gfk_prev,xk
double precision, dimension(:),allocatable :: sk,pk,yk
double precision, dimension(:),allocatable :: results
double precision, dimension(:,:),allocatable :: mem_sk,mem_yk
logical :: lmessage,notConverged,lBaker
external fegrad
! ***
! f2min -> external function to be minimized
! args() -> independent variables of f2min;
! -> as an input: initial guess
! -> as an output: coordinates of the minimum
! grad -> gradient of f2min
!
! gtol -> convergence criterion (largest element of the gradient vector)
! xtol -> convergence criterion for the function arguments
! maxiter -> maximum number of iterations allowed
! maxfun -> maximum number of function evaluations allowed
! finit -> initial value of f2min
! fopt -> minimal value of f2min
! niter -> number of iterations performed
! nfeval -> number of function evaluations performed
! ngeval -> number of gradient evaluations performed
! plevel -> determine the amount of information to be printed (the larger the more)
! ***
ndim = size(args) ! dimension of the grad vector (fegrad(1:ndim)); the energy is stored in fegrad(ndim+1)
allocate(gfk(ndim))
allocate(gfk_prev(ndim))
allocate(xk(ndim))
allocate(sk(ndim))
allocate(pk(ndim))
allocate(yk(ndim))
allocate(results(ndim+1))
allocate(mem_sk(ndim,mem))
allocate(mem_yk(ndim,mem))
nfeval = 0
ngeval = 0
niter = 0
bool = .False.
lBaker = .True. ! Baker's convergence criteria are set
call fegrad(csys,results)
finit = results(ndim+1) ! initial fucntion value
ngeval = ngeval+1
nfeval = nfeval+1
do i=1,ndim
gfk(i) = results(i)
enddo
fval = finit ! current function value
fval_prev = fval + 5000.0d0 ! previous function value
call copy_coord_sys(csys,csys_k)
gnorm = vecnorm(gfk,2) ! Euclidean
gmax = vecnorm(gfk,1000) ! infinit
call wrt_iter(niter) ! # interations is written in the file ITER
if(lmolden) call wrt_molden(niter,fval,gnorm,gmax)! MOLDEN info
Delta_k = Delta_0
notConverged = .True.
if( gnorm <= gtol) notConverged = .False.
if(.not. notConverged) then
if(plevel.gt.1) then
call print_iter_info(niter,fval,gnorm,gmax,snorm,smax,ared)
endif
endif
do while(notConverged .and. niter < maxiter)! csonti introduce ftol and xtol here
call lbfgs_step(ndim,H0,gfk,mem_sk,mem_yk,sk,niter,mem)
sn = vecnorm(sk,2)
if(sn>delta_k) call dscal(ndim,delta_k/sn,sk,1)
write(*,*) 'lbfgs step'
write(*,'(100ES12.3)') sk
write(*,*) 'delta: ',delta_k
niter = niter+1
! xk = xk + sk
call copy_coord_sys(csys_k,csys_prev)
call update_coordinates(sk,csys_k)
call fegrad(csys_k,results)
fval_prev = fval
fval = results(ndim+1)
nfeval = nfeval + 1
ngeval = ngeval + 1
do i=1,ndim
yk(i) = results(i) - gfk(i)
gfk_prev(i) = gfk(i)
gfk(i)= results(i)
enddo
ared = fval_prev - fval ! actual reduction in function value
gnorm = vecnorm(gfk,2) ! Euclidean
gmax = vecnorm(gfk,1000) ! infinit
snorm = vecnorm(sk,2)
smax = vecnorm(sk,1000)
if(lBaker) then !Baker conv criteria; JCC, 14, 1085 (1993)
if( gmax <= 3.d-4 .and. (ared<=1.d-6 .or. smax<=3.d-4) ) then
notConverged = .False.
endif
else
if( gnorm <= gtol) notConverged = .False.
endif
if(.not. notConverged) then
if(plevel.gt.1) then
call print_iter_info(niter,fval,gnorm,gmax,snorm,smax,ared)
endif
exit
endif
call wrt_iter(niter)
if(lmolden) call wrt_molden(niter,fval,gnorm,gmax)! MOLDEN info
if(plevel.gt.1) then
call print_iter_info(niter,fval,gnorm,gmax,snorm,smax,ared)
endif
if(niter>1) then
call lbfgs_trustr_update(ndim,fval,fval_prev,sk,&
mem_sk(:,mod(niter-2,mem)+1),gfk,gfk_prev,sn,delta_k,&
delta_max)
endif
if(fval>fval_prev .or. ddot(ndim,gfk,1,sk,1)>0.0d0) then
delta_k=0.5d0*delta_k
call copy_coord_sys(csys_prev,csys_k)
gfk = gfk_prev
fval = fval_prev
niter=niter-1
else
mem_sk(:,mod(niter-1,mem)+1) = sk
mem_yk(:,mod(niter-1,mem)+1) = yk
endif
enddo
fopt = fval
call copy_coord_sys(csys_k,csys)
args = csys%coord
call dealloc_coord_sys(csys_k)
call dealloc_coord_sys(csys_prev)
if(.not. notConverged .and. &
niter .lt. maxiter .and. &
.not.lmessage) then
bool=.True.
if(lmolden) call update_molden
endif
deallocate(gfk)
deallocate(gfk_prev)
deallocate(xk)
deallocate(sk)
deallocate(pk)
deallocate(yk)
deallocate(results)
deallocate(mem_sk)
deallocate(mem_yk)
end subroutine lbfgs
!************************************************************************
subroutine lbfgs_trustr_update(ndim,ener,ener_old,s,s_old,g,g_old,&
sn,delta,delta_max)
!************************************************************************
! L-BFGS trus radius update, Phys. Chem. Chem. Phys., 2000, 2, 2177
!************************************************************************
implicit none
integer, intent(in) :: ndim
double precision, intent(in) :: ener,ener_old,sn,delta_max
double precision, intent(in) :: s(ndim),s_old(ndim)
double precision, intent(in) :: g(ndim),g_old(ndim)
double precision, intent(inout) :: delta
! local
double precision, parameter :: w1 = 1.0d-4
double precision, parameter :: w2 = 0.9d0
double precision :: dener,gs,gs_old,a
double precision :: ddot
logical lwolfe
dener = ener-ener_old
gs_old = ddot(ndim,g_old,1,s_old,1)
gs = ddot(ndim,g,1,s_old,1)
lwolfe = (dener<w1*gs_old .and. gs>w2*gs_old)
if(dener<w1*gs_old .and. sn>delta) then
a=1.25d0
else
a=1.0d0
endif
if(lwolfe) then
delta=min(2*a*delta,delta_max)
else
delta=min(delta_max,a*delta,sn)
endif
end subroutine
!************************************************************************
subroutine lbfgs_step(ndim,H0,grad,mem_sk,mem_yk,sk,niter,mem)
!************************************************************************
! Calculates th L-BFGS step vector
! Nocedal Wright, Numerical optimization, algorithm 7.4
!************************************************************************
implicit none
integer, intent(in) :: ndim,niter,mem
double precision, intent(in) :: H0(ndim,1),grad(ndim)
double precision, intent(in) :: mem_sk(ndim,mem),mem_yk(ndim,mem)
double precision, intent(out) :: sk(ndim)
!local
integer :: i,m,k
double precision :: beta
double precision, allocatable :: alpha(:),rho(:)
allocate(alpha(mem))
allocate(rho(mem))
m=min(niter,mem)
if(m==0) then
do i=1,ndim
sk(i)=H0(i,1)*grad(i)
enddo
else
sk=grad
do k=niter-1,niter-m,-1
i=mod(k,mem)+1
rho(i)=1.0d0/dot_product(mem_sk(:,1),mem_yk(:,i))
alpha(i)=rho(i)*dot_product(mem_sk(:,i),sk)
sk=sk-alpha*mem_yk(:,i)
enddo
do i=1,ndim
sk(i)=H0(i,1)*sk(i)
enddo
do k=niter-m,niter-1
i=mod(k,mem)+1
beta=rho(i)*dot_product(mem_yk(:,i),sk)
sk=sk+(alpha(i)-beta)*mem_sk(:,i)
enddo
endif
sk=-sk
deallocate(alpha)
deallocate(rho)
end subroutine
!************************************************************************
subroutine bfgs_rfo(fegrad,args,Bk,ftol,gtol,xtol,maxiter,&
maxfun,finit,fopt,niter,nfeval,ngeval,plevel,lmolden,&
bool,csys)
!************************************************************************
! Rational function optimization with BFGS Hessian
!************************************************************************
implicit none
type(coord_sys_type) csys,csys_k,csys_prev
double precision, intent(in) :: ftol,gtol,xtol
double precision, intent(out) :: finit
double precision, intent(out) :: fopt
integer, intent(in) :: maxfun,maxiter,plevel
integer, intent(out) :: niter,nfeval,ngeval
double precision, dimension(:), intent(inout) :: args
logical, intent(in) :: lmolden ! Is molden file required?
logical, intent(out) :: bool
double precision, parameter :: Delta_0=0.5d0
double precision, parameter :: Lb=0.0d0
double precision, parameter :: Ub=2.0d0
double precision, dimension(size(args),size(args)) :: Bk
! local variables
integer :: i,ndim,natoms
double precision :: gnorm,snorm,gmax,smax
double precision :: pred,ared,q,Delta_k
double precision :: fval,fval_prev
double precision, dimension(:),allocatable :: gfk,gfk_prev,gfk_c
double precision, dimension(:),allocatable :: sk,yk,Bs
double precision, dimension(:),allocatable :: results
double precision, dimension(:,:),allocatable :: Pmat,PB
logical :: lmessage,notConverged,lBaker,converged
external fegrad
! ***
! f2min -> external function to be minimized
! args() -> independent variables of f2min;
! -> as an input: initial guess
! -> as an output: coordinates of the minimum
! grad -> gradient of f2min
!
! gtol -> convergence criterion (largest element of the gradient vector)
! xtol -> convergence criterion for the function arguments
! maxiter -> maximum number of iterations allowed
! maxfun -> maximum number of function evaluations allowed
! finit -> initial value of f2min
! fopt -> minimal value of f2min
! niter -> number of iterations performed
! nfeval -> number of function evaluations performed
! ngeval -> number of gradient evaluations performed
! plevel -> determine the amount of information to be printed (the larger the more)
! ***
! ndim = size(args) ! dimension of the grad vector (fegrad(1:ndim)); the energy is stored in fegrad(ndim+1)
ndim=csys%ncoord
natoms=csys%natoms
allocate(gfk(ndim))
allocate(gfk_c(ndim))
allocate(gfk_prev(ndim))
allocate(sk(ndim))
allocate(yk(ndim))
allocate(Bs(ndim))
allocate(results(ndim+1))
allocate(Pmat(ndim,ndim))
allocate(PB(ndim,ndim))
nfeval = 0
ngeval = 0
niter = 0
bool = .False.
lBaker = .true. ! Baker's convergence criteria are set
call fegrad(csys,results)
finit = results(ndim+1) ! initial fucntion value
ngeval = ngeval+1
nfeval = nfeval+1
do i=1,ndim
gfk(i) = results(i)
enddo
fval = finit ! current function value
fval_prev = fval + 5000.0d0 ! previous function value
call copy_coord_sys(csys,csys_k)
gnorm = vecnorm(gfk,2) ! Euclidean
gmax = vecnorm(gfk,1000) ! infinit
call wrt_iter(niter) ! # interations is written in the file ITER
if(lmolden) call wrt_molden(niter,fval,gnorm,gmax)! MOLDEN info
Delta_k = Delta_0
notConverged = .True.
if( gnorm <= gtol) notConverged = .False.
if(.not. notConverged) then
if(plevel.gt.1) then
call print_iter_info(niter,fval,gnorm,gmax,snorm,smax,ared)
endif
endif
do while(notConverged .and. niter < maxiter)! csonti introduce ftol and xtol here
niter = niter+1
if(csys%nfrozen /= 0) then
call get_constrain_term(csys,gfk,gfk_c)
call daxpy(ndim,1.0d0,gfk,1,gfk_c,1)
else
gfk_c=gfk
endif
! call rfo_step_new(ndim,Bk,gfk_c,sk,delta_k,csys_k,pred)
call rfo_step(ndim,Bk,gfk_c,sk,delta_k,csys_k%nonred)
pred=-rfo_pred(ndim,gfk,sk,Bk,Bs)
! xk = xk + sk
call copy_coord_sys(csys_k,csys_prev)
call update_coordinates(sk,csys_k)
call fegrad(csys_k,results)
fval_prev = fval
fval = results(ndim+1)
nfeval = nfeval + 1
ngeval = ngeval + 1
do i=1,ndim
yk(i) = results(i) - gfk(i)
gfk_prev(i) = gfk(i)
gfk(i)= results(i)
enddo
ared = fval - fval_prev ! actual reduction in function value
gnorm = vecnorm(gfk_c,2) ! Euclidean
gmax = vecnorm(gfk_c,1000) ! infinit
snorm = vecnorm(sk,2)
smax = vecnorm(sk,1000)
! if(lBaker) then !Baker conv criteria; JCC, 14, 1085 (1993)
! if( gmax <= 3.d-4 .and. (dabs(ared)<=1.d-6 .or. smax<=3.d-4) ) then
! notConverged = .False.
! endif
! else
! if( gmax <= gtol .and. (dabs(ared)<=ftol .or. smax <= xtol)) then
! notConverged = .False.
! endif
! endif
converged=gopt_conv(gmax,ared,smax,gtol,ftol,xtol,lbaker)
notconverged=.not.converged
if(.not. notConverged) then
if(plevel.gt.1) then
call print_iter_info(niter,fval,gnorm,gmax,snorm,smax,ared)
endif
exit
endif
call wrt_iter(niter)
if(lmolden) call wrt_molden(niter,fval,gnorm,gmax)! MOLDEN info
if(plevel.gt.1) then
call print_iter_info(niter,fval,gnorm,gmax,snorm,smax,ared)
endif
q = ared/pred
if(q.le.Lb .or. q.gt.Ub) then
write(*,*) 'Discarding RFO step'
call copy_coord_sys(csys_prev,csys_k)
gfk = gfk_prev
fval = fval_prev
endif
! call rfo_trustR_update(ared,pred,Delta_k,snorm)
call trustR_update(ared,pred,Delta_k,snorm)
call bfgs_update_damped_B(sk,yk,Bk,q,Bs)
call read_Pmat(ndim,Pmat)
call dgemm('n','n',ndim,ndim,ndim,1.0d0,Bk,ndim,Pmat,ndim,&
0.0d0,PB,ndim)
call dgemm('n','n',ndim,ndim,ndim,1.0d0,Pmat,ndim,PB,ndim,&
0.0d0,Bk,ndim)
enddo
fopt = fval
call copy_coord_sys(csys_k,csys)
args = csys%coord
call dealloc_coord_sys(csys_k)
call dealloc_coord_sys(csys_prev)
if(.not. notConverged .and. niter .lt. maxiter) then
bool=.True.
if(lmolden) call update_molden
endif
deallocate(gfk)
deallocate(gfk_c)
deallocate(gfk_prev)
deallocate(sk)
deallocate(yk)
deallocate(Bs)
deallocate(results)
deallocate(Pmat)
deallocate(PB)
end subroutine
!************************************************************************
subroutine update_molden
!************************************************************************
! Update MOLDEN file
!************************************************************************
implicit none
call ishell('cat COORD.xyz.energies >> MOLDEN')
call ishell('cat COORD.xyz.rforce >> MOLDEN')
call ishell('cat COORD.xyz.mforce >> MOLDEN')
call ishell('cat COORD.xyz.geometries >> MOLDEN')
call ishell('rm -f COORD.xyz.* COORD.xyz.energies')
call ishell('rm -f COORD.xyz.rforce COORD.xyz.mforce')
call ishell('rm -f COORD.xyz.geometries')
end subroutine
!************************************************************************
double precision function rfo_pred(ndim,grad,sk,B,Bs)
!************************************************************************
! Predected energy change for RFO
!************************************************************************
implicit none
integer, intent(in) :: ndim
double precision, intent(in) :: grad(ndim),sk(ndim)
double precision, intent(in) :: B(ndim,ndim),Bs(ndim)
call dgemv('n',ndim,ndim,1.0d0,B,ndim,sk,1,0.0d0,Bs,1)
rfo_pred = -1.d0*(dot_product(grad,sk)+0.5d0*dot_product(sk,Bs))
return
end function
!************************************************************************
subroutine rfo_step_new(ndim,Bk,grad,dq,trust_radius,csys,q_pred)
!************************************************************************
! Calculating RFO step vector, Theor Chem Acc (1998) 100:265-274
!************************************************************************
implicit none
type(coord_sys_type) :: csys
integer, intent(in) :: ndim
double precision :: q_pred
double precision, intent(in) :: Bk(ndim,ndim) !Hessian
double precision :: grad(ndim) !gradient vector
double precision, intent(out) :: dq(ndim) !step vector
double precision, intent(in) :: trust_radius
!local
integer :: nonred ! number of coordinates
integer :: info,lwork,n,nn
double precision :: work1(1)
double precision, allocatable :: eigvec(:,:) !storing eigenvectors of hessian
double precision, allocatable :: eigval(:) !storing eigenvalues of hessian
double precision, allocatable :: grad_proj(:) !storing the projected gradient
double precision, allocatable :: grad_deloc(:) !storing the delocalized gradient
double precision, allocatable :: dq_proj(:) !step in the projected space
double precision, allocatable :: Bk_deloc(:,:) !delocalized hessian
double precision, allocatable :: work(:)
! nonred=csys%ncoord_ric
info=0
nonred=csys%nonred
allocate(Bk_deloc(nonred,nonred))
allocate(grad_deloc(nonred))
allocate(grad_proj(nonred))
allocate(dq_proj(nonred))
call rfo_deloc_hessian(csys,Bk,Bk_deloc,grad,grad_deloc)
! call dcopy(nonred**2,Bk,1,Bk_deloc,1)
! call dcopy(nonred,grad,1,grad_deloc,1)
! Calculating eigenvectors
allocate(eigvec(nonred,nonred))
allocate(eigval(nonred))
call dcopy(nonred*nonred,Bk_deloc,1,eigvec,1)
call dsyev('v','u',nonred,eigvec,nonred,eigval,work1,-1,info)
lwork=int(work1(1))
allocate(work(lwork))
call dsyev('v','u',nonred,eigvec,nonred,eigval,work,lwork,info)
write(*,'(A)') 'hessian eigvals'
write(*,'(9999999ES14.4)') eigval
if(info/=0) then
write(*,'(A)') 'Diagonalization failed in RFO step calculation'
write(*,'(A)') 'Aborting execution'
call mrccend(1)
endif
n=csys%nonred
nn=csys%ncoord_ric-n+1
! Projecting the gradient to the eigenspace
call dgemv('t',nonred,nonred,1.0d0,eigvec,nonred,grad_deloc,1,&
0.0d0,grad_proj,1)
! call dgemv('t',n,nonred,1.0d0,eigvec(1,nn),nonred,grad_deloc,1,&
! 0.0d0,grad_proj,1)
! getting the rfo step in the active space
call calc_dq_rfo(nonred,nonred,eigval,eigvec,grad_proj,dq_proj,&
trust_radius,q_pred)
! call calc_dq_rfo(nonred,n,eigval(nn),eigvec(1,nn),grad_proj,dq_proj,&
! trust_radius,q_pred)
! transfoming the step back to full space
call dcopy(csys%ncoord_ric,dq_proj,1,dq,1)
call dgemv('n',csys%ncoord_ric,nonred,1.0d0,csys%umatrix,&
csys%ncoord_ric,dq_proj,1,0.0d0,dq,1)
! call dgemv('n',nonred,n,1.0d0,eigvec(1,nn),nonred,dq_proj,1,0.d0,&
! dq,1)
if(allocated(eigvec)) deallocate(eigvec)
if(allocated(eigval)) deallocate(eigval)
if(allocated(work)) deallocate(work)
if(allocated(grad_proj)) deallocate(grad_proj)
if(allocated(grad_deloc))deallocate(grad_deloc)
if(allocated(Bk_deloc)) deallocate(Bk_deloc)
if(allocated(dq_proj)) deallocate(dq_proj)
contains
subroutine calc_dq_rfo(full_dim,ndim,eigval,eigvec,grad_proj,dq,&
trust_radius,q_red)
implicit none
integer :: ndim,full_dim
double precision :: eigval(ndim),eigvec(full_dim,ndim)
double precision :: grad_proj(ndim),dq(ndim),trust_radius
!local
integer :: k,lwork,p,state
double precision :: alpha,alpha_old,alpha_old2,work1(1),q_red
double precision :: alpha1,alpha2,norm
double precision, allocatable :: aug_hess(:,:),lambda(:)
double precision, allocatable :: work(:)
double precision :: dnrm2
logical :: lconv
k=0
p=0
state=0
alpha1 = 0.0d0
alpha2 = 1.0d0
alpha=1.0d0
alpha_old=0.0d0
! call get_newton_step(ndim,eigval,grad_proj,dq,q_red)
! lconv = check_convergence(ndim,k,dq,trust_radius,&
! alpha,alpha_old)
! if(lconv) then
! write(*,'(A,ES14.4)') 'Newton-step accepted! Norm: ',&
! dnrm2(ndim,dq,1)
! return
! endif
k=1
allocate(aug_hess(ndim+1,ndim+1))
allocate(lambda(ndim+1))
call solve_rfo_eq(ndim,alpha,aug_hess,dq,lambda,work1,-1,q_red)
lwork=int(work1(1))
allocate(work(lwork))
do
call build_aug_hess(ndim,eigval,grad_proj,alpha,aug_hess)
call solve_rfo_eq(ndim,alpha,aug_hess,dq,lambda,work,lwork,&
q_red)
lconv = check_convergence(ndim,k,dq,trust_radius,&
alpha,alpha_old)
! alpha_old2=alpha_old
alpha_old=alpha
! if(.not. lconv) then
! call update_alpha(ndim,alpha,alpha_old2,dq,trust_radius,&
! grad_proj,eigval,lambda(1),p)
if(lconv) exit
! bisection search
! alpha1 -> upper bound in norm
! alpha2 -> lower bound in norm
select case(state)
case(0) ! searching alpha2
if(dnrm2(ndim,dq,1) < trust_radius) then
alpha = 0.5d0*(alpha1 + alpha2)
state = 1
else
alpha2 = alpha2 + 10.0d0
alpha = alpha2
endif
case(1)
norm = dnrm2(ndim,dq,1)
if(norm < trust_radius) then
alpha2 = alpha
else
alpha1 = alpha
endif
alpha = 0.5d0*(alpha1 + alpha2)
end select
k=k+1
enddo
deallocate(aug_hess)
deallocate(work)
deallocate(lambda)
end subroutine
subroutine get_newton_step(ndim,eigval,grad_proj,dq,pred)
implicit none
integer :: ndim,i
double precision :: eigval(ndim),grad_proj(ndim),dq(ndim)
double precision :: pred
double precision :: ddot
do i=1,ndim
dq(i) = -grad_proj(i)/eigval(i)
enddo
pred = 0.5d0*ddot(ndim,grad_proj,1,dq,1)
end subroutine
subroutine build_aug_hess(ndim,eigval,grad_proj,alpha,aug_hess)
! Builds augmented hessian matrix
implicit none
integer :: i
integer, intent(in) :: ndim
double precision, intent(in) :: eigval(ndim),grad_proj(ndim),alpha
double precision :: aug_hess(ndim+1,ndim+1)
! local
double precision :: sqrt_alpha, inv_alpha
sqrt_alpha=dsqrt(alpha)
inv_alpha=1.0d0/alpha
aug_hess = 0.0d0
do i=2,ndim+1
aug_hess(i,1) = sqrt_alpha * grad_proj(i-1)
aug_hess(1,i) = sqrt_alpha * grad_proj(i-1)
aug_hess(i,i) = inv_alpha * eigval(i-1)
enddo
end subroutine
subroutine solve_rfo_eq(ndim,alpha,aug_hess,dq,lambda,work,lwork,&
q_pred)
! Calculates the RFO step vector for a given nu parameter
implicit none
integer :: lwork
integer, intent(in) :: ndim
double precision :: aug_hess(ndim+1,ndim+1)
double precision :: alpha,q_pred,lambda(ndim+1)
double precision :: work(*)
double precision, intent(out) :: dq(ndim)
!local
integer idx_min
integer i,j
double precision :: dnrm2
double precision, parameter :: eps = 1.0d-8
idx_min = 1 ! eigenvalue index to minimize along
if(lwork == -1) then
call dsyev('v','u',ndim+1,aug_hess,ndim+1,lambda,work,-1,i)
return
endif
! solving the generalized eigenvector equation
call dsyev('v','u',ndim+1,aug_hess,ndim+1,lambda,work,lwork,i)
! transfroming back the eigenvectors
call dscal(ndim,1.0d0/dsqrt(alpha),aug_hess(2,idx_min),1)
! getting the actual step
dq = aug_hess(2:ndim+1,idx_min) / aug_hess(1,idx_min)
q_pred = lambda(1)/(aug_hess(1,idx_min)**2)
return
end subroutine
subroutine update_alpha(ndim,alpha,alpha_old,dq,trust_radius,&
grad_proj,eigval,lambda_min,p)
! update the alpha parameter with Newton's method
implicit none
integer :: ndim,p
double precision :: alpha,alpha_old,trust_radius,lambda_min
double precision :: dq(ndim),eigval(ndim),grad_proj(ndim)
double precision :: dnrm2
! local
integer :: i
double precision :: dq2,norm,dq_da,alpha_save
norm=dnrm2(ndim,dq,1)
dq2=norm*norm
dq_da=0.0d0
do i=p+1,ndim
dq_da=dq_da+grad_proj(i)**2/(eigval(i)-lambda_min*alpha)**3
enddo
dq_da=2.0d0*lambda_min/(1+dq2*alpha)*dq_da
alpha_save = alpha
alpha = alpha + 2.0d0*(trust_radius*norm-dq2)/dq_da
if(alpha < 0.0d0) alpha=0.5d0*(alpha_save+alpha_old)
end subroutine
logical function check_convergence(ndim,niter,dq,trust_radius,&
alpha,alpha_old) result(lconv)
! checking the convergence of the rfo step
implicit none
integer :: niter,ndim
double precision :: dq(ndim),trust_radius,alpha,alpha_old
double precision :: norm
double precision :: eps1
double precision, parameter :: eps2 = 1.0d-5
double precision :: dnrm2
norm = dnrm2(ndim,dq,1)
write(*,'(A,ES12.4)') 'norm: ',norm
write(*,'(A,ES12.4)') 'trust radius: ',trust_radius
write(*,'(A,ES12.4)') 'alpha: ',alpha
write(*,'(A,ES12.4)') 'alpha_old: ',alpha_old
if(niter == 0) then
lconv = (norm < trust_radius)
else
eps1 = trust_radius/1.0d2
lconv = (dabs(norm-trust_radius) < eps1 .or. &
dabs(alpha_old-alpha) < eps2)
endif
write(*,'(A,L)') 'conv: ',lconv
end function
end subroutine rfo_step_new
!************************************************************************
subroutine rfo_deloc_hessian(csys,H,H_deloc,grad,grad_deloc)
!************************************************************************
! Delocalize Hessian for RFO step
!************************************************************************
implicit none
type(coord_sys_type) :: csys
double precision :: H(csys%ncoord,csys%ncoord)
double precision :: grad(csys%ncoord)
double precision :: H_deloc(csys%nonred,csys%nonred)
double precision :: grad_deloc(csys%nonred)
! local
integer :: i
double precision, allocatable :: B(:,:)
double precision, allocatable :: gmat(:,:)
if(csys%nonred == csys%ncoord) then
call dcopy(csys%nonred*csys%nonred,H,1,H_deloc,1)
call dcopy(csys%nonred,grad,1,grad_deloc,1)
return
endif
allocate(B(csys%ncoord,3*csys%natoms))
allocate(gmat(csys%ncoord,csys%ncoord))
call build_Wilson_Bmat(csys%natoms,csys%cart_coord,csys%rim,B)
call active_subspace(csys%ncoord,csys%natoms,i,B,Gmat)
call get_deloc_matrix(csys%ncoord,csys%nonred,Gmat,csys%Umatrix)
call dgemm('n','n',csys%ncoord,csys%nonred,csys%ncoord,1.0d0,&
H,csys%ncoord,csys%Umatrix,csys%ncoord,0.0d0,gmat,&
csys%ncoord)
call dgemm('t','n',csys%nonred,csys%nonred,csys%ncoord,1.0d0,&
csys%umatrix,csys%ncoord,gmat,csys%ncoord,0.0d0,&
H_deloc,csys%nonred)
call dgemv('t',csys%ncoord,csys%nonred,1.0d0,csys%umatrix,&
csys%ncoord,grad,1,0.0d0,grad_deloc,1)
deallocate(B)
deallocate(gmat)
end subroutine
!************************************************************************
subroutine rfo_step(ndim,Bk,grad,dq,trust_radius,nonred)
!************************************************************************
! Calculating RFO step vector, Theor Chem Acc (1998) 100:265-274
!************************************************************************
implicit none
integer, intent(in) :: ndim ! number of coordinates
integer, intent(in) :: nonred ! number of nonredundant coordinates
double precision, intent(in) :: Bk(ndim,ndim) !Hessian
double precision :: grad(ndim) !gradient vector
double precision, intent(out) :: dq(ndim) !step vector
double precision, intent(in) :: trust_radius
!local
integer info,lwork,nred
double precision :: work1(1),nu1,nu2,nu,norm
double precision :: delta
double precision, allocatable :: eigvec(:,:) !storing eigenvectors of hessian
double precision, allocatable :: eigval(:) !storing eigenvalues of hessian
double precision, allocatable :: grad_proj(:) !storing the projected gradient
double precision, allocatable :: work(:)
double precision :: dnrm2
logical :: conv
info=0
delta=trust_radius/1.0d2
allocate(eigvec(ndim,ndim))
allocate(eigval(ndim))
allocate(grad_proj(ndim))
call dcopy(ndim*ndim,Bk,1,eigvec,1)
call dcopy(ndim,grad,1,grad_proj,1)
call dscal(ndim,-1.0d0,grad_proj,1)
call dgelss(ndim,ndim,1,eigvec,ndim,grad_proj,ndim,eigval,&
1.0d-10,nred,work1,-1,info)
lwork=int(work1(1))
allocate(work(lwork))
call dgelss(ndim,ndim,1,eigvec,ndim,grad_proj,ndim,eigval,&
1.0d-10,nred,work,lwork,info)
deallocate(work)
call dcopy(ndim,grad_proj,1,dq,1)
norm=dnrm2(ndim,dq,1)
if(norm < trust_radius) then
! write(*,'(A,ES12.3)') 'Newton-step accepted. Norm: ',norm
call dealloc
return
endif
! Calculating eigenvectors
call dcopy(ndim*ndim,Bk,1,eigvec,1)
call dsyev('v','u',ndim,eigvec,ndim,eigval,work1,-1,info)
lwork=int(work1(1))
allocate(work(lwork))
call dsyev('v','u',ndim,eigvec,ndim,eigval,work,lwork,info)
if(info/=0) then
write(*,'(A)') 'Diagonalization failed in RFO step calculation'
write(*,'(A)') 'Aborting execution'
call mrccend(1)
endif
nred=ndim-nonred+1 ! nonredundant coordinates start at this index
! Projecting the gradient to the eigenspace
call dgemv('t',ndim,ndim,1.0d0,eigvec,ndim,grad,1,0.0d0,&
grad_proj,1)
! finding best nu with bisection method
! for nu2=eigval(1): ||dq|| == inf
! we have to find nu1: ||dq|| < trust_radius
nu2=eigval(nred)
nu1=nu2-10.0d0
do
call calc_dq_rfo(ndim,nred,eigval,eigvec,grad_proj,nu1,dq,norm)
if(norm<trust_radius) then
exit
else
nu2=nu1
endif
nu1=nu1-10.0d0
enddo
! bisection method
conv=.false.
do while(.not.conv)
nu=(nu1+nu2)/2.0d0
call calc_dq_rfo(ndim,nred,eigval,eigvec,grad_proj,nu,dq,norm)
if(norm<=trust_radius .and. norm>=trust_radius-delta) then
conv=.true.
elseif(norm<trust_radius) then
nu1=nu
else
nu2=nu
endif
enddo
! write(*,'(A,ES12.3)') 'Trust-region step accepted. Norm: ',norm
! write(*,'(A,ES12.3,A,ES12.3)') 'nu: ',nu,' eigval1: ',eigval(nred)
call dealloc
contains
subroutine calc_dq_rfo(ndim,nred,eigval,eigvec,grad_proj,nu,dq,norm)
! Calculates the RFO step vector for a given nu parameter
implicit none
integer, intent(in) :: ndim,nred
double precision, intent(in) :: eigval(ndim),eigvec(ndim,ndim)
double precision, intent(in) :: grad_proj(ndim),nu
double precision, intent(out) :: dq(ndim),norm
!local
integer i,j
double precision :: dnrm2
dq=0.0d0
do i=nred,ndim
do j=1,ndim
dq(j)=dq(j)-grad_proj(i)/(eigval(i)-nu)*eigvec(j,i)
enddo
enddo
norm=dnrm2(ndim,dq,1)
end subroutine
subroutine dealloc
! Deallocates memory
implicit none
if(allocated(eigvec)) deallocate(eigvec)
if(allocated(eigval)) deallocate(eigval)
if(allocated(work)) deallocate(work)
if(allocated(grad_proj)) deallocate(grad_proj)
end subroutine
end subroutine rfo_step
!************************************************************************
integer function get_nonred(natoms,nintcoord,Bmatrix)result(nonred)
!************************************************************************
! Counts the number of nonredundant coordinates based on Wilson's B
!************************************************************************
implicit none
integer, intent(in) :: natoms,nintcoord
double precision, intent(in) :: Bmatrix(nintcoord,3*natoms)
integer :: info,lwork,rank
double precision :: work1(1)
double precision, parameter :: delta=1.0d-10
double precision, allocatable :: Gmat(:,:),sval(:),work(:)
rank=min(3*natoms,nintcoord)
allocate(Gmat(nintcoord,3*natoms))
allocate(sval(rank))
call dcopy(nintcoord*3*natoms,Bmatrix,1,Gmat,1)
call dgesvd('n','n',nintcoord,3*natoms,Gmat,nintcoord,sval,&
work1,1,work1,1,work1,-1,info)
lwork=int(work1(1))
allocate(work(lwork))
call dgesvd('n','n',nintcoord,3*natoms,Gmat,nintcoord,sval,&
work1,1,work1,1,work,lwork,info)
nonred=0
write(*,*) 'sval'
write(*,'(100ES12.3)') sval
do while(sval(nonred+1)>delta)
nonred=nonred+1
enddo
deallocate(work)
deallocate(Gmat)
deallocate(sval)
return
end function
!************************************************************************
subroutine bfgs_update_B(sk,yk,Bk)
!************************************************************************
!************************************************************************
! BFGS Update
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Nocedal and Wright, eq. 18.22, pg. 538
implicit none
double precision, dimension(:), intent(in) :: sk
double precision, dimension(:), intent(in) :: yk
double precision, dimension(:,:),intent(inout) ::Bk
!local
double precision :: sBs,denom,rho_k,r_k
double precision, dimension(:,:), allocatable :: Id,A1,A2,A3
double precision, dimension(:), allocatable ::Bs
integer :: i,j,ndim
ndim = size(sk)
allocate(Id(ndim,ndim))
allocate(A1(ndim,ndim))
allocate(Bs(ndim))
allocate(A2(ndim,ndim))
allocate(A3(ndim,ndim))
do j=1,ndim ! initialization of arrays
do i=1,ndim
if(i .eq. j) then
Id(i,j) = 1.d0
else
Id(i,j) = 0.d0
endif
A1(i,j) = 0.d0
A2(i,j) = 0.d0
A3(i,j) = 0.d0
enddo
enddo
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
denom = dot_product(yk,sk)
if(denom < 1.d-6) then ! csonti
rho_k = 1.d6
else
rho_k = 1.d0/denom
endif
! Bs = matrix_dot_vec(Bk,sk)
call dgemv('n',ndim,ndim,1.0d0,Bk,ndim,sk,1,0.0d0,Bs,1)
sBs = dot_product(sk,Bs) ! r_k = 1/sBs
if(sBs < 1.d-6) then ! csonti
r_k = 1.d6
else
r_k = 1.d0/sBs
endif
call outer_product(Bs,sk,A1)
A2 = matmul(A1,Bk)
call outer_product(yk,yk,A3)
do j=1,ndim
do i=1,ndim
A2(i,j) = -1.d0*r_k * A2(i,j)
A3(i,j) = rho_k * A3(i,j)
enddo
enddo
do j=1,ndim
do i=1,ndim
Bk(i,j) = Bk(i,j) + A2(i,j) + A3(i,j)
enddo
enddo
! call print_matrixR(Bk,9)
deallocate(Id)
deallocate(A1)
deallocate(Bs)
deallocate(A2)
deallocate(A3)
end subroutine bfgs_update_B
!************************************************************************
!************************************************************************
subroutine bfgs_update_damped_B(sk,yk,Bk,q,Bs)
!************************************************************************
!************************************************************************
! BFGS Update
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Nocedal and Wright, eq. 18.22, pg. 538
implicit none
double precision, dimension(:), intent(in) :: sk, Bs
double precision, dimension(:), intent(inout) :: yk
double precision, intent(in) :: q
double precision, dimension(:,:),intent(inout) ::Bk
!local
double precision :: sBs,thres,theta_k,denom,rho_k,r_k,sy
integer :: ndim
ndim = size(sk)
sy = dot_product(sk,yk)
sBs = dot_product(sk,Bs) ! r_k = 1/sBs
thres = 0.2d0*sBs
if(sy .ge. thres) then
theta_k = 1.0d0
else
theta_k = (0.8d0*sBs)/(sBs-sy)
endif
yk(:) = theta_k*yk(:) + (1.d0-theta_k)*Bs(:)
denom = dot_product(yk,sk)
rho_k = min(1.d0/denom, 1.0d6)
r_k = min(1.0d0/sBs, 1.0d6)
call dsyr('u',ndim,-r_k,Bs,1,Bk,ndim)
call dsyr('u',ndim,rho_k,yk,1,Bk,ndim)
call filllo(Bk,ndim)
end subroutine bfgs_update_damped_B
!************************************************************************
!************************************************************************
subroutine bfgs_update(sk,yk,Hk)
!************************************************************************
!************************************************************************
! BFGS Update
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Nocedal and Wright, eq. 18.22, pg. 538
implicit none
double precision, dimension(:), intent(in) :: sk
double precision, dimension(:), intent(in) :: yk
double precision, dimension(:,:),intent(inout) ::Hk
!local
double precision :: denom,rho_k
double precision, dimension(:,:), allocatable :: Id,A1,A2,A3
integer :: i,j,ndim
ndim = size(sk)
allocate(Id(ndim,ndim))
allocate(A1(ndim,ndim))
allocate(A2(ndim,ndim))
allocate(A3(ndim,ndim))
do j=1,ndim ! initialization of arrays
do i=1,ndim
if(i .eq. j) then
Id(i,j) = 1.d0
else
Id(i,j) = 0.d0
endif
A1(i,j) = 0.d0
A2(i,j) = 0.d0
A3(i,j) = 0.d0
enddo
enddo
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
denom = dot_product(yk,sk)
if(denom < 1.d-12) then
rho_k = 1.d3
else
rho_k = 1.d0/denom
endif
call outer_product(sk,yk,A1)
call outer_product(yk,sk,A2)
call outer_product(sk,sk,A3)
do j=1,ndim
do i=1,ndim
A1(i,j) = Id(i,j) - rho_k * A1(i,j)
A2(i,j) = Id(i,j) - rho_k * A2(i,j)
A3(i,j) = rho_k * A3(i,j)
enddo
enddo
Hk = matmul( A1,matmul( Hk,A2) )
do j=1,ndim
do i=1,ndim
Hk(i,j) = Hk(i,j) + A3(i,j)
enddo
enddo
! call print_matrixR(Hk,9)
deallocate(Id)
deallocate(A1)
deallocate(A2)
deallocate(A3)
end subroutine bfgs_update
!************************************************************************
!************************************************************************
subroutine bfgs_update_damped(sk,yk,Hk,q,Bs)
!************************************************************************
!************************************************************************
! BFGS Update
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Nocedal and Wright, eq. 18.22, pg. 538
implicit none
double precision, dimension(:), intent(in) :: sk, Bs
double precision, dimension(:), intent(inout) :: yk
double precision, intent(in) :: q
double precision, dimension(:,:),intent(inout) ::Hk
!local
double precision :: sy,sBs,thres,theta_k,denom,rho_k
double precision, dimension(:,:), allocatable :: Id,A1,A2,A3
integer :: i,j,ndim
ndim = size(sk)
allocate(Id(ndim,ndim))
allocate(A1(ndim,ndim))
allocate(A2(ndim,ndim))
allocate(A3(ndim,ndim))
do j=1,ndim ! initialization of arrays
do i=1,ndim
if(i .eq. j) then
Id(i,j) = 1.d0
else
Id(i,j) = 0.d0
endif
A1(i,j) = 0.d0
A2(i,j) = 0.d0
A3(i,j) = 0.d0
enddo
enddo
! Bs = matrix_dot_vec(Hk,sk)
sy = dot_product(sk,yk)
sBs = dot_product(sk,Bs)
thres = 0.2d0*sBs
if(sy .ge. thres) then
theta_k = 1.0d0
else
! theta_k = (0.8d0*sBs)/(sBs-sy)
! theta_k = (0.8d0*thres)/(thres-sy)
theta_k = (0.8d0*sBs)/(sBs-sy)
endif
yk(:) = theta_k*yk(:) + (1.d0-theta_k)*Bs(:)
write(*,'(A,3f12.6)')'trust theta_k: ',theta_k,sy,0.2d0*sBs
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
denom = dot_product(yk,sk)
if(denom < 1.d-12) then
rho_k = 1.d3
else
rho_k = 1.d0/denom
endif
call outer_product(sk,yk,A1)
call outer_product(yk,sk,A2)
call outer_product(sk,sk,A3)
do j=1,ndim
do i=1,ndim
A1(i,j) = Id(i,j) - rho_k * A1(i,j)
A2(i,j) = Id(i,j) - rho_k * A2(i,j)
A3(i,j) = rho_k * A3(i,j)
enddo
enddo
Hk = matmul( A1,matmul( Hk,A2) )
do j=1,ndim
do i=1,ndim
Hk(i,j) = Hk(i,j) + A3(i,j)
enddo
enddo
! BFGS Update END
! endif
! else
! Hk = Id
! endif
! write(*,*)'inverse Hessian matrix'
! call print_matrixR(Hk,9)
deallocate(Id)
deallocate(A1)
deallocate(A2)
deallocate(A3)
end subroutine bfgs_update_damped
!************************************************************************
subroutine rfo_trustr_update(ared,pred,Delta_k,snorm)
!************************************************************************
! Trust radius update for RFO opzimization
! Theor Chem Acc (1998) 100:265-274
!************************************************************************
implicit none
double precision, intent(in) :: ared,pred,snorm
double precision, intent(inout) :: Delta_k
!local
double precision :: r
double precision, parameter :: sf = 2.0d0
double precision, parameter :: Lb=0.0d0
double precision, parameter :: Ub=2.0d0
double precision, parameter :: delta_e=0.75d0
double precision, parameter :: delta_i=0.80d0
double precision, parameter :: eps1=1.0d-4
double precision, parameter :: delta_min=1.0d-3
double precision :: r_le,r_ue,r_ui,r_li
r=ared/pred
r_le=Lb+delta_e
r_ue=Ub-delta_e
r_ui=Ub-delta_i
r_li=Lb+delta_i
if(r<r_le .or. r>r_ue) then
Delta_k=snorm/sf
elseif(r<=r_ui .and. r>=r_li) then
Delta_k=dsqrt(sf)*Delta_k
endif
delta_k=max(delta_k,delta_min)
end subroutine
!************************************************************************
subroutine trustR_update(ared,pred,Delta_k,snorm)
!************************************************************************
! it updates the trust radius (Delta_k)
!************************************************************************
implicit none
double precision, intent(in) :: ared,pred,snorm
double precision, intent(inout) :: Delta_k
!local
double precision :: q
double precision, parameter :: Delta_max=0.8d0
double precision, parameter :: Delta_min=0.0001d0
double precision, parameter :: scale_up=1.2d0
double precision, parameter :: scale_down=0.67d0
q=ared/pred
if(q < 0.25d0) then
Delta_k = scale_down*snorm!Delta_k!
if(Delta_k < Delta_min) Delta_k = Delta_min
! write(*,'(A,5f12.6)') &
! 'The trust radius was decreased in this step to',&
! Delta_k,q,snorm,ared,pred
else
if(q > 0.75d0 .and. snorm > 0.8d0*Delta_k) then
Delta_k = min(scale_up*Delta_k,Delta_max)
! write(*,'(A,5f12.6)') &
! 'The trust radius was increased in this step to',&
! Delta_k,q,snorm,ared,pred
else
Delta_k = 1.0d0*Delta_k
! write(*,'(A,5f12.6)') &
! 'The trust radius was not changed in this step',&
! Delta_k,q,snorm,ared,pred
endif
endif
return
end subroutine trustR_update
!************************************************************************
!************************************************************************
double precision function direction_alpha(step,gradient)
!************************************************************************
! it calculates the angle between the step and gradient vector
! that should be between -90 and -180 somewhere
!************************************************************************
implicit none
double precision, dimension(:), intent(in) :: step,gradient
!local
double precision :: rtmp
rtmp = dot_product(step,gradient)/&
(sqrt(dot_product(gradient,gradient))&
*sqrt(dot_product(step,step)))
if(rtmp> 1.d0) rtmp = 1.d0
if(rtmp<-1.d0) rtmp = -1.d0
direction_alpha = (-180.d0/PI)*dacos(rtmp)
if(direction_alpha > -95.d0) then
write(*,*) 'Warning: the optimizer might move uphill!!!'
write(*,'(A,f8.1)')&
'Iteration info direction alpha: ',direction_alpha
endif
end function direction_alpha
!************************************************************************
!************************************************************************
subroutine ddogleg(Delta,pB,grad,H,sk,pred,Bs)
!************************************************************************
! double dogleg Dennis, Robert, Schnabel section 6.4.2 pg 139-147.
implicit none
double precision, intent(in) :: Delta ! trust radius
double precision, dimension(:), intent(in) :: pB !
double precision, dimension(:), intent(in) :: grad ! gradient vector
double precision, dimension(:,:), intent(in) :: H ! the inverse Hessian matrix, B^-1 = H
double precision, dimension(:), intent(out) :: sk ! the dogleg step
double precision, intent(out) :: pred ! predicted function value
double precision, dimension(:), intent(out) :: Bs
!local
integer :: ndim
double precision :: pB_norm,pU_norm,nom,denom,a,hb,c,kappa,kappa2
double precision :: gBg,gHg,gamma_,eta_
double precision, dimension(:),allocatable :: pU,pBU,gtmp
double precision, dimension(:,:), allocatable :: B,E
ndim = size(grad)
allocate(pU(ndim))
allocate(pBU(ndim))
allocate(gtmp(ndim))
allocate(B(ndim,ndim))
! allocate(E(ndim,ndim)) ! just for test remove csonti
call matrix_pseudoinverse(H,B)
pB_norm = vecnorm(pB,2)
! CASE A -- the full Newton step is inside the trust radius
if(pB_norm .le. Delta) then
write(*,*) &
'The full Newton step is inside the trust radius'
sk = pB
! Bs = matrix_dot_vec(B,sk)
call dgemv('n',ndim,ndim,1.0d0,B,ndim,sk,1,0.0d0,Bs,1)
pred = -1.d0*(dot_product(grad,sk)+0.5d0*dot_product(sk,Bs))
call dealloc_mem
return
endif
! gtmp = matrix_dot_vec(B,grad)
call dgemv('n',ndim,ndim,1.0d0,B,ndim,grad,1,0.0d0,gtmp,1)
! gtmp = dot_product(B,transpose(grad))
! call print_vectorR(gtmp,8)
nom = dot_product(grad,grad)
denom = dot_product(grad,gtmp)
pU = -1.d0*(nom/denom)*grad
! CASE B -- the Cauchy step reaches outside the border of the trust radius; let's scale it back to the border
pU_norm = vecnorm(pU,2)
if(pU_norm .gt. Delta) then
sk = (Delta/pU_norm)*pU
! sk = sk + (Delta/pB_norm)*pB
! Bs = matrix_dot_vec(B,sk)
call dgemv('n',ndim,ndim,1.0d0,B,ndim,sk,1,0.0d0,Bs,1)
pred = -1.d0*(dot_product(grad,sk)+0.5d0*dot_product(sk,Bs))
write(*,'(A)',advance='no') &
'Let us scale the Cauchy step (steepest descent) back '
write(*,*) 'to the trust border'
call dealloc_mem
return
endif
! CASE C -- quadratic part; we need the point of intersection with the trust radius
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
call dgemv('n',ndim,ndim,1.0d0,B,ndim,grad,1,0.0d0,gtmp,1)
gBg = dot_product(grad,gtmp)
call dgemv('n',ndim,ndim,1.0d0,H,ndim,grad,1,0.0d0,gtmp,1)
gHg = dot_product(grad,gtmp)
gamma_ = (dot_product(grad,grad))**2/(gBg*gHg)
eta_ = 0.8d0*gamma_ + 0.2d0
sk = eta_*pB
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
pBU = sk - pU
a = dot_product(pBU,pBU)
hb = dot_product(pU,pBU) !half b, hb=0.5*b
c = dot_product(pU,pU) - Delta**2
kappa = (-1.d0*hb + sqrt(hb**2 - a*c))/a! kappa = (tau-1)
kappa2 = (-1.d0*hb - sqrt(hb**2 - a*c))/a! kappa = (tau-1)
write(*,'(A)',advance='no') &
'We need the intersection of the trust radius with that of'
write(*,*) 'the dogleg step (Cauchy step + Newton step)'
write(*,*) 'Trust radius tau is equal to ',kappa+1.d0
write(*,*) 'Trust radius tau2 is equal to ',kappa2+1.d0
sk = pU + kappa*pBU
Bs = matrix_dot_vec(B,sk)
pred = -1.d0*(dot_product(grad,sk)+0.5d0*dot_product(sk,Bs))
call dealloc_mem
return
contains
subroutine dealloc_mem
implicit none
if(allocated(B)) deallocate(B) ! deallocation in case A, B, and C !csonti
if(allocated(E)) deallocate(E)
if(allocated(pU)) deallocate(pU)
if(allocated(pBU)) deallocate(pBU)
if(allocated(gtmp)) deallocate(gtmp)
end subroutine dealloc_mem
end subroutine ddogleg
!************************************************************************
!************************************************************************
subroutine dogleg_B(Delta,pB,grad,B,sk,pred,Bs)
!************************************************************************
! see Nocedal and Wright, equations 4.10-4.13, pg. 71-73.
implicit none
double precision, intent(in) :: Delta ! trust radius
double precision, dimension(:), intent(in) :: pB !
double precision, dimension(:), intent(in) :: grad ! gradient vector
double precision, dimension(:,:), intent(in) :: B ! the Hessian matrix
double precision, dimension(:), intent(out) :: sk ! the dogleg step
double precision, intent(out) :: pred ! predicted function value
double precision, dimension(:), intent(out) :: Bs
!local
integer :: ndim
double precision :: pB_norm,pU_norm,nom,denom,a,hb,c,kappa
double precision, dimension(:),allocatable :: pU,pBU,gtmp
ndim = size(grad)
allocate(pU(ndim))
allocate(pBU(ndim))
allocate(gtmp(ndim))
pB_norm = vecnorm(pB,2)
! CASE A -- the full Newton step is inside the trust radius
if(pB_norm .le. Delta) then
sk = pB
! Bs = matrix_dot_vec(B,sk)
call dgemv('n',ndim,ndim,1.0d0,B,ndim,sk,1,0.0d0,Bs,1)
pred = -1.d0*(dot_product(grad,sk)+0.5d0*dot_product(sk,Bs))
call dealloc_mem
return
endif
! gtmp = matrix_dot_vec(B,grad)
call dgemv('n',ndim,ndim,1.0d0,B,ndim,grad,1,0.0d0,gtmp,1)
! gtmp = dot_product(B,transpose(grad))
! call print_vectorR(gtmp,8)
nom = dot_product(grad,grad)
denom = dot_product(grad,gtmp)
pU = -1.d0*(nom/denom)*grad
! CASE B -- the Cauchy step reaches outside the border of the trust radius; let's scale it back to the border
pU_norm = vecnorm(pU,2)
if(pU_norm .gt. Delta) then
sk = (Delta/pU_norm)*pU
! Bs = matrix_dot_vec(B,sk)
call dgemv('n',ndim,ndim,1.0d0,B,ndim,sk,1,0.0d0,Bs,1)
pred = -1.d0*(dot_product(grad,sk)+0.5d0*dot_product(sk,Bs))
call dealloc_mem
return
endif
! CASE C -- quadratic part; we need the point of intersection with the trust radius
pBU = pB - pU
a = dot_product(pBU,pBU)
hb = dot_product(pU,pBU) !half b, hb=0.5*b
c = dot_product(pU,pU) - Delta**2
kappa = (-1.d0*hb + sqrt(hb**2 - a*c))/a! kappa = (tau-1)
! write(*,'(A)',advance='no') &
! 'We need the intersection of the trust radius with that of'
! write(*,*) 'the dogleg step (Cauchy step + Newton step)'
! write(*,*) 'Trust radius tau is equal to ',kappa+1.d0
sk = pU + kappa*pBU
! Bs = matrix_dot_vec(B,sk)
call dgemv('n',ndim,ndim,1.0d0,B,ndim,sk,1,0.0d0,Bs,1)
pred = -1.d0*(dot_product(grad,sk)+0.5d0*dot_product(sk,Bs))
call dealloc_mem
return
contains
subroutine dealloc_mem
implicit none
if(allocated(pU)) deallocate(pU)
if(allocated(pBU)) deallocate(pBU)
if(allocated(gtmp)) deallocate(gtmp)
end subroutine dealloc_mem
end subroutine dogleg_B
!************************************************************************
subroutine dogleg(Delta,pB,grad,H,sk,pred,Bs)
!************************************************************************
! see Nocedal and Wright, equations 4.10-4.13, pg. 71-73.
implicit none
double precision, intent(in) :: Delta ! trust radius
double precision, dimension(:), intent(in) :: pB !
double precision, dimension(:), intent(in) :: grad ! gradient vector
double precision, dimension(:,:), intent(in) :: H ! the inverse Hessian matrix, B^-1 = H
double precision, dimension(:), intent(out) :: sk ! the dogleg step
double precision, intent(out) :: pred ! predicted function value
double precision, dimension(:), intent(out) :: Bs
!local
integer :: ndim
double precision :: pB_norm,pU_norm,nom,denom,a,hb,c,kappa
double precision, dimension(:),allocatable :: pU,pBU,gtmp
double precision, dimension(:,:), allocatable :: B
! double precision, dimension(:,:), allocatable :: E
ndim = size(grad)
allocate(pU(ndim))
allocate(pBU(ndim))
allocate(gtmp(ndim))
allocate(B(ndim,ndim))
! allocate(E(ndim,ndim)) ! just for test remove csonti
call matrix_pseudoinverse(H,B)
! write(*,*)'inverse Hessian'
! call print_matrixR(H,9)
! write(*,*)'Hessian'
! call print_matrixR(B,9)
! E = matmul(H,B)
! write(*,*)'H*B'
! call print_matrixR(E,9)
pB_norm = vecnorm(pB,2)
! CASE A -- the full Newton step is inside the trust radius
if(pB_norm .le. Delta) then
! write(*,*) &
! 'The full Newton step is inside the trust radius'
sk = pB
! Bs = matrix_dot_vec(B,sk)
call dgemv('n',ndim,ndim,1.0d0,B,ndim,sk,1,0.0d0,Bs,1)
pred = -1.d0*(dot_product(grad,sk)+0.5d0*dot_product(sk,Bs))
call dealloc_mem
return
endif
! gtmp = matrix_dot_vec(B,grad)
call dgemv('n',ndim,ndim,1.0d0,B,ndim,grad,1,0.0d0,gtmp,1)
! gtmp = dot_product(B,transpose(grad))
! call print_vectorR(gtmp,8)
nom = dot_product(grad,grad)
denom = dot_product(grad,gtmp)
pU = -1.d0*(nom/denom)*grad
! CASE B -- the Cauchy step reaches outside the border of the trust radius; let's scale it back to the border
pU_norm = vecnorm(pU,2)
if(pU_norm .gt. Delta) then
sk = (Delta/pU_norm)*pU
! Bs = matrix_dot_vec(B,sk)
call dgemv('n',ndim,ndim,1.0d0,B,ndim,sk,1,0.0d0,Bs,1)
pred = -1.d0*(dot_product(grad,sk)+0.5d0*dot_product(sk,Bs))
! write(*,'(A)',advance='no') &
! 'Let us scale the Cauchy step (steepest descent) back '
! write(*,*) 'to the trust border'
call dealloc_mem
return
endif
! CASE C -- quadratic part; we need the point of intersection with the trust radius
pBU = pB - pU
a = dot_product(pBU,pBU)
hb = dot_product(pU,pBU) !half b, hb=0.5*b
c = dot_product(pU,pU) - Delta**2
kappa = (-1.d0*hb + sqrt(hb**2 - a*c))/a! kappa = (tau-1)
! write(*,'(A)',advance='no') &
! 'We need the intersection of the trust radius with that of'
! write(*,*) 'the dogleg step (Cauchy step + Newton step)'
! write(*,*) 'Trust radius tau is equal to ',kappa+1.d0
sk = pU + kappa*pBU
! Bs = matrix_dot_vec(B,sk)
call dgemv('n',ndim,ndim,1.0d0,B,ndim,sk,1,0.0d0,Bs,1)
pred = -1.d0*(dot_product(grad,sk)+0.5d0*dot_product(sk,Bs))
call dealloc_mem
return
contains
subroutine dealloc_mem
implicit none
if(allocated(B)) deallocate(B) ! deallocation in case A, B, and C !csonti
! if(allocated(E)) deallocate(E)
if(allocated(pU)) deallocate(pU)
if(allocated(pBU)) deallocate(pBU)
if(allocated(gtmp)) deallocate(gtmp)
end subroutine dealloc_mem
end subroutine dogleg
!************************************************************************
!************************************************************************
subroutine print_inverse(H)
!************************************************************************
! see Nocedal and Wright, equations 4.10-4.13, pg. 71-73.
implicit none
double precision, dimension(:,:), intent(in) :: H ! the inverse Hessian matrix, B^-1 = H
!local
integer :: ndim
double precision, dimension(:,:), allocatable :: B
ndim = size(H,1)
allocate(B(ndim,ndim))
call matrix_pseudoinverse(H,B)
write(*,*)'HESSIAN MATRIX'
call print_MatrixR(B,9)
if(allocated(B)) deallocate(B) ! deallocation in case A, B, and C !csonti
return
end subroutine print_inverse
!************************************************************************
!************************************************************************
subroutine quadratic(sk,grad,H,pred,Bs)
!************************************************************************
! see Nocedal and Wright, equations 4.10-4.13, pg. 71-73.
implicit none
double precision, dimension(:), intent(in) :: sk !
double precision, dimension(:), intent(in) :: grad ! gradient vector
double precision, dimension(:,:), intent(in) :: H ! the inverse Hessian matrix, B^-1 = H
double precision, intent(out) :: pred ! predicted function value
double precision, dimension(:), intent(out) :: Bs
!local
integer :: ndim
double precision, dimension(:,:), allocatable :: B
ndim = size(grad)
allocate(B(ndim,ndim))
call matrix_pseudoinverse(H,B)
! Bs = matrix_dot_vec(B,sk)
call dgemv('n',ndim,ndim,1.0d0,B,ndim,sk,1,0.0d0,Bs,1)
pred = -1.d0*(dot_product(grad,sk)+0.5d0*dot_product(sk,Bs))
if(allocated(B)) deallocate(B) ! deallocation in case A, B, and C !csonti
return
end subroutine quadratic
!************************************************************************
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! LINEAR ALGEBRA
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!************************************************************************
double precision function vecnorm(vec,p)
! it returns the usual p-norm of the vector vec
! the infinit norm can be called with p>999
implicit none
double precision, dimension(:),intent(in) :: vec
integer, intent(in) :: p
!local
integer i,ndim
ndim = size(vec)
if(p .gt. 999) then ! this is the infinity norm
if ( dabs(maxval(vec)) .gt. dabs(minval(vec)) ) then
vecnorm = dabs(maxval(vec))
else
vecnorm = dabs(minval(vec))
endif
else
vecnorm = 0.d0
do i=1,ndim
vecnorm = vecnorm + dabs( vec(i) )**(p)
enddo
vecnorm = vecnorm**(1.d0/dble(p))
endif
return
end function vecnorm
!************************************************************************
!************************************************************************
function vec_norm_comp(A)
!************************************************************************
! it returns the components of the normal vector corresponding to A
! A is a 3-dimensional vector
!************************************************************************
implicit none
double precision, dimension(3), intent(in) :: A
double precision, dimension(3) :: vec_norm_comp
!local
integer :: i
do i=1,3
vec_norm_comp(i) = A(i)/vec_length(A)
enddo
return
end function vec_norm_comp
!************************************************************************
!************************************************************************
function vec_comp(A,B)
!************************************************************************
! it returns the components of the vector pointing from A to B
! A and B are 3-dimensional points
!************************************************************************
implicit none
double precision, dimension(3), intent(in) :: A,B
double precision, dimension(3) :: vec_comp
!local
integer :: i
do i=1,3
vec_comp(i) = B(i)-A(i)
enddo
return
end function vec_comp
!************************************************************************
!************************************************************************
double precision function vec_length(A)
!************************************************************************
! it returns the length of A (Euclidean norm, ||A||)
! for a 3D vector
!************************************************************************
implicit none
double precision, dimension(3), intent(in) :: A
vec_length = 0.d0
vec_length = sqrt( vec_dot(A,A) )
return
end function vec_length
!************************************************************************
!************************************************************************
double precision function vec_dot(A,B)
!************************************************************************
! it returns the dot product of vectors A and B
! A and B are 3-dimensional vectors
!************************************************************************
implicit none
double precision, dimension(3), intent(in) :: A,B
!local
integer :: i
vec_dot = 0.d0
do i=1,3
vec_dot = vec_dot + A(i)*B(i)
enddo
return
end function vec_dot
!************************************************************************
!************************************************************************
function vec_cross(A,B)
!************************************************************************
! it returns the cross product of vectors A and B
! A and B are 3-dimensional vectors
!************************************************************************
implicit none
double precision, dimension(3), intent(in) :: A,B
double precision, dimension(3) :: vec_cross
!local
double precision,dimension(3) :: AxB
call crproduct(A,B,AxB)
vec_cross = AxB
return
end function vec_cross
!************************************************************************
!************************************************************************
double precision function vec_mixed(A,B,C)
!************************************************************************
! it returns the mixed product of vectors A, B, and C
!
! AxB.C
!
! A, B, and C are 3-dimensional vectors
!************************************************************************
implicit none
double precision, dimension(3), intent(in) :: A,B,C
vec_mixed = vec_dot(vec_cross(A,B),C)
return
end function vec_mixed
!************************************************************************
!************************************************************************
subroutine crproduct(a,b,acb)
!************************************************************************
! Computes cross product of a,b in 3 dimensions
!************************************************************************
real*8 a(3),b(3),acb(3)
!
acb(1)=a(2)*b(3)-a(3)*b(2)
acb(2)=a(3)*b(1)-a(1)*b(3)
acb(3)=a(1)*b(2)-a(2)*b(1)
return
end subroutine crproduct
!
!************************************************************************
!************************************************************************
function w_prime_comp(u,v)
!************************************************************************
! it returns the component of the vector w'
! JCP, 117, 9160 (2002), Eq. 24
!************************************************************************
implicit none
double precision, dimension(3), intent(in) :: u,v
double precision, dimension(3) :: w_prime_comp
!local
double precision, dimension(3) :: vtmp
double precision, parameter :: eps=1.d-6 ! csonti more precise definition is required
double precision,dimension(3),parameter::v2=(/ 1.d0,-1.d0,1.d0/),&
v3=(/-1.d0, 1.d0,1.d0/)
vtmp = vec_cross(u,v)
if(vec_length(vtmp).ge.eps) then ! u and v are not parallel
w_prime_comp = vtmp
else
vtmp = vec_cross(u,v2)
if(vec_length(vtmp).ge.eps) then
w_prime_comp = vtmp
else
w_prime_comp = vec_cross(u,v3)
endif
endif
return
end function w_prime_comp
!************************************************************************
subroutine build_projection_hessian(B,P,csys)
!************************************************************************
! it builds the projection matrix P from B
!
! P = B*B+
!
!************************************************************************
implicit none
type(coord_sys_type) :: csys
double precision,dimension(:,:),intent(in) :: B !m x n
double precision,dimension(size(B,1),size(B,1)),intent(inout)::P !m x m
!local
double precision,dimension(:,:),allocatable :: Bp !n x m
integer :: i,n,m
m = size(B,1)
n = size(B,2)
allocate(Bp(n,m),stat=i)
if(i /= 0) then
write(*,*) &
'Memory allocation was not successfull in build_projection'
call mrccend(1)
endif
call matrix_pseudoinverse(B,Bp)
call dgemm('n','n',m,m,n,1.d0,B,m,Bp,n,0.d0,P,m)
deallocate(Bp)
end subroutine
!************************************************************************
subroutine build_projection(B,P,csys)
!************************************************************************
! it builds the projection matrix P from B
!
! P = B*B+
!
!************************************************************************
implicit none
type(coord_sys_type) :: csys
double precision,dimension(:,:),intent(in) :: B !m x n
double precision,dimension(size(B,1),size(B,1)),intent(inout)::P !m x m
!local
double precision,dimension(:,:),allocatable :: Bp !n x m
double precision,dimension(:,:),allocatable :: B2
integer :: i,n,m
m = size(B,1)
n = size(B,2)
allocate(Bp(n,m),stat=i)
if(i /= 0) then
write(*,*) &
'Memory allocation was not successfull in build_projection'
call mrccend(1)
endif
if(csys%nfrozen /= 0) then
allocate(b2(m,n))
call dcopy(n*m,b,1,b2,1)
call freezing_bmat_int(csys,b2)
call matrix_pseudoinverse(B2,Bp)
call dgemm('n','n',m,m,n,1.d0,B2,m,Bp,n,0.d0,P,m)
deallocate(b2)
else
call matrix_pseudoinverse(B,Bp)
call dgemm('n','n',m,m,n,1.d0,B,m,Bp,n,0.d0,P,m)
endif
deallocate(Bp)
end subroutine build_projection
!************************************************************************
!************************************************************************
subroutine matrix_inverse_sym(B,Binv)
!************************************************************************
! it computes Binv the inverse of symmetric positive definite matrix B
! using lapack routines:
!
! dpotrf - compute the Cholesky factorization of a real symmetric
! positive definite matrix
! dpotri - compute the inverse of a real symmetric positive
! definite matrix A using the Cholesky factorization
! A = U**T*U or A = L*L**T computed by DPOTRF
!
! it returns Binv
!************************************************************************
implicit none
double precision,dimension(:,:),intent(in) :: B !n x n
double precision,dimension(size(B,1),size(B,1)),&
intent(inout)::Binv!n x n
!local
integer :: n,info
external dpotrf
external dpotri
info=0
n = size(B,1)
Binv = B ! to keep B intact
! write(*,*) 'B in inverse routine'
! call print_matrixR(Binv,9)
call dpotrf('L',n,Binv,n,info)
if(info .ne. 0) then
write(*,*) &
'Cholesky factorization failed in matrix_inverse_sym',info
call mrccend(1)
endif
! write(*,*) 'LU decomposition of B'
! call print_matrixR(Binv,9)
call dpotri('L',n,Binv,n,info)
if(info .ne. 0) then
write(*,*) &
'Matrix inversion failed in matrix_inverse_sym'
call mrccend(1)
endif
! call print_matrixR(Binv,9)
end subroutine matrix_inverse_sym
!************************************************************************
!************************************************************************
subroutine matrix_inverse(B,Binv)
!************************************************************************
! it computes Binv the inverse of matrix B using lapack routines:
!
! dgetrf - LU decomposition (partial pivoting with raw interchanges)
! dgetri - This method inverts U and then computes inv(A) by solving
! the system inv(A)*L = inv(U) for inv(A)
!
! it returns Binv
!************************************************************************
implicit none
double precision,dimension(:,:),intent(in) :: B !n x n
double precision,dimension(size(B,1),size(B,1)),&
intent(inout)::Binv!n x n
!local
integer,dimension(size(B,1)) :: ipiv
integer :: n,res
integer :: LWORK,info
double precision,dimension(:),allocatable :: WORK !
external dgetrf
external dgetri
info=0
n = size(B,1)
LWORK = n*n
allocate(WORK(LWORK),STAT=res)
if(res .eq. 0) then
Binv = B ! to keep B intact
! write(*,*) 'B in inverse routine'
! call print_matrixR(Binv,9)
call dgetrf(n,n,Binv,n,IPIV,info)
if(info .ne. 0) then
write(*,*) &
'LU decomposition failed in subroutine matrix_inverse'
call mrccend(1)
endif
! write(*,*) 'LU decomposition of B'
! call print_matrixR(Binv,9)
call dgetri(n,Binv,n,IPIV,WORK,LWORK,info)
if(info .ne. 0) then
write(*,*) &
'Matrix inversion failed in subroutine matrix_inverse'
call mrccend(1)
endif
! call print_matrixR(Binv,9)
deallocate(WORK)
else
write(*,*) &
'Memory allocation was not successfull in matrix_nverse'
call mrccend(1)
endif
end subroutine matrix_inverse
!************************************************************************
!************************************************************************
subroutine matrix_diag(B,evec,eval)
!************************************************************************
! it computes the diagonal form of B using lapack routines:
!
!************************************************************************
implicit none
double precision,dimension(:,:),intent(in) :: B !n x n
double precision,dimension(size(B,1),size(B,1)),&
intent(inout) :: evec!n x n matrix of eigenvectors
double precision,dimension(size(B,1)),intent(inout) :: eval
!local
double precision,dimension(:) ,allocatable :: WORK !
integer :: res,info,LWORK,n
info=0
n = size(B,1)
evec = B ! keep B
LWORK=-1 ! check for optimal LWORK value
allocate(WORK(1))
call dsyev('V','U',n,evec,n,eval,WORK,LWORK,info) ! lapack routine for diagonalization
LWORK=WORK(1)
deallocate(WORK)
allocate(WORK(LWORK),STAT=res)
if(res .eq. 0) then
call dsyev('V','U',n,evec,n,eval,WORK,LWORK,info)
if(info.ne.0) then
write(*,*) 'Fatal error at the diagonalization!'
call mrccend(1)
endif
deallocate(WORK)
else
write(*,*) &
'Memory allocation was not successfull in matrix_diag'
call mrccend(1)
endif
end subroutine matrix_diag
!************************************************************************
!************************************************************************
subroutine matrix_pseudoinverse(B,Bp)
!************************************************************************
! it computes B+ the pseudoinverse of matrix B using singular value
! decomposition:
!
! B = U * SIGMA * V^T ; the svd of B
! B+ = V * (U * SIGMA^-1)^T
!
! it returns Bp
!************************************************************************
implicit none
double precision,dimension(:,:),intent(in) :: B !m x n
double precision,dimension(size(B,2),size(B,1)),intent(inout)::Bp!n x m
!local
double precision,dimension(:,:),allocatable :: U !m x m
double precision,dimension(:,:),allocatable :: VT !n x n
double precision,dimension(:), allocatable :: s
double precision,dimension(:,:),allocatable :: USi !
double precision,dimension(:,:),allocatable :: O ! temp matrix
double precision,dimension(:), allocatable :: WORK !
integer,dimension(:),allocatable :: IWORK
integer :: n,m,res
integer :: LWORK,info
info=0
m = size(B,1)
n = size(B,2)
allocate(U(m,m),STAT=res)
if(res /= 0) call dealloc_mem(res)
allocate(VT(n,n),STAT=res)
if(res /= 0) call dealloc_mem(res)
allocate(s(min(m,n)),STAT=res)
if(res /= 0) call dealloc_mem(res)
allocate(USi(m,n),STAT=res)
if(res /= 0) call dealloc_mem(res)
allocate(O(m,n),STAT=res)
if(res /= 0) call dealloc_mem(res)
allocate(IWORK(8*min(m,n)),STAT=res)
if(res /= 0) call dealloc_mem(res)
LWORK=-1 ! check for optimal LWORK value
allocate(WORK(1))
call dgesdd('A',m,n,B,m,s,U,m,VT,n,WORK,LWORK,IWORK,info) ! lapack routine for SVD
LWORK=int(WORK(1))
deallocate(WORK)
allocate(WORK(LWORK),STAT=res)
if(res /= 0) call dealloc_mem(res)
O = B ! to keep B intact
call dgesdd('A',m,n,O,m,s,U,m,VT,n,WORK,LWORK,IWORK,info) ! lapack routine for SVD
if(info/=0) then
write(*,'(A)') ' Matrix pseudoinverse calculation failed!'
write(*,'(A)') ' SVD did not converge!'
write(*,*) 'Error code: ',info
call mrccend(1)
endif
call matrix_pseudo1(U,s,USi)
call matrix_pseudo2(VT,USi,Bp)
call dealloc_mem(0)
return
contains
subroutine dealloc_mem(res)
implicit none
integer res
if(allocated(WORK)) deallocate(WORK)
if(allocated(U)) deallocate(U)
if(allocated(VT)) deallocate(VT)
if(allocated(s)) deallocate(s)
if(allocated(USi)) deallocate(USi)
if(allocated(O)) deallocate(O)
if(allocated(IWORK)) deallocate(IWORK)
if(res /= 0) then
write(*,*) &
'Memory allocation was not successfull in matrix_pseudoinverse'
call mrccend(1)
endif
end subroutine dealloc_mem
end subroutine matrix_pseudoinverse
!************************************************************************
!************************************************************************
subroutine matrix_pseudo2(VT,USi,Bp)
!************************************************************************
! it computes the matrix multiplication, V * USi^T,
! where USi = U * SIGMA^-1
!
! B = U * SIGMA * V^T the svd of B
! B+ = V * SIGMA^-1^T * U^T the pseudoinverse of B or otherwise
! B+ = V * (U * SIGMA^-1)^T
!
! it returns B+ /Bp/ the pseudoinverse of B
!************************************************************************
implicit none
double precision,dimension(:,:),intent(in) :: VT
double precision,dimension(:,:),intent(in) :: USi
double precision,&
dimension(size(VT,2),size(USi,1)),intent(inout) :: Bp
!local
integer :: n,m
m = size(VT,2)
n = size(USi,1)
call dgemm('t','t',m,n,m,1.d0,VT,m,USi,n,0.d0,Bp,m)
end subroutine matrix_pseudo2
!************************************************************************
!************************************************************************
subroutine matrix_pseudo1(U,s,USi)
!************************************************************************
! it computes the matrix multiplication, U*SIGMA^-1, by scaling the
! column vectors of U with the blas routine sdcal
! s is an array which elements are the column by column scaling
! factors (the diagonal elements of SIGMA)
!
! B = U * SIGMA * V^T the svd of B
! B+ = V * SIGMA^-1^T * U^T the pseudoinverse of B or otherwise
! B+ = V * (U * SIGMA^-1)^T
!
! it returns USi = U * SIGMA^-1
!************************************************************************
implicit none
double precision,dimension(:,:),intent(in) :: U
double precision,dimension(:) :: s
double precision,dimension(:,:),intent(inout) :: USi
!local
integer :: i,k,n,m
double precision, parameter :: eps = 1.0d-7
n = size(U,1)
m = size(USi,2)
k = size(s)
do i=1,m
if(i .le. k) then
USi(1:n,i) = U(1:n,i)
if( s(i) .gt. eps ) then ! the criterion is from Pulay - JCP, 96, 2856 (1992)
call dscal(n,1.d0/s(i),USi(1,i),1)
else
call dscal(n,0.d0,USi(1,i),1)
endif
else
USi(1:n,i) = 0.0d0
endif
enddo
end subroutine matrix_pseudo1
!************************************************************************
!************************************************************************
function matrix_dot_vec(A,vec)
!************************************************************************
! it returns as A*vec
! just a simple test routine
! A is an mxn and the length of vec is n
!************************************************************************
implicit none
double precision, dimension(:,:), intent(in) :: A
double precision, dimension(size(A,2)) :: vec
double precision, dimension(size(A,1)) :: matrix_dot_vec
!local
integer :: i,j,m,n
m = size(A,1)
n = size(A,2)
do i=1,m
matrix_dot_vec(i)=0.d0
do j=1,n
matrix_dot_vec(i) = matrix_dot_vec(i) + A(i,j)*vec(j)
! write(*,*) A(i,j), vec(j)
enddo
enddo
end function matrix_dot_vec
!************************************************************************
!************************************************************************
double precision function distance2(A,B)
!************************************************************************
! it returns the Euclidean distance between two 3D-points
!************************************************************************
implicit none
double precision, dimension(3), intent(in) :: A,B
!local
integer :: i
distance2 = 0.d0
do i=1,3
distance2 = distance2 + (B(i)-A(i))**2
enddo
distance2 = dsqrt(distance2)
return
end function distance2
!************************************************************************
!************************************************************************
double precision function angle3(A,B,C)
!************************************************************************
! it returns the bond angle between atoms A-B-C;
! the angle is measured at vertex atom B
!
! A C
! \ /
! B
!
! i.e. the angle between bonds B-A and B-C is returned in radial
! JCP, 117, 9160 (2002), Eq. 23
!************************************************************************
implicit none
double precision, dimension(3), intent(in) :: A, B, C
!local
double precision, dimension(3) :: up,vp,u,v
double precision :: dtmp
double precision, parameter :: eps = 1.d-8 ! csonti constraint
up = vec_comp(B,A) ! u'
vp = vec_comp(B,C) ! v'
u = vec_norm_comp(up)
v = vec_norm_comp(vp)
dtmp = vec_dot(u,v)
if( dtmp .gt. 1.d0 ) then
if( dtmp-1.d0 .gt. eps ) then
write(*,*) 'Something is wrong in function angle3!!!'
call mrccend(1)
else
dtmp = 1.d0
endif
elseif( dtmp .lt. -1.d0 ) then
if( -1.d0-dtmp .gt. eps ) then
write(*,*) 'Something is wrong in function angle3!!!'
call mrccend(1)
else
dtmp = -1.d0
endif
endif
angle3 = dacos(dtmp)
return
end function angle3
!************************************************************************
!************************************************************************
double precision function dihedral4(A,B,C,D)
!************************************************************************
! it returns the dihedral angle between bonds A-B and C-D;
! i.e. the angle between the planes defined by points A,B,C and B,C,D
!
! side view:
!
! A D
! \ /
! B -- C
!
! bond view (along B--C):
!
! A (D)
! \ / this conformation has a + sign
! B(C)
!
! (D) A
! \ / this conformation has a - sign
! B(C)
!
! A,B are in the front C,D are in the back
!
! the angle is restricted to be in the range -Pi,Pi and measured in radian
! JCP, 117, 9160 (2002), Eq. 31 as well as JCC, 16, 527 (1995)
!
!************************************************************************
implicit none
double precision, dimension(3), intent(in) :: A, B, C, D
!local
double precision, dimension(3) :: up,vp,wp,u,v,w,uxw,vxw
double precision :: sinu,sinv,dtmp
double precision, parameter :: eps = 1.d-8 ! csonti constraint
up = vec_comp(B,A) ! u'
vp = vec_comp(C,D) ! v'
wp = vec_comp(B,C) ! w'
u = vec_norm_comp(up)
v = vec_norm_comp(vp)
w = vec_norm_comp(wp)
uxw = vec_cross(u,w)
vxw = vec_cross(v,w)
sinu= dsqrt(1.d0 - (vec_dot(u,w))**2)
sinv= dsqrt(1.d0 - (vec_dot(v,w))**2)
dtmp = vec_dot(uxw,vxw) / (sinu*sinv)
if( dtmp .gt. 1.d0 ) then
if( dtmp .gt. 1.0d0+eps) then
write(*,'(1X,A)') 'Warning in dihedral4! '
write(*,'(1X,A)') 'cosine of the angle is greater than 1'
write(*,'(1X,A)') 'resetting it to 1'
endif
dtmp = 1.d0
elseif( dtmp .lt. -1.d0 ) then
if( dtmp .lt. -1.0d0-eps ) then
write(*,'(1X,A)') 'Warning in dihedral4! '
write(*,'(1X,A)') 'cosine of the angle is less than -1'
write(*,'(1X,A)') 'resetting it to -1'
endif
dtmp = -1.d0
endif
dihedral4 = dacos( dtmp )
if( vec_mixed(w,u,v) .lt. 0.d0 ) dihedral4 = -1.d0*dihedral4
return
end function dihedral4
!************************************************************************
double precision function improper(A,B,C,D)
!************************************************************************
! The atoms A,B and C are connected to the central atom D. The A,B and
! D atoms define a plane. It returns the angle between the plane and the
! DC vector
!************************************************************************
implicit none
double precision, dimension(3), intent(in) :: A, B, C, D
double precision vec1(3),vec2(3),normal(3)
double precision length
vec1 = A-D
vec2 = B-D
call crproduct(vec1,vec2,normal)
vec1 = C-D
length=vec_length(vec1)*vec_length(normal)
improper = dasin(vec_dot(vec1,normal)/length)
return
end function
!************************************************************************
logical function is_parallel(A,B,C)
!************************************************************************
! it checks whether or not the lines (A,B) and (B,C) are parallel
! or A, B, and C are on the same line
!************************************************************************
implicit none
double precision, dimension(3), intent(in) :: A, B, C
!local
double precision, dimension(3) :: up,vp,u,v,uxv
is_parallel=.False.
up = vec_comp(B,A) ! u'
vp = vec_comp(B,C) ! v'
u = vec_norm_comp(up)
v = vec_norm_comp(vp)
uxv = vec_cross(u,v)
if(vec_dot(uxv,uxv) .lt. 1e-6) is_parallel=.True.
! write(*,*) 'parallel',is_parallel, A,B,C,up,vp
return
end function is_parallel
!************************************************************************
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! WILSON'S B-matrix related
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!************************************************************************
subroutine build_Wilson_Bmat(natoms,coords,red_int_matrix,&
Bmatrix)
!************************************************************************
! it builds Wilson's B-matrix for redundant internal coordinates
!************************************************************************
implicit none
integer, intent(in) :: natoms
double precision, dimension(3,natoms), intent(in) :: coords
integer, dimension(:,:),intent(in) :: red_int_matrix
double precision :: Bmatrix(size(red_int_matrix,2),3*natoms)
!local
integer :: i,ncol
ncol = size(red_int_matrix,2)
do i=1,ncol
call zero_line_i(Bmatrix,i)
if(red_int_matrix(1,i) .ne. 0) then
call Bmat_line(natoms,coords,red_int_matrix(1:,i),i,&
Bmatrix)
! the columns of red_int_matrix contain the info for the given internal coordinate
! based on this info the appropriate line/row is filled in the B-matrix
endif
enddo
end subroutine build_Wilson_Bmat
!************************************************************************
subroutine Bmat_line(natoms,coords,column,idx,Bmatrix)
!************************************************************************
! it builds one line in Wilson's B-matrix
!************************************************************************
implicit none
integer, intent(in) :: natoms
double precision, dimension(3,natoms), intent(in) :: coords
integer, dimension(:), intent(in) :: column
integer, intent(in) :: idx
double precision, dimension(:,:), intent(inout)::Bmatrix
!local
integer :: btype,i,j,k,l
double precision, dimension(6) :: bond_vec
double precision, dimension(9) :: angle_vec
double precision, dimension(12) :: dihedral_vec
btype = column(1) ! type of int. coord
i = column(2) ! atom1
j = column(3) ! atom2
k = column(4) ! atom3
l = column(5) ! atom4
! write(*,*)'i,j,k,l: ',i,j,k,l
if(btype .eq. 1 .or. btype .eq. 4 .or. btype .eq. 5 .or. &
btype .eq. 6 .or. btype .eq. 7) then ! bond
bond_vec = Bmat_bond(coords(1:3,i),coords(1:3,j))
Bmatrix(idx,3*(i-1)+1:3*(i-1)+3) = bond_vec(1:3)
Bmatrix(idx,3*(j-1)+1:3*(j-1)+3) = bond_vec(4:6)
elseif(column(1) .eq. 2) then ! angle
angle_vec = Bmat_angle(coords(1:3,i),&
coords(1:3,j),&
coords(1:3,k))
Bmatrix(idx,3*(i-1)+1:3*(i-1)+3) = angle_vec(1:3)
Bmatrix(idx,3*(j-1)+1:3*(j-1)+3) = angle_vec(4:6)
Bmatrix(idx,3*(k-1)+1:3*(k-1)+3) = angle_vec(7:9)
elseif(column(1) .eq. 3) then ! dihedral
dihedral_vec = Bmat_dihedral(coords(1:3,i),&
coords(1:3,j),&
coords(1:3,k),&
coords(1:3,l))
Bmatrix(idx,3*(i-1)+1:3*(i-1)+3) = dihedral_vec(1:3)
Bmatrix(idx,3*(j-1)+1:3*(j-1)+3) = dihedral_vec(4:6)
Bmatrix(idx,3*(k-1)+1:3*(k-1)+3) = dihedral_vec(7:9)
Bmatrix(idx,3*(l-1)+1:3*(l-1)+3) = dihedral_vec(10:12)
elseif(column(1) == improper_code) then
dihedral_vec = bmat_improper(coords(1,l),coords(1,i),&
coords(1,k),coords(1,j))
Bmatrix(idx,3*(i-1)+1:3*(i-1)+3) = dihedral_vec(4:6)
Bmatrix(idx,3*(j-1)+1:3*(j-1)+3) = dihedral_vec(10:12)
Bmatrix(idx,3*(k-1)+1:3*(k-1)+3) = dihedral_vec(7:9)
Bmatrix(idx,3*(l-1)+1:3*(l-1)+3) = dihedral_vec(1:3)
endif
end subroutine Bmat_line
!************************************************************************
!************************************************************************
subroutine zero_line_i(A,i)
implicit none
double precision,dimension(:,:),intent(inout) :: A
integer, intent(in) :: i
!local
integer :: k,ndim
ndim = size(A,2)
do k=1,ndim
A(i,k) = 0.d0
enddo
end subroutine zero_line_i
!************************************************************************
!************************************************************************
subroutine active_subspace(nintcoord,natoms,nonred,Bmatrix,Gmat)
!************************************************************************
! Delocalizing RIC B matrix: J. Chem. Phys. 105, 192 (1996)
!************************************************************************
implicit none
integer :: nintcoord,natoms
integer :: nonred
double precision :: Bmatrix(nintcoord,3*natoms)
double precision :: Gmat(nintcoord,nintcoord)
integer :: info,lwork,i
double precision, parameter :: delta = 1.0d-7
double precision :: work1(1)
double precision, allocatable :: eigval(:),work(:)
allocate(eigval(nintcoord))
! Eigendecomposition of G=BB^T
call dsyrk('u','n',nintcoord,3*natoms,1.0d0,Bmatrix,nintcoord,&
0.0d0,Gmat,nintcoord)
call dsyev('v','u',nintcoord,Gmat,nintcoord,eigval,work1,-1,info)
lwork=int(work1(1))
allocate(work(lwork))
call dsyev('v','u',nintcoord,Gmat,nintcoord,eigval,work,lwork,&
info)
! Counting nonredundant coordinates
nonred=0
do i=1,nintcoord
if(dabs(eigval(i))>delta) nonred=nonred+1
enddo
deallocate(eigval)
deallocate(work)
end subroutine
!************************************************************************
subroutine get_deloc_matrix(nintcoord,nonred,Gmat,Umatrix)
!************************************************************************
! Returns the delocalization matrix U
! G contains the eigenvector of BB^T returned by active_subspace
!************************************************************************
implicit none
integer :: nintcoord,nonred
double precision, intent(in) :: Gmat(nintcoord,nintcoord)
double precision, intent(out) :: Umatrix(nintcoord,nonred)
integer :: nred
nred=nintcoord-nonred
call dcopy(nintcoord*nonred,Gmat(1,nred+1),1,Umatrix,1)
end subroutine
!************************************************************************
subroutine delocalize(nintcoord,nonred,n,Umatrix,mat,mat_deloc)
!************************************************************************
! Delocalizes a matrix with the U matrix returned by get_deloc_matrix
!************************************************************************
implicit none
integer, intent(in) :: nintcoord,nonred,n
double precision, intent(in) :: Umatrix(nintcoord,nonred)
double precision, intent(in) :: mat(nintcoord,n)
double precision, intent(out) :: mat_deloc(nonred,n)
call dgemm('t','n',nonred,n,nintcoord,1.0d0,Umatrix,nintcoord,&
mat,nintcoord,0.0d0,mat_deloc,nonred)
end subroutine
!************************************************************************
subroutine delocalize_mat(csys,mat,mat_deloc)
!************************************************************************
!************************************************************************
implicit none
type(coord_sys_type) :: csys
double precision :: mat(csys%ncoord_ric,csys%ncoord_ric)
double precision :: mat_deloc(csys%ncoord,csys%ncoord)
double precision, allocatable :: work(:,:)
allocate(work(csys%ncoord,csys%ncoord_ric))
call dgemm('t','n',csys%ncoord,csys%ncoord_ric,csys%ncoord_ric,&
1.0d0,csys%Umatrix,csys%ncoord_ric,0.0d0,work,csys%ncoord)
call dgemm('n','n',csys%ncoord,csys%ncoord,csys%ncoord_ric,&
1.0d0,work,csys%ncoord,0.0d0,mat_deloc,csys%ncoord)
deallocate(work)
end subroutine
!************************************************************************
function Bmat_bond(A, B)
!************************************************************************
! it returns the component of Wilson's B-matrix for the bonds
! between A and B
! JCP, 117, 9160 (2002), Eq. 17
!************************************************************************
implicit none
double precision, dimension(3), intent(in) :: A, B
double precision, dimension(6) :: Bmat_bond
!local
double precision, dimension(3) :: up,u
up = vec_comp(A,B) ! u'=B-A
u = vec_norm_comp(up)
Bmat_bond(1:3) = -1.d0*u !A
Bmat_bond(4:6) = +1.d0*u !B
return
end function Bmat_bond
!************************************************************************
!************************************************************************
function Bmat_angle(A, B, C)
!************************************************************************
! it returns the component of Wilson's B-matrix for the bond angles
! of A-B-C; the angle is measured at vertex atom B
! i.e. the angle between bonds B-A and B-C
! JCP, 117, 9160 (2002), Eq. 25 !!!!!!it is wrong in this article!!!!!!
! W. F. MURPHY. Can. J. Chem. 69, 1672 (1991)
!************************************************************************
implicit none
double precision, dimension(3), intent(in) :: A, B, C
double precision, dimension(9) :: Bmat_angle
!local
double precision, dimension(3) :: up,vp,u,v,wp,w,uxw,wxv
double precision :: lu,lv,angle
angle = angle3(A, B, C)
up = vec_comp(B,A)
lu = vec_length(up)*dsin(angle) ! lambda_u
vp = vec_comp(B,C)
lv = vec_length(vp)*dsin(angle) ! lambda_v
u = vec_norm_comp(up)
v = vec_norm_comp(vp)
wp = w_prime_comp(u,v)
w = vec_norm_comp(wp)
uxw = vec_cross(u,w)
wxv = vec_cross(w,v)
Bmat_angle(1:3) = uxw/lu
Bmat_angle(4:6) = (-1.d0*uxw/lu - 1.d0*wxv/lv)
Bmat_angle(7:9) = wxv/lv
return
end function Bmat_angle
!************************************************************************
!************************************************************************
function Bmat_dihedral(A, B, C, D)
!************************************************************************
! it returns the component of Wilson's B-matrix for the dihedral angles
! the angle is restricted to be in the range -Pi,Pi and measured in radian
! JCP, 117, 9160 (2002), Eq. 34
!************************************************************************
implicit none
double precision, dimension(3), intent(in) :: A, B, C, D
double precision, dimension(12) :: Bmat_dihedral
!local
double precision, dimension(3) :: up,vp,wp, u,v,w, uxw,vxw
double precision :: lu,lv,lw, sinu2,sinv2, cosu,cosv, su,sv,cu,cv
up = vec_comp(B,A)
lu = vec_length(up) ! lambda_u
vp = vec_comp(C,D)
lv = vec_length(vp) ! lambda_v
wp = vec_comp(B,C)
lw = vec_length(wp) ! lambda_w
u = vec_norm_comp(up)
v = vec_norm_comp(vp)
w = vec_norm_comp(wp)
uxw = vec_cross(u,w)
vxw = vec_cross(v,w)
sinu2= (1.d0 - (vec_dot(u,w))**2)
sinv2= (1.d0 - (vec_dot(v,w))**2)
cosu= 1.d0*vec_dot(u,w)
cosv= -1.d0*vec_dot(v,w)
su = 1.d0/(lu*sinu2)
sv = 1.d0/(lv*sinv2)
cu = cosu/(lw*sinu2)
cv = cosv/(lw*sinv2)
Bmat_dihedral(1:3) = 1.d0*uxw*su + 0.d0 + 0.d0
Bmat_dihedral(4:6) = -1.d0*uxw*su + 0.d0 + 1.d0*(uxw*cu+vxw*cv)
Bmat_dihedral(7:9) = 0.d0 + vxw*sv -1.d0*(uxw*cu+vxw*cv)
Bmat_dihedral(10:12) = 0.d0 -1.d0*vxw*sv +0.d0
return
end function Bmat_dihedral
!************************************************************************
function Bmat_improper(A, B, C, D)
!************************************************************************
! it returns the component of Wilson's B-matrix for the improper dihedral
! angles. Atoms A,B and C are connected to the central atom D, the plane
! is defined by the atoms B,C and D.
!************************************************************************
implicit none
double precision, dimension(3), intent(in) :: A, B, C, D
double precision, dimension(12) :: Bmat_improper
!local
double precision, dimension(3) :: e41,e42,e43
double precision :: r41,r42,r43
double precision :: sin_theta,cos_theta,tan_theta,cos_phi,sin_phi
e41=A-D
e42=B-D
e43=C-D
r41=vec_length(e41)
r42=vec_length(e42)
r43=vec_length(e43)
e41=e41/r41
e42=e42/r42
e43=e43/r43
cos_phi = vec_dot(e42,e43)
sin_phi = dsqrt(1.0d0 - cos_phi*cos_phi)
sin_theta = vec_mixed(e42,e43,e41)/sin_phi
cos_theta = dsqrt(1.0d0 - sin_theta*sin_theta)
tan_theta = sin_theta/cos_theta
bmat_improper(1:3) = (vec_cross(e42,e43)/(cos_theta*sin_phi)-&
tan_theta*e41)/r41
bmat_improper(4:6) = (vec_cross(e43,e41)/(cos_theta*sin_phi)-&
tan_theta/(sin_phi*sin_phi)*(e42-cos_phi*e43))/r42
bmat_improper(7:9) = (vec_cross(e41,e42)/(cos_theta*sin_phi)-&
tan_theta/(sin_phi*sin_phi)*(e43-cos_phi*e42))/r43
bmat_improper(10:12) = -bmat_improper(1:3)-bmat_improper(4:6)-&
bmat_improper(7:9)
end function
!*************************************************************************
subroutine build_red_int_matrix(natoms,atnums,coords,&
red_int_matrix,natomswdummy,coordswdummy)
!************************************************************************
! it builds red_int_matrix (matrix of redundant internal coordinates)
! its format as follows:
!
! red_int_matrix(1,i) ! type
! red_int_matrix(2,i) ! first atom
! red_int_matrix(3,i) ! second atom
! red_int_matrix(4,i) ! third atom
! red_int_matrix(5,i) ! fourth atom
!
! i refers to the i^th internal coordinate
!
! atnums is an array of atomic numbers
!************************************************************************
implicit none
integer :: natoms,atnums(natoms),natomswdummy
integer, allocatable :: red_int_matrix(:,:)
double precision, target :: coords(3,natoms)
double precision, allocatable, target :: coordswdummy(:,:)
!local
integer, allocatable, target :: bond_matrix(:,:)
integer, allocatable, target :: bond_matrix_new(:,:)
integer, pointer :: bm(:,:)
integer, allocatable :: rim_angles(:,:)
integer, allocatable :: rim_dummy_angles(:,:)
integer, allocatable :: rim_dihedrals(:,:)
integer, allocatable :: dummy_bonds(:)
integer :: nb,na,nd,nlin,nintcoord
integer :: ndummy
integer :: ii,i
double precision, pointer :: cart_coords(:,:)
allocate(bond_matrix(natoms,natoms))
! build bond matrix from covalent and interfragment bonds
call build_bond_matrix(natoms,atnums,coords,bond_matrix)
nb = nint_bonds(bond_matrix)
! write(*,'(A,I4)') 'nb: ',nb
! get the bond angles
na = nint_angles(bond_matrix)
allocate(rim_angles(5,na))
rim_angles=0
call get_angles(bond_matrix,rim_angles)
! check for linear angles
! linear angles are removed and dummy atoms are added if needed
call check_linear(natoms,coords,na,rim_angles,bond_matrix,&
natomswdummy,coordswdummy,dummy_bonds,nlin)
ndummy = natomswdummy - natoms
if(ndummy == 0) then
bm => bond_matrix
cart_coords => coords
else
! building new bond matrix with dummy atoms
allocate(bond_matrix_new(natomswdummy,natomswdummy))
allocate(rim_dummy_angles(5,2*ndummy))
bm => bond_matrix_new
cart_coords => coordswdummy
call add_dummy_atoms(natoms,natomswdummy,ndummy,bond_matrix,&
bond_matrix_new,rim_angles,rim_dummy_angles,dummy_bonds)
endif
! get the dihedral angles
! dihedral angles can contain dummy atoms as well
nd = nint_dihedrals(bm,cart_coords,ndummy)
allocate(rim_dihedrals(5,nd))
rim_dihedrals = 0
call get_dihedrals(natomswdummy,bm,cart_coords,rim_dihedrals,nd,&
ndummy,dummy_bonds,rim_angles)
! write(*,*) 'rim angles'
! write(*,'(5I4)') rim_angles
! write(*,*) 'rim dummy angles'
! write(*,'(5I4)') rim_dummy_angles
! write(*,*) 'rim dihedrals'
! write(*,'(5I4)') rim_dihedrals
! Building the final redundant internal matrix
nintcoord = (nb + ndummy) + (na-nlin+2*ndummy) + nd ! # internal coordinates
allocate(red_int_matrix(5,nintcoord))
red_int_matrix=0
! Get bonds
call get_bonds(bm,red_int_matrix)
! copy angles
ii=nb+ndummy
do i=1,na
if(rim_angles(1,i) /= 0) then
ii=ii+1
red_int_matrix(:,ii)=rim_angles(:,i)
endif
enddo
! copy dummy angles
do i=1,2*ndummy
ii=ii+1
red_int_matrix(:,ii) = rim_dummy_angles(:,i)
enddo
! copy dihedral angles
do i=1,nd
ii=ii+1
red_int_matrix(:,ii)=rim_dihedrals(:,i)
enddo
! deallocate memory
if(allocated(bond_matrix)) deallocate(bond_matrix)
if(allocated(bond_matrix_new)) deallocate(bond_matrix_new)
if(allocated(rim_angles)) deallocate(rim_angles)
if(allocated(rim_dummy_angles))deallocate(rim_dummy_angles)
if(allocated(rim_dihedrals)) deallocate(rim_dihedrals)
if(allocated(dummy_bonds)) deallocate(dummy_bonds)
end subroutine build_red_int_matrix
!************************************************************************
subroutine print_intcoords(rim,coords,inttype)
!************************************************************************
! it prints the internal coordinates using the redundant internal
! coordinate matrix (rim) and the cartesian coordinates (coords)
!************************************************************************
implicit none
integer, dimension(:,:),intent(in) :: rim ! redundant internal coordinate matrix
double precision, dimension(:,:),intent(in) :: coords ! cartesian coordinates
character(len=*), intent(in) :: inttype ! type of the internal coordinate
!local
integer :: natoms,nintcoord,code,i,k,l,m,n,ivalue
double precision :: fvalue
natoms = size(coords,2)
nintcoord = size(rim,2)
if(inttype(1:4) .eq. 'bond') then
ivalue = 1
elseif(inttype(1:5) .eq. 'angle') then
ivalue = 2
elseif(inttype(1:8) .eq. 'dihedral') then
ivalue = 3
elseif(inttype(1:8) .eq. 'aux bond') then
ivalue = 4
else
write(*,*) 'Invalid internal coordinate type was asked in &
subroutine print_intcoords!!!'
call mrccend(1)
endif
do i=1,nintcoord
code = rim(1,i)
k = rim(2,i)
l = rim(3,i)
m = rim(4,i)
n = rim(5,i)
if(code .gt. 0) then
if(code .eq. ivalue) then
if(ivalue .eq. 1) then
fvalue = &
distance2(coords(1:3,k),&
coords(1:3,l))
write(*,101) 'bond:',k,'-',l, fvalue
elseif(ivalue .eq. 2) then
fvalue = &
angle3(coords(1:3,k),&
coords(1:3,l),&
coords(1:3,m))
fvalue = 180.d0*fvalue/PI
write(*,102) 'angle:',k,'-',l,'-',m, fvalue
elseif(ivalue .eq. 3) then
fvalue = &
dihedral4(coords(1:3,k),&
coords(1:3,l),&
coords(1:3,m),&
coords(1:3,n))
fvalue = 180.d0*fvalue/PI
write(*,103) 'dihedral:',k,'-',l,'-',m,'-',n, fvalue
elseif(ivalue .eq. 4) then
fvalue = &
distance2(coords(1:3,k),&
coords(1:3,l))
write(*,101) 'aux bond:',k,'-',l, fvalue
endif
endif
else
write(*,*) 'Invalid internal coordinate index in the &
redundant internal coordinate matrix!!!'
call mrccend(1)
endif
enddo
101 format(A20,I4,A4,I4,F12.6)
102 format(A20,I4,A4,I4,A4,I4,F12.6)
103 format(A20,I4,A4,I4,A4,I4,A4,I4,F12.6)
end subroutine print_intcoords
!************************************************************************
!************************************************************************
subroutine build_bond_matrix(natoms,atnum,coords,bond_matrix)
!************************************************************************
! it builds the bond matrix which is like the distance matrix but
! (i,j)=1 if there is a "regular" bond zero otherwise
! auxiliary bonds are indicated by the integer 4, i.e., (i,j)=4
! H-bonds will be indicated by 5 and inter-fragment bonds by 6
!************************************************************************
implicit none
integer :: natoms
integer, intent(in) :: atnum(natoms) ! atomic/proton number
double precision, intent(in) :: coords(3,natoms)
integer, intent(out) :: bond_matrix(natoms,natoms)
bond_matrix=0
call regular_bonds(natoms,atnum,coords,bond_matrix)
call fragment_bonds(natoms,coords,bond_matrix)
return
end subroutine build_bond_matrix
!************************************************************************
subroutine regular_bonds(natoms,atnum,coords,bond_matrix)
!************************************************************************
! Adds regular and auxiliary bonds to the bond matrix
!************************************************************************
implicit none
integer :: natoms
integer, intent(in) :: atnum(natoms) ! atomic/proton number
double precision, intent(in) :: coords(3,natoms)
integer :: bond_matrix(natoms,natoms)
!local
double precision d,cr,rb,ab
integer :: i,j
do j=1,natoms
do i=j+1,natoms
d = distance2(coords(1:3,j),coords(1:3,i))
cr = get_cov_radius(atnum(j))+get_cov_radius(atnum(i)) ! sum of covalent radii
rb = 1.3d0*cr ! regular bond
ab = 2.6d0*cr ! auxiliary bond !csonti
if( d .le. rb ) then
! write(*,*) 'Regular bond between ', i,j,d
bond_matrix(i,j) = 1
bond_matrix(j,i) = 1
elseif (d .le. ab) then
! write(*,*) 'Auxiliary bond between ', i,j,d
bond_matrix(i,j) = 4
bond_matrix(j,i) = 4
endif
enddo ! i
enddo ! j
end subroutine
!************************************************************************
subroutine fragment_bonds(natoms,coords,bond_matrix)
!************************************************************************
! Adds bonds between fragments
!************************************************************************
implicit none
integer :: natoms
double precision, intent(in) :: coords(3,natoms)
integer :: bond_matrix(natoms,natoms)
!local
integer :: iatoms,jatoms
integer :: nfrag,n_fbonds
integer, allocatable :: fragment_code(:)
allocate(fragment_code(natoms))
call graph_coloring(natoms,bond_matrix,fragment_code)
nfrag=maxval(fragment_code)
if(nfrag /= 1) then
n_fbonds=nfrag*(nfrag-1)/2
call update_bond_matrix(natoms,natoms,fragment_code,&
n_fbonds,coords,bond_matrix)
do iatoms=1,natoms
do jatoms=1,iatoms-1
if(bond_matrix(jatoms,iatoms)==afbond_code) &
n_fbonds=n_fbonds+1
enddo
enddo
endif
deallocate(fragment_code)
return
end subroutine
!************************************************************************
subroutine get_bonds(bond_matrix,red_int_matrix)
!************************************************************************
! the first few columns (bond-related part) of the redundant internal
! coordinate matrix, red_int_matrix, are set up.
!************************************************************************
implicit none
integer, dimension(:,:),intent(in) :: bond_matrix
integer, dimension(:,:),intent(inout) :: red_int_matrix
!local
integer :: i,j,k,natoms,code
natoms = size(bond_matrix,1)
k = 0
do j=1,natoms
do i=j+1,natoms
code = bond_matrix(i,j)
if(code==bond_code .or. code==abond_code .or. &
code==fbond_code .or. code==afbond_code .or. &
code==hbond_code) then
k = k+1
red_int_matrix(1,k) = code ! type: regular bond
red_int_matrix(2,k) = j ! first atom
red_int_matrix(3,k) = i ! second atom
red_int_matrix(4,k) = 0 ! third atom
red_int_matrix(5,k) = 0 ! fourth atom
endif
enddo ! i
enddo ! j
return
end subroutine get_bonds
!************************************************************************
!************************************************************************
integer function nint_bonds(bond_matrix)
!************************************************************************
! number of internal coordinate bonds is returned
!************************************************************************
implicit none
integer, dimension(:,:),intent(in) :: bond_matrix
!local
integer :: i,j,k,natoms,code
natoms = size(bond_matrix,1)
k = 0
do j=1,natoms
do i=j+1,natoms
code = bond_matrix(i,j)
if(code .ne. 0) k = k+1
enddo ! i
enddo ! j
nint_bonds = k
return
end function nint_bonds
!************************************************************************
!************************************************************************
subroutine get_angles(bond_matrix,red_int_matrix)
!************************************************************************
! it determines the angles between bonds
! the second (angle-related) part of the redundant internal
! coordinate matrix, red_int_matrix, is also set up.
!************************************************************************
implicit none
integer, dimension(:,:),intent(in) :: bond_matrix
integer, dimension(:,:),intent(inout) :: red_int_matrix
!local
integer :: i,j,natoms,ncol
integer :: first = 1
integer :: first_zero !first zero position in red_int_matrix
natoms = size(bond_matrix,1)
ncol = size(red_int_matrix,2)
do i=1,ncol
if(red_int_matrix(1,i) .eq. 0) then
first_zero = i
exit
endif
enddo
do j=1,natoms
call rec_g_angle(first,bond_matrix(1:natoms,j),red_int_matrix,&
first_zero,j)
enddo
end subroutine get_angles
!************************************************************************
!************************************************************************
recursive subroutine rec_g_angle(first,column,red_int_matrix,&
first_zero,cidx)
!************************************************************************
implicit none
integer, intent(inout) :: first,first_zero
integer, dimension(:), intent(in) :: column
integer, dimension(:,:), intent(inout) :: red_int_matrix
integer, intent(in) :: cidx !column index of bond matrix
!local
integer :: i,k,last,nbonds
logical :: lfirst
integer :: first_bond !first occasion of a bond in the given column of the bond matrix
last = size(column)
first_bond = 0
nbonds = 0
lfirst = .True.
do i=first,last
if(is_primary_bond(column(i))) then
nbonds = nbonds+1
if (lfirst) then
first_bond = i
lfirst = .False.
endif
endif
if(nbonds .eq. 2) exit
enddo
if(nbonds .eq. 2) then
do k=first_bond+1,last
if(is_primary_bond(column(k))) then
red_int_matrix(1,first_zero) = 2 ! type: angle
red_int_matrix(2,first_zero) = first_bond ! first atom
red_int_matrix(3,first_zero) = cidx ! second, vertex atom
red_int_matrix(4,first_zero) = k ! third atom
red_int_matrix(5,first_zero) = 0 ! fourth atom
first_zero = first_zero+1
endif
enddo
if(first_bond .lt. last) then
first_bond = first_bond+1
call rec_g_angle(first_bond,column,red_int_matrix,&
first_zero,cidx)
endif
endif
return
end subroutine rec_g_angle
!************************************************************************
!************************************************************************
integer function nint_angles(bond_matrix)
!************************************************************************
! number of internal coordinate angles is returned
!************************************************************************
implicit none
integer, dimension(:,:),intent(in) :: bond_matrix
!local
integer :: j,natoms
integer :: first = 1
nint_angles = 0
natoms = size(bond_matrix,1)
nint_angles = 0
do j=1,natoms
call rec_n_angle(first,nint_angles,bond_matrix(1:natoms,j))
enddo
return
end function nint_angles
!************************************************************************
!************************************************************************
recursive subroutine rec_n_angle(first,nint_angles,column)
!************************************************************************
implicit none
integer, intent(inout) :: first,nint_angles
integer, dimension(:), intent(in) :: column
!local
integer :: i,j,k,last,nbonds
logical :: lfirst
integer :: first_bond !first occasion of a bond in the given column of the bond matrix
last = size(column)
first_bond = 0
nbonds = 0
lfirst = .True.
do i=first,last
if(is_primary_bond(column(i))) then
nbonds = nbonds+1
if (lfirst) then
first_bond = i
lfirst = .False.
endif
endif
if(nbonds .eq. 2) exit
enddo
if(nbonds .eq. 2) then
j = 0
do k=first_bond+1,last
if(is_primary_bond(column(k))) then
j = j+1
endif
enddo
nint_angles = nint_angles + j
if(first_bond .lt. last) then
first_bond = first_bond+1
call rec_n_angle(first_bond,nint_angles,column)
endif
endif
return
end subroutine rec_n_angle
!************************************************************************
!************************************************************************
subroutine get_angles_o(bond_matrix,red_int_matrix)
!************************************************************************
! it determines the angles between bonds
! the second (angle-related) part of the redundant internal
! coordinate matrix, red_int_matrix, is also set up.
!************************************************************************
implicit none
integer, dimension(:,:),intent(in) :: bond_matrix
integer, dimension(:,:),intent(inout) :: red_int_matrix
!local
integer :: i,j,k,natoms,nbonds,ncol
logical :: lfirst
integer :: first_bond !first occasion of a bond in the given column of the bond matrix
integer :: first_zero !first zero position in red_int_matrix
natoms = size(bond_matrix,1)
ncol = size(red_int_matrix,2)
do i=1,ncol
if(red_int_matrix(1,i) .eq. 0) then
first_zero = i
exit
endif
enddo
first_bond=0
do j=1,natoms
nbonds = 0
lfirst = .True.
do i=1,natoms
if(bond_matrix(i,j) .eq. 1) then
nbonds = nbonds+1
if (lfirst) then
first_bond=i
lfirst = .False.
endif
endif
if(nbonds .eq. 2) exit
enddo
if(nbonds .eq. 2) then
do k=first_bond+1,natoms ! csonti implement a recursive algorithm here
if(bond_matrix(k,j) .eq. 1) then
red_int_matrix(1,first_zero) = 2 ! type: angle
red_int_matrix(2,first_zero) = first_bond ! first atom
red_int_matrix(3,first_zero) = j ! second, vertex atom
red_int_matrix(4,first_zero) = k ! third atom
red_int_matrix(5,first_zero) = 0 ! fourth atom
first_zero = first_zero+1
endif
enddo
endif
enddo
end subroutine get_angles_o
!************************************************************************
!************************************************************************
integer function nint_angles_o(bond_matrix)
!************************************************************************
! number of internal coordinate angles is returned
!************************************************************************
implicit none
integer, dimension(:,:),intent(in) :: bond_matrix
!local
integer :: i,j,k,l,natoms,nbonds
logical :: lfirst
integer :: first_bond !first occasion of a bond in the given column of the bond matrix
nint_angles_o = 0
natoms = size(bond_matrix,1)
first_bond=0
do j=1,natoms
nbonds = 0
lfirst = .True.
do i=1,natoms
if(bond_matrix(i,j) .eq. 1) then
nbonds = nbonds+1
if (lfirst) then
first_bond=i
lfirst = .False.
endif
endif
if(nbonds .eq. 2) exit
enddo
if(nbonds .eq. 2) then
l = 0
do k=first_bond+1,natoms ! csonti implement a recursive algorithm here
if(bond_matrix(k,j) .eq. 1) then
l = l+1
endif
enddo
nint_angles_o = nint_angles_o + l
endif
enddo
return
end function nint_angles_o
!************************************************************************
!************************************************************************
subroutine get_dihedrals(natoms,bond_matrix,coords,red_int_matrix,&
ndihedral,ndummy,dummy_bonds,rim_angles)
!************************************************************************
! it determines the dihedral angles between the first and last bonds of
! three consecutive bonds
! the third (dihedral-related) part of the redundant internal
! coordinate matrix, red_int_matrix, is also set up.
!************************************************************************
implicit none
integer :: natoms,ndihedral,ndummy
integer :: dummy_bonds(ndummy)
integer :: bond_matrix(natoms,natoms),red_int_matrix(5,ndihedral)
integer :: rim_angles(5,*)
double precision :: coords(3,natoms)
!local
integer :: natoms_original,idummy,iidummy,bonds(3),center
integer :: i,j,k,l,nrow,ncol,n
integer :: first_zero !first zero position in red_int_matrix
logical :: no_regular !are there any regular (A-B-C-D type) dihedral
logical :: bool1, bool2
nrow = 5
ncol = ndihedral
first_zero = 1
no_regular = .True.
do i=1,natoms
do j=1,natoms
if(is_primary_bond(bond_matrix(i,j))) then
do k=1,natoms
if(is_primary_bond(bond_matrix(j,k)) .and. (k.ne.i)) then
do l=i,natoms
if(is_primary_bond(bond_matrix(k,l)) .and. &
( (l .ne. j) .and. (l .ne. i) ) ) then
bool1 = is_parallel(coords(1:3,i),&
coords(1:3,j),coords(1:3,k))
bool2 = is_parallel(coords(1:3,j),&
coords(1:3,k),coords(1:3,l))
if((.not. bool1) .and. (.not. bool2)) then ! none of the ends of the dihedral coincides with a line (0 or 180 degree bond angle)
red_int_matrix(1,first_zero) = 3 ! type: dihedral
red_int_matrix(2,first_zero) = i ! first atom
red_int_matrix(3,first_zero) = j ! second, vertex atom
red_int_matrix(4,first_zero) = k ! third atom
red_int_matrix(5,first_zero) = l ! fourth atom
first_zero = first_zero + 1
no_regular = .False. ! regular dihedral angles are present
endif
endif
enddo !l
endif
enddo !k
endif
enddo !j
enddo !i
! improper dihedral angles for dummy atoms
natoms_original = natoms - ndummy
do iidummy=1,ndummy
idummy=natoms_original + iidummy
n = dummy_bonds(iidummy)
i = rim_angles(2,n)
j = rim_angles(3,n) ! central atom
k = rim_angles(4,n)
! a plane is defined by the dummy atom, the central atom and one
! of the other atoms in the linear bond angle.
! The angle of this plane and the other half of the linear angle
! gives the improper dihedral angle
red_int_matrix(1,first_zero) = improper_code
red_int_matrix(2,first_zero) = idummy
red_int_matrix(3,first_zero) = j
red_int_matrix(4,first_zero) = i
red_int_matrix(5,first_zero) = k
first_zero=first_zero+1
no_regular = .false.
enddo
! improper dihedral angle for four atom molecules
if(natoms .ge. 4 .and. no_regular) then
! We need central atoms with 3 neighbours
do center = 1,natoms
n=0
bonds=0
do j=1,natoms
if(is_primary_bond(bond_matrix(j,center))) then
n=n+1
bonds(n)=j
if(n==3) exit
endif
enddo
if(n==3) then
! The central atom and two of its neighbours define a plane.
! The angle of the plane and the third bond gives the
! improper dihedral angle
red_int_matrix(1,first_zero) = improper_code
red_int_matrix(2,first_zero) = bonds(1)
red_int_matrix(3,first_zero) = center
red_int_matrix(4,first_zero) = bonds(2)
red_int_matrix(5,first_zero) = bonds(3)
first_zero=first_zero+1
endif
enddo
endif
return
end subroutine get_dihedrals
!************************************************************************
!************************************************************************
integer function nint_dihedrals(bond_matrix,coords,ndummy)
!************************************************************************
! number of internal coordinate dihedrals is returned
!************************************************************************
implicit none
integer :: ndummy
integer, dimension(:,:),intent(in) :: bond_matrix
double precision,dimension(3,size(bond_matrix,1)),intent(in):: coords
!local
integer :: i,j,k,l,natoms,n_linear,n,center
logical :: bool1, bool2
natoms = size(bond_matrix,1)
nint_dihedrals = 0
n_linear = 0
do i=1,natoms
do j=1,natoms
if(is_primary_bond(bond_matrix(i,j))) then
do k=1,natoms
if(is_primary_bond(bond_matrix(j,k)) .and. (k .ne. i) ) then
do l=i,natoms
if(is_primary_bond(bond_matrix(k,l)) .and. &
( (l .ne. j) .and. (l .ne. i) ) ) then
nint_dihedrals = nint_dihedrals + 1
bool1 = is_parallel(coords(1:3,i),&
coords(1:3,j),coords(1:3,k))
bool2 = is_parallel(coords(1:3,j),&
coords(1:3,k),coords(1:3,l))
if(bool1 .or. bool2) then ! at least one end of the dihedral coincides with a line (0 or 180 degree bond angle)
n_linear = n_linear + 1
nint_dihedrals = nint_dihedrals - 1
endif
endif
enddo !l
endif
enddo !k
endif
enddo !j
enddo !i
! improper dihedral angles
! First, we add one improper dihedral for each dummy atom
nint_dihedrals = nint_dihedrals+ndummy
! for four atom molecules we might need improper dihedrals too
if(natoms .ge. 4 .and. (nint_dihedrals .eq. 0) ) then
do center = 1,natoms
n=0
do j=1,natoms
if(is_primary_bond(bond_matrix(j,center))) n=n+1
enddo
if(n >= 3) nint_dihedrals=nint_dihedrals+1
enddo
endif
return
end function nint_dihedrals
!************************************************************************
!************************************************************************
logical function is_primary_bond(b)
!************************************************************************
! Determines if a bond is primary bond: regular bond, interfrag. bond
! or H-bond
!************************************************************************
implicit none
integer b
if(b==bond_code .or. b==fbond_code .or. b==hbond_code) then
is_primary_bond=.true.
else
is_primary_bond=.false.
endif
return
end function
!************************************************************************
subroutine get_intcoords(natoms,cartcoords,nintcoord,&
red_int_matrix,intcoords)
!************************************************************************
! it returns the values of the internal coordinates
! using the matrix of redundant internal coordinates and
! the Cartesian coordinates
! no constrains are handled at the moment (csonti)
!************************************************************************
implicit none
integer, intent(in) :: natoms
double precision, dimension(3,natoms), intent(in):: cartcoords
integer, intent(in) :: nintcoord
integer, dimension(:,:),intent(in) :: red_int_matrix
double precision, dimension(nintcoord) :: intcoords
!local
integer :: i,k,l,m,n,nrow,ncol,rim
nrow = size(red_int_matrix,1)
ncol = size(red_int_matrix,2)
do i=1,ncol
rim = red_int_matrix(1,i) ! type of the internal coordinate
if (rim .eq. 0) then ! last element
exit
elseif(rim==bond_code.or.rim==abond_code.or.rim==fbond_code &
.or.rim==hbond_code.or.rim==afbond_code) then ! bond
k = red_int_matrix(2,i)
l = red_int_matrix(3,i)
! write(*,*) 'distance',k,l,&
! distance2(cartcoords(1:3,k),cartcoords(1:3,l))
intcoords(i) = &
distance2(cartcoords(1:3,k),cartcoords(1:3,l))
elseif(rim .eq. 2) then ! angle
k = red_int_matrix(2,i)
l = red_int_matrix(3,i)
m = red_int_matrix(4,i)
! write(*,*) 'angle',k,l,m,&
! angle3(cartcoords(1:3,k),&
! cartcoords(1:3,l),&
! cartcoords(1:3,m))
intcoords(i) = &
angle3(cartcoords(1:3,k),&
cartcoords(1:3,l),&
cartcoords(1:3,m))
elseif(rim .eq. 3) then ! dihedral
k = red_int_matrix(2,i)
l = red_int_matrix(3,i)
m = red_int_matrix(4,i)
n = red_int_matrix(5,i)
! write(*,*) 'dihedral',k,l,m,n,&
! dihedral4(cartcoords(1:3,k),&
! cartcoords(1:3,l),&
! cartcoords(1:3,m),&
! cartcoords(1:3,n))
intcoords(i) = &
dihedral4(cartcoords(1:3,k),&
cartcoords(1:3,l),&
cartcoords(1:3,m),&
cartcoords(1:3,n))
elseif(rim == improper_code) then
k = red_int_matrix(2,i)
l = red_int_matrix(3,i)
m = red_int_matrix(4,i)
n = red_int_matrix(5,i)
intcoords(i)=improper(cartcoords(1,k),cartcoords(1,m),&
cartcoords(1,n),cartcoords(1,l))
endif
enddo
return
end subroutine get_intcoords
!************************************************************************
!************************************************************************
subroutine read_intcoords(nintcoord,intcoords)
!************************************************************************
! it reads values of the internal coordinates from a scrfile
!************************************************************************
implicit none
integer, intent(in) :: nintcoord
double precision, dimension(nintcoord), intent(out) :: intcoords
!local
integer :: i
open(icoordfile,file='COORD.int',&
status='old',form='unformatted')
do i=1,nintcoord
read(icoordfile) intcoords(i)
enddo
close(icoordfile)
end subroutine read_intcoords
!************************************************************************
!************************************************************************
subroutine wrt_intcoords(nintcoord,intcoords)
!************************************************************************
! it writes values of the internal coordinates into a scrfile
!************************************************************************
implicit none
integer, intent(in) :: nintcoord
double precision, dimension(nintcoord), intent(in) :: intcoords
!local
integer :: i
open(icoordfile,file='COORD.int',&
status='unknown',form='unformatted')
do i=1,nintcoord
write(icoordfile) intcoords(i)
enddo
close(icoordfile)
end subroutine wrt_intcoords
!************************************************************************
subroutine pretty_print_intcoords(csys)
!************************************************************************
!* Print internal coordinates to screen
!************************************************************************
implicit none
type(coord_sys_type), target :: csys
integer :: nintcoord
double precision, pointer :: intcoord(:)
double precision, allocatable, target :: intcoords_ric(:)
integer :: i,naux
logical :: lprint
nintcoord = csys%ncoord_ric
if(trim(csys%name) == 'ric') then
intcoord => csys%coord
else
allocate(intcoords_ric(csys%ncoord_ric))
call get_intcoords(csys%natoms,csys%cart_coord,&
csys%ncoord_ric,csys%rim,intcoords_ric)
intcoord => intcoords_ric
endif
! counting auxiliary bonds
naux=0
do i=1,nintcoord
if(csys%rim(1,i)==abond_code .or. csys%rim(1,i)==afbond_code)&
naux=naux+1
enddo
write(*,*)
write(*,'(A,I10)') ' Number of redundant internal coordinates: ',&
nintcoord
write(*,'(A,I10)') ' Number of auxiliary bonds (not printed) : ',&
naux
write(*,'(A,I10)') ' Number of frozen internal coordinates : ',&
csys%nfrozen
write(*,*)
! bond length
lprint=.false.
do i=1,nintcoord
if(csys%rim(1,i)==1) then
lprint=.true.
exit
endif
enddo
if(lprint) then
write(*,'(A)') ' Bond length: '
write(*,'(A)') ' Atom1 Atom2 Length'
do i=1,nintcoord
if(csys%rim(1,i)==1) then
write(*,'(I5,3X,I5,3X,f17.10)') &
csys%rim(2,i),csys%rim(3,i),intcoord(i)
endif
enddo
write(*,*)
endif
! bond angels
lprint=.false.
do i=1,nintcoord
if(csys%rim(1,i)==2) then
lprint=.true.
exit
endif
enddo
if(lprint) then
write(*,'(A)') ' Bond angles'
write(*,'(A)') ' Atom1 Atom2 Atom3 Angle'
do i=1,nintcoord
if(csys%rim(1,i)==2) then
write(*,'(I5,3X,I5,3X,I5,3X,f17.10)') &
csys%rim(2,i),csys%rim(3,i),csys%rim(4,i),intcoord(i)
endif
enddo
write(*,*)
endif
! dihedral angels
lprint=.false.
do i=1,nintcoord
if(csys%rim(1,i)==3) then
lprint=.true.
exit
endif
enddo
if(lprint) then
write(*,'(A)') ' Dihedral angles'
write(*,'(A)') ' Atom1 Atom2 Atom3 Atom4 Angle'
do i=1,nintcoord
if(csys%rim(1,i)==3) then
write(*,'(I5,3X,I5,3X,I5,3X,I5,3X,f17.10)') &
csys%rim(2,i),csys%rim(3,i),csys%rim(4,i),&
csys%rim(5,i),intcoord(i)
endif
enddo
write(*,*)
endif
! improper diedral angles
lprint=.false.
do i=1,nintcoord
if(csys%rim(1,i)==improper_code) then
lprint=.true.
exit
endif
enddo
if(lprint) then
write(*,'(A)') ' Improper dihedral angles'
write(*,'(A)') ' Atom1 Atom2 Atom3 Atom4 Angle'
do i=1,nintcoord
if(csys%rim(1,i)==improper_code) then
write(*,'(I5,3X,I5,3X,I5,3X,I5,3X,f17.10)') &
csys%rim(2,i),csys%rim(3,i),csys%rim(4,i),&
csys%rim(5,i),intcoord(i)
endif
enddo
write(*,*)
endif
! interfragment bonds
lprint=.false.
do i=1,nintcoord
if(csys%rim(1,i)==fbond_code) then
lprint=.true.
exit
endif
enddo
if(lprint) then
write(*,'(A)') ' Interfragment Bond length: '
write(*,'(A)') ' Atom1 Atom2 Length'
do i=1,nintcoord
if(csys%rim(1,i)==fbond_code) then
write(*,'(I5,3X,I5,3X,f17.10)') &
csys%rim(2,i),csys%rim(3,i),intcoord(i)
endif
enddo
write(*,*)
endif
if(allocated(intcoords_ric)) deallocate(intcoords_ric)
end subroutine
!************************************************************************
subroutine wrt_Pmat(nintcoord,Pmat)
!************************************************************************
! it writes the projection matrix into a scrfile
!************************************************************************
implicit none
integer, intent(in) :: nintcoord
double precision,dimension(nintcoord,nintcoord),intent(in) :: Pmat
!local
integer :: i,j
open(pmatfile,file='PMAT.int',&
status='unknown',form='unformatted')
do j=1,nintcoord
do i=1,nintcoord
write(pmatfile) Pmat(i,j)
enddo
enddo
close(pmatfile)
end subroutine wrt_Pmat
!************************************************************************
!************************************************************************
subroutine read_Pmat(nintcoord,Pmat)
!************************************************************************
! it reads the projection matrix from a scrfile
!************************************************************************
implicit none
integer, intent(in) :: nintcoord
double precision,dimension(nintcoord,nintcoord),intent(out):: Pmat
!local
integer :: i,j
open(pmatfile,file='PMAT.int',&
status='old',form='unformatted')
do j=1,nintcoord
do i=1,nintcoord
read(pmatfile) Pmat(i,j)
enddo
enddo
close(pmatfile)
end subroutine read_Pmat
!************************************************************************
!************************************************************************
subroutine step_transform(x0,Bmatrix,Bp,sq,csys)
!************************************************************************
! transformation of the projected internal coordinate step sq
! to Cartesian coordinates; JCP, 117, 9160 (2002), section 5
!
! x0 - initial Cartesian coordinate vector
! q0 - initial internal coordinate vector
! B - Wilson's B-matrix
! Bp - pseudo-inverse /B+/ of Wilson's B-matrix
! sq - internal coordinate step
!
!************************************************************************
implicit none
type(coord_sys_type), target :: csys
double precision :: Bp(csys%ncoord,3*csys%natoms)
double precision :: Bmatrix(csys%ncoord_ric,3*csys%natoms)
double precision, intent(in) :: sq(csys%ncoord)
double precision, intent(in) :: x0(3*csys%natoms)
!local
integer :: natoms,nintcoord,nintcoord_ric
integer :: k,lwork,nsol
double precision :: work1(1)
double precision :: dqk1_norm,dnrm2,step_norm,int_step_norm
double precision, parameter :: eps = 1.d-7 ! JCP, 117, 9160 (2002), section 5
double precision, allocatable :: xk1(:),x1(:),q0(:),Gmat(:,:)
double precision, allocatable :: solution(:),work(:)
double precision, allocatable, target :: qk_ric(:),qk_deloc(:)
double precision, pointer :: qk(:),xk(:,:)
logical :: conv
nintcoord = csys%ncoord
nintcoord_ric = csys%ncoord_ric
natoms = csys%natoms
nsol=max(nintcoord,3*natoms)
xk => csys%cart_coord
allocate(q0(nintcoord_ric))
allocate(qk_ric(nintcoord_ric))
if(trim(csys%name) == 'ric') then
qk => qk_ric
elseif(trim(csys%name) == 'deloc-ic') then
allocate(qk_deloc(nintcoord))
qk => qk_deloc
endif
allocate(xk1(3*natoms))
allocate(x1(3*natoms))
allocate(solution(nsol))
allocate(Gmat(nintcoord,nintcoord))
call get_intcoords(natoms,xk,nintcoord,csys%rim,q0)
conv= .False.
k = 0
! x1=x0+(B^+)sq
call dcopy(nintcoord,sq,1,solution,1)
call back_transform(natoms,csys,Bmatrix,Gmat,x1,solution,eps,&
work1,-1)
lwork=int(work1(1))
allocate(work(lwork))
call back_transform(natoms,csys,Bmatrix,Gmat,x1,solution,eps,&
work,lwork)
call daxpy(3*natoms,1.0d0,x0,1,x1,1)
call dcopy(3*natoms,x1,1,xk,1) ! initial estimate
do while ( (.not.conv) .and. k .le. 25)
k = k+1
call get_intcoords(natoms,xk,nintcoord_ric,csys%rim,qk_ric)
! dq = qk-q0
! We have to take the difference in redundant ic. (before
! delocalization) to be able to fix the angle periodicity
call daxpy(nintcoord_ric,-1.0d0,q0,1,qk_ric,1)
call fix_angles(qk_ric,csys%rim,nintcoord_ric)
if(trim(csys%name) == 'deloc-ic') then
call delocalize(nintcoord_ric,nintcoord,1,csys%Umatrix,&
qk_ric,qk_deloc)
endif
! dqk=sq-(qk-q0)=sq-dq
call dscal(nintcoord,-1.0d0,qk,1)
call daxpy(nintcoord,1.0d0,sq,1,qk,1)
if(trim(csys%name) == 'ric') then
call fix_angles(qk,csys%rim,nintcoord)
endif
if(k .eq. 1) then
dqk1_norm = vecnorm(qk,2)
else
if(vecnorm(qk,2) .gt. dqk1_norm) then
call dcopy(3*natoms,x1,1,xk,1)
exit
endif
endif
! xk1 = xk + (B^+)dqk
call dcopy(nintcoord,qk,1,solution,1)
call back_transform(natoms,csys,Bmatrix,Gmat,xk1,solution,eps,&
work,lwork)
conv = (dnrm2(3*natoms,xk1,1)/dsqrt(dble(3*natoms)) < eps)
call daxpy(3*natoms,1.0d0,xk,1,xk1,1)
! conv = conv .or. check_conv(xk1,xk,eps)
call dcopy(3*natoms,xk1,1,xk,1)
enddo
! if(conv) then
! write(*,'(A,I3,A)') 'Step transform converged in ', k, ' steps'
! else
! write(*,'(A)') 'Step transform failed to converge'
! write(*,'(A,I3)') 'Number of iteration steps: ', k
! endif
! x1=xk-csys%cart_coord
call dcopy(3*natoms,xk,1,x1,1)
call daxpy(3*natoms,-1.0d0,x0,1,x1,1)
! step_norm = dnrm2(3*natoms,x1,1)
! write(*,'(A,ES15.3)') 'Step norm in Cartesian coordinates: ',&
! step_norm
! int_step_norm = dnrm2(nintcoord,sq,1)
! write(*,'(A,ES15.3)') 'Step norm in internal coordinates: ',&
! int_step_norm
deallocate(q0)
deallocate(qk_ric)
if(allocated(qk_deloc)) deallocate(qk_deloc)
deallocate(xk1)
deallocate(x1)
deallocate(work)
deallocate(solution)
deallocate(Gmat)
end subroutine step_transform
!************************************************************************
subroutine back_transform(natoms,csys,Bmatrix,Gmat,x,s,delta,&
work,lwork)
!************************************************************************
! Calculates the x=B^T(BB^T)^(-1)*s product
! B: Wilson B matrix
! s: coordinates in internal system
!************************************************************************
implicit none
integer :: natoms,lwork
type(coord_sys_type) :: csys
double precision :: delta
double precision :: Bmatrix(csys%ncoord,3*natoms)
double precision :: Gmat(csys%ncoord,csys%ncoord)
double precision :: x(3,natoms)
double precision :: s(csys%ncoord)
double precision :: work(*)
integer :: rank,lwork2,i,nintcoord
if(lwork == -1) then
call dgelss(csys%ncoord,csys%ncoord,1,Bmatrix,csys%ncoord,s,&
csys%ncoord,work,delta,rank,work(1),-1,i)
work(1) = work(1) + dble(csys%ncoord)
work(1) = max(work(1),dble(csys%ncoord*3*natoms))
return
endif
nintcoord=size(csys%rim,2)
if(trim(csys%name) /= 'ric') then
call build_wilson_bmat(natoms,csys%cart_coord,csys%rim,work)
if(csys%nfrozen /= 0) call freezing_bmat_int(csys,work)
call delocalize(nintcoord,csys%ncoord,3*natoms,csys%Umatrix,&
work,Bmatrix)
else
call build_wilson_bmat(natoms,csys%cart_coord,csys%rim,Bmatrix)
if(csys%nfrozen /= 0) call freezing_bmat_int(csys,work)
endif
call dsyrk('u','n',csys%ncoord,3*natoms,1.0d0,Bmatrix,csys%ncoord,&
0.0d0,Gmat,csys%ncoord)
call filllo(Gmat,csys%ncoord)
lwork2=lwork-csys%ncoord
call dgelss(csys%ncoord,csys%ncoord,1,Gmat,csys%ncoord,s,&
csys%ncoord,work,delta,rank,work(1+csys%ncoord),lwork2,i)
call dgemv('t',csys%ncoord,3*natoms,1.0d0,Bmatrix,csys%ncoord,s,1,&
0.0d0,x,1)
end subroutine
!************************************************************************
subroutine transform_grad(natoms,grad_x,grad_int,csys)
!************************************************************************
! Transform Cartesian gradient to internal
!************************************************************************
implicit none
integer :: natoms
type(coord_sys_type) :: csys
double precision :: grad_x(3*natoms),grad_int(csys%ncoord)
!local
integer :: nintcoord,rank,lwork,info
double precision :: work1(1)
double precision, allocatable, target :: Bmatrix_ric(:,:)
double precision, allocatable, target :: Bmatrix_deloc(:,:)
double precision, contiguous, pointer :: Bmatrix(:,:)
double precision, allocatable :: Gmat(:),GB(:,:),eigval(:)
double precision, allocatable :: work(:)
lwork=0
nintcoord=size(csys%rim,2)
allocate(Bmatrix_ric(nintcoord,3*natoms))
if(trim(csys%name) /= 'ric') then
allocate(Bmatrix_deloc(csys%ncoord,3*natoms))
call build_wilson_bmat(natoms,csys%cart_coord,csys%rim,&
Bmatrix_ric)
! if(csys%nfrozen /= 0) call freezing_bmat_cart(csys,bmatrix_ric)
call delocalize(nintcoord,csys%ncoord,3*natoms,csys%Umatrix,&
Bmatrix_ric,Bmatrix_deloc)
Bmatrix => Bmatrix_deloc
else
Bmatrix => Bmatrix_ric
call build_wilson_bmat(natoms,csys%cart_coord,csys%rim,Bmatrix)
! if(csys%nfrozen /= 0) call freezing_bmat_cart(csys,bmatrix_ric)
endif
allocate(Gmat(max(3*natoms,csys%ncoord)**2))
allocate(eigval(max(3*natoms,csys%ncoord)))
! ! building projection to the internal coordinate space
allocate(GB(3*natoms,csys%ncoord))
! call dsyrk('u','t',3*natoms,csys%ncoord,1.0d0,Bmatrix,&
! csys%ncoord,0.0d0,Gmat,3*natoms)
! call filllo(Gmat,3*natoms)
!
! GB=transpose(Bmatrix)
! call dgelss(3*natoms,3*natoms,csys%ncoord,Gmat,3*natoms,GB,&
! 3*natoms,eigval,1.0d-7,rank,work1,-1,info)
! lwork=int(work1(1))
! allocate(work(lwork))
! call dgelss(3*natoms,3*natoms,csys%ncoord,Gmat,3*natoms,GB,&
! 3*natoms,eigval,1.0d-7,rank,work,lwork,info)
! call dgemm('n','n',csys%ncoord,csys%ncoord,3*natoms,1.0d0,&
! Bmatrix,csys%ncoord,GB,3*natoms,0.0d0,Gmat,csys%ncoord)
! call wrt_pmat(csys%ncoord,Gmat)
call build_projection(Bmatrix_ric,gmat,csys)
call wrt_pmat(csys%ncoord,Gmat)
! transforming gradient
call dgemv('n',csys%ncoord,3*natoms,1.0d0,Bmatrix,csys%ncoord,&
grad_x,1,0.0d0,grad_int,1)
call dsyrk('u','n',csys%ncoord,3*natoms,1.0d0,Bmatrix,&
csys%ncoord,0.0d0,Gmat,csys%ncoord)
call filllo(Gmat,csys%ncoord)
call dgelss(csys%ncoord,csys%ncoord,1,Gmat,csys%ncoord,&
grad_int,csys%ncoord,eigval,1.0d-7,rank,work1,-1,info)
if(lwork<int(work1(1))) then
if(allocated(work)) deallocate(work)
lwork=int(work1(1))
allocate(work(lwork))
endif
call dgelss(csys%ncoord,csys%ncoord,1,Gmat,csys%ncoord,&
grad_int,csys%ncoord,eigval,1.0d-7,rank,work,lwork,info)
deallocate(work)
deallocate(Gmat)
deallocate(GB)
deallocate(Bmatrix_ric)
deallocate(eigval)
if(allocated(Bmatrix_deloc)) deallocate(Bmatrix_deloc)
end subroutine
!************************************************************************
subroutine freezing_bmat_cart(csys,bmatrix)
!************************************************************************
! Calculates the B_proj=(1-(B^+)_constr*B_constr)*B matrix. It is
! required to freeze coordinates in cartesian->internal transformation.
! The B matrix is the Wilson B matrix in redundant IC, B_constr is the B
! matrix of the frozen coordinates.
!************************************************************************
implicit none
type(coord_sys_type) :: csys
double precision :: bmatrix(csys%ncoord_ric,3*csys%natoms)
! local
integer :: i,ii,n,rank,lwork
double precision :: work1(1)
double precision, parameter :: rcond=1.0d-7
double precision, allocatable :: bmat_frozen(:,:),gmat(:,:)
double precision, allocatable :: work(:),s(:)
n=max(csys%ncoord_ric,3*csys%natoms)
allocate(bmat_frozen(csys%ncoord_ric,3*csys%natoms))
allocate(gmat(n,n))
allocate(s(n))
bmat_frozen=0.0d0
gmat=0.0d0
! Extract the B matrix of the frozen coordinates
do ii=1,csys%nfrozen
i=csys%frozen(ii)
bmat_frozen(i,:)=bmatrix(i,:)
gmat(i,:)=bmatrix(i,:)
enddo
! Calculate (B^+)_constr*B_constr
call dgelss(csys%ncoord_ric,3*csys%natoms,3*csys%natoms,&
bmat_frozen,csys%ncoord_ric,gmat,n,s,rcond,rank,work1,-1,i)
lwork = int(work1(1))
allocate(work(lwork))
call dgelss(csys%ncoord_ric,3*csys%natoms,3*csys%natoms,&
bmat_frozen,csys%ncoord_ric,gmat,n,s,rcond,rank,work,lwork,i)
! Calculate the projector 1-(B^+)_constr*B_constr
call dscal(n*n,-1.0d0,gmat,1)
do i=1,3*csys%natoms
gmat(i,i)=gmat(1,1)+1.0d0
enddo
! Get the B_proj matrix
call dgemm('n','n',csys%ncoord_ric,3*csys%natoms,3*csys%natoms,&
1.0d0,bmatrix,csys%ncoord_ric,gmat,n,0.0d0,bmat_frozen,&
csys%ncoord_ric)
call dcopy(3*csys%natoms*csys%ncoord_ric,bmat_frozen,1,bmatrix,1)
deallocate(bmat_frozen)
deallocate(gmat)
deallocate(s)
deallocate(work)
end subroutine
!************************************************************************
subroutine freezing_bmat_int(csys,bmatrix)
!************************************************************************
! B_proj=(B_constr*(B^+)_constr-1)*B=((B^T)^+_constr*B^T_constr-1)^T*B
!************************************************************************
implicit none
type(coord_sys_type) :: csys
double precision :: bmatrix(csys%ncoord_ric,3*csys%natoms)
! local
integer :: i,ii,n,rank,lwork
double precision :: work1(1)
double precision, parameter :: rcond=1.0d-7
double precision, allocatable :: bmat_frozen(:,:),gmat(:,:)
double precision, allocatable :: work(:),s(:)
n=max(csys%ncoord_ric,3*csys%natoms)
allocate(bmat_frozen(3*csys%natoms,csys%ncoord_ric))
allocate(gmat(n,n))
allocate(s(n))
bmat_frozen=0.0d0
gmat=0.0d0
! Extract B^T of the frozen coordinates
do ii=1,csys%nfrozen
i=csys%frozen(ii)
bmat_frozen(:,i)=bmatrix(i,:)
gmat(:,i)=bmat_frozen(:,i)
enddo
!(B^T)^+_constr*B^T_constr
call dgelss(3*csys%natoms,csys%ncoord_ric,csys%ncoord_ric,&
bmat_frozen,3*csys%natoms,gmat,n,s,rcond,rank,work1,-1,i)
lwork = int(work1(1))
allocate(work(lwork))
call dgelss(3*csys%natoms,csys%ncoord_ric,csys%ncoord_ric,&
bmat_frozen,3*csys%natoms,gmat,n,s,rcond,rank,work,lwork,i)
!(B^T)^+_constr*B^T_constr-1
do i=1,csys%ncoord_ric
gmat(i,i)=gmat(1,1)-1.0d0
enddo
!((B^T)^+_constr*B^T_constr-1)^T*B
call dgemm('t','n',csys%ncoord_ric,3*csys%natoms,csys%ncoord_ric,&
1.0d0,gmat,n,bmatrix,csys%ncoord_ric,0.0d0,bmat_frozen,&
csys%ncoord_ric)
call dcopy(3*csys%natoms*csys%ncoord_ric,bmat_frozen,1,bmatrix,1)
deallocate(gmat)
deallocate(bmat_frozen)
deallocate(s)
deallocate(work)
end subroutine
!************************************************************************
subroutine fix_angles(q,red_int_matrix,nintcoord)
!************************************************************************
! it handles the periodicity of angles and dihedrals
!************************************************************************
implicit none
integer nintcoord,red_int_matrix(5,nintcoord)
double precision q(nintcoord)
integer i
do i=1,nintcoord
if((red_int_matrix(1,i) .eq. 2 .or. red_int_matrix(1,i) .eq. 3&
.or. red_int_matrix(1,i) .eq. 8).and. dabs(q(i)) .gt. PI) then
if(q(i) .gt. 0.d0) then
q(i) = q(i) - 2.0d0*PI
else
q(i) = q(i) + 2.0d0*PI
endif
endif
enddo
end subroutine
!************************************************************************
logical function check_conv(xk,x,eps)
!************************************************************************
! it returns .True. if xk is "close" to x;
! the rmsd of xk from x is less than eps
!************************************************************************
implicit none
double precision, dimension(:), intent(in) :: xk,x
double precision, intent(in) :: eps
!local
double precision :: s
integer :: i,ndim
check_conv = .False.
ndim=size(xk)
if(ndim .ne. size(x)) then
write(*,*) 'Error in check_conv!!!'
return
endif
s = 0.d0
do i=1,ndim
s = s + dabs( xk(i) - x(i) )**2
enddo
s = dsqrt(s/ndim)
if(s .le. eps) check_conv = .True.
return
end function check_conv
!************************************************************************
subroutine project_hessian(natoms,nintcoord,hessian,hessian_proj,&
csys)
!************************************************************************
! Projects Hessian matrix with P=BB^+ or with UP=UBB^+ in case of
! delocalized coordinates
!************************************************************************
implicit none
integer, intent(in) :: natoms,nintcoord
type(coord_sys_type), intent(in) :: csys
double precision, intent(in) :: hessian(nintcoord,nintcoord)
double precision :: hessian_proj(csys%ncoord,csys%ncoord)
! local
double precision, allocatable :: bmatrix_ric(:,:)
double precision, contiguous, pointer :: pmat(:,:)
double precision, allocatable, target :: pmat_ric(:,:)
double precision, allocatable, target :: pmat_deloc(:,:)
double precision, allocatable :: work(:,:)
allocate(Pmat_ric(nintcoord,nintcoord))
allocate(Bmatrix_ric(nintcoord,3*natoms))
call build_Wilson_Bmat(natoms,csys%cart_coord,csys%rim,&
Bmatrix_ric)
call build_projection_hessian(Bmatrix_ric,Pmat_ric,csys)
if(trim(csys%name) == 'ric') then
pmat => pmat_ric
elseif(trim(csys%name) == 'deloc-ic') then
allocate(pmat_deloc(csys%ncoord,nintcoord))
call delocalize(nintcoord,csys%ncoord,nintcoord,csys%Umatrix,&
pmat_ric,pmat_deloc)
pmat => pmat_deloc
endif
allocate(work(nintcoord,csys%ncoord))
call dgemm('n','t',nintcoord,csys%ncoord,nintcoord,1.0d0,&
hessian,nintcoord,Pmat,csys%ncoord,0.0d0,work,nintcoord)
call dgemm('n','n',csys%ncoord,csys%ncoord,nintcoord,1.0d0,&
Pmat,csys%ncoord,work,nintcoord,0.0d0,hessian_proj,&
csys%ncoord)
deallocate(work)
deallocate(Pmat_ric)
if(allocated(pmat_deloc)) deallocate(pmat_deloc)
end subroutine
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! STRING HANDLING
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!************************************************************************
integer function integer_(str)
!************************************************************************
! it returns an integer from string (str)
!************************************************************************
implicit none
character(len=*), intent(in) :: str
!local
character(len=len(str)) :: stmp
integer :: code ! ASCII
integer :: i
stmp = trim(adjustl(str))
do i=1,len_trim(stmp)
code = ichar(stmp(i:i))
if(code .lt. 48 .or. code .gt. 57) then
write(*,*) 'Non numeric character in ', str,code
write(*,*) 'invalid conversion to integer'
call mrccend(1)
endif
enddo
read(str,*) integer_
end function integer_
!************************************************************************
!************************************************************************
function int2char(i)
!************************************************************************
! it converts an integer to a string
!************************************************************************
implicit none
integer,intent(in) :: i
character(len=512) :: int2char
!local
character(len=512) :: stmp
character(len=512) :: fmts
fmts = '(I0)'
write(stmp,fmts) i
int2char=trim(adjustl(stmp))
end function int2char
!************************************************************************
!************************************************************************
double precision function double_(str)
!************************************************************************
! it returns a double from string (str)
!************************************************************************
implicit none
character(len=*), intent(in) :: str
read(str,*) double_
end function double_
!************************************************************************
!************************************************************************
subroutine str_srch(str,substr,pos)
!************************************************************************
! it search for the position (pos) of the substring (substr) in the
! string (str)
! if the string contains the substring it returns the position of its
! first character, otherwise returns 0
!************************************************************************
implicit none
character(len=*),intent(in) :: str
character(len=*),intent(in) :: substr
integer,intent(out) :: pos
!local
integer :: lstr,lsub,i
logical :: bool
lstr = len(str)
lsub = len(substr)
if(lstr.lt.lsub) then
write(*,*) 'The substring is longer than the string!!!'
return
endif
bool=.True.
pos=0
i=1
do while (i .le. lstr-lsub+1 .and. bool)
if(str(i:i+lsub-1) .eq. substr(1:lsub)) then
pos=i
bool = .False.
endif
i=i+1
enddo
! strb=adjustl(trim(strb))
! stra=adjustl(trim(stra))
! write(*,*) 'Characters before ',ch,' ',strb
! write(*,*) 'Characters after ',ch,' ',stra
return
end subroutine str_srch
!************************************************************************
!************************************************************************
subroutine str_cut(str,ch,strb,stra)
!************************************************************************
! it cuts the string at first occurence of character ch
! then returns strb (part before character ch) and
! stra (part after character ch)
!************************************************************************
implicit none
character(len=*),intent(in) :: str
character(len=1),intent(in) :: ch
character(len=*),intent(out) :: strb,stra
!local
integer :: i,length
character(len=len(str)) :: stmp
length = len(stmp)
strb=''
stra=''
i=1
do while (i.le.length .and. str(i:i).ne.ch)
strb(i:i)=str(i:i)
i=i+1
enddo
stra(:)=str(i+1:)
! strb=adjustl(trim(strb))
! stra=adjustl(trim(stra))
! write(*,*) 'Characters before ',ch,' ',strb
! write(*,*) 'Characters after ',ch,' ',stra
return
end subroutine str_cut
!************************************************************************
!************************************************************************
subroutine str_del(str,pos,len)
!************************************************************************
! it deletes 'len' characters from position 'pos' from the string (str)
!************************************************************************
implicit none
character(len=*), intent(inout) :: str
integer, intent(in) :: pos,len
str(pos:) = str(pos+len:)
end subroutine str_del
!************************************************************************
!************************************************************************
subroutine str_dtest(str,double,bool,sm)
!************************************************************************
! it converts the string (str) to double (double)
! using the function double_(str)
! and also checks for special marks (bool) and returns them in sm
!************************************************************************
implicit none
character(len=*), intent(in) :: str
double precision, intent(out) :: double
logical, intent(inout) :: bool
character(len=2), intent(inout) :: sm
character(len=len(trim(adjustl(str)))) :: stmp
double = 0.d0
sm = ' ' ! special mark i.e., ++ or --; default return value is ' '
stmp = trim(adjustl(str))
if(index(stmp,'++').gt.0) then
bool = .True.
sm = '++'
call str_del(stmp,index(stmp,'++'),2)
double = double_(stmp)
else
if(index(stmp,'--').gt.0) then
bool = .False.
sm = '--'
call str_del(stmp,index(stmp,'--'),2)
double = double_(stmp)
else
double = double_(stmp)
endif
endif
end subroutine str_dtest
!************************************************************************
!************************************************************************
subroutine str_itest(str,int_,bool,sm)
!************************************************************************
! it converts the string (str) to integer (int_)
! using the function integer_(str)
! and also checks for special marks (bool) and returns them in sm
!************************************************************************
implicit none
character(len=*), intent(in) :: str
integer, intent(out) :: int_
logical, intent(inout) :: bool
character(len=2), intent(inout) :: sm
character(len=len(trim(adjustl(str)))) :: stmp
int_ = 0
sm = ' ' ! special mark i.e., ++ or --; default return value is ' '
stmp = trim(adjustl(str))
if(index(stmp,'++').gt.0) then
bool = .True.
sm = '++'
call str_del(stmp,index(stmp,'++'),2)
int_ = integer_(stmp)
else
if(index(stmp,'--').gt.0) then
bool = .False.
sm = '--'
call str_del(stmp,index(stmp,'--'),2)
int_ = integer_(stmp)
else
int_ = integer_(stmp)
endif
endif
end subroutine str_itest
!************************************************************************
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! PERIODIC TABLE RELATED
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!************************************************************************
integer function get_atomic_number(atsymbol)
!************************************************************************
! Get atomic number from atomic symbol or from atomic number :)
! /if atomic number is given as a string(atsymbol) instead of an integer/
! this seemed practical during file processing
!************************************************************************
character(len=*), intent(in) :: atsymbol
!local
integer, parameter :: natmax = 118
character(len=3) :: chl3
character(len=2) :: atsym(0:natmax),chl2a,chl2b
integer :: length,atnum,code
logical :: bool
data atsym /'Bf',&
'H ','He','Li','Be','B ','C ','N ','O ','F ','Ne',&
'Na','Mg','Al','Si','P ','S ','Cl','Ar','K ','Ca',&
'Sc','Ti','V ','Cr','Mn','Fe','Co','Ni','Cu','Zn',&
'Ga','Ge','As','Se','Br','Kr','Rb','Sr','Y ','Zr',&
'Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd','In','Sn',&
'Sb','Te','I ','Xe','Cs','Ba','La','Ce','Pr','Nd',&
'Pm','Sm','Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb',&
'Lu','Hf','Ta','W ','Re','Os','Ir','Pt','Au','Hg',&
'Tl','Pb','Bi','Po','At','Rn','Fr','Ra','Ac','Th',&
'Pa','U ','Np','Pu','Am','Cm','Bk','Cf','Es','Fm',&
'Md','No','Lr','Rf','Db','Sg','Bh','Hs','Mt','Ds',&
'Rg','Cn','Nh','Fl','Mc','Lv','Ts','Og'/
!
length = len_trim(atsymbol)
if(length .gt. 3 .or. length .lt. 1) then
write(*,*) 'Unknown atomic symbol0 '//trim(atsymbol)//'!'
call mrccend(1)
endif
chl3 = trim(adjustl(atsymbol)) ! remove blanks
code = ichar(chl3(1:1))
if(code .gt. 47 .and. code .lt. 58) then ! atomic number in atsymbol
atnum = integer_(chl3)
if(atnum .gt. natmax .or. atnum .lt. 0) then
write(*,*) 'Unknown atomic symbol1 '//trim(atsymbol)//'!'
call mrccend(1)
else
get_atomic_number = atnum
endif
else ! atomic symbol
if(length .ne. 3) then
chl2a = trim(adjustl(atsymbol)) ! remove blanks
call lowercase(chl2a,chl2a,2)
bool = .False.
do i=1,natmax
call lowercase(atsym(i),chl2b,2)
if(chl2a .eq. chl2b) then
get_atomic_number = i
bool = .True.
endif
enddo
if(.not. bool) then
write(*,*) 'Unknown atomic symbol2 '//trim(atsymbol)//'!'
call mrccend(1)
endif
else
write(*,*) 'Unknown atomic symbol3 '//trim(atsymbol)//'!'
call mrccend(1)
endif
endif
return
end function get_atomic_number
!************************************************************************
!************************************************************************
double precision function get_cov_radius(atnum)
!************************************************************************
! it returns the covalent radius of an atom
! Values are extracted from Chemistry A European Journal, 15, 186 (2009)
!************************************************************************
implicit none
integer, intent(in) :: atnum
!local
integer, parameter :: maxnum = 118
double precision, dimension(maxnum) :: radii
integer :: i
data (radii(i), i = 1, maxnum)&
/&
32, 46, & ! H -> He
133, 102, 85, 75, 71, 63, 64, 67, & ! Li -> Ne
155, 139, 126, 116, 111, 103, 99, 96, & ! Na -> Ar
196, 171, & ! K -> Ca
148, 136, 134, 122, 119, 116, 111, 110, 112, 118, & ! Sc -> Zn Transition Metals
124, 121, 121, 116, 114, 117, & ! Ga -> Kr
210, 185, & ! Rb -> Sr
163, 154, 147, 138, 128, 125, 125, 120, 128, 136, & ! Y -> Cd Transition Metals
142, 140, 140, 136, 133, 131, & ! In -> Xe
232, 196, & ! Cs -> Ba
180,163,176,174,173,172,168,169,168,167,166,165,164,170,162, & ! La -> Lu Rare Earth Elements
152, 146, 137, 131, 129, 122, 123, 124, 133, & ! Hf -> Hg Transition Metals
144, 144, 151, 145, 147, 142, & ! Tl -> Rn!
223, 201, & ! Fr -> Ra
186,175,169,170,171,172,166,166,168,168,165,167,173,176,161, & ! Ac -> Lr Rare Earth Elements
157, 149, 143, 141, 134, 129, 128, 121, 122, & ! Rf -> Cn Transition Metals
136 ,143 ,162 ,175 ,165 ,157 & ! Nh -> Og [Pyykko & Atsumi;2009;10.1002/chem.200800987]
/
!
if (atnum .lt. 1 .or. atnum .gt. maxnum) then
write(*,*) 'Not valid atomic number: ', atnum
write(*,*) 'Allowed atomic numbers are between 1 and ', maxnum
else
get_cov_radius = radii(atnum)/100.d0 ! pm to Angstrom
get_cov_radius = get_cov_radius*ang2bohr ! Angstrom to Bohr
endif
end function get_cov_radius
!************************************************************************
!************************************************************************
double precision function get_atomic_mass(atnum)
!************************************************************************
! it returns the atomic mass (values were copied from integ.f; 2015-09-15)
!************************************************************************
implicit none
integer, intent(in) :: atnum
!local
integer, parameter :: maxnum = 118+1
double precision, dimension(0:maxnum-1) :: atmas
integer :: i
data (atmas(i), i=0, maxnum-1) &
/ &
0.d0,&
1.007825035d+00, 4.00260324d+00, 7.0160030d+00 , &
9.0121822d+00, 11.0093054d+00, 12.0000000d+00 , &
14.003074002d+00, 15.99491463d+00, 18.99840322d+00 , &
19.9924356d+00, 22.9897677d+00, 23.9850423d+00 , &
26.9815386d+00, 27.9769271d+00, 30.9737620d+00 , &
31.97207070d+00,34.968852721d+00, 39.9623837d+00 , &
38.9637074d+00, 39.9625906d+00, 44.9559100d+00 , &
47.9479473d+00, 50.9439617d+00, 51.9405098d+00 , &
54.9380471d+00, 55.9349393d+00, 58.9331976d+00 , &
57.9353462d+00, 62.9295989d+00, 63.9291448d+00 , &
68.925580d+00, 73.9211774d+00, 74.9215942d+00 , &
79.9165196d+00, 78.9183361d+00, 83.911507d+00 , &
84.911794d+00, 87.9056188d+00, 88.905849d+00 , &
89.9047026d+00, 92.9063772d+00, 97.9054073d+00 , &
97.907215d+00, 101.9043485d+00, 102.905500d+00 , &
105.903478d+00, 106.905092d+00, 113.903357d+00 , &
114.903882d+00, 119.9021991d+00, 120.9038212d+00, &
129.906229d+00, 126.904473d+00, 131.904144d+00 , &
132.905429d+00, 137.905232d+00, 138.906347d+00 , &
139.905433d+00, 140.907647d+00, 141.907719d+00 , &
144.912743d+00, 151.919728d+00, 152.921225d+00 , &
157.924019d+00, 158.925342d+00, 163.929171d+00 , &
164.930319d+00, 165.930290d+00, 168.934212d+00 , &
173.938859d+00, 174.940770d+00, 179.9465457d+00 , &
180.947462d+00, 183.950928d+00, 186.955744d+00 , &
191.961467d+00, 192.962917d+00, 194.964766d+00 , &
196.966543d+00, 201.970617d+00, 204.974401d+00 , &
207.976627d+00, 208.980374d+00, 208.982404d+00 , &
209.987126d+00, 222.017571d+00, 223.019733d+00 , &
226.025403d+00, 227.027750d+00, 232.038051d+00 , &
231.035880d+00, 238.050785d+00, 237.048168d+00 , &
244.064199d+00, 243.061373d+00, 247.070347d+00 , &
247.070300d+00, 251.079580d+00, 252.082944d+00 , &
257.095099d+00, 258.098570d+00, 259.100931d+00 , &
260.105320d+00, 261.108690d+00, 262.113760d+00 , &
263.118220d+00, 262.122930d+00, 269.134100d+00 , &
267.138000d+00, 268.143500d+00, 272.000000d+00 , &
277.000000d+00, 283.000000d+00, 289.000000d+00 , &
294.000000d+00, 300.000000d+00, 306.000000d+00 , &
310.000000d+00 /
if (atnum .lt. 0 .or. atnum .gt. maxnum-1) then
write(*,*) 'Not valid atomic number: ', atnum
write(*,*) 'Allowed atomic numbers are between 0 and ', maxnum-1
else
get_atomic_mass = atmas(atnum)
endif
end function get_atomic_mass
!************************************************************************
!************************************************************************
integer function nint_fragment(natoms,natomswdummy,atnum,coords,&
bond_matrix)
!************************************************************************
! Calculates number of interfragment bonds
!************************************************************************
implicit none
integer natoms,natomswdummy,atnum(natoms)
integer, allocatable :: fragment_code(:)
integer bond_matrix(natomswdummy,natomswdummy),nfrag,iatoms,jatoms
double precision coords(3,natoms)
allocate(fragment_code(natomswdummy))
call graph_coloring(natomswdummy,bond_matrix,fragment_code)
nfrag=maxval(fragment_code)
nint_fragment=nfrag*(nfrag-1)/2
call update_bond_matrix(natoms,natomswdummy,fragment_code,&
nint_fragment,coords,bond_matrix)
do iatoms=1,natoms
do jatoms=1,iatoms-1
if(bond_matrix(jatoms,iatoms)==afbond_code) &
nint_fragment=nint_fragment+1
enddo
enddo
deallocate(fragment_code)
end function
!************************************************************************
subroutine update_bond_matrix(natoms,natomswdummy,fragment_code,&
nint_fragment,coords,bond_matrix)
!************************************************************************
!* Calculates interfragment bonds
!************************************************************************
implicit none
integer natoms,natomswdummy
integer fragment_code(natomswdummy),nint_fragment
integer nfrag,bond_matrix(natomswdummy,natomswdummy)
integer i,j
double precision coords(3,natomswdummy),fdist
type(fragment_type), allocatable :: flist(:)
if(nint_fragment==0) return
nfrag=maxval(fragment_code)
allocate(flist(nfrag))
call build_fragments(flist,nfrag,fragment_code,natoms)
do i=1,nfrag
do j=i+1,nfrag
call fragment_bond(flist(i),flist(j),coords,bond_matrix,&
natoms,natomswdummy,fdist)
call aux_fragment_bond(flist(i),flist(j),coords,bond_matrix,&
natoms,natomswdummy,fdist)
enddo
enddo
do i=1,nfrag
deallocate(flist(i)%atom_list)
enddo
deallocate(flist)
end subroutine
!************************************************************************
subroutine build_fragments(flist,nfrag,fragment_code,natoms)
!************************************************************************
! Build fragments form fragment_code array
!************************************************************************
implicit none
integer natoms,nfrag,fragment_code(natoms),i,j,n
type(fragment_type) flist(nfrag)
do i=1,nfrag
n=0
do j=1,natoms
if(fragment_code(j)==i) n=n+1
enddo
flist(i)%natoms=n
allocate(flist(i)%atom_list(n))
n=0
do j=1,natoms
if(fragment_code(j)==i) then
n=n+1
flist(i)%atom_list(n)=j
endif
enddo
write(*,*) 'fragment',i
write(*,'(100I4)') flist(i)%atom_list
enddo
end subroutine
!************************************************************************
subroutine fragment_bond(f1,f2,coords,bond_matrix,natoms,&
natomswdummy,min_dist)
!************************************************************************
!* Calculates the interfragment bond between two fragments
!************************************************************************
implicit none
integer natoms,natomswdummy
integer bond_matrix(natomswdummy,natomswdummy)
integer atom1,atom2,i,j,iatoms,jatoms
double precision coords(3,natomswdummy),dist,min_dist
type(fragment_type) f1,f2
min_dist=1.0d32
do i=1,f1%natoms
iatoms=f1%atom_list(i)
if(iatoms > natoms) continue
do j=1,f2%natoms
jatoms=f2%atom_list(j)
if(jatoms > natoms) continue
dist=(coords(1,iatoms)-coords(1,jatoms))**2+&
(coords(2,iatoms)-coords(2,jatoms))**2+&
(coords(3,iatoms)-coords(3,jatoms))**2
dist=dsqrt(dist)
if(dist<min_dist) then
min_dist=dist
atom1=iatoms
atom2=jatoms
endif
enddo
enddo
bond_matrix(atom1,atom2)=fbond_code
bond_matrix(atom2,atom1)=fbond_code
end subroutine
!************************************************************************
subroutine aux_fragment_bond(f1,f2,coords,bond_matrix,natoms,&
natomswdummy,min_dist)
!************************************************************************
!* Calculates the auxiliary interfragment bonds between two fragments
!************************************************************************
implicit none
integer natoms,natomswdummy
integer bond_matrix(natomswdummy,natomswdummy)
integer i,j,iatoms,jatoms
double precision coords(3,natomswdummy),dist,min_dist,threshold
type(fragment_type) f1,f2
threshold=2.0d0*ang2bohr
do i=1,f1%natoms
iatoms=f1%atom_list(i)
if(iatoms > natoms) continue
do j=1,f2%natoms
jatoms=f2%atom_list(j)
if(jatoms > natoms) continue
dist=(coords(1,iatoms)-coords(1,jatoms))**2+&
(coords(2,iatoms)-coords(2,jatoms))**2+&
(coords(3,iatoms)-coords(3,jatoms))**2
dist=dsqrt(dist)
if((dist<1.3d0*min_dist.or.dist<threshold).and.&
bond_matrix(iatoms,jatoms)==0) then
bond_matrix(iatoms,jatoms)=afbond_code
bond_matrix(jatoms,iatoms)=afbond_code
endif
enddo
enddo
end subroutine
!************************************************************************
subroutine graph_coloring(natoms,bond_matrix,fragment_code)
!************************************************************************
! Colors each fragment in a graph
! natoms: number of nodes
! bond_matrix: adjacency matrix
! fragment_code: coloring
!************************************************************************
implicit none
integer natoms,bond_matrix(natoms,natoms),fragment_code(natoms)
integer nfragment,node,stack_size,i
integer, allocatable :: stack(:)
allocate(stack(natoms))
fragment_code=0
nfragment=1
stack(1)=1
stack_size=1
do while(stack_size/=0)
! Pop a node from stack and mark it as part of the current fragment
node=stack(stack_size)
fragment_code(node)=nfragment
stack_size=stack_size-1
! Check the neighbours of the current node
! if they have not been visited yet add them to the stack
do i=1,natoms
if(bond_matrix(i,node)==1.and.fragment_code(i)==0) then
stack_size=stack_size+1
stack(stack_size)=i
endif
enddo
! If the stack is empty check for unvisited nodes
if(stack_size==0) then
do i=1,natoms
if(fragment_code(i)==0) then
stack_size=1
stack(1)=i
nfragment=nfragment+1
exit
endif
enddo
endif
enddo
deallocate(stack)
end subroutine
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! I/O
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!************************************************************************
double precision function get_last_energy()
!************************************************************************
! it extracts the last energy from the file iface
!************************************************************************
implicit none
!local
character(len=512) :: line,stmp
character(len=8) :: cscr8
character(len=15) :: cscr15
integer :: check,i
check = 0
open(ifcfile,file='iface',status='old')
do while (check.eq.0)
read(ifcfile,200,iostat=check) line ! lines before keyword geom
stmp=adjustl(trim(line))
enddo
read(stmp,7596) cscr8,cscr15,i,i,i,get_last_energy
close(ifcfile)
200 format(a512)
7596 format(a8,1x,a15,1x,3(i2,1x),1pe23.15)
return
end function get_last_energy
!************************************************************************
!************************************************************************
subroutine print_vectorR(vec,cols)
!************************************************************************
! nice :) printout for real values
!************************************************************************
implicit none
double precision,dimension(:),intent(in) :: vec
integer,intent(in) :: cols ! # columns on the screen (<=99)
!local
integer :: i,j,k,m,n,n_columns
character(len=10) :: formats
character(len=2) :: snum
snum = int2char(cols)
n_columns = size(vec)
m = mod(n_columns,cols)
n = n_columns/cols
formats = '(A6,'//snum//'I12)'
if(n .gt. 0) then
do j=1,n
write(*,formats,advance='no') 'col-',(cols*(j-1)+i, i=1,cols)
write(*,*) ''
write(*,998,advance='no') '| '
do k=1,cols
write(*,999,advance='no') vec(cols*(j-1)+k)
enddo
write(*,*)
write(*,*)
enddo
! remainder
write(*,formats,advance='no') 'col-',(cols*n+i, i=1,m)
write(*,*) ''
write(*,998,advance='no') '| '
do k=1,m
write(*,999,advance='no') vec(cols*n+k)
enddo
write(*,*)
else
write(*,formats,advance='no') 'col-',(cols*n+i, i=1,m)
write(*,*) ''
write(*,998,advance='no') '| '
do k=1,m
write(*,999,advance='no') vec(k)
enddo
write(*,*)
endif
write(*,*) ''
998 format(A6)
999 format(f14.8)
end subroutine print_vectorR
!************************************************************************
!************************************************************************
subroutine print_matrixR(A,cols)
!************************************************************************
! nice :) printout for real values
!************************************************************************
implicit none
double precision,dimension(:,:),intent(in) :: A
integer,intent(in) :: cols ! # columns on the screen (<=99)
!local
integer :: i,j,k,m,n,n_rows,n_columns
character(len=10) :: formats
character(len=2) :: snum
snum = int2char(cols)
n_rows = size(A,1)
n_columns = size(A,2)
m = mod(n_columns,cols)
n = n_columns/cols
formats = '(A6,'//snum//'I12)'
if(n .gt. 0) then
do j=1,n
write(*,formats,advance='no') 'col-',(cols*(j-1)+i, i=1,cols)
write(*,*) ''
write(*,997) 'row|'
do i=1,n_rows
write(*,998,advance='no') i,'| '
do k=1,cols
write(*,999,advance='no') A(i,cols*(j-1)+k)
enddo
write(*,*)
enddo
write(*,*)
enddo
! remainder
write(*,formats,advance='no') 'col-',(cols*n+i, i=1,m)
write(*,*) ''
write(*,997) 'row|'
do i=1,n_rows
write(*,998,advance='no') i,'| '
do k=1,m
write(*,999,advance='no') A(i,cols*n+k)
enddo
write(*,*)
enddo
else
write(*,formats,advance='no') 'col-',(cols*n+i, i=1,m)
write(*,*) ''
write(*,997) 'row|'
do i=1,n_rows
write(*,998,advance='no') i,'| '
do k=1,m
write(*,999,advance='no') A(i,k)
enddo
write(*,*)
enddo
endif
write(*,*) ''
997 format(A6)
998 format(I4,A2)
999 format(f14.8)
!99 format(es13.5e2)
end subroutine print_matrixR
!************************************************************************
!************************************************************************
subroutine print_matrixI(A,cols)
!************************************************************************
! nice :) printout for integer values
!************************************************************************
implicit none
integer,dimension(:,:),intent(in) :: A
integer,intent(in) :: cols ! # columns on the screen (<=99)
!local
integer :: i,j,k,m,n,n_rows,n_columns
character(len=9) :: formats
character(len=2) :: snum
snum = int2char(cols)
n_rows = size(A,1)
n_columns = size(A,2)
m = mod(n_columns,cols)
n = n_columns/cols
formats = '(A6,'//snum//'I8)'
if(n .gt. 0) then
do j=1,n
write(*,formats,advance='no') 'col-',(cols*(j-1)+i, i=1,cols)
write(*,*) ''
write(*,997) 'row|'
do i=1,n_rows
write(*,998,advance='no') i,'| '
do k=1,cols
write(*,999,advance='no') A(i,cols*(j-1)+k)
enddo
write(*,*)
enddo
write(*,*)
enddo
! remainder
write(*,formats,advance='no') 'col-',(cols*n+i, i=1,m)
write(*,*) ''
write(*,997) 'row|'
do i=1,n_rows
write(*,998,advance='no') i,'| '
do k=1,m
write(*,999,advance='no') A(i,cols*n+k)
enddo
write(*,*)
enddo
else
write(*,formats,advance='no') 'col-',(cols*n+i, i=1,m)
write(*,*) ''
write(*,997) 'row|'
do i=1,n_rows
write(*,998,advance='no') i,'| '
do k=1,m
write(*,999,advance='no') A(i,k)
enddo
write(*,*)
enddo
endif
write(*,*) ''
997 format(A6)
998 format(I4,A2)
999 format(I8)
end subroutine print_matrixI
!************************************************************************
subroutine copy_coord_sys(src,dest)
!************************************************************************
! Copies coordinate system information from src to dest
!************************************************************************
implicit none
type(coord_sys_type) :: src,dest
integer :: nrow,ncol,nrow2,ncol2
if(src%ncoord /= dest%ncoord) then
if(allocated(dest%coord)) deallocate(dest%coord)
if(allocated(dest%Umatrix)) deallocate(dest%Umatrix)
if(allocated(dest%rim)) deallocate(dest%rim)
if(allocated(dest%cart_coord)) deallocate(dest%cart_coord)
if(allocated(dest%frozen)) deallocate(dest%frozen)
endif
dest%name=src%name
dest%nonred=src%nonred
dest%ncoord=src%ncoord
dest%ncoord_ric=src%ncoord_ric
dest%nfrozen=src%nfrozen
dest%natoms=src%natoms
dest%natoms_original=src%natoms_original
dest%natoms_extra=src%natoms_extra
if(allocated(src%coord)) then
nrow=size(src%coord)
if(allocated(dest%coord)) then
nrow2=size(dest%coord)
if(nrow/=nrow2) then
deallocate(dest%coord)
allocate(dest%coord(nrow))
endif
else
allocate(dest%coord(nrow))
endif
dest%coord=src%coord
endif
if(allocated(src%Umatrix)) then
nrow=size(src%Umatrix,1)
ncol=size(src%Umatrix,2)
if(allocated(dest%Umatrix)) then
nrow2=size(dest%Umatrix,1)
ncol2=size(dest%Umatrix,2)
if(nrow/=nrow2 .or. ncol/=ncol2) then
deallocate(dest%Umatrix)
allocate(dest%Umatrix(nrow,ncol))
endif
else
allocate(dest%Umatrix(nrow,ncol))
endif
dest%Umatrix=src%Umatrix
endif
if(allocated(src%rim)) then
nrow=size(src%rim,1)
ncol=size(src%rim,2)
if(allocated(dest%rim)) then
nrow2=size(dest%rim,1)
ncol2=size(dest%rim,2)
if(nrow/=nrow2 .or. ncol/=ncol2) then
deallocate(dest%rim)
allocate(dest%rim(nrow,ncol))
endif
else
allocate(dest%rim(nrow,ncol))
endif
dest%rim=src%rim
endif
if(allocated(src%cart_coord)) then
nrow=size(src%cart_coord,1)
ncol=size(src%cart_coord,2)
if(allocated(dest%cart_coord)) then
nrow2=size(dest%cart_coord,1)
ncol2=size(dest%cart_coord,2)
if(nrow/=nrow2 .or. ncol/=ncol2) then
deallocate(dest%cart_coord)
allocate(dest%cart_coord(nrow,ncol))
endif
else
allocate(dest%cart_coord(nrow,ncol))
endif
dest%cart_coord=src%cart_coord
endif
if(src%nfrozen /= 0) then
if(allocated(dest%frozen)) then
if(dest%nfrozen /= src%nfrozen) then
deallocate(dest%frozen)
allocate(dest%frozen(src%nfrozen))
endif
else
allocate(dest%frozen(src%nfrozen))
endif
if(allocated(dest%cvals)) then
if(dest%nfrozen /= src%nfrozen) then
deallocate(dest%cvals)
allocate(dest%cvals(src%nfrozen))
endif
else
allocate(dest%cvals(src%nfrozen))
endif
dest%frozen=src%frozen
dest%cvals=src%cvals
endif
end subroutine
!************************************************************************
subroutine dealloc_coord_sys(sys)
!************************************************************************
! Deallocate coordinate system memory
!************************************************************************
implicit none
type(coord_sys_type) sys
if(allocated(sys%coord)) deallocate(sys%coord)
if(allocated(sys%Umatrix)) deallocate(sys%Umatrix)
if(allocated(sys%rim)) deallocate(sys%rim)
if(allocated(sys%cart_coord)) deallocate(sys%cart_coord)
if(allocated(sys%frozen)) deallocate(sys%frozen)
if(allocated(sys%cvals)) deallocate(sys%cvals)
end subroutine
!************************************************************************
subroutine build_coordinate_system(natoms,cart_coord,csys,atnums)
!************************************************************************
! Builds the necessary coordinate system related quantities
!************************************************************************
implicit none
integer :: natoms,atnums(natoms)
double precision :: cart_coord(3,natoms)
type(coord_sys_type) :: csys
call dealloc_coord_sys(csys)
if(trim(csys%name) == 'cartesian') then
write(*,'(A)') 'Cartesian coordinates are not supported!!'
call mrccend(1)
elseif(trim(csys%name) == 'ric') then
call build_ric
elseif(trim(csys%name) == 'deloc-ic') then
call build_deloc_ic
endif
contains
!************************************************************************
subroutine copy_cart(natoms,csys,cart_coord)
implicit none
integer, intent(in) :: natoms
double precision, intent(in) :: cart_coord(3,natoms)
type(coord_sys_type), intent(inout) :: csys
allocate(csys%cart_coord(3,natoms))
call dcopy(3*natoms,cart_coord,1,csys%cart_coord,1)
end subroutine
!************************************************************************
subroutine build_ric
implicit none
integer :: natoms_new
double precision, allocatable :: cart_coord_new(:,:)
double precision, allocatable :: Gmat(:,:),Bmatrix_ric(:,:)
call build_red_int_matrix(natoms,atnums,cart_coord,csys%rim,&
natoms_new,cart_coord_new)
csys%natoms=natoms_new
csys%natoms_original=natoms
csys%natoms_extra=natoms_new-natoms
if(csys%natoms_extra == 0) then
call copy_cart(natoms,csys,cart_coord)
else
call copy_cart(natoms_new,csys,cart_coord_new)
endif
csys%ncoord=size(csys%rim,2)
csys%ncoord_ric=csys%ncoord
allocate(csys%coord(csys%ncoord))
call get_intcoords(csys%natoms,csys%cart_coord,csys%ncoord,csys%rim,&
csys%coord)
call freeze_coordinates(csys,csys%coord)
! We need the number of nonredundant coordinates (e.g. for rfo)
allocate(Bmatrix_ric(csys%ncoord,3*csys%natoms))
allocate(Gmat(csys%ncoord,csys%ncoord))
bmatrix_ric=0.0d0
! Build B matrix for RIC
call build_Wilson_Bmat(csys%natoms,csys%cart_coord,csys%rim,&
Bmatrix_ric)
! Calculate the active subspace of RIC
call active_subspace(csys%ncoord,csys%natoms,csys%nonred,&
Bmatrix_ric,Gmat)
allocate(csys%Umatrix(csys%ncoord_ric,csys%nonred))
if(allocated(cart_coord_new)) deallocate(cart_coord_new)
deallocate(Bmatrix_ric)
deallocate(Gmat)
end subroutine
!************************************************************************
subroutine build_deloc_ic
implicit none
integer :: natoms_new
integer :: nintcoord
double precision, allocatable :: intcoord(:)
double precision, allocatable :: cart_coord_new(:,:)
double precision, allocatable :: Gmat(:,:),Bmatrix_ric(:,:)
! build redundant internal coordinate matrix and get the
! Cartesian coordinates with the dummy atoms
call build_red_int_matrix(natoms,atnums,cart_coord,csys%rim,&
natoms_new,cart_coord_new)
csys%natoms=natoms_new
csys%natoms_original=natoms
csys%natoms_extra=natoms_new-natoms
if(csys%natoms_extra == 0) then
call copy_cart(natoms,csys,cart_coord)
else
call copy_cart(natoms_new,csys,cart_coord_new)
endif
! Building internal coordinate system
nintcoord=size(csys%rim,2)
csys%ncoord_ric=nintcoord
allocate(intcoord(nintcoord))
allocate(Bmatrix_ric(nintcoord,3*csys%natoms))
allocate(Gmat(nintcoord,nintcoord))
! generate redundant internal coordinates
call get_intcoords(csys%natoms,csys%cart_coord,nintcoord,&
csys%rim,intcoord)
call fix_angles(intcoord,csys%rim,nintcoord)
call freeze_coordinates(csys,intcoord)
! Build B matrix for RIC
call build_Wilson_Bmat(csys%natoms,csys%cart_coord,csys%rim,&
Bmatrix_ric)
! Calculate the active subspace of RIC
call active_subspace(nintcoord,csys%natoms,csys%ncoord,&
Bmatrix_ric,Gmat)
csys%nonred=csys%ncoord
allocate(csys%Umatrix(nintcoord,csys%ncoord))
allocate(csys%coord(csys%ncoord))
! Delocalize RIC
call get_deloc_matrix(nintcoord,csys%ncoord,Gmat,csys%Umatrix)
call delocalize(nintcoord,csys%ncoord,1,csys%Umatrix,intcoord,&
csys%coord)
if(allocated(cart_coord_new)) deallocate(cart_coord_new)
deallocate(intcoord)
deallocate(Bmatrix_ric)
deallocate(Gmat)
end subroutine
end subroutine build_coordinate_system
!************************************************************************
subroutine freeze_coordinates(csys,coord_ric)
!************************************************************************
! Freezing coordinates
!************************************************************************
implicit none
type(coord_sys_type) :: csys
double precision :: coord_ric(*)
! local
integer :: nf,ifr,idummy,iidummy,i
ifr=0
nf=0
! for each dummy atom we freeze the bond length, bond angle and
! a dihedral angle
if(csys%natoms_extra /= 0) nf=nf+3*csys%natoms_extra
! freezing coordinates requested by the user
! ....
csys%nfrozen=nf
if(nf == 0) return
allocate(csys%frozen(nf))
allocate(csys%cvals(nf))
! freeze dummy atoms
if(csys%natoms_extra /= 0) then
do iidummy = 1,csys%natoms_extra
idummy=csys%natoms_original+iidummy
! check for the bond
do i=1,csys%ncoord_ric
if(csys%rim(1,i)==bond_code.and.&
(csys%rim(2,i)==idummy.or.csys%rim(3,i)==idummy)) then
ifr=ifr+1
csys%frozen(ifr)=i
csys%cvals(ifr)=coord_ric(i)
exit
endif
enddo
! check for bond angle
do i=1,csys%ncoord_ric
if(csys%rim(1,i)==angle_code.and.&
(csys%rim(2,i)==idummy.or.csys%rim(4,i)==idummy)) then
ifr=ifr+1
csys%frozen(ifr)=i
csys%cvals(ifr)=coord_ric(i)
exit
endif
enddo
! check for dihedral angle
do i=1,csys%ncoord_ric
if((csys%rim(1,i)==dangle_code.or.&
csys%rim(1,i)==improper_code).and.&
(csys%rim(2,i)==idummy.or.csys%rim(3,i)==idummy.or.&
csys%rim(4,i)==idummy.or.csys%rim(5,i)==idummy)) then
ifr=ifr+1
csys%frozen(ifr)=i
csys%cvals(ifr)=coord_ric(i)
exit
endif
enddo
enddo
endif
write(*,*) 'freezing coordinates'
write(*,'(10000I5)') csys%frozen
end subroutine
!************************************************************************
subroutine check_linear(natoms,cart_coord,n_angles,rim,&
bond_matrix,natoms_new,cart_coord_new,dummy_bonds,n_bad_angles)
!************************************************************************
! Check for linear angles and add dummy atoms if needed
! the linear angles are removed
! the angle 'i' is removed if rim_angles(1,i)==0
!************************************************************************
! cart_coord_new : the new set of Cartesian coordinates
! if there are no linear angles it is not allocated
!
! natoms_new : the number of atoms including dummy atoms
! natoms_new==natoms if no dummy atoms are required
!
! dummy_bonds : it stores which angle is corrected with a given
! dummy atom
! j=dummy_bonds(i) means that the ith dummy bond
! corrects the rim(:,j) angle, and the ith dummy atom
! is bonded to the central atom of rim(:,j)
!************************************************************************
implicit none
integer :: natoms,natoms_new,n_angles,n_bad_angles
integer :: rim(5,n_angles)
integer :: bond_matrix(natoms,natoms)
integer, allocatable :: dummy_bonds(:)
double precision :: cart_coord(3,natoms)
double precision, allocatable :: cart_coord_new(:,:)
! local
integer :: nn,ii,i,j,k,l,m,idummy
integer, allocatable :: bad_angles(:),dummy_atoms(:)
double precision :: angle,normal(3),vec(3)
logical :: lplanar
n_bad_angles=0
natoms_new=0
if(natoms < 3) then
natoms_new=natoms
return
endif
allocate(bad_angles(n_angles))
allocate(dummy_atoms(n_angles))
do i=1,n_angles
k = rim(2,i)
l = rim(3,i)
m = rim(4,i)
angle = angle3(cart_coord(1:3,k),&
cart_coord(1:3,l),&
cart_coord(1:3,m))
! The angle is problematic if angle>175deg or angle<5deg
if(angle>3.05432619099008 .or. angle<0.0872664625997165) then
! count how many atoms are connected to the central atom
n_bad_angles=n_bad_angles+1
nn=0
do j=1,natoms
if(bond_matrix(j,l) == 1) nn=nn+1
enddo
if(nn<4) then
natoms_new=natoms_new+1
bad_angles(n_bad_angles)=i
dummy_atoms(n_bad_angles)=1
elseif(nn>=4) then
lplanar = is_planar(natoms,l,bond_matrix(1,l),cart_coord)
if(lplanar) then
natoms_new=natoms_new+1
bad_angles(n_bad_angles)=i
dummy_atoms(n_bad_angles)=1
else
bad_angles(n_bad_angles)=i
! just remove the angle but do not add dummy atom
dummy_atoms(n_bad_angles)=0
endif
endif
endif
enddo
if(n_bad_angles>0) then
allocate(cart_coord_new(3,natoms+natoms_new))
allocate(dummy_bonds(natoms_new))
call dcopy(3*natoms,cart_coord,1,cart_coord_new,1)
idummy=0
do ii=1,n_bad_angles
i=bad_angles(ii)
rim(1,i) = 0
if(dummy_atoms(ii) == 0) continue
idummy=idummy+1
l = rim(2,i)
k = rim(3,i)
m = rim(4,i)
write(*,'(3I6)') l,k,m
vec=cart_coord(:,l)-cart_coord(:,k)
call get_normal_vector(vec, normal)
cart_coord_new(:,natoms+idummy)=normal+cart_coord(:,k)
dummy_bonds(idummy)=i
enddo
endif
natoms_new=natoms+natoms_new
deallocate(dummy_atoms)
deallocate(bad_angles)
end subroutine
!**********************************************************************
subroutine add_dummy_atoms(natoms,natomswdummy,ndummy,&
bond_matrix,bond_matrix_new,rim,rim_dummy,dummy_bonds)
!**********************************************************************
! Adds the dummy atoms required because of the linear bond angles.
! A new bond matrix is formed containinng the dummy atoms and a new
! redundant internal matrix is calculated which stores the bond angles
! of the dummy atoms.
!**********************************************************************
implicit none
integer :: ndummy,natoms,natomswdummy
integer :: rim(5,*),rim_dummy(5,2*ndummy)
integer :: dummy_bonds(ndummy)
integer :: bond_matrix(natoms,natoms)
integer :: bond_matrix_new(natomswdummy,natomswdummy)
!local
integer :: idummy,iangle,k,l,m
bond_matrix_new = 0
rim_dummy = 0
bond_matrix_new(1:natoms,1:natoms)=bond_matrix(:,:)
do idummy=1,ndummy
iangle = dummy_bonds(idummy)
l = rim(2,iangle)
k = rim(3,iangle) ! central atom
m = rim(4,iangle)
! Add the bond of the dummy atom and the central atom to the
! bond matrix
bond_matrix_new(idummy+natoms,k) = bond_code
bond_matrix_new(k,idummy+natoms) = bond_code
! Each dummy atom form two bond angles with the atoms of the
! linear bond: dummy-k-l; dummy-k-m
rim_dummy(1,2*(idummy-1)+1) = 2
rim_dummy(2,2*(idummy-1)+1) = natoms+idummy
rim_dummy(3,2*(idummy-1)+1) = k
rim_dummy(4,2*(idummy-1)+1) = l
rim_dummy(1,2*(idummy-1)+2) = 2
rim_dummy(2,2*(idummy-1)+2) = natoms+idummy
rim_dummy(3,2*(idummy-1)+2) = k
rim_dummy(4,2*(idummy-1)+2) = m
enddo
end subroutine
!**********************************************************************
logical function is_planar(natoms,atom,bonds,coords)
!**********************************************************************
! Checks if the atoms bonded to "atom" are in one plane
!**********************************************************************
implicit none
integer :: natoms,atom,bonds(natoms)
double precision :: coords(3,natoms)
!local
integer i,n
double precision :: normal(3),vec1(3),vec2(3)
double precision, parameter :: eps = 1.48352986419518 ! 85deg in rad
! first we need 3 non collinear points
! The first one is coords(:,atom)
n=0
i=1
do while(i<=natoms.and. n<2)
if(bonds(i) /= 0) then
if(n == 0) then
n=n+1
vec1=coords(:,i)
else
if(.not.is_parallel(coords(:,i),coords(:,atom),vec1)) then
n=n+1
vec2=coords(:,i)
endif
endif
endif
i=i+1
enddo
! if we could not find 3 points then it is a linear
if(n<2) then
is_planar=.true.
return
endif
! the three points define a plane, it normal vector is the cross
! product of the two (non parallel) vectors of the plane
vec1=vec1-coords(:,atom)
vec2=vec2-coords(:,atom)
call crproduct(vec1,vec2,normal)
normal=normal/vec_length(normal)
! check the dot product of the bond vectors and the normal vector
! of the plane
is_planar = .true.
do while(i<=natoms .and. is_planar)
if(bonds(i) /= 0) then
vec1=coords(:,i)-coords(:,atom)
vec1=vec1/vec_length(vec1)
if(dacos(vec_dot(normal,vec1)).lt.eps) is_planar=.false.
endif
i=i+1
enddo
end function
!************************************************************************
subroutine get_normal_vector(vec,normal)
!************************************************************************
! get the normal vector perpendicular to vec
! orthogonality: normal*vec=sum_i normal_i*vec_i=0
! if vec_1!=0, a possible solution:
! normal_2=normal_3=1, normal_1=-=(vec_2+vec_3)/vec_1
!************************************************************************
implicit none
integer :: i
double precision :: vec(3),normal(3)
double precision :: vec_norm,n_norm
double precision, parameter :: delta = 1.0d-10
vec_norm=max(dabs(vec(1)),dabs(vec(2)),dabs(vec(3)))
if(vec_norm < delta*delta) then
normal=1.0d0
return
endif
i=1
do while(dabs(vec(i)) < delta)
i=i+1
enddo
select case(i)
case(1)
normal(1)=-(vec(2)+vec(3))/vec(1)
normal(2)=1.0d0
normal(3)=1.0d0
case(2)
normal(1)=1.0d0
normal(2)=-(vec(1)+vec(3))/vec(2)
normal(3)=1.0d0
case(3)
normal(1)=1.0d0
normal(2)=1.0d0
normal(3)=-(vec(1)+vec(2))/vec(3)
end select
vec_norm=dsqrt(vec(1)*vec(1)+vec(2)*vec(2)+vec(3)*vec(3))
n_norm=dsqrt(normal(1)*normal(1)+&
normal(2)*normal(2)+&
normal(3)*normal(3))
normal=normal*vec_norm/n_norm
return
end subroutine
!************************************************************************
subroutine constrain_der(csys,der)
!************************************************************************
! Calculates of the derivatives of constraints wrt the coordinates
!************************************************************************
implicit none
type(coord_sys_type) :: csys
double precision :: der(csys%ncoord,csys%nfrozen)
! local
integer :: i,j
if(trim(csys%name) == 'ric') then
der=0.0d0
do i=1,csys%nfrozen
j=csys%frozen(i)
der(j,i)=1.0d0
enddo
endif
end subroutine
!************************************************************************
subroutine get_multipliers(csys,der,grad,lambda)
!************************************************************************
! Gets the lagrange multipliers in the case of constrained optimization
!************************************************************************
implicit none
type(coord_sys_type) :: csys
double precision :: der(csys%ncoord,csys%nfrozen)
double precision :: grad(csys%ncoord)
double precision :: lambda(csys%nfrozen)
! local
integer :: rank,lwork,info,nsol
double precision :: work1(1)
double precision, allocatable :: der2(:),solution(:)
double precision, allocatable :: s(:),work(:)
double precision, parameter :: rcond = 1.0d-7
info=0
nsol=max(csys%ncoord,csys%nfrozen)
allocate(der2(csys%ncoord*csys%nfrozen))
allocate(solution(nsol))
allocate(s(nsol))
call dcopy(csys%ncoord*csys%nfrozen,der,1,der2,1)
call dcopy(csys%ncoord,grad,1,solution,1)
call dgelss(csys%ncoord,csys%nfrozen,1,der2,csys%ncoord,solution,&
nsol,s,rcond,rank,work1,-1,info)
lwork=int(work1(1))
allocate(work(lwork))
call dgelss(csys%ncoord,csys%nfrozen,1,der2,csys%ncoord,solution,&
nsol,s,rcond,rank,work,lwork,info)
if(info /= 0) then
write(*,'(A)') ' Error in calcualtion of Lagrange multipliers'
write(*,'(A)') 'Error code: ',info
call mrccend(1)
endif
call dcopy(csys%nfrozen,solution,1,lambda,1)
! We solved der*lambda=grad but we have to solve der*lambda=-grad
call dscal(csys%nfrozen,-1.0d0,lambda,1)
deallocate(work)
deallocate(der2)
deallocate(solution)
deallocate(s)
end subroutine
!************************************************************************
subroutine get_constrain_term(csys,grad,constrain)
!************************************************************************
! Calculates the term sum_i lambda_i*dC_i/dq in the Lagrange eq.
!************************************************************************
implicit none
type(coord_sys_type) :: csys
double precision :: constrain(csys%ncoord)
double precision :: grad(csys%ncoord)
! local
double precision, allocatable :: der(:,:)
double precision, allocatable :: lambda(:)
allocate(der(csys%ncoord,csys%nfrozen))
allocate(lambda(csys%nfrozen))
call constrain_der(csys,der)
call get_multipliers(csys,der,grad,lambda)
call dgemv('n',csys%ncoord,csys%nfrozen,1.0d0,der,csys%ncoord,&
lambda,1,0.0d0,constrain,1)
deallocate(der)
deallocate(lambda)
end subroutine
!************************************************************************
subroutine build_hessian(natoms,atnums,csys,hessian,hessian_type)
!************************************************************************
! Builds Hessian for geometry optimization
! TODO: LBFGS!!!!
!************************************************************************
implicit none
integer, intent(in) :: natoms,atnums(natoms)
type(coord_sys_type), intent(in) :: csys
double precision, intent(out) :: hessian(csys%ncoord,csys%ncoord)
character*16, intent(in) :: hessian_type
! local
integer :: nintcoord
double precision, allocatable :: hessian_ric(:,:)
if(trim(csys%name) == 'cartesian') then
call mrccend(1)
elseif(trim(csys%name) == 'ric' .or.&
trim(csys%name) == 'deloc-ic') then
nintcoord=csys%ncoord_ric
allocate(hessian_ric(nintcoord,nintcoord))
call build_hessian_ric(natoms,nintcoord,atnums,hessian_ric,&
hessian_type,csys)
! call dummy_hessian(csys,hessian_ric)
call project_hessian(csys%natoms,nintcoord,hessian_ric,hessian,&
csys)
deallocate(hessian_ric)
endif
contains
subroutine build_hessian_ric(natoms,nintcoord,atnums,hessian,&
hessian_type,csys)
implicit none
type(coord_sys_type) :: csys
integer, intent(in) :: nintcoord,natoms,atnums(natoms)
double precision, intent(out) :: hessian(nintcoord,nintcoord)
character*16, intent(in) :: hessian_type
if(trim(hessian_type) == 'lindh') then
call build_lindh_hessian(hessian,csys%rim,csys%cart_coord,&
atnums)
elseif(trim(hessian_type) == 'schlegel') then
call build_schlegel_hessian(hessian,csys%rim,csys%cart_coord,&
atnums)
elseif(trim(hessian_type) == 'unit') then
call build_unit_hessian(hessian)
elseif(trim(hessian_type) == 'diag') then
call build_initial_hessian(hessian,csys%rim,csys%cart_coord)
endif
end subroutine
subroutine build_deloc_ic_hessian
implicit none
integer :: nintcoord
double precision, allocatable :: hessian_ric(:,:),work(:,:)
nintcoord=size(csys%rim,2)
allocate(hessian_ric(nintcoord,nintcoord))
call build_hessian_ric(natoms,nintcoord,atnums,hessian_ric,&
hessian_type,csys)
allocate(work(nintcoord,csys%ncoord))
call dgemm('t','n',csys%ncoord,nintcoord,nintcoord,1.0d0,&
csys%Umatrix,nintcoord,hessian_ric,nintcoord,0.0d0,work,&
csys%ncoord)
call dgemm('n','n',csys%ncoord,csys%ncoord,nintcoord,1.0d0,&
work,csys%ncoord,csys%Umatrix,nintcoord,0.0d0,hessian,&
csys%ncoord)
deallocate(hessian_ric)
deallocate(work)
end subroutine
end subroutine
!************************************************************************
subroutine dummy_hessian(csys,hessian_ric)
!************************************************************************
!************************************************************************
implicit none
type(coord_sys_type) :: csys
double precision :: hessian_ric(csys%ncoord_ric,csys%ncoord_ric)
! local
integer :: natoms,i,ii
natoms=csys%natoms_original
do ii=1,csys%nfrozen
i=csys%frozen(ii)
hessian_ric(i,i)=0.0d0
enddo
end subroutine
!************************************************************************
subroutine project_coordinates(s,csys)
!************************************************************************
! projects coordinates with P=BB^+
!************************************************************************
implicit none
type(coord_sys_type), intent(in) :: csys
double precision :: s(csys%ncoord)
! local
integer :: nintcoord,natoms
double precision, contiguous, pointer :: p(:,:)
double precision, allocatable :: bmatrix_ric(:,:)
double precision, allocatable, target :: p_ric(:,:),p_deloc(:,:)
double precision, allocatable :: temp(:)
natoms=csys%natoms
nintcoord=csys%ncoord_ric
allocate(bmatrix_ric(nintcoord,3*natoms))
allocate(p_ric(nintcoord,nintcoord))
call build_wilson_bmat(natoms,csys%cart_coord,csys%rim,&
Bmatrix_ric)
call build_projection(bmatrix_ric,p_ric,csys)
if(trim(csys%name) == 'deloc-ic') then
call delocalize(nintcoord,csys%ncoord,nintcoord,csys%Umatrix,&
p_ric,p_deloc)
p => p_deloc
elseif(trim(csys%name) == 'ric') then
p => p_ric
endif
allocate(temp(csys%ncoord))
call dgemv('n',csys%ncoord,csys%ncoord,1.0d0,p,csys%ncoord,s,1,&
0.0d0,temp,1)
call dcopy(csys%ncoord,temp,1,s,1)
deallocate(bmatrix_ric)
deallocate(p_ric)
if(allocated(p_deloc)) deallocate(p_deloc)
deallocate(temp)
end subroutine
!************************************************************************
subroutine update_coordinates(sk,csys)
!************************************************************************
! updates coordinates
!************************************************************************
implicit none
type(coord_sys_type) :: csys
double precision, intent(inout) :: sk(csys%ncoord)
integer :: nintcoord,i,ii
double precision, allocatable :: x0(:)
double precision, allocatable :: Bmatrix(:,:),Bp(:,:)
double precision, allocatable :: sk_frozen(:)
nintcoord = csys%ncoord_ric
call project_coordinates(sk,csys)
call daxpy(csys%ncoord,1.0d0,sk,1,csys%coord,1)
if(trim(csys%name) == 'ric') then
call fix_angles(csys%coord,csys%rim,csys%ncoord)
endif
allocate(x0(3*csys%natoms))
allocate(Bmatrix(nintcoord,3*csys%natoms))
allocate(Bp(3*csys%natoms,nintcoord))
call dcopy(3*csys%natoms,csys%cart_coord,1,x0,1)
call step_transform(x0,Bmatrix,Bp,sk,csys)
if(csys%nfrozen /= 0) then
write(*,'(A)') 'Correcting frozen coordinates'
allocate(sk_frozen(csys%ncoord))
sk_frozen=0.0d0
do ii=1,csys%nfrozen
i=csys%frozen(ii)
sk_frozen(i) = csys%cvals(ii) - csys%coord(i)
enddo
call fix_angles(sk_frozen,csys%rim,csys%ncoord)
call daxpy(csys%ncoord,1.0d0,sk_frozen,1,csys%coord,1)
call dcopy(3*csys%natoms,csys%cart_coord,1,x0,1)
call step_transform(x0,Bmatrix,Bp,sk_frozen,csys)
deallocate(sk_frozen)
endif
call get_intcoords(csys%natoms,csys%cart_coord,csys%ncoord_ric,&
csys%rim,csys%coord)
deallocate(x0)
deallocate(Bmatrix)
deallocate(Bp)
end subroutine
!************************************************************************
logical function gopt_conv(gmax,ared,smax,gtol,ftol,xtol,lbaker)
!************************************************************************
! check convergence of geometry optimization
!************************************************************************
implicit none
double precision gmax,ared,smax
double precision gtol,ftol,xtol
logical lbaker
gopt_conv=.false.
if(lBaker) then !Baker conv criteria; JCC, 14, 1085 (1993)
if( gmax <= 3.d-4 .and. (dabs(ared)<=1.d-6 .or. smax<=3.d-4) ) then
gopt_conv = .true.
endif
else
if( gmax <= gtol .and. (dabs(ared)<=ftol .or. smax <= xtol) ) then
gopt_conv = .true.
endif
endif
return
end function
!************************************************************************
end module optim
!************************************************************************
Reference in New Issue View Git Blame Copy Permalink