Chimie Théorique » OpenPath

SUBROUTINE Hinvup_DFP(Nfree,ds,dgrad,Hess)

  IMPLICIT NONE

  INTEGER, PARAMETER :: KINT=KIND(1)

  INTEGER, PARAMETER :: KREAL=KIND(1.D0)

  INTEGER(KINT), INTENT(IN) :: NFREE

  REAL(KREAL), INTENT(INOUT) :: Hess(Nfree,Nfree)

  REAL(KREAL), INTENT(IN) :: ds(Nfree)

  REAL(KREAL), INTENT(IN) :: dGrad(Nfree)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!

! This subroutine updates the inverse of the Hessian

! using a DFP formula.

!

! input:

!  - nfree: number of coordinates

!  - ds: GeomOld-Geom (expressed in the optimization coord.)

!  - dgrad: GradOld-Grad  (expressed in the optimization coord.)

!

!  input/output:

!  - Hess: old Hessian in input, replaced by updated Hessian on output

!

!  Notations for the formula:

! s=Geom-GeomOld

! y=Grad-GradOld

! W= (H)-1 ie the inverse matrix that we are updating

! W+=W + s(sT)/(s,y)-[Wy(yT)W]/(y,Wy)

!

! We decompose the computation in two steps:

! first we compute the update, and then we add it to Hess to get the

! new Hessian.

! This allows us to introduce a scaling factor if needed later.

!

!!!!!!!!!!!!!!!!

!

! Due to the dual properties, this routine is also called to compute

! the BFGS update for the Hessian

!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  REAL(KREAL), ALLOCATABLE  :: HessOld(:,:) , Wy(:)

  REAL(KREAL), ALLOCATABLE  :: Hup(:,:)

  REAL(KREAL), ALLOCATABLE  :: Num(:,:), Num2(:,:)

  REAL(KREAL) :: Den, Den2,NormDS

  INTEGER(KINT) :: i,j,k, Idx

  LOGICAL :: debug

  interface

     function valid(string) result (isValid)

       logical                  :: isValid

       character(*), intent(in) :: string

     end function valid

  end interface

  debug=valid("Hinvup_DFP").OR. Valid('HUPDATE')

  if (debug) WRITE(*,*) "=========================== Entering Hinvup_DFP ===================="

  ALLOCATE(HessOld(nfree,nfree), Hup(nfree,nfree), &

       Num(nfree,nfree), Num2(nfree,nfree),Wy(Nfree) )

  HessOld=Hess

  if (debug) THEN

     WRITE(*,*) 'DBG Hinvup_DFP HessOld'

     Idx=min(12,Nfree)

     DO I=1,NFree

        WRITE(*,'(12(1X,F8.4))') HessOld(I,1:Idx)

     END DO

     WRITE(*,*) 'DBG Hinvup_DFP ds'

     WRITE(*,'(12(1X,F8.4))') ds(1:Idx)

     WRITE(*,*) 'DBG Hinvup_DFP dGrad'

     WRITE(*,'(12(1X,F8.4))') dGrad(1:Idx)

  END IF

  NormDS=sqrt(DOT_PRODUCT(DS,DS))

  if (NormDS>=1e-6) THEN

     IF (debug) WRITE(*,*) 'NormDS=',NormDS

     IF (debug) WRITE(*,*) 'DS=',DS

     IF (debug) WRITE(*,*) 'DGrad=',DGrad

     ! We calculate the denominator (DGrad,DS)

     den=DOT_PRODUCT(DGrad,DS)

     if (debug) WRITE(*,*) "(y,s)=(yT)s",den

     ! We calculate Wy

     Wy=0

     DO I=1,nfree

        DO J=1,NFree

           Wy(I)=Wy(I)+HessOld(i,j)*DGrad(j)

        END DO

     END DO

     if (debug) WRITE(*,*) "Wy=",Wy

     ! We calculate Num=s(sT)

     Num=0.

     DO I=1,Nfree

        DO J=1,Nfree

           Num(I,J)=ds(i)*Ds(j)

        END DO

     END DO

     if (debug) THEN

        WRITE(*,*) "s(sT)"

        DO I=1,NFree

           WRITE(*,*) Num(I,:)

        END DO

     END if

     ! We calculate Num2=Wy(WyT)

     Num2=0

     Do I=1,NFree

        DO J=1,NFree

             Num2(I,J)=Wy(i)*Wy(j)

        END DO

     END DO

     if (debug) THEN

        WRITE(*,*) "Wy(WyT)"

        DO I=1,NFree

           WRITE(*,*) Num2(I,:)

        END DO

     END if

! we calculate den=(sT)y

     den=DOT_PRODUCT(ds,dgrad)

! we calculate den2=(yT)Wy

     den2=DOT_PRODUCT(dgrad,Wy)

     if (debug) THEN

        WRITE(*,*) "(sT)y,(yT)Wy ",den,den2

     END if

     !We add everything

     Hup=Num/den-Num2/den2

     Hess=HessOld+Hup

     if (debug) THEN

        WRITE(*,*) 'DBG Hinvup_DFP Hup'

        Idx=min(12,Nfree)

        DO I=1,NFree

           WRITE(*,'(12(1X,F8.4))') Hup(I,1:Idx)

        END DO

        WRITE(*,*) 'DBG Hinvup_DFP Hess new'

        Idx=min(12,Nfree)

        DO I=1,NFree

           WRITE(*,'(12(1X,F8.4))') Hess(I,1:Idx)

        END DO

     END IF

  ELSE

     Hess=HessOld

  END IF

  DEALLOCATE(HessOld, Wy, Hup, Num, Num2 )

  if (debug) WRITE(*,*) "=========================== Hinvup_DFP Over ===================="

END SUBROUTINE Hinvup_DFP