subroutine pcgbfgs (YD_PX,YD_PRHS,kmaxiter,pgreduc,YD_PSY,kpdim,knp,kip)

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

!  *PCGBFGS* - Solves OPM(px)=prhs

!  Purpose
!  -------
!      To solve OPM(px)=prhs using preconditioned conjugate gradients.
!      Preconditioning is done using the BFGS method.

!  Interface
!  ---------
!      CALL pcgbfgs (px,prhs,kmaxiter,pgreduc,
!    +               psy,kpdim,knp,kip)

!  Explicit Arguments
!   ------------------
!            px      = first guess at solution
!            prhs    = right hand sides
!            kmaxiter = maximum number of iterations to be performed
!            pgreduc = required reduction in residual norm
!            psy     = array to hold BFGS pairs
!            kpdim   = maximum nuber of BFGS pairs
!            knp      = number of BFGS pairs
!                     (set to 0 first call, leave untouched thereafter)
!            kip      = index of last BFGS pair
!                     (set to 0 first call, leave untouched thereafter)

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

!     Method.
!     -------
!        Generalized conjugate gradients with variable preconditioner.
!        (Algorithm 5(a) on page 549 of "Iteratve Solution Methods",
!         Axelsson (1994) Cambridge University Press.)

!     Externals.
!     ----------
!          DISTRIBUTED_VECTORS_MIX
!          OPM
!          BFGS
!          ABOR1

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

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

!     Modifications.
!     --------------
!        Original : 97-11-14
!        Y.Tremolet   02-08-08  Use control_vectors.
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Hamrud      01-Dec-2003 CY28R1 Cleaning
!-----------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMLUN   , ONLY : NULOUT
USE CONTROL_VECTORS

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KPDIM 
TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_PX 
TYPE(CONTROL_VECTOR),INTENT(IN)    :: YD_PRHS 
INTEGER(KIND=JPIM),INTENT(IN)    :: KMAXITER 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PGREDUC 
TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_PSY(KPDIM,2) 
INTEGER(KIND=JPIM),INTENT(INOUT) :: KNP 
INTEGER(KIND=JPIM),INTENT(INOUT) :: KIP
 
TYPE(control_vector) :: YL_ZR,YL_ZW
TYPE(control_vector), DIMENSION(0:kmaxiter) :: YL_ZD,YL_ZG

INTEGER(KIND=JPIM) :: j,iter
REAL(KIND=JPRB)    :: zrok,zdot,zalpha,zps,zbeta
REAL(KIND=JPRB)    :: zgamma(0:kmaxiter)
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"
#include "bfgs.intfb.h"
#include "opm.intfb.h"

IF (LHOOK) CALL DR_HOOK('PCGBFGS',0,ZHOOK_HANDLE)
call ALLOCATE_CTLVEC(YL_ZD(0))
call ALLOCATE_CTLVEC(YL_ZG(0))
call ALLOCATE_CTLVEC(YL_ZR)
call ALLOCATE_CTLVEC(YL_ZW)

if (DOT_PRODUCT (YD_PX,YD_PX)  /=  0.0_JPRB) then
  call opm (YD_PX,YL_ZR)
  YL_ZR%data = YL_ZR%data - YD_PRHS%data
else
  YL_ZR%data = -YD_PRHS%data
endif

zrok = DOT_PRODUCT(YL_ZR,YL_ZR)
write (NULOUT,*) 'pcgbfgs: initial residual=',zrok
zrok = pgreduc*pgreduc*zrok

YL_ZD(0)%data = -YL_ZR%data

iter=1
iter_loop: DO
  call opm(YL_ZD(iter-1),YL_ZG(iter-1))
  zgamma(iter-1) = DOT_PRODUCT(YL_ZD(iter-1),YL_ZG(iter-1))

  zalpha = -DOT_PRODUCT(YL_ZR,YL_ZD(iter-1))/zgamma(iter-1)

  knp = min(kpdim,knp+1)
  kip = 1+mod(kip,kpdim)
  YD_PSY(kip,1) = YD_PX
  YD_PSY(kip,2) = YL_ZR

  YD_PX%data = YD_PX%data + zalpha*YL_ZD(iter-1)%data
  YL_ZR%data = YL_ZR%data + zalpha*YL_ZG(iter-1)%data

  zdot = DOT_PRODUCT(YL_ZR,YL_ZR)
  write (NULOUT,*) 'pcgbfgs: iteration ',iter,' residual=',zdot

  YD_PSY(kip,1)%data = YD_PX%data - YD_PSY(kip,1)%data
  YD_PSY(kip,2)%data = YL_ZR%data - YD_PSY(kip,2)%data
  zps = DOT_PRODUCT(YD_PSY(kip,1),YD_PSY(kip,2))
  if (zps <= 0.0_JPRB) then
    write (NULOUT,*) 'pcgbfgs error: zps=',zps
    call ABOR1('pcgbfgs: negative zps')
  endif
  zps = 1.0_JPRB/SQRT(zps)
  YD_PSY(kip,1)%data = zps*YD_PSY(kip,1)%data
  YD_PSY(kip,2)%data = zps*YD_PSY(kip,2)%data

  if (iter >= kmaxiter .or. DOT_PRODUCT(YL_ZR,YL_ZR)  <=  zrok) EXIT

  call bfgs (YL_ZR,YL_ZW,YD_PSY,kpdim,knp,kip)

  call ALLOCATE_CTLVEC(YL_ZD(iter))
  call ALLOCATE_CTLVEC(YL_ZG(iter))

  YL_ZD(iter)%data = -YL_ZW%data

  do j=0,iter-1
    zbeta = DOT_PRODUCT(YL_ZW,YL_ZG(j))/zgamma(j)
    YL_ZD(iter)%data = YL_ZD(iter)%data + zbeta*YL_ZD(j)%data
  enddo

  iter = iter+1
ENDDO iter_loop

do j=iter-1,0,-1
  call DEALLOCATE_CTLVEC(YL_ZG(j))
  call DEALLOCATE_CTLVEC(YL_ZD(j))
enddo
call DEALLOCATE_CTLVEC(YL_ZW)
call DEALLOCATE_CTLVEC(YL_ZR)

IF (LHOOK) CALL DR_HOOK('PCGBFGS',1,ZHOOK_HANDLE)
END SUBROUTINE pcgbfgs
