mirror of https://gitlab.com/QEF/q-e.git
1141 lines
39 KiB
Fortran
1141 lines
39 KiB
Fortran
!
|
|
! Copyright (C) 2003-2020 Quantum ESPRESSO group
|
|
! This file is distributed under the terms of the
|
|
! GNU General Public License. See the file `License'
|
|
! in the root directory of the present distribution,
|
|
! or http://www.gnu.org/copyleft/gpl.txt .
|
|
!
|
|
!----------------------------------------------------------------------------
|
|
MODULE bfgs_module
|
|
!----------------------------------------------------------------------------
|
|
!! Ionic relaxation through the Newton-Raphson optimization scheme
|
|
!! based on the Broyden-Fletcher-Goldfarb-Shanno algorithm for the
|
|
!! estimate of the inverse Hessian matrix.
|
|
!! The ionic relaxation is performed converting cartesian (and cell)
|
|
!! positions into internal coordinates.
|
|
!! The algorithm uses a "trust radius" line search based on Wolfe
|
|
!! conditions. Steps are rejected until the first Wolfe condition
|
|
!! (sufficient energy decrease) is satisfied. Updated step length
|
|
!! is estimated from quadratic interpolation.
|
|
!! When the step is accepted inverse hessian is updated according to
|
|
!! BFGS scheme and a new search direction is obtained from NR or GDIIS
|
|
!! method. The corresponding step length is limited by trust_radius_max
|
|
!! and can't be larger than the previous step multiplied by a certain
|
|
!! factor determined by Wolfe and other convergence conditions.
|
|
!
|
|
!! Originally written (5/12/2003) and maintained (2003-2007) by
|
|
!! Carlo Sbraccia.
|
|
!! Modified for variable-cell-shape relaxation (2007-2008) by
|
|
!! Javier Antonio Montoya, Lorenzo Paulatto and Stefano de Gironcoli.
|
|
!! Re-analyzed by Stefano de Gironcoli (2010).
|
|
!! FCP case added by Minoru Otani and collaborators (2020).
|
|
!
|
|
!! References:
|
|
!! 1) Roger Fletcher, Practical Methods of Optimization, John Wiley and
|
|
!! Sons, Chichester, 2nd edn, 1987.
|
|
!! 2) Salomon R. Billeter, Alexander J. Turner, Walter Thiel,
|
|
!! Phys. Chem. Chem. Phys. 2, 2177 (2000).
|
|
!! 3) Salomon R. Billeter, Alessandro Curioni, Wanda Andreoni,
|
|
!! Comput. Mat. Science 27, 437, (2003).
|
|
!! 4) Ren Weiqing, PhD Thesis: Numerical Methods for the Study of Energy
|
|
!! Landscapes and Rare Events.
|
|
!
|
|
USE kinds, ONLY : DP
|
|
USE constants, ONLY : eps4, eps8, eps16, RYTOEV
|
|
!
|
|
USE basic_algebra_routines
|
|
USE matrix_inversion
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
PRIVATE
|
|
!
|
|
! ... public methods
|
|
!
|
|
PUBLIC :: bfgs, init_bfgs, terminate_bfgs, bfgs_get_n_iter
|
|
!
|
|
! ... global module variables
|
|
!
|
|
SAVE
|
|
!
|
|
CHARACTER (len=18) :: fname="energy"
|
|
!! name of the function to be minimized
|
|
CHARACTER (len=320):: bfgs_file=" "
|
|
!! name of file (with path) used to store and retrieve the status
|
|
!
|
|
REAL(DP), ALLOCATABLE :: pos(:)
|
|
!! positions + cell
|
|
REAL(DP), ALLOCATABLE :: grad(:)
|
|
!! gradients + cell_force
|
|
REAL(DP), ALLOCATABLE :: pos_p(:)
|
|
!! positions at the previous accepted iteration
|
|
REAL(DP), ALLOCATABLE :: grad_p(:)
|
|
!! gradients at the previous accepted iteration
|
|
REAL(DP), ALLOCATABLE :: inv_hess(:,:)
|
|
!! inverse hessian matrix (updated using BFGS formula)
|
|
REAL(DP), ALLOCATABLE :: metric(:,:)
|
|
REAL(DP), ALLOCATABLE :: inv_metric(:,:)
|
|
REAL(DP), ALLOCATABLE :: h_block(:,:)
|
|
REAL(DP), ALLOCATABLE :: hinv_block(:,:)
|
|
REAL(DP), ALLOCATABLE :: step(:)
|
|
!! the (new) search direction (normalized NR step)
|
|
REAL(DP), ALLOCATABLE :: step_old(:)
|
|
!! the previous search direction (normalized NR step)
|
|
REAL(DP), ALLOCATABLE :: pos_old(:,:)
|
|
!! list of m old positions - used only by gdiis
|
|
REAL(DP), ALLOCATABLE :: grad_old(:,:)
|
|
!! list of m old gradients - used only by gdiis
|
|
REAL(DP), ALLOCATABLE :: pos_best(:)
|
|
!! best extrapolated positions - used only by gdiis
|
|
!
|
|
REAL(DP) :: nr_step_length
|
|
!! length of (new) Newton-Raphson step
|
|
REAL(DP) :: nr_step_length_old
|
|
!! length of previous Newton-Raphson step
|
|
REAL(DP) :: trust_radius
|
|
!! new displacement along the search direction
|
|
REAL(DP) :: trust_radius_old
|
|
!! old displacement along the search direction
|
|
REAL(DP) :: energy_p
|
|
!! energy at previous accepted iteration
|
|
!
|
|
INTEGER :: scf_iter
|
|
!! number of scf iterations
|
|
INTEGER :: bfgs_iter
|
|
!! number of bfgs iterations
|
|
INTEGER :: gdiis_iter
|
|
!! number of gdiis iterations
|
|
INTEGER :: tr_min_hit = 0
|
|
!! set to 1 if the trust_radius has already been set to the minimum value
|
|
!! at the previous step. Set to 2 if trust_radius is reset again: exit.
|
|
LOGICAL :: conv_bfgs = .FALSE.
|
|
!! .TRUE. when bfgs convergence has been achieved
|
|
!
|
|
! ... default values for bfgs_ndim, trust_radius_max, trust_radius_min,
|
|
! ... trust_radius_ini, w_1, w_2, are set in Modules/read_namelist.f90
|
|
! ... (SUBROUTINE ions_defaults) and can be assigned in the input
|
|
!
|
|
LOGICAL :: bfgs_initialized = .FALSE.
|
|
INTEGER :: stdout
|
|
!! standard output for writing
|
|
INTEGER :: bfgs_ndim
|
|
!! dimension of the subspace for GDIIS for standard BFGS algorithm,
|
|
!! \(\text{bfgs_ndim}=1\)
|
|
REAL(DP) :: trust_radius_ini
|
|
!! suggested initial displacement
|
|
REAL(DP) :: trust_radius_min
|
|
!! minimum allowed displacement
|
|
REAL(DP) :: trust_radius_max
|
|
!! maximum allowed displacement
|
|
!
|
|
! ... parameters for Wolfe conditions
|
|
!
|
|
REAL(DP) :: w_1
|
|
!! 1st Wolfe condition: sufficient energy decrease
|
|
REAL(DP) :: w_2
|
|
!! 2nd Wolfe condition: sufficient gradient decrease
|
|
!
|
|
CONTAINS
|
|
!
|
|
!------------------------------------------------------------------------
|
|
SUBROUTINE init_bfgs( stdout_, bfgs_ndim_, trust_radius_max_, &
|
|
trust_radius_min_, trust_radius_ini_, w_1_, w_2_)
|
|
!------------------------------------------------------------------------
|
|
!! set values for several parameters of the algorithm
|
|
!
|
|
INTEGER, INTENT(IN) :: &
|
|
stdout_, &
|
|
bfgs_ndim_
|
|
REAL(DP), INTENT(IN) :: &
|
|
trust_radius_ini_, &
|
|
trust_radius_min_, &
|
|
trust_radius_max_, &
|
|
w_1_, &
|
|
w_2_
|
|
!
|
|
stdout = stdout_
|
|
bfgs_ndim = bfgs_ndim_
|
|
trust_radius_max = trust_radius_max_
|
|
trust_radius_min = trust_radius_min_
|
|
trust_radius_ini = trust_radius_ini_
|
|
w_1 = w_1_
|
|
w_2 = w_2_
|
|
bfgs_initialized = .true.
|
|
!
|
|
END SUBROUTINE init_bfgs
|
|
!
|
|
!------------------------------------------------------------------------
|
|
SUBROUTINE bfgs( filebfgs, pos_in, h, nelec, energy, &
|
|
grad_in, fcell, iforceh, felec, &
|
|
energy_thr, grad_thr, cell_thr, fcp_thr, &
|
|
energy_error, grad_error, cell_error, fcp_error, &
|
|
lmovecell, lfcp, fcp_cap, fcp_hess, step_accepted, &
|
|
stop_bfgs, failed, istep )
|
|
!------------------------------------------------------------------------
|
|
!! BFGS algorithm.
|
|
!
|
|
USE constants, ONLY : ry_kbar
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
REAL(DP), INTENT(INOUT) :: pos_in(:)
|
|
!! vector containing 3N coordinates of the system ( x )
|
|
REAL(DP), INTENT(INOUT) :: h(3,3)
|
|
!! 3x3 matrix of the primitive lattice vectors
|
|
REAL(DP), INTENT(INOUT) :: nelec
|
|
!! number of electrons (for FCP)
|
|
REAL(DP), INTENT(INOUT) :: energy
|
|
!! energy of the system ( V(x) )
|
|
REAL(DP), INTENT(INOUT) :: grad_in(:)
|
|
!! vector containing 3N components of grad( V(x) )
|
|
REAL(DP), INTENT(INOUT) :: fcell(3,3)
|
|
!! 3x3 matrix containing the stress tensor
|
|
REAL(DP), INTENT(INOUT) :: felec
|
|
!! force on FCP
|
|
CHARACTER(LEN=*), INTENT(IN) :: filebfgs
|
|
!! file name for storing and retrieving data
|
|
REAL(DP), INTENT(IN) :: energy_thr
|
|
!! threshold on energy difference for BFGS convergence
|
|
REAL(DP), INTENT(IN) :: grad_thr
|
|
!! threshold on grad difference for BFGS convergence
|
|
!! the largest component of grad( V(x) ) is considered
|
|
REAL(DP), INTENT(IN) :: cell_thr
|
|
!! threshold on grad of cell for BFGS convergence
|
|
REAL(DP), INTENT(IN) :: fcp_thr
|
|
!! treshold on grad of FCP for BFGS convergence
|
|
INTEGER, INTENT(IN) :: iforceh(3,3)
|
|
!! 3x3 matrix containing cell constraints
|
|
LOGICAL, INTENT(IN) :: lmovecell
|
|
LOGICAL, INTENT(IN) :: lfcp
|
|
!! include FCP, or not ?
|
|
REAL(DP), INTENT(IN) :: fcp_cap
|
|
!! capacitance for FCP
|
|
REAL(DP), INTENT(IN) :: fcp_hess
|
|
!! hessian for FCP
|
|
REAL(DP), INTENT(OUT) :: energy_error
|
|
!! energy difference \(\| V(x_i) - V(x_{i-1}) \|\)
|
|
REAL(DP), INTENT(OUT) :: grad_error
|
|
!! the largest component of \(\|\text{grad}(V(x_i)) -
|
|
!! \text{grad}(V(x_{i-1}))\|\)
|
|
REAL(DP), INTENT(OUT) :: cell_error
|
|
!! the largest component of: omega*(stress-press*I)
|
|
REAL(DP), INTENT(OUT) :: fcp_error
|
|
!! \(\| \text{grad}(V(x_{FCP})) \|\)
|
|
LOGICAL, INTENT(OUT) :: step_accepted
|
|
!! .TRUE. if a new BFGS step is done
|
|
LOGICAL, INTENT(OUT) :: stop_bfgs
|
|
!! .TRUE. if BFGS convergence has been achieved
|
|
LOGICAL, INTENT(OUT) :: failed
|
|
!! .TRUE. if BFGS failed
|
|
INTEGER, INTENT(OUT) :: istep
|
|
!
|
|
! ... local variables
|
|
!
|
|
INTEGER :: n, i, j, k, nat
|
|
LOGICAL :: lwolfe
|
|
REAL(DP) :: dE0s, den
|
|
! ... for scaled coordinates
|
|
REAL(DP) :: hinv(3,3),g(3,3),ginv(3,3), omega
|
|
!
|
|
! ... additional dimensions of cell and FCP
|
|
INTEGER, PARAMETER :: NADD = 9 + 1
|
|
!
|
|
!
|
|
failed = .FALSE.
|
|
!
|
|
IF ( .NOT.bfgs_initialized ) CALL errore('bfgs',' not initialized',1)
|
|
!
|
|
IF ( bfgs_file == " ") bfgs_file = TRIM(filebfgs)
|
|
lwolfe=.false.
|
|
n = SIZE( pos_in ) + NADD
|
|
nat = size (pos_in) / 3
|
|
if (nat*3 /= size (pos_in)) call errore('bfgs',' strange dimension',1)
|
|
!
|
|
! ... work-space allocation
|
|
!
|
|
ALLOCATE( pos( n ) )
|
|
ALLOCATE( grad( n ) )
|
|
!
|
|
ALLOCATE( grad_old( n, bfgs_ndim ) )
|
|
ALLOCATE( pos_old( n, bfgs_ndim ) )
|
|
!
|
|
ALLOCATE( inv_hess( n, n ) )
|
|
!
|
|
ALLOCATE( pos_p( n ) )
|
|
ALLOCATE( grad_p( n ) )
|
|
ALLOCATE( step( n ) )
|
|
ALLOCATE( step_old( n ) )
|
|
ALLOCATE( pos_best( n ) )
|
|
! ... scaled coordinates work-space
|
|
ALLOCATE( hinv_block( n-NADD, n-NADD ) )
|
|
! ... cell related work-space
|
|
ALLOCATE( metric( n , n ) )
|
|
ALLOCATE( inv_metric( n , n ) )
|
|
!
|
|
! ... the BFGS file read (pos & grad) in scaled coordinates
|
|
!
|
|
call invmat(3, h, hinv, omega)
|
|
! volume is defined to be positive even for left-handed vector triplet
|
|
omega = abs(omega)
|
|
!
|
|
hinv_block = 0.d0
|
|
FORALL ( k=0:nat-1, i=1:3, j=1:3 ) hinv_block(i+3*k,j+3*k) = hinv(i,j)
|
|
!
|
|
! ... generate metric to work with scaled ionic coordinates
|
|
g = MATMUL(TRANSPOSE(h),h)
|
|
call invmat(3,g,ginv)
|
|
metric = 0.d0
|
|
FORALL ( k=0:nat-1, i=1:3, j=1:3 ) metric(i+3*k,j+3*k) = g(i,j)
|
|
FORALL ( k=nat:nat+2, i=1:3, j=1:3 ) metric(i+3*k,j+3*k) = 0.04d0 * omega * ginv(i,j)
|
|
!
|
|
IF ( lfcp ) THEN
|
|
IF ( fcp_cap > eps4 ) THEN
|
|
metric(n,n) = (0.5d0 / (0.1d0 * fcp_cap)) ** 2
|
|
ELSE
|
|
metric(n,n) = 1.d0
|
|
END IF
|
|
ELSE
|
|
metric(n,n) = 1.d0
|
|
END IF
|
|
!
|
|
! ... generate inverse of metric
|
|
inv_metric = 0.d0
|
|
FORALL ( k=0:nat-1, i=1:3, j=1:3 ) inv_metric(i+3*k,j+3*k) = ginv(i,j)
|
|
FORALL ( k=nat:nat+2, i=1:3, j=1:3 ) inv_metric(i+3*k,j+3*k) = g(i,j) / (0.04d0 * omega)
|
|
inv_metric(n,n) = 1.d0 / metric(n,n)
|
|
!
|
|
! ... generate bfgs vectors for the degrees of freedom and their gradients
|
|
pos = 0.d0
|
|
pos(1:n-NADD) = pos_in
|
|
if (lmovecell) FORALL( i=1:3, j=1:3) pos( n-NADD + j+3*(i-1) ) = h(i,j)
|
|
if (lfcp) pos( n ) = nelec
|
|
grad = 0.d0
|
|
grad(1:n-NADD) = grad_in
|
|
if (lmovecell) FORALL( i=1:3, j=1:3) grad( n-NADD + j+3*(i-1) ) = fcell(i,j)*iforceh(i,j)
|
|
if (lfcp) grad( n ) = felec
|
|
!
|
|
! if the cell moves the quantity to be minimized is the enthalpy
|
|
fname = "energy"
|
|
IF ( lmovecell ) fname="enthalpy"
|
|
IF ( lfcp ) fname = "grand-" // TRIM(fname)
|
|
!
|
|
CALL read_bfgs_file( pos, grad, energy, n, lfcp, fcp_hess )
|
|
!
|
|
scf_iter = scf_iter + 1
|
|
istep = scf_iter
|
|
!
|
|
! ... convergence is checked here
|
|
!
|
|
energy_error = ABS( energy_p - energy )
|
|
!
|
|
! ... obscure PGI bug as of v.17.4
|
|
!
|
|
#if defined (__PGI)
|
|
grad_in = MATMUL( TRANSPOSE(hinv_block), grad(1:n-NADD) )
|
|
grad_error = MAXVAL( ABS( grad_in ) )
|
|
#else
|
|
grad_error = MAXVAL( ABS( MATMUL( TRANSPOSE(hinv_block), grad(1:n-NADD)) ) )
|
|
#endif
|
|
conv_bfgs = energy_error < energy_thr
|
|
conv_bfgs = conv_bfgs .AND. ( grad_error < grad_thr )
|
|
!
|
|
IF( lmovecell) THEN
|
|
cell_error = MAXVAL( ABS( MATMUL ( TRANSPOSE ( RESHAPE( grad(n-NADD+1:n-1), (/ 3, 3 /) ) ),&
|
|
TRANSPOSE(h) ) ) ) / omega
|
|
conv_bfgs = conv_bfgs .AND. ( cell_error < cell_thr )
|
|
#undef DEBUG
|
|
#if defined(DEBUG)
|
|
write (*,'(3f15.10)') TRANSPOSE ( RESHAPE( grad(n-NADD+1:n-1), (/ 3, 3 /) ) )
|
|
write (*,*)
|
|
write (*,'(3f15.10)') TRANSPOSE(h)
|
|
write (*,*)
|
|
write (*,'(3f15.10)') MATMUL (TRANSPOSE( RESHAPE( grad(n-NADD+1:n-1), (/ 3, 3 /) ) ),&
|
|
TRANSPOSE(h) ) / omega
|
|
write (*,*)
|
|
write (*,*) cell_error/cell_thr*0.5d0
|
|
#endif
|
|
END IF
|
|
!
|
|
IF( lfcp ) THEN
|
|
fcp_error = ABS( grad( n ) )
|
|
conv_bfgs = conv_bfgs .AND. ( fcp_error < fcp_thr )
|
|
END IF
|
|
!
|
|
! ... converged (or useless to go on): quick return
|
|
!
|
|
IF ( .NOT. conv_bfgs .AND. ( tr_min_hit > 1 ) ) THEN
|
|
CALL infomsg( 'bfgs',&
|
|
'history already reset at previous step: exiting' )
|
|
failed = .TRUE.
|
|
END IF
|
|
!
|
|
conv_bfgs = conv_bfgs .OR. ( tr_min_hit > 1 )
|
|
!
|
|
WRITE(stdout, '(5X,"Energy error",T30,"= ",1PE12.1," Ry")') energy_error
|
|
WRITE(stdout, '(5X,"Gradient error",T30,"= ",1PE12.1," Ry/Bohr")') grad_error
|
|
IF( lmovecell ) WRITE(stdout, &
|
|
'(5X,"Cell gradient error",T30,"= ",1PE12.1," kbar")') &
|
|
cell_error * ry_kbar
|
|
IF( lfcp ) WRITE(stdout, &
|
|
'(5X,"FCP gradient error",T30,"= ",1PE12.1,/)') fcp_error
|
|
!
|
|
IF ( conv_bfgs ) GOTO 1000
|
|
!
|
|
! ... some output is written
|
|
!
|
|
WRITE( UNIT = stdout, &
|
|
& FMT = '(/,5X,"number of scf cycles",T30,"= ",I3)' ) scf_iter
|
|
WRITE( UNIT = stdout, &
|
|
& FMT = '(5X,"number of bfgs steps",T30,"= ",I3,/)' ) bfgs_iter
|
|
IF ( scf_iter > 1 ) WRITE( UNIT = stdout, &
|
|
& FMT = '(5X,A," old",T30,"= ",F18.10," Ry")' ) fname,energy_p
|
|
WRITE( UNIT = stdout, &
|
|
& FMT = '(5X,A," new",T30,"= ",F18.10," Ry",/)' ) fname,energy
|
|
!
|
|
! ... the bfgs algorithm starts here
|
|
!
|
|
IF ( .NOT. energy_wolfe_condition( energy ) .AND. (scf_iter > 1) .AND. (.NOT. lfcp) ) THEN
|
|
!
|
|
! ... Wolfe condition not met: the previous step is rejected,
|
|
! ... line search goes on
|
|
! ... Note that for the FCP case, the Wolfe condition is ignored
|
|
!
|
|
step_accepted = .FALSE.
|
|
!
|
|
WRITE( UNIT = stdout, &
|
|
& FMT = '(5X,"CASE: ",A,"_new > ",A,"_old",/)' ) fname,fname
|
|
!
|
|
! ... the new trust radius is obtained by quadratic interpolation
|
|
!
|
|
! ... E(s) = a*s*s + b*s + c ( we use E(0), dE(0), E(s') )
|
|
!
|
|
! ... s_min = - 0.5*( dE(0)*s'*s' ) / ( E(s') - E(0) - dE(0)*s' )
|
|
!
|
|
if (abs(scnorm(step_old(:))-1._DP) > 1.d-10) call errore('bfgs', &
|
|
' step_old is NOT normalized ',1)
|
|
! (normalized) search direction is the same as in previous step
|
|
step(:) = step_old(:)
|
|
!
|
|
dE0s = ( grad_p(:) .dot. step(:) ) * trust_radius_old
|
|
IF (dE0s > 0._DP ) CALL errore( 'bfgs', &
|
|
'dE0s is positive which should never happen', 1 )
|
|
den = energy - energy_p - dE0s
|
|
!
|
|
! estimate new trust radius by interpolation
|
|
trust_radius = - 0.5_DP*dE0s*trust_radius_old / den
|
|
!
|
|
WRITE( UNIT = stdout, &
|
|
& FMT = '(5X,"new trust radius",T30,"= ",F18.10," bohr")' ) &
|
|
trust_radius
|
|
!
|
|
! ... values from the last successful bfgs step are restored
|
|
!
|
|
pos(:) = pos_p(:)
|
|
energy = energy_p
|
|
grad(:) = grad_p(:)
|
|
!
|
|
IF ( trust_radius < trust_radius_min ) THEN
|
|
!
|
|
! ... the history is reset ( the history can be reset at most two
|
|
! ... consecutive times )
|
|
!
|
|
WRITE( UNIT = stdout, &
|
|
FMT = '(/,5X,"trust_radius < trust_radius_min")' )
|
|
WRITE( UNIT = stdout, FMT = '(/,5X,"resetting bfgs history",/)' )
|
|
!
|
|
! ... if tr_min_hit=1 the history has already been reset at the
|
|
! ... previous step : something is going wrong
|
|
!
|
|
IF ( tr_min_hit == 1 ) THEN
|
|
CALL infomsg( 'bfgs', &
|
|
'history already reset at previous step: stopping' )
|
|
tr_min_hit = 2
|
|
ELSE
|
|
tr_min_hit = 1
|
|
END IF
|
|
!
|
|
CALL reset_bfgs( n, lfcp, fcp_hess )
|
|
!
|
|
step(:) = - ( inv_hess(:,:) .times. grad(:) )
|
|
if (lmovecell) FORALL( i=1:3, j=1:3) step( n-NADD+j+3*(i-1) ) = step( n-NADD+j+3*(i-1) )*iforceh(i,j)
|
|
! normalize step but remember its length
|
|
nr_step_length = scnorm(step)
|
|
step(:) = step(:) / nr_step_length
|
|
!
|
|
trust_radius = min(trust_radius_ini, nr_step_length)
|
|
!
|
|
ELSE
|
|
!
|
|
tr_min_hit = 0
|
|
!
|
|
END IF
|
|
!
|
|
ELSE
|
|
!
|
|
! ... a new bfgs step is done
|
|
!
|
|
bfgs_iter = bfgs_iter + 1
|
|
!
|
|
IF ( bfgs_iter == 1 ) THEN
|
|
!
|
|
! ... first iteration
|
|
!
|
|
step_accepted = .FALSE.
|
|
!
|
|
ELSE
|
|
!
|
|
step_accepted = .TRUE.
|
|
!
|
|
nr_step_length_old = nr_step_length
|
|
!
|
|
IF ( .NOT. lfcp ) THEN
|
|
!
|
|
WRITE( UNIT = stdout, &
|
|
& FMT = '(5X,"CASE: ",A,"_new < ",A,"_old",/)' ) fname,fname
|
|
!
|
|
END IF
|
|
!
|
|
CALL check_wolfe_conditions( lwolfe, energy, grad )
|
|
!
|
|
CALL update_inverse_hessian( pos, grad, n, lfcp, fcp_hess )
|
|
!
|
|
END IF
|
|
! compute new search direction and store NR step length
|
|
IF ( bfgs_ndim > 1 ) THEN
|
|
!
|
|
! ... GDIIS extrapolation
|
|
!
|
|
CALL gdiis_step()
|
|
!
|
|
ELSE
|
|
!
|
|
! ... standard Newton-Raphson step
|
|
!
|
|
step(:) = - ( inv_hess(:,:) .times. grad(:) )
|
|
if (lmovecell) FORALL( i=1:3, j=1:3) step( n-NADD+j+3*(i-1) ) = step( n-NADD+j+3*(i-1) )*iforceh(i,j)
|
|
!
|
|
END IF
|
|
IF ( ( grad(:) .dot. step(:) ) > 0.0_DP ) THEN
|
|
!
|
|
WRITE( UNIT = stdout, &
|
|
FMT = '(5X,"uphill step: resetting bfgs history",/)' )
|
|
!
|
|
CALL reset_bfgs( n, lfcp, fcp_hess )
|
|
step(:) = - ( inv_hess(:,:) .times. grad(:) )
|
|
if (lmovecell) FORALL( i=1:3, j=1:3) step( n-NADD+j+3*(i-1) ) = step( n-NADD+j+3*(i-1) )*iforceh(i,j)
|
|
!
|
|
END IF
|
|
!
|
|
! normalize the step and save the step length
|
|
nr_step_length = scnorm(step)
|
|
step(:) = step(:) / nr_step_length
|
|
!
|
|
! ... the new trust radius is computed
|
|
!
|
|
IF ( bfgs_iter == 1 ) THEN
|
|
!
|
|
trust_radius = min(trust_radius_ini, nr_step_length)
|
|
tr_min_hit = 0
|
|
!
|
|
ELSE
|
|
!
|
|
CALL compute_trust_radius( lwolfe, energy, grad, n, lfcp, fcp_hess )
|
|
!
|
|
END IF
|
|
!
|
|
WRITE( UNIT = stdout, &
|
|
& FMT = '(5X,"new trust radius",T30,"= ",F18.10," bohr")' ) &
|
|
trust_radius
|
|
!
|
|
END IF
|
|
!
|
|
! ... step along the bfgs direction
|
|
!
|
|
IF ( nr_step_length < eps16 ) &
|
|
CALL errore( 'bfgs', 'NR step-length unreasonably short', 1 )
|
|
!
|
|
! ... information required by next iteration is saved here ( this must
|
|
! ... be done before positions are updated )
|
|
!
|
|
CALL write_bfgs_file( pos, energy, grad )
|
|
!
|
|
! ... positions and cell are updated
|
|
!
|
|
pos(:) = pos(:) + trust_radius * step(:)
|
|
!
|
|
1000 stop_bfgs = conv_bfgs
|
|
! ... input ions+cell variables
|
|
pos_in = pos(1:n-NADD)
|
|
IF ( lmovecell ) FORALL( i=1:3, j=1:3) h(i,j) = pos( n-NADD + j+3*(i-1) )
|
|
IF ( lfcp ) nelec = pos( n )
|
|
! ... update forces
|
|
grad_in = grad(1:n-NADD)
|
|
!
|
|
! ... work-space deallocation
|
|
!
|
|
DEALLOCATE( pos )
|
|
DEALLOCATE( grad )
|
|
DEALLOCATE( pos_p )
|
|
DEALLOCATE( grad_p )
|
|
DEALLOCATE( pos_old )
|
|
DEALLOCATE( grad_old )
|
|
DEALLOCATE( inv_hess )
|
|
DEALLOCATE( step )
|
|
DEALLOCATE( step_old )
|
|
DEALLOCATE( pos_best )
|
|
DEALLOCATE( hinv_block )
|
|
DEALLOCATE( metric )
|
|
DEALLOCATE( inv_metric )
|
|
!
|
|
RETURN
|
|
!
|
|
CONTAINS
|
|
!
|
|
!--------------------------------------------------------------------
|
|
SUBROUTINE gdiis_step()
|
|
!--------------------------------------------------------------------
|
|
!! GDIIS extrapolation
|
|
!
|
|
USE basic_algebra_routines
|
|
IMPLICIT NONE
|
|
!
|
|
REAL(DP), ALLOCATABLE :: res(:,:), overlap(:,:), work(:)
|
|
INTEGER, ALLOCATABLE :: iwork(:)
|
|
INTEGER :: k, k_m, info
|
|
REAL(DP) :: gamma0
|
|
!
|
|
!
|
|
gdiis_iter = gdiis_iter + 1
|
|
!
|
|
k = MIN( gdiis_iter, bfgs_ndim )
|
|
k_m = k + 1
|
|
!
|
|
ALLOCATE( res( n, k ) )
|
|
ALLOCATE( overlap( k_m, k_m ) )
|
|
ALLOCATE( work( k_m ), iwork( k_m ) )
|
|
!
|
|
work(:) = 0.0_DP
|
|
iwork(:) = 0
|
|
!
|
|
! ... the new direction is added to the workspace
|
|
!
|
|
DO i = bfgs_ndim, 2, -1
|
|
!
|
|
pos_old(:,i) = pos_old(:,i-1)
|
|
grad_old(:,i) = grad_old(:,i-1)
|
|
!
|
|
END DO
|
|
!
|
|
pos_old(:,1) = pos(:)
|
|
grad_old(:,1) = grad(:)
|
|
!
|
|
! ... |res_i> = H^-1 \times |g_i>
|
|
!
|
|
CALL DGEMM( 'N', 'N', n, k, n, 1.0_DP, &
|
|
inv_hess, n, grad_old, n, 0.0_DP, res, n )
|
|
!
|
|
! ... overlap_ij = <grad_i|res_j>
|
|
!
|
|
CALL DGEMM( 'T', 'N', k, k, n, 1.0_DP, &
|
|
res, n, res, n, 0.0_DP, overlap, k_m )
|
|
!
|
|
overlap( :, k_m) = 1.0_DP
|
|
overlap(k_m, : ) = 1.0_DP
|
|
overlap(k_m,k_m) = 0.0_DP
|
|
!
|
|
! make sure the overlap matrix is not singular
|
|
!
|
|
FORALL( i = 1:k ) overlap(i,i) = overlap(i,i) * ( 1.0_DP + eps8 ) ; overlap(k_m,k_m) = eps8
|
|
!
|
|
! ... overlap is inverted via Bunch-Kaufman diagonal pivoting method
|
|
!
|
|
CALL DSYTRF( 'U', k_m, overlap, k_m, iwork, work, k_m, info )
|
|
CALL DSYTRI( 'U', k_m, overlap, k_m, iwork, work, info )
|
|
CALL errore( 'gdiis_step', 'error in Bunch-Kaufman inversion', info )
|
|
!
|
|
! ... overlap is symmetrised
|
|
!
|
|
FORALL( i = 1:k_m, j = 1:k_m, j > i ) overlap(j,i) = overlap(i,j)
|
|
!
|
|
pos_best(:) = 0.0_DP
|
|
step(:) = 0.0_DP
|
|
!
|
|
DO i = 1, k
|
|
!
|
|
gamma0 = overlap(k_m,i)
|
|
!
|
|
pos_best(:) = pos_best(:) + gamma0*pos_old(:,i)
|
|
!
|
|
step(:) = step(:) - gamma0*res(:,i)
|
|
!
|
|
END DO
|
|
!
|
|
! ... the step must be consistent with the last positions
|
|
!
|
|
step(:) = step(:) + ( pos_best(:) - pos(:) )
|
|
!
|
|
IF ( ( grad(:) .dot. step(:) ) > 0.0_DP ) THEN
|
|
!
|
|
! ... if the extrapolated direction is uphill use only the
|
|
! ... last gradient and reset gdiis history
|
|
!
|
|
step(:) = - ( inv_hess(:,:) .times. grad(:) )
|
|
if (lmovecell) FORALL( i=1:3, j=1:3) step( n-NADD+j+3*(i-1) ) = step( n-NADD+j+3*(i-1) )*iforceh(i,j)
|
|
!
|
|
gdiis_iter = 0
|
|
!
|
|
END IF
|
|
!
|
|
DEALLOCATE( res, overlap, work, iwork )
|
|
!
|
|
END SUBROUTINE gdiis_step
|
|
!
|
|
END SUBROUTINE bfgs
|
|
!
|
|
!------------------------------------------------------------------------
|
|
SUBROUTINE reset_bfgs( n, lfcp, fcp_hess )
|
|
!------------------------------------------------------------------------
|
|
!! \(\text{inv_hess}\) in re-initialized to the initial guess
|
|
!! defined as the inverse metric.
|
|
!
|
|
INTEGER, INTENT(IN) :: n
|
|
LOGICAL, INTENT(IN) :: lfcp
|
|
REAL(DP), INTENT(IN) :: fcp_hess
|
|
!
|
|
inv_hess = inv_metric
|
|
!
|
|
IF ( lfcp ) THEN
|
|
!
|
|
IF ( fcp_hess > eps4 ) THEN
|
|
!
|
|
inv_hess(n,n) = fcp_hess
|
|
!
|
|
END IF
|
|
!
|
|
END IF
|
|
!
|
|
gdiis_iter = 0
|
|
!
|
|
END SUBROUTINE reset_bfgs
|
|
!
|
|
!------------------------------------------------------------------------
|
|
SUBROUTINE read_bfgs_file( pos, grad, energy, n, lfcp, fcp_hess )
|
|
!------------------------------------------------------------------------
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
REAL(DP), INTENT(INOUT) :: pos(:)
|
|
REAL(DP), INTENT(INOUT) :: grad(:)
|
|
INTEGER, INTENT(IN) :: n
|
|
LOGICAL, INTENT(IN) :: lfcp
|
|
REAL(DP), INTENT(IN) :: fcp_hess
|
|
REAL(DP), INTENT(INOUT) :: energy
|
|
!
|
|
INTEGER :: iunbfgs
|
|
LOGICAL :: file_exists
|
|
!
|
|
!
|
|
INQUIRE( FILE = bfgs_file, EXIST = file_exists )
|
|
!
|
|
IF ( file_exists ) THEN
|
|
!
|
|
! ... bfgs is restarted from file
|
|
!
|
|
OPEN( NEWUNIT = iunbfgs, FILE = bfgs_file, &
|
|
STATUS = 'UNKNOWN', ACTION = 'READ' )
|
|
!
|
|
READ( iunbfgs, * ) pos_p
|
|
READ( iunbfgs, * ) grad_p
|
|
READ( iunbfgs, * ) scf_iter
|
|
READ( iunbfgs, * ) bfgs_iter
|
|
READ( iunbfgs, * ) gdiis_iter
|
|
READ( iunbfgs, * ) energy_p
|
|
READ( iunbfgs, * ) pos_old
|
|
READ( iunbfgs, * ) grad_old
|
|
READ( iunbfgs, * ) inv_hess
|
|
READ( iunbfgs, * ) tr_min_hit
|
|
READ( iunbfgs, * ) nr_step_length
|
|
!
|
|
CLOSE( UNIT = iunbfgs )
|
|
!
|
|
step_old = ( pos(:) - pos_p(:) )
|
|
trust_radius_old = scnorm( step_old )
|
|
step_old = step_old / trust_radius_old
|
|
!
|
|
ELSE
|
|
!
|
|
! ... bfgs initialization
|
|
!
|
|
WRITE( UNIT = stdout, FMT = '(/,5X,"BFGS Geometry Optimization")' )
|
|
!
|
|
! initialize the inv_hess to the inverse of the metric
|
|
inv_hess = inv_metric
|
|
!
|
|
IF ( lfcp ) THEN
|
|
!
|
|
IF ( fcp_hess > eps4 ) THEN
|
|
!
|
|
inv_hess(n,n) = fcp_hess
|
|
!
|
|
END IF
|
|
!
|
|
END IF
|
|
!
|
|
pos_p = 0.0_DP
|
|
grad_p = 0.0_DP
|
|
scf_iter = 0
|
|
bfgs_iter = 0
|
|
gdiis_iter = 0
|
|
energy_p = energy
|
|
step_old = 0.0_DP
|
|
nr_step_length = 0.0_DP
|
|
!
|
|
trust_radius_old = trust_radius_ini
|
|
!
|
|
pos_old(:,:) = 0.0_DP
|
|
grad_old(:,:) = 0.0_DP
|
|
!
|
|
tr_min_hit = 0
|
|
!
|
|
END IF
|
|
!
|
|
END SUBROUTINE read_bfgs_file
|
|
!
|
|
!------------------------------------------------------------------------
|
|
SUBROUTINE write_bfgs_file( pos, energy, grad )
|
|
!------------------------------------------------------------------------
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
REAL(DP), INTENT(IN) :: pos(:)
|
|
REAL(DP), INTENT(IN) :: energy
|
|
REAL(DP), INTENT(IN) :: grad(:)
|
|
!
|
|
INTEGER :: iunbfgs
|
|
!
|
|
OPEN( NEWUNIT = iunbfgs, FILE = bfgs_file, STATUS = 'UNKNOWN', ACTION = 'WRITE' )
|
|
!
|
|
WRITE( iunbfgs, * ) pos
|
|
WRITE( iunbfgs, * ) grad
|
|
WRITE( iunbfgs, * ) scf_iter
|
|
WRITE( iunbfgs, * ) bfgs_iter
|
|
WRITE( iunbfgs, * ) gdiis_iter
|
|
WRITE( iunbfgs, * ) energy
|
|
WRITE( iunbfgs, * ) pos_old
|
|
WRITE( iunbfgs, * ) grad_old
|
|
WRITE( iunbfgs, * ) inv_hess
|
|
WRITE( iunbfgs, * ) tr_min_hit
|
|
WRITE( iunbfgs, * ) nr_step_length
|
|
!
|
|
CLOSE( UNIT = iunbfgs )
|
|
!
|
|
END SUBROUTINE write_bfgs_file
|
|
!
|
|
SUBROUTINE update_inverse_hessian( pos, grad, n, lfcp, fcp_hess )
|
|
!------------------------------------------------------------------------
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
REAL(DP), INTENT(IN) :: pos(:)
|
|
REAL(DP), INTENT(IN) :: grad(:)
|
|
INTEGER, INTENT(IN) :: n
|
|
LOGICAL, INTENT(IN) :: lfcp
|
|
REAL(DP), INTENT(IN) :: fcp_hess
|
|
INTEGER :: info
|
|
!
|
|
REAL(DP), ALLOCATABLE :: y(:), s(:)
|
|
REAL(DP), ALLOCATABLE :: Hy(:), yH(:)
|
|
REAL(DP) :: sdoty, sBs, Theta
|
|
REAL(DP), ALLOCATABLE :: B(:,:)
|
|
!
|
|
ALLOCATE( y( n ), s( n ), Hy( n ), yH( n ) )
|
|
!
|
|
s(:) = pos(:) - pos_p(:)
|
|
y(:) = grad(:) - grad_p(:)
|
|
!
|
|
sdoty = ( s(:) .dot. y(:) )
|
|
!
|
|
IF ( ABS( sdoty ) < eps16 ) THEN
|
|
!
|
|
! ... the history is reset
|
|
!
|
|
WRITE( stdout, '(/,5X,"WARNING: unexpected ", &
|
|
& "behaviour in update_inverse_hessian")' )
|
|
WRITE( stdout, '( 5X," resetting bfgs history",/)' )
|
|
!
|
|
CALL reset_bfgs( n, lfcp, fcp_hess )
|
|
!
|
|
RETURN
|
|
!
|
|
ELSE
|
|
! Conventional Curvature Trap here
|
|
! See section 18.2 (p538-539 ) of Nocedal and Wright "Numerical
|
|
! Optimization"for instance
|
|
! LDM Addition, April 2011
|
|
!
|
|
! While with the Wolfe conditions the Hessian in most cases
|
|
! remains positive definite, if one is far from the minimum
|
|
! and/or "bonds" are being made/broken the curvature condition
|
|
! Hy = s ; or s = By
|
|
! cannot be satisfied if s.y < 0. In addition, if s.y is small
|
|
! compared to s.B.s too greedy a step is taken.
|
|
!
|
|
! The trap below is conventional and "OK", and has been around
|
|
! for ~ 30 years but, unfortunately, is rarely mentioned in
|
|
! introductory texts and hence often neglected.
|
|
!
|
|
! First, solve for inv_hess*t = s ; i.e. t = B*s
|
|
! Use yH as workspace here
|
|
|
|
ALLOCATE (B(n,n) )
|
|
B = inv_hess
|
|
yH= s
|
|
call DPOSV('U',n,1,B,n, yH, n, info)
|
|
! Info .ne. 0 should be trapped ...
|
|
if(info .ne. 0)write( stdout, '(/,5X,"WARNING: info=",i3," for Hessian")' )info
|
|
DEALLOCATE ( B )
|
|
!
|
|
! Calculate s.B.s
|
|
sBs = ( s(:) .dot. yH(:) )
|
|
!
|
|
! Now the trap itself
|
|
if ( sdoty < 0.20D0*sBs ) then
|
|
! Conventional damping
|
|
Theta = 0.8D0*sBs/(sBs-sdoty)
|
|
WRITE( stdout, '(/,5X,"WARNING: bfgs curvature condition ", &
|
|
& "failed, Theta=",F6.3)' )theta
|
|
y = Theta*y + (1.D0 - Theta)*yH
|
|
endif
|
|
END IF
|
|
!
|
|
Hy(:) = ( inv_hess .times. y(:) )
|
|
yH(:) = ( y(:) .times. inv_hess )
|
|
!
|
|
! ... BFGS update
|
|
!
|
|
inv_hess = inv_hess + 1.0_DP / sdoty * &
|
|
( ( 1.0_DP + ( y .dot. Hy ) / sdoty ) * matrix( s, s ) - &
|
|
( matrix( s, yH ) + matrix( Hy, s ) ) )
|
|
!
|
|
DEALLOCATE( y, s, Hy, yH )
|
|
!
|
|
RETURN
|
|
!
|
|
END SUBROUTINE update_inverse_hessian
|
|
!
|
|
!------------------------------------------------------------------------
|
|
SUBROUTINE check_wolfe_conditions( lwolfe, energy, grad )
|
|
!------------------------------------------------------------------------
|
|
IMPLICIT NONE
|
|
REAL(DP), INTENT(IN) :: energy
|
|
REAL(DP), INTENT(IN) :: grad(:)
|
|
LOGICAL, INTENT(OUT) :: lwolfe
|
|
!
|
|
lwolfe = energy_wolfe_condition ( energy ) .AND. &
|
|
gradient_wolfe_condition ( grad )
|
|
!
|
|
END SUBROUTINE check_wolfe_conditions
|
|
!
|
|
!------------------------------------------------------------------------
|
|
LOGICAL FUNCTION energy_wolfe_condition ( energy )
|
|
!------------------------------------------------------------------------
|
|
IMPLICIT NONE
|
|
REAL(DP), INTENT(IN) :: energy
|
|
!
|
|
energy_wolfe_condition = &
|
|
( energy-energy_p ) < w_1 * ( grad_p.dot.step_old ) * trust_radius_old
|
|
!
|
|
END FUNCTION energy_wolfe_condition
|
|
!
|
|
!------------------------------------------------------------------------
|
|
LOGICAL FUNCTION gradient_wolfe_condition ( grad )
|
|
!------------------------------------------------------------------------
|
|
IMPLICIT NONE
|
|
REAL(DP), INTENT(IN) :: grad(:)
|
|
!
|
|
gradient_wolfe_condition = &
|
|
ABS( grad .dot. step_old ) < - w_2 * ( grad_p .dot. step_old )
|
|
!
|
|
END FUNCTION gradient_wolfe_condition
|
|
!
|
|
!------------------------------------------------------------------------
|
|
SUBROUTINE compute_trust_radius( lwolfe, energy, grad, n, lfcp, fcp_hess )
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
LOGICAL, INTENT(IN) :: lwolfe
|
|
REAL(DP), INTENT(IN) :: energy
|
|
REAL(DP), INTENT(IN) :: grad(:)
|
|
INTEGER, INTENT(IN) :: n
|
|
LOGICAL, INTENT(IN) :: lfcp
|
|
REAL(DP), INTENT(IN) :: fcp_hess
|
|
!
|
|
REAL(DP) :: a
|
|
LOGICAL :: ltest
|
|
!
|
|
ltest = energy_wolfe_condition( energy )
|
|
!
|
|
! The instruction below replaces the original instruction:
|
|
! ltest = ltest .AND. ( nr_step_length_old > trust_radius_old )
|
|
! which gives a random result if trust_radius was set equal to
|
|
! nr_step_length at previous step. I am not sure what the best
|
|
! action should be in that case, though (PG)
|
|
!
|
|
ltest = ltest .AND. ( nr_step_length_old > trust_radius_old + eps8 )
|
|
!
|
|
IF ( ltest ) THEN
|
|
a = 1.5_DP
|
|
ELSE
|
|
a = 1.1_DP
|
|
END IF
|
|
IF ( lwolfe ) a = 2._DP * a
|
|
!
|
|
trust_radius = MIN( trust_radius_max, a*trust_radius_old, nr_step_length )
|
|
!
|
|
IF ( trust_radius < trust_radius_min ) THEN
|
|
!
|
|
! ... the history is reset
|
|
!
|
|
! ... if tr_min_hit the history has already been reset at the
|
|
! ... previous step : something is going wrong
|
|
!
|
|
IF ( tr_min_hit == 1 ) THEN
|
|
CALL infomsg( 'bfgs :: compute_trust_radius', &
|
|
'history already reset at previous step: stopping' )
|
|
tr_min_hit = 2
|
|
ELSE
|
|
tr_min_hit = 1
|
|
END IF
|
|
!
|
|
WRITE( UNIT = stdout, &
|
|
FMT = '(5X,"small trust_radius: resetting bfgs history",/)' )
|
|
!
|
|
CALL reset_bfgs( n, lfcp, fcp_hess )
|
|
step(:) = - ( inv_hess(:,:) .times. grad(:) )
|
|
!
|
|
nr_step_length = scnorm(step)
|
|
step(:) = step(:) / nr_step_length
|
|
!
|
|
trust_radius = min(trust_radius_min, nr_step_length )
|
|
!
|
|
ELSE
|
|
!
|
|
tr_min_hit = 0
|
|
!
|
|
END IF
|
|
!
|
|
END SUBROUTINE compute_trust_radius
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
REAL(DP) FUNCTION scnorm1( vect )
|
|
!-----------------------------------------------------------------------
|
|
IMPLICIT NONE
|
|
REAL(DP), INTENT(IN) :: vect(:)
|
|
!
|
|
scnorm1 = SQRT( DOT_PRODUCT( vect , MATMUL( metric, vect ) ) )
|
|
!
|
|
END FUNCTION scnorm1
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
REAL(DP) FUNCTION scnorm( vect )
|
|
!-----------------------------------------------------------------------
|
|
IMPLICIT NONE
|
|
REAL(DP), INTENT(IN) :: vect(:)
|
|
REAL(DP) :: ss
|
|
INTEGER :: i,k,l,n
|
|
INTEGER :: ndim
|
|
!
|
|
ndim = SIZE (vect)
|
|
!
|
|
scnorm = 0._DP
|
|
n = (ndim - 1) / 3
|
|
do i=1,n
|
|
ss = 0._DP
|
|
do k=1,3
|
|
do l=1,3
|
|
ss = ss + &
|
|
vect(k+(i-1)*3)*metric(k+(i-1)*3,l+(i-1)*3)*vect(l+(i-1)*3)
|
|
end do
|
|
end do
|
|
scnorm = MAX (scnorm, SQRT (ss) )
|
|
end do
|
|
!
|
|
ss = vect(ndim) * metric(ndim,ndim) * vect(ndim)
|
|
scnorm = MAX (scnorm, SQRT (ss) )
|
|
!
|
|
END FUNCTION scnorm
|
|
!
|
|
!------------------------------------------------------------------------
|
|
SUBROUTINE terminate_bfgs( energy, energy_thr, grad_thr, cell_thr, fcp_thr, &
|
|
lmovecell, lfcp, failed )
|
|
!------------------------------------------------------------------------
|
|
!
|
|
USE io_files, ONLY : delete_if_present
|
|
!
|
|
IMPLICIT NONE
|
|
REAL(DP), INTENT(IN) :: energy, energy_thr, grad_thr, cell_thr, fcp_thr
|
|
LOGICAL, INTENT(IN) :: lmovecell, lfcp, failed
|
|
!
|
|
IF ( conv_bfgs ) THEN
|
|
!
|
|
IF ( failed ) THEN
|
|
WRITE( UNIT = stdout, &
|
|
& FMT = '(/,5X,"bfgs failed after ",I3," scf cycles and ", &
|
|
& I3," bfgs steps, convergence not achieved")' ) &
|
|
& scf_iter, bfgs_iter
|
|
ELSE
|
|
WRITE( UNIT = stdout, &
|
|
& FMT = '(/,5X,"bfgs converged in ",I3," scf cycles and ", &
|
|
& I3," bfgs steps")' ) scf_iter, bfgs_iter
|
|
END IF
|
|
IF ( lmovecell ) THEN
|
|
WRITE( UNIT = stdout, &
|
|
& FMT = '(5X,"(criteria: energy < ",ES8.1," Ry, force < ",ES8.1,&
|
|
& " Ry/Bohr, cell < ",ES8.1," kbar)")') energy_thr, grad_thr, cell_thr
|
|
ELSE
|
|
WRITE( UNIT = stdout, &
|
|
& FMT = '(5X,"(criteria: energy < ",ES8.1," Ry, force < ",ES8.1,&
|
|
& " Ry/Bohr)")') energy_thr, grad_thr
|
|
END IF
|
|
!
|
|
IF ( lfcp ) THEN
|
|
WRITE( UNIT = stdout, &
|
|
& FMT = '(5X,"(criteria: force on FCP < ",ES8.1," eV)")') fcp_thr * RYTOEV
|
|
END IF
|
|
!
|
|
WRITE( UNIT = stdout, &
|
|
& FMT = '(/,5X,"End of BFGS Geometry Optimization")' )
|
|
WRITE( UNIT = stdout, &
|
|
& FMT = '(/,5X,"Final ",A," = ",F18.10," Ry")' ) fname, energy
|
|
!
|
|
CALL delete_if_present( bfgs_file )
|
|
bfgs_file = " "
|
|
!
|
|
ELSE
|
|
!
|
|
WRITE( UNIT = stdout, &
|
|
FMT = '(/,5X,"The maximum number of steps has been reached.")' )
|
|
WRITE( UNIT = stdout, &
|
|
FMT = '(/,5X,"End of BFGS Geometry Optimization")' )
|
|
!
|
|
END IF
|
|
!
|
|
END SUBROUTINE terminate_bfgs
|
|
!
|
|
FUNCTION bfgs_get_n_iter (what) RESULT(n_iter)
|
|
!
|
|
IMPLICIT NONE
|
|
INTEGER :: n_iter
|
|
CHARACTER(10),INTENT(IN) :: what
|
|
SELECT CASE (TRIM(what))
|
|
CASE ('bfgs_iter')
|
|
n_iter = bfgs_iter
|
|
CASE ( 'scf_iter')
|
|
n_iter = scf_iter
|
|
CASE default
|
|
n_iter = -1
|
|
END SELECT
|
|
END FUNCTION bfgs_get_n_iter
|
|
END MODULE bfgs_module
|