subroutine bfgs (YD_PIN,YD_POUT,YD_PSY,kpdim,kp,kip)

!-----------------------------------------------------------------------

!   *BFGS*   - Applies the BFGS matrix

!   Purpose
!   -------
!        Applies the BFGS preconditioner matrix. Called by the
!        preconditioned CG routine PCGBFGS.

!   Interface
!   ---------
!        CALL BFGS (pin,pout,psy,kpdim,kp,kip)

!   Explicit Arguments
!   ------------------
!                       pin  - input vector.
!                       pout - output vector.
!                       psy  - circular array holding s and y vectors.
!                       kpdim - the first dimension of psy.
!                       kp    - the number of (s,y) pairs.
!                       kip   - the index of the latest pair in psy.

!        Implicit arguments :
!        --------------------
!        None

!     Method.
!     -------
!        See Nocedal, J., 1980 "Updataing quasi-Newton matrices with
!            limited storage", Maths of Computation, 1980, vol 35,
!            no 151, pp773-782

!     Externals.
!     ----------
!          DISTRIBUTED_VECTORS_MIX

!     Reference.
!     ----------
!     See documentation

!     Author.
!     -------
!        Mike Fisher *ECMWF*

!     Modifications.
!     --------------
!        Original : 97-11-14
!        02-08-08 Y.Tremolet   Use control_vectors.
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        O.Spaniel     Oct-2004 cleaning AL29
!-----------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

USE CONTROL_VECTORS
USE YOMVAR, ONLY : LMPCGL

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KPDIM
INTEGER(KIND=JPIM),INTENT(IN)    :: KP
INTEGER(KIND=JPIM),INTENT(IN)    :: KIP
TYPE(CONTROL_VECTOR),INTENT(IN)    :: YD_PIN 
TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_POUT 
TYPE(CONTROL_VECTOR),INTENT(IN)    :: YD_PSY(KPDIM,2) 
REAL(KIND=JPRB)    :: zr
INTEGER(KIND=JPIM) :: i,j
REAL(KIND=JPRB), DIMENSION(kp) :: zalpha
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "precond.intfb.h"

IF (LHOOK) CALL DR_HOOK('BFGS',0,ZHOOK_HANDLE)
YD_POUT = YD_PIN

i=kip
do j=kp,1,-1
  zr = DOT_PRODUCT(YD_PSY(i,1),YD_POUT)
  YD_POUT%data = YD_POUT%data - zr * YD_PSY(i,2)%data
  zalpha(j) = zr
  i=i-1
  if (i == 0) i=kpdim
enddo

if (lmpcgl) then
  call precond(YD_POUT,-1)
endif

do j=1,kp
  i = 1+mod(i,kpdim)
  zr = zalpha(j)-DOT_PRODUCT(YD_POUT,YD_PSY(i,2))
  YD_POUT%data = YD_POUT%data + zr * YD_PSY(i,1)%data
enddo

IF (LHOOK) CALL DR_HOOK('BFGS',1,ZHOOK_HANDLE)
END SUBROUTINE bfgs
