SUBROUTINE JACDAV( PRITZ, YD_PV, KEIG, KSTART, KEQ, KINNER,&
 & KITER, PEPS, YD_PAV, YD_PBV)  

!**********************************************************************

!**** *JACDAV*   - Routine to solve generalized eigenproblem

!     Purpose.
!     --------
!        Solves generalized eigenproblem OPK(x)=c OPM(x)

!**   Interface.
!     ----------
!        *CALL* *JACDAV( PRITZ, PV, KEIG, KSTART, KEQ, KINNER,
!     $                  KITER, PEPS, PAV, PBV)

!        Explicit arguments :
!        --------------------
!        PRITZ  : PRITZ values
!        KEIG  : Number of converged eigenpairs
!        KINNER : Number of inner loops
!        KITER : Number of outer loops
!        PAV    : Eigenvectors
!        PEPS   : Accuracy level

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

!     Method.
!     -------
!        See documentation

!     Externals.
!     ----------
!     None

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

!     Author.
!     -------
!        Martin van Gijzen *Utrecht University*

!     Modifications.
!     --------------
!        Original : 95-10-5
!        Update   : 95-10-23 Martin van Gijzen
!        97-11-26 : Mike Fisher - USE DISTRIBUTED_VECTORS_MIX
!        97-11-26 : Mike Fisher - Use pcgbfgs for the inner problem
!        97-12-05 : Mike Fisher - Use precond to precondition
!        02-08-08 : Y.Tremolet  - Use control_vectors.
!**********************************************************************
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Hamrud      01-Dec-2003 CY28R1 Cleaning

! Solve generalized eigensystem with the Jacobi-Davidson method
! of Sleijpen and van der Vorst

! input parameters: KSTART - number of vectors in start-space
!                   KEQ    - NMAX, dimension of problem
!                   KEIG   - number of wanted eigenpairs
!                   PEPS    - tolerance, relative residual norm
!                               |Ax - eBx|/|Ax0 - e0 Bx0|
!                   KINNER  - Number of inner iterations to solve 
!                               Jacobian system
!                   KITER  - maximum number of outer iterations

! On input the first KSTART columns of PV must be filled with 
! basis-vectors for an initial space
! On output, the largest KEIG eigenvectors are written to disk in 
! descending order, the corresponding eigenvalues are stored in 
! the array PRITZ
! On output the parameter KEIG contains the number of converged 
! eigenpairs
!**********************************************************************

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMMSC   , ONLY : N_DEFAULT_REAL_KIND, N_DOUBLE_KIND
USE YOMLCZ   , ONLY : MEMBFGS  ,GREDBFGS
USE YOMCVA   , ONLY : YSCALP
USE YOMLUN   , ONLY : NULOUT   ,NULUSR4  ,NULERR
USE CONTROL_VECTORS

IMPLICIT NONE
INTEGER(KIND=JPIM)  ,INTENT(INOUT) :: KITER
REAL(KIND=JPRB)     ,INTENT(OUT)   :: PRITZ(KITER) 
TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_PV(KITER) 
INTEGER(KIND=JPIM)  ,INTENT(INOUT) :: KEIG 
INTEGER(KIND=JPIM)  ,INTENT(IN)    :: KSTART 
INTEGER(KIND=JPIM)  ,INTENT(IN)    :: KEQ
INTEGER(KIND=JPIM)  ,INTENT(IN)    :: KINNER 
REAL(KIND=JPRB)     ,INTENT(IN)    :: PEPS 
TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_PAV(KITER) 
TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_PBV(KITER) 
REAL(KIND=JPRB) ::             ZEI,&
 & ZWORK(KEQ,3), ZHES1(KITER,KITER), &
 & ZHESS1(KITER,KITER), ZRV(KITER,KITER),&
 & ZRITZVL(KITER)  

TYPE(control_vector)                   :: YL_ZR,YL_ZEIVEC,YL_ZBEIVEC

!...     blas:
REAL(KIND=JPRB) ::             ZR0, ZRN
INTEGER(KIND=JPIM) ::          INFO, ITS, IEIG, IL

LOGICAL ::          LLDOIN

!...     Local variables:
!...        ieig: number of converged eigenpairs

EXTERNAL OPK,OPM
TYPE(control_vector), DIMENSION(MEMBFGS,2) :: YL_ZSY

INTEGER(KIND=JPIM) :: i, inp, ip, J, J1, J2, JA
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"
#include "pcgbfgs.intfb.h"

#include "mortho.h"

IF (LHOOK) CALL DR_HOOK('JACDAV',0,ZHOOK_HANDLE)
DO i=1,MEMBFGS
  call ALLOCATE_CTLVEC(YL_ZSY(i,1))
  call ALLOCATE_CTLVEC(YL_ZSY(i,2))
ENDDO

call ALLOCATE_CTLVEC(YL_ZR)
call ALLOCATE_CTLVEC(YL_ZEIVEC)
call ALLOCATE_CTLVEC(YL_ZBEIVEC)

!...     Compute M-orthogonal basis pv for the initial KSTART vectors,
!...     Also compute pav and pbv

DO J = 1, KSTART
  CALL MORTHO(OPK,OPM,KITER,J,NULERR,YD_PV,YD_PAV,YD_PBV,ZHES1)
ENDDO

ITS = KSTART-1

!...     Initialization completed, start outer iteration loop
IEIG = 0
ZRN = 1.0_JPRB
ZR0 = 1.0_JPRB
LLDOIN = .TRUE.
ip=0
inp=0

!...     Begin of outer iteration loop

OUT_IT:DO
  LLDOIN=.TRUE.

  ITS = ITS + 1

!...        Copy projected matrices:
  DO J1 = 1, ITS
    DO J2 = 1, J1
      ZHESS1(J1,J2) = ZHES1(J2,J1)
    ENDDO
  ENDDO

!...        Compute Ritzvalues/vector

  IF (JPRB == N_DEFAULT_REAL_KIND) THEN
    CALL SSYEV ('V','L',ITS,ZHESS1,KITER,ZRITZVL,ZWORK,3*KEQ,INFO)
  ELSEIF (JPRB == N_DOUBLE_KIND) THEN
    CALL DSYEV ('V','L',ITS,ZHESS1,KITER,ZRITZVL,ZWORK,3*KEQ,INFO)
  ELSE
    CALL ABOR1 ('REAL(KIND=JPRB) is neither default real nor double precision')
  ENDIF
  
  IF ( INFO  /=  0 ) THEN
    WRITE(NULOUT,*) ' SSYEV/DSYEV failed with info=',info
    CALL ABOR1 ('JACDAV: SSYEV/DSYEV failed to solve eigensystem')
  ENDIF
  
  ZRV(1:ITS,1:ITS) = ZHESS1(1:ITS,1:ITS)
  
  WRITE(NULOUT,*) 'INTERMEDIATE SPECTRUM, ITS =',ITS
  DO J=1,ITS
    WRITE(NULOUT,201) J,ZRITZVL(J)
    WRITE(NULUSR4,201) J,ZRITZVL(J)
  ENDDO
  WRITE(NULUSR4,*)
201 FORMAT(I3,1X,E20.12)

  IL = ITS - IEIG
  ZEI = ZRITZVL(IL)

!...        Compute the Ritzvector:
  YL_ZEIVEC  = 0.0_JPRB
  YL_ZBEIVEC = 0.0_JPRB
  DO J1 = 1, ITS
    YL_ZEIVEC%data  = YL_ZEIVEC%data + YD_PV(J1)%data  * ZRV(J1,IL)
    YL_ZBEIVEC%data = YL_ZBEIVEC%data+ YD_PBV(J1)%data * ZRV(J1,IL)
  ENDDO

!...        compute the residual:

  YL_ZR%data = -ZEI * YL_ZBEIVEC%data
  WHERE (YSCALP%data==0.0_JPRB) YL_ZR%data=0.0_JPRB

  DO J1 = 1, ITS
    YL_ZR%data = YL_ZR%data + YD_PAV(J1)%data * ZRV(J1,IL)
    WHERE (YSCALP%data==0.0_JPRB) YL_ZR%data=0.0_JPRB
  ENDDO

  ZRN = SQRT(DOT_PRODUCT(YL_ZR,YL_ZR))

  IF ( ITS  ==  KSTART ) THEN
    IF ( ZR0  >  0.0_JPRB ) ZR0 = 1.0_JPRB/ZRN
  ENDIF

!...        If convergence is starting, do inner iterations

!...        Eigenpair satisfies criterion?
  IF ( ZRN*ZR0  <  PEPS ) THEN
    LLDOIN = .TRUE.
    IEIG = IEIG + 1
    PRITZ(IEIG) = ZEI
    WRITE(NULOUT,*) ' CONVERGED EIGENVALUE: ', ZEI
    WRITE(NULOUT,*) ' ITS ', ITS, ' ZRN ', ZRN

    IF ( IEIG  <  KEIG ) THEN

!...               Compute new Ritzvector:
      IL = ITS - IEIG
      ZEI = ZRITZVL(IL)

!...              Compute the Ritzvector:
      YL_ZEIVEC  = 0.0_JPRB
      YL_ZBEIVEC = 0.0_JPRB
      DO J1 = 1, ITS
        YL_ZEIVEC%data  = YL_ZEIVEC%data  + YD_PV(J1)%data  * ZRV(J1,IL)
        YL_ZBEIVEC%data = YL_ZBEIVEC%data + YD_PBV(J1)%data * ZRV(J1,IL)
      ENDDO

    ELSE

!...              All wanted eigenpairs are found
      EXIT OUT_IT
    ENDIF
  ENDIF
  WRITE(NULOUT,*) ZRN*ZR0, ZEI, LLDOIN

!...        Too many iterations?
  IF ( ITS  ==  KITER ) THEN
    WRITE(NULOUT,*) ' ONLY ', IEIG, ' EIGENPAIRS CONVERGED '
    EXIT OUT_IT
    
  ENDIF

!...        Solve Jacobian system:
  IF ( .NOT. LLDOIN .OR. KINNER  ==  0 ) THEN
    YD_PV(ITS+1) = YL_ZR
  ELSE
    WRITE(NULOUT,*) 'PERFORMING INNER ITERATIONS'

!mf     ZWORK(:,1) = ZR
!mf     ZWORK(:,2) = PV(ITS+1)
!mf     CALL GCR( ZWORK(:,1), ZV, KEQ, KINNER )
!mf     PV(ITS+1) = ZWORK(:,2)

    YD_PV(ITS+1) = 0.0_JPRB
    call pcgbfgs (YD_PV(ITS+1),YL_ZR,KINNER,GREDBFGS,YL_ZSY,MEMBFGS,inp,ip)

!C      NWOOD=3
!C      ZWORK(:,1) = ZR
!C      ZWORK(:,2) = PV(ITS+1)
!C      CALL WOOD(KEQ, ZWORK(:,1), ZV, NWOOD)
!C      PV(ITS+1) = ZWORK(:,2)
  ENDIF

  WRITE(NULOUT,*) 'ITS JACDAV= ',ITS

!...        M-Orthogonalize the new basis vector:
  CALL MORTHO(OPK,OPM,KITER,ITS+1,NULERR,YD_PV,YD_PAV,YD_PBV,ZHES1)

ENDDO OUT_IT

KEIG = IEIG
KITER= ITS

IF(KEIG < 3) THEN

!jan  in case no convergence has reached yet

  IEIG=MIN(3,ITS)
  KEIG=IEIG

ENDIF

!...     Maybe better approximations for the eigenvalues/vectors
!...     are wanted. If so, uncomment the folowing lines.
!...     the eigenvectors are stored in the array pav, on the
!...     places 1-ieig. If all Ritzpairs are wanted, change the
!...     ieig's into its
!...

DO J1 = 1, ITS
  IL = ITS - J1 + 1
  PRITZ(J1) = ZRITZVL(IL)
  YD_PAV(J1) = 0.0_JPRB
  DO JA = 1, ITS
    YD_PAV(J1)%data = YD_PAV(J1)%data + YD_PV(JA)%data * ZRV(JA,IL)
  ENDDO

!...        The eigenvectors can be B-reorthogonalized here

ENDDO

call DEALLOCATE_CTLVEC (YL_ZR)
call DEALLOCATE_CTLVEC (YL_ZEIVEC)
call DEALLOCATE_CTLVEC (YL_ZBEIVEC)

DO i=1,MEMBFGS
  call DEALLOCATE_CTLVEC (YL_ZSY(i,1))
  call DEALLOCATE_CTLVEC (YL_ZSY(i,2))
ENDDO

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