subroutine CONGRAD (YD_PX,YD_PGRAD,YD_PLANC1,preduc,pkappa,kmaxit,kmaxevecs,&
                  & kminit,pgolubu_inv,pgolubl_inv,pgolubu_log,pgolubl_log, &
                  & YDCGLWK,pwork, &
                  & ldevecs,ldsolve,LD_LGOLUB,LD_INFO_CONVERGENCE)  

!-----------------------------------------------------------------------
!   CONGRAD - Lanczos algorithm linear equation and eigenvalue solver

!   Purpose. Simultaneously minimizes the cost function and determines
!   -------- some of the eigenvalues and eigenvectors of its Hessian.

!   Interface.
!   ----------
!      CALL CONGRAD (px,pgrad,planc1,preduc,pkappa,kmaxit,pgolubu_inv,pgolubl_inv,&
!                  & ldevecs,ldsolve)

!      Explicit arguments: 

!      Inputs: px           -- guess at the vector which minimizes the cost.
!              pgrad        -- gradient of then cost function at initial 'px'.
!              planc1       -- Initial Lanczos vector
!              preduc       -- required reduction in gradient norm,
!                              or dfi-per-iteration if ld_info_convergence.
!              pkappa       -- required precision for eigenvectors.
!              kmaxit       -- iteration stops if number of iterations
!                              exceeds this value.
!              kmaxevecs    -- iteration stops when this number of eigenpairs have converged
!              kminit       -- minimum number of iterations to be performed,
!                              regardless of the convergence criterion.
!                              (Note: if kminit>kmaxit then only kmaxit
!                               iterations will be performed.)
!              ldevecs      -- calculate eigenvectors?
!              ldsolve      -- Solve the linear equation J"(x-x_0)=planc1.
!                              To minimize the cost function, set planc1=-grad(J(x_0))
!              lgolub       -- calculate bounds on d=N-(planc1)'(J'')^-1 planc1
!                              and S=-(planc1)' log_2[(J'')^-1] planc1 /2 ?
!              ld_info_convergence -- use information-based convergence
!                              criterion. Convergence is deemed to have occured
!                              when the relative change in the norm of the solution
!                              vector n one iteration is less than preduc. (In
!                              the un-preconditioned case, the length of the
!                              solution vector is equal to the degrees of
!                              freedom for signal.
!      Outputs: px          -- improved guess at the vector which minimizes
!                              the cost.
!               pgrad       -- estimate of the gradient of the cost function at final 'px'.
!               preduc      -- achieved estimated reduction in gradient norm,
!                              or dfi-per-iteration
!               pgolubu_inv -- upper bound for: N - (planc1)' (J'')^-1 planc1
!               pgolubl_inv -- lower bound for: N - (planc1)' (J'')^-1 planc1
!               pgolubu_log -- upper bound for: -(planc1)' log_2[(J'')^-1] planc1 /2
!               pgolubl_log -- lower bound for: -(planc1)' log_2[(J'')^-1] planc1 /2
!               kmaxit      -- the number of iterations actually performed
!               kmaxevecs   -- the number of eigenpairs actually converged

!      Implicit input:  SCALP from YOMCVA

!      Implicit output: eigenvalues and eigenvectors are written by wrevecs to
!                       RCGLEV and YVCGLEV in module YOMVCGL

!   Externals.   SIM4D (or OPK)
!   ----------   SSTEQR/DSTEQR (LAPACK eigen-decomposition routine)
!                SPTSV/DPTSV   (LAPACK symmetric tri-diagonal solver)
!                PRECOND
!                WREVECS
!                ABOR1

!   Reference.
!   ----------
!       None yet!

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

!   Modifications.
!   --------------
!       Original      94/04/19
!       M. Fisher:    95/09/20   Reorganized code
!       M. Fisher:    96/05/16   Orthogonalize every iteration
!       M. Fisher:    96/08/01   Optionally keep vectors in memory
!       E. Andersson  96/08/01   Pre-calculated SQRT(SCALP)
!       M. Fisher:    97/08/05   Change orthogonalization and f90ize
!       M. Fisher:    97/11/26   USE DISTRIBUTED_VECTORS_MIX
!       M. Fisher:    99/01/12   Generalized Cross Validation
!       Y.Tremolet:   02-08-05   Use control_vectors.
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Hamrud      01-Dec-2003 CY28R1 Cleaning
!        M.Fisher     17-Mar-2004 Optimizations (OpenMP and loop unrolling)
!        M.Fisher     04-Mar-2005 Added L_CHECK_GRADIENT
!        Y.Tremolet   22-Feb-2008 Added YDCGLWK,pwork as arguments
!        D.Dee        04-Mar-2008 Added VarBC gradient diagnostics
!       R. El Khatib  19-Sep-2007 Add a missing PARALLEL directive for OMP

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

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMCT0   , ONLY : NCONF
USE YOMCT0B  , ONLY : LECMWF
USE YOMCVA   , ONLY : YSCALPSQRT, YRSCALPSQRT
USE YOMVAR   , ONLY : LMPCGL, L_OPENMP_CV, L_CHECK_GRADIENT, RTOL_CHECK_GRADIENT, LVARBC
USE YOMLUN   , ONLY : NULOUT
USE YOMLCZ   , ONLY : XMIN_RITZ
USE YOMMSC   , ONLY : N_DEFAULT_REAL_KIND, N_DOUBLE_KIND
USE VARBC_SETUP, ONLY : YVARBC, NOBGROUP    
USE CONTROL_VECTORS, ONLY : CONTROL_VECTOR, ALLOCATE_CTLVEC, DEALLOCATE_CTLVEC, DOT_PRODUCT, &
                          & ASSIGNMENT(=)

IMPLICIT NONE

TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_PX 
TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_PGRAD 
TYPE(CONTROL_VECTOR),INTENT(IN)    :: YD_PLANC1 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PREDUC 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PKAPPA 
INTEGER(KIND=JPIM),INTENT(INOUT) :: KMAXIT 
INTEGER(KIND=JPIM),INTENT(INOUT) :: KMAXEVECS 
INTEGER(KIND=JPIM),INTENT(IN)    :: KMINIT 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PGOLUBU_INV 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PGOLUBL_INV 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PGOLUBU_LOG 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PGOLUBL_LOG 
LOGICAL           ,INTENT(IN)    :: LDEVECS 
LOGICAL           ,INTENT(IN)    :: LDSOLVE 
LOGICAL           ,INTENT(IN)    :: LD_LGOLUB 
LOGICAL           ,INTENT(IN)    :: LD_INFO_CONVERGENCE
TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YDCGLWK(kmaxit+1)
REAL(KIND=JPRB), INTENT(OUT) :: pwork(kmaxit+1,4)
REAL(KIND=JPRB) :: zbeta(2:kmaxit+1),zdelta(kmaxit),zv(kmaxit+1,kmaxit+1),&
 & zbnds(kmaxit),zritz(kmaxit+1),zwork(kmaxit+1,4),ztheta(kmaxit),&
 & zqg0(kmaxit+1),zdummy, zsstwrk(2*kmaxit)  

REAL(KIND=JPRB) :: Z_DLA, ZTOL,Z_DLAV(kmaxit+1)

type(control_vector) ::YL_ZX0,YL_ZGRAD0,YL_ZW,YL_ZLANC1

LOGICAL :: ll_inv_ok, ll_log_ok

INTEGER(KIND=JPIM) :: i, idum, indic, ing, ingood, idprob, iter, itheta1, j, jm, imaxevecs, &
                    & ji, istart, jj
INTEGER(KIND=JPIM) :: ibeg, iend, incount, inparam

REAL(KIND=JPRB) ::   zbndlm, zeta, zgnorm, znorm2l1, zreqrd, ztheta1, za, &
 & zl_inv, zu_inv, zl_log, zu_log, zdfi, zdfi_old
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"
#include "opk.intfb.h"
#include "precond.intfb.h"
#include "predict_runtime.intfb.h"
#include "sim4d.intfb.h"
#include "wrevecs.intfb.h"
#include "write_ctlvec_grib.intfb.h"

IF (LHOOK) CALL DR_HOOK('CONGRAD',0,ZHOOK_HANDLE)
write (NULOUT,*) '---- Lanczos Solver ----'

idprob = YD_PX%nsizeg

!--- allocate distributed storage

call allocate_ctlvec(YL_ZX0)
call allocate_ctlvec(YL_ZGRAD0)
call allocate_ctlvec(YL_ZW)
call allocate_ctlvec(YL_ZLANC1)

!--- 'zeta' is an upper bound on the relative error of the gradient.

zeta  = 1e-4_JPRB

zreqrd = preduc

zdfi = 0.0

!--- change of variable to account for scalar product and preconditioning

YD_PX%data = YD_PX%data * YSCALPSQRT%data

if (LMPCGL) call precond(YD_PX,+2)

!--- (Note: the factor 0.5 below is because sim4d defines the cost
!---  function to be J = transpose(chi)*(chi) + 2*Jo, which makes
!---  J''b = 2I, whereas CONGRAD defines J to be half of this value,
!---- so that J''b = I.)

! account for 1/2 J
YD_PGRAD%data = YD_PGRAD%data * YSCALPSQRT%data
YL_ZLANC1%data =  YD_PLANC1%data * YSCALPSQRT%data
zgnorm  = SQRT( DOT_PRODUCT (YL_ZLANC1,YL_ZLANC1))

IF ((.NOT. LECMWF) .AND. (NCONF == 601) .AND. (zgnorm == 0.0_JPRB)) THEN
    WRITE (NULOUT,*) "INFO : zgnorm set to 1.0 to avoid opt. problem"
    zgnorm = 1.0_JPRB
ENDIF

if (ldsolve) then
  write (NULOUT,'('' GREPMIN: Starting point : Estimated gradient norm='',1X,E22.16,1X,Z17)') &
   & zgnorm, zgnorm  
endif

if (lvarbc) then
  ! store initial gradient w/r to the varbc bias parameters, for diagnostics
  ibeg = 1
  do i = 1, nobgroup
    incount = yvarbc(i)%ncount
    inparam = yvarbc(i)%nparam
    iend = ibeg + inparam - 1
    if (incount/=0) yvarbc(i)%agrad0(1:inparam) = yd_pgrad%params(ibeg:iend)
    ibeg = iend + 1
  enddo
endif

if (LMPCGL) call precond(YD_PGRAD,-2)
if (LMPCGL) call precond(YL_ZLANC1,-2)

YDCGLWK(1)%data = -YL_ZLANC1%data 
znorm2l1 = DOT_PRODUCT(YDCGLWK(1),YDCGLWK(1))
YDCGLWK(1)%data = YDCGLWK(1)%data / SQRT(znorm2l1)

write (NULOUT,'('' GREPMIN: Starting point : scalar product znorm2l1='',1X,E22.16)') &
   & znorm2l1

!--- save initial control vector and gradient

YL_ZGRAD0 = YD_PGRAD
YL_ZX0    = YD_PX

zqg0(1) = DOT_PRODUCT (YDCGLWK(1),YL_ZLANC1)

!--- Start timer

IF(NCONF == 131) CALL PREDICT_RUNTIME (0,KMAXIT,preduc,zreqrd)

!--- Lanczos iteration starts here

ingood = 0
iter   = 1
Lanczos_loop : DO

!--- evaluate the Hessian applied to the latest Lanczos vector

  CALL GSTATS(1233,0)
! YL_ZW%data = YL_ZX0%data + YDCGLWK(iter)%data
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jj)
  do jj=1,YL_ZW%nsizel
    YL_ZW%data(jj) = YL_ZX0%data(jj) + YDCGLWK(iter)%data(jj)
  enddo
!$OMP END PARALLEL DO
  CALL GSTATS(1233,1)

  if (LMPCGL) call precond(YL_ZW,-2)

  if (NCONF == 131) then
    CALL GSTATS(1233,0)
!   YL_ZW%data = YL_ZW%data * YRSCALPSQRT%data
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jj)
    do jj=1,YL_ZW%nsizel
      YL_ZW%data(jj) = YL_ZW%data(jj) * YRSCALPSQRT%data(jj)
    enddo
!$OMP END PARALLEL DO
    CALL GSTATS(1233,1)
    idum = -999
    indic = 4
    call sim4d(indic,idum,YL_ZW,zdummy,YD_PGRAD,iter)
    CALL GSTATS(1233,0)
!   YD_PGRAD%data = 0.5_JPRB * YD_PGRAD%data * YSCALPSQRT%data
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jj)
    do jj=1,YD_PGRAD%nsizel
      YD_PGRAD%data(jj) = YD_PGRAD%data(jj) * YSCALPSQRT%data(jj)
    enddo
!$OMP END PARALLEL DO
    CALL GSTATS(1233,1)
  else
    call OPK (YL_ZW,YD_PGRAD)
  endif

  if (LMPCGL) call precond(YD_PGRAD,-2)

  CALL GSTATS(1233,0)
! YD_PGRAD%data = YD_PGRAD%data - YL_ZGRAD0%data
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jj)
  do jj=1,YD_PGRAD%nsizel
    YD_PGRAD%data(jj) = YD_PGRAD%data(jj) - YL_ZGRAD0%data(jj)
  enddo
!$OMP END PARALLEL DO
  CALL GSTATS(1233,1)

!--- calculate zdelta

  zdelta(iter) = DOT_PRODUCT (YDCGLWK(iter),YD_PGRAD)

  if (zdelta(iter) <= 0.0_JPRB) then
    write(NULOUT,*)'congrad stopping: J" not positive definite',zdelta(iter)
    iter = iter-1
    EXIT Lanczos_loop
  endif

!--- Calculate the new Lanczos vector (This is the Lanczos recurrence)

  CALL GSTATS(1233,0)
! YD_PGRAD%data = YD_PGRAD%data - zdelta(iter) * YDCGLWK(iter)%data
! if (iter > 1) YD_PGRAD%data = YD_PGRAD%data -zbeta(iter) * YDCGLWK(iter-1)%data
  if(iter <= 1 ) then
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jj)
    do jj=1,YD_PGRAD%nsizel
      YD_PGRAD%data(jj) = YD_PGRAD%data(jj) - zdelta(iter) * YDCGLWK(iter)%data(jj)
    enddo
!$OMP END PARALLEL DO
  else
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jj)
    do jj=1,YD_PGRAD%nsizel
      YD_PGRAD%data(jj) = (YD_PGRAD%data(jj) - zdelta(iter) * YDCGLWK(iter)%data(jj)) &
                        &  - zbeta(iter)  * YDCGLWK(iter-1)%data(jj)
    enddo
!$OMP END PARALLEL DO
  endif
  CALL GSTATS(1233,1)


!--- orthonormalize gradient against previous gradients
  Z_DLAV(1:iter)= DOT_PRODUCT(YDCGLWK(1:iter),YD_PGRAD)
  do jm=iter,1,-1
!    Z_DLA = DOT_PRODUCT(YD_PGRAD,YDCGLWK(jm))
    Z_DLA=Z_DLAV(jm)

    CALL GSTATS(1233,0)
!   YD_PGRAD%data = YD_PGRAD%data - Z_DLA*YDCGLWK(jm)%data
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jj)
    do jj=1,YD_PGRAD%nsizel
      YD_PGRAD%data(jj) = YD_PGRAD%data(jj) - Z_DLA*YDCGLWK(jm)%data(jj)
    enddo
!$OMP END PARALLEL DO
    CALL GSTATS(1233,1)
  enddo

  if (lvarbc) then
!   store gradient w/r to the VarBC bias parameters, for diagnostics
    ibeg = 1
    do i = 1, nobgroup
      incount = yvarbc(i)%ncount
      inparam = yvarbc(i)%nparam
      iend = ibeg + inparam - 1
      if (incount/=0) yvarbc(i)%agrad(1:inparam) = yd_pgrad%params(ibeg:iend)
      ibeg = iend + 1
    enddo
  endif

  zbeta(iter+1) = SQRT(DOT_PRODUCT(YD_PGRAD,YD_PGRAD))

  CALL GSTATS(1233,0)
! YDCGLWK(iter+1)%data = YD_PGRAD%data / zbeta(iter+1)
! zbetad=1.0_JPRB/zbeta(iter+1)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jj)
  do jj=1,YD_PGRAD%nsizel
!   YDCGLWK(iter+1)%data(jj) = YD_PGRAD%data(jj) * zbetad
    YDCGLWK(iter+1)%data(jj) = YD_PGRAD%data(jj) / zbeta(iter+1)
  enddo
!$OMP END PARALLEL DO
  CALL GSTATS(1233,1)

  zqg0(iter+1) = DOT_PRODUCT (YDCGLWK(iter+1),YL_ZLANC1)

!--- calculate the reduction in the gradient norm and cost

  if (ldsolve) then
    zwork(1:iter,1) =  zdelta(1:iter)
    zwork(2:iter,2) =  zbeta (2:iter)
    zwork(1:iter,3) =  zqg0  (1:iter)

    call ptsv

    if (MOD(iter,2)==0) then
      istart=1
    else
      istart=2
    endif

    if (L_CHECK_GRADIENT .or. .not.ld_info_convergence) then
      YD_PX = YL_ZX0
      CALL GSTATS(1233,0)
!     YL_ZW%data = -YL_ZLANC1%data + (zbeta(iter+1)*zwork(iter,3))*YDCGLWK(iter+1)%data
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jj)
      do jj=1,YL_ZW%nsizel
        YL_ZW%data(jj) = -YL_ZLANC1%data(jj) + (zbeta(iter+1)*zwork(iter,3))*YDCGLWK(iter+1)%data(jj)
      enddo
!$OMP END PARALLEL DO
      CALL GSTATS(1233,1)


      CALL GSTATS(1231,0)
!$OMP PARALLEL PRIVATE(j,ji) IF(L_OPENMP_CV)

    if (istart==2) then
!$OMP DO SCHEDULE(STATIC)
      do ji=1,YL_ZW%nsizel
        YL_ZW%data(ji) = YL_ZW%data(ji) + YDCGLWK(1)%data(ji)*zqg0(1)
        YD_PX%data(ji) = YD_PX%data(ji) + YDCGLWK(1)%data(ji)*zwork(1,3)
      enddo
!$OMP END DO NOWAIT
!     Warning: NOWAIT is correct here for STATIC scheduling only.
      endif
      do j=istart,iter-1,2
!$OMP DO SCHEDULE(STATIC)
        do ji=1,YL_ZW%nsizel
          YD_PX%data(ji) = YD_PX%data(ji) + YDCGLWK(j  )%data(ji) * zwork(j  ,3) &
                      &                   + YDCGLWK(j+1)%data(ji) * zwork(j+1,3)
          YL_ZW%data(ji) = YL_ZW%data(ji) + YDCGLWK(j  )%data(ji)*zqg0(j  ) &
                        &                 + YDCGLWK(j+1)%data(ji)*zqg0(j+1)
        enddo
!$OMP END DO NOWAIT
!     Warning: NOWAIT is correct here for STATIC scheduling only.
      enddo
!$OMP END PARALLEL
      CALL GSTATS(1231,1)

      if (LMPCGL) then
        if (L_CHECK_GRADIENT) then
          call precond(YD_PX,-2)
        endif
        call precond(YL_ZW,+2)
      endif

      preduc = SQRT(DOT_PRODUCT(YL_ZW,YL_ZW))
      write (NULOUT, &
     &'('' GREPMIN: Iteration '',I4,'' : Estimated gradient norm='',1X,E22.16,1X,Z17)') &
     & iter, preduc, preduc  

      if (L_CHECK_GRADIENT) then
        CALL GSTATS(1233,0)
!       YD_PX%data = YD_PX%data * YRSCALPSQRT%data
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jj)
        do jj=1,YD_PX%nsizel
          YD_PX%data(jj) = YD_PX%data(jj) * YRSCALPSQRT%data(jj)
        enddo
!$OMP END PARALLEL DO
        CALL GSTATS(1233,1)
        idum = -999
        indic = 4
        call sim4d(indic,idum,YD_PX,zdummy,YD_PGRAD,iter)
        CALL GSTATS(1233,0)
!       YD_PGRAD%data = YL_ZW%data - 0.5_JPRB * YD_PGRAD%data * YSCALPSQRT%data
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jj)
        do jj=1,YD_PGRAD%nsizel
          YD_PGRAD%data(jj) = YL_ZW%data(jj) - 0.5_JPRB * YD_PGRAD%data(jj) * YSCALPSQRT%data(jj)
        enddo
!$OMP END PARALLEL DO
        CALL GSTATS(1233,1)

        ztol=SQRT(DOT_PRODUCT(YD_PGRAD,YD_PGRAD))/preduc
        write (NULOUT,*) 'Relative accuracy of gradient is : ',ztol

        if (ztol>RTOL_CHECK_GRADIENT) then
          CALL WRITE_CTLVEC_GRIB ('gradient_error',YD_PGRAD)
          CALL ABOR1 ('Gradient Error Exceeds Tolerance')
        endif
      endif

      preduc = preduc/zgnorm
      write (NULOUT,*) 'Estimated reduction in norm of gradient is: ',preduc
    endif

!--- Information-based convergence criterion. Here, we should really measure the
!--- change in length of the solution vector in the un-preconditioned metric.
!--- But,that would require an extra expensive call to the preconditioner.

    if (ld_info_convergence) then
      CALL GSTATS(1233,0)
!     YD_PX%data = 0.0
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(ji)
      do ji=1,YD_PX%nsizel
        YD_PX%data(ji) = 0.0
      enddo
!$OMP END PARALLEL  DO
      CALL GSTATS(1233,1)
      CALL GSTATS(1231,0)
!$OMP PARALLEL PRIVATE(j,ji) IF(L_OPENMP_CV)
      if (istart==2) then
!$OMP DO SCHEDULE(STATIC)
        do ji=1,YD_PX%nsizel
          YD_PX%data(ji)  = YD_PX%data(ji) + YDCGLWK(1)%data(ji)*zwork(1,3)
        enddo
!$OMP END DO NOWAIT
!     Warning: NOWAIT is correct here for STATIC scheduling only.
      endif
      do j=istart,iter-1,2
!$OMP DO SCHEDULE(STATIC)
        do ji=1,YD_PX%nsizel
          YD_PX%data(ji)    = YD_PX%data(ji) + YDCGLWK(j  )%data(ji) * zwork(j  ,3) &
                      &                      + YDCGLWK(j+1)%data(ji) * zwork(j+1,3)
        enddo
!$OMP END DO NOWAIT
!     Warning: NOWAIT is correct here for STATIC scheduling only.
      enddo
!$OMP END PARALLEL
      CALL GSTATS(1231,1)

      zdfi_old = zdfi
      zdfi = 0.5*DOT_PRODUCT(YD_PX,YD_PX)
      preduc = (zdfi - zdfi_old)/zdfi

      write (NULOUT, &
     &'('' GREPMIN: Iter '',I4,'' Control vector norm**2='',1X,E22.16,1X,Z17)') &
     & iter, zdfi, zdfi

      write (NULOUT, &
     &'('' GREPMIN: Iter '',I4,'' Relative info increase='',1X,E22.16)') &
     & iter, preduc
    endif
  else
    preduc = 1.0_JPRB
  endif

!--- determine eigenvalues and eigenvectors of the tri-diagonal problem

  CALL GSTATS(1233,0)
  zwork(1:iter  ,4) = zdelta(1:iter)
  zwork(1:iter-1,1) = zbeta (2:iter)

  if (iter /= 1) then
    call steqr
  else
    zv(1,1) = 1.0_JPRB
  endif

  zritz(1:iter) = zwork(1:iter,4)

  write (NULOUT,*) 'congrad: ritz values are: ',zritz(1:iter)

!--- estimate error bounds

  zbndlm = zeta*zritz(iter)

  zbnds(1:iter) = abs(zbeta(iter+1)*zv(iter,1:iter))
  CALL GSTATS(1233,1)
  write (NULOUT,*) 'congrad: error bounds are: ',zbnds(1:iter)

!--- Check for exploding or negative Ritz values

  if (ANY(zritz(1:iter) < 0.0_JPRB)) then
    write (NULOUT,*) 'congrad stopping: negative ritz value'
    iter = iter-1
    zwork(1:iter  ,4) = zdelta(1:iter)
    zwork(1:iter-1,1) = zbeta(2:iter)

    if (iter > 1) then
      call steqr
    else
      zv(1,1) = 1.0_JPRB
    endif

    zritz(1:iter) = zwork(1:iter,4)

    zbnds(1:iter) = abs(zbeta(iter+1)*zv(iter,1:iter))
    EXIT Lanczos_loop
  endif

  if (ingood > 0) then
    if (zritz(itheta1) > 1.01_JPRB*ztheta1) then
      write (NULOUT,*) 'congrad stopping: ritz values exploding'
      write (NULOUT,*) 'leading ritz value=',zritz(itheta1)
      write (NULOUT,*) 'leading converged eigenvalue=',ztheta1
    endif
  endif

!--- Count the converged eigenvectors

  ing = 0
  do jm=1,iter
    if (zbnds(jm) <= zbndlm) then
      ing = ing+1
      write (NULOUT,*) 'congrad: converged eigenvalue ',zritz(jm)
    endif
  enddo

!--- Deal with newly converged eigenvector and recompute eigenvectors

  ingood = ing

!--- save leading converged eigenvalue for explosion test

  if (ingood > 0) then
    do jm=iter,1,-1
      if (zbnds(jm) <= zbndlm) then
        ztheta1 = zritz(jm)
        itheta1 = jm
        exit
      endif
    enddo
  endif

  write (NULOUT,*) 'congrad: End of iteration: ',iter
  write (NULOUT,'(/)')

  if (iter >= kmaxit .or. (preduc <= zreqrd .and. iter >= kminit)) &
    & EXIT Lanczos_loop

!--- count how many eigenpairs have converged to PKAPPA precision and have eigenvalue > xmin_ritz (which is 1 by default)
!--- (For the analysis, all eigenvalues should be >1. For the singular vector calculation,
!--- we are not interested in decaying modes.)
!--- However, when SVs are computed with projection operators, 1 may not 
!    be an appropriate choice for xmin_ritz

  imaxevecs = COUNT(zbnds(1:iter)/zritz(1:iter) <= pkappa .AND. zritz(1:iter) > xmin_ritz)

  if (imaxevecs >= kmaxevecs) then
    write (NULOUT,*) imaxevecs,' eigenpairs converged to precision ',pkappa
    write (NULOUT,'(/)')
    EXIT Lanczos_loop
  endif

!--- Estimate when the minimization will end

  IF(NCONF == 131) CALL PREDICT_RUNTIME (iter,kmaxit,preduc,zreqrd)

!--- Increment the iteration counter

  iter = iter+1
  if (ingood > 0) itheta1 = itheta1+1

ENDDO Lanczos_loop

!--- end of Lanczos iteration

write (NULOUT,*)'Summary of Lanczos iteration:'
write (NULOUT,*) '   Number of iterations performed: ',iter
if (ldsolve) then
  write (NULOUT,*) '   Maximum allowed number of iterations: ',kmaxit
  write (NULOUT,*) '   Minimum allowed number of iterations: ',kminit
  if (ld_info_convergence) then
    write (NULOUT,*) '   Required relative dfi change per iteration: ',zreqrd
    write (NULOUT,*) '   Achieved relative dfi change per iteration: ',preduc
  else
    write (NULOUT,*) '   Required reduction in norm of gradient: ',zreqrd
    write (NULOUT,*) '   Achieved reduction in norm of gradient: ',preduc
  endif
  if (preduc > zreqrd) then
    write (NULOUT,*)&
     & '   *** Failed to meet convergence criterion ***'  
  endif
  write (NULOUT,*) '   Number of sufficiently-converged eigenpairs: ',imaxevecs
endif

!--- Calculate sufficiently converged eigenvectors of the
!--- preconditioned Hessian

if (ldevecs) then
  zbndlm = pkappa
  zbnds(1:iter) = zbnds(1:iter)/zritz(1:iter)

  call wrevecs(iter,kmaxit,zritz,zbnds,zbndlm,xmin_ritz,&
   & zv,YDCGLWK,ingood,ztheta)  

  if (ingood == 0) then
    write (NULOUT,*) 'Warning: congrad found no eigenpairs'
  endif

  write (NULOUT,*)&
   & 'number of eigenpairs converged to requested accuracy=',ingood  

  kmaxevecs = ingood
endif

!--- Calculate bounds on (planc1)' (J'')^-1 planc1 and (planc1)' log[(J'')^-1] planc1

if (LD_LGOLUB) then
  pgolubu_inv=0.0_JPRB
  pgolubu_log=0.0_JPRB
  do jm=1,iter
    pgolubu_inv = pgolubu_inv + zv(1,jm)*zv(1,jm) / zritz(jm)
    pgolubu_log = pgolubu_log + zv(1,jm)*zv(1,jm)*log(zritz(jm))
  enddo

!--- For the Gauss-Radau rule, za is a non-zero lower bound on the eigenvalues
!--- For the analysis Hessian, za=1. For the model, we have to guess.

  if (NCONF==131) then
    za = 1.0_JPRB
  else
    za = 1.0E-8_JPRB
  endif

  zwork(1:iter,1)   =  zdelta(1:iter) -za
  zwork(2:iter,2)   =  zbeta (2:iter)
  zwork(1:iter-1,3) =  0.0_JPRB
  zwork(iter,3)     =  zbeta(iter+1)*zbeta(iter+1)

  call ptsv

  zwork(1:iter,4) = zdelta(1:iter)
  zwork(iter+1,4) = za + zwork(iter,3)
  zwork(1:iter,1) = zbeta(2:iter+1)

  iter=iter+1
  call steqr
  iter=iter-1

  pgolubl_inv=0.0_JPRB
  pgolubl_log=0.0_JPRB
  do jm=1,iter+1
    pgolubl_inv = pgolubl_inv + zv(1,jm)*zv(1,jm) / zwork(jm,4)
    pgolubl_log = pgolubl_log + zv(1,jm)*zv(1,jm)*log(zwork(jm,4))
  enddo

!--- Calculate what the bounds were at the first iteration

  zwork(1,4) = zdelta(1)
  zwork(2,4) = za + zbeta(2)*zbeta(2)/(zdelta(1) -za)
  zwork(1,1) = zbeta(2)

  i=iter
  iter=2
  call steqr
  iter=i

  zl_inv = zv(1,1)*zv(1,1)/zwork(1,4) + zv(1,2)*zv(1,2)/zwork(2,4)
  zl_log = zv(1,1)*zv(1,1)*log(zwork(1,4)) + zv(1,2)*zv(1,2)*log(zwork(2,4))

  zu_inv = 1.0/zdelta(1)
  zu_log = log(zdelta(1))

!--- check that the bounds have converged towards each other.
!--- Failure to converge may indicate that za is too large. za must be
!--- less than the smallest eigenvalue.

  ll_inv_ok = (zl_inv      < pgolubl_inv .AND. &
   & pgolubl_inv < pgolubu_inv .AND. &
   & pgolubu_inv < zu_inv              ) .OR. &
   & (zl_inv      > pgolubl_inv .AND. &
   & pgolubl_inv > pgolubu_inv .AND. &
   & pgolubu_inv > zu_inv              )  

  ll_log_ok = (zl_log      < pgolubl_log .AND. &
   & pgolubl_log < pgolubu_log .AND. &
   & pgolubu_log < zu_log              ) .OR. &
   & (zl_log      > pgolubl_log .AND. &
   & pgolubl_log > pgolubu_log .AND. &
   & pgolubu_log > zu_log              )  

  if (.NOT.(ll_inv_ok .AND. ll_log_ok)) then
    write (nulout,*) 'Bounds on traces have not converged towards each other'
    write (nulout,*) 'Bounds on trace of inverse:'
    write (nulout,*) '  first lower bound = ',zl_inv
    write (nulout,*) '  final lower bound = ',pgolubl_inv
    write (nulout,*) '  final upper bound = ',pgolubu_inv
    write (nulout,*) '  first upper bound = ',zu_inv
    write (nulout,*) 'Bounds on trace of log:'
    write (nulout,*) '  first lower bound = ',zl_log
    write (nulout,*) '  final lower bound = ',pgolubl_log
    write (nulout,*) '  final upper bound = ',pgolubu_log
    write (nulout,*) '  first upper bound = ',zu_log
    call ABOR1 ('Bounds on traces have not converged towards each other')
  endif

!--- convert bounds to degrees of freedom for signal and entropy

  pgolubu_inv = znorm2l1 * (1.0_JPRB - pgolubu_inv)
  pgolubl_inv = znorm2l1*(1.0_JPRB - pgolubl_inv)
  pgolubu_log = 0.5_JPRB * znorm2l1 * pgolubu_log / log(2.0_JPRB)
  pgolubl_log = 0.5_JPRB * znorm2l1 * pgolubl_log / log(2.0_JPRB)
endif

!--- Calculate the solution vector and gradient

if (ldsolve) then
  zwork(1:iter,1) =  zdelta(1:iter)
  zwork(2:iter,2) =  zbeta (2:iter)
  zwork(1:iter,3) =  zqg0  (1:iter)

  call ptsv

  YD_PX = YL_ZX0
  pwork=zwork

CALL GSTATS(1233,0)
! YD_PGRAD%data = -YL_ZLANC1%data + zbeta(iter+1)*YDCGLWK(iter+1)%data*zwork(iter,3)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jj)
  do jj=1,YD_PGRAD%nsizel
    YD_PGRAD%data(jj) = -YL_ZLANC1%data(jj) + zbeta(iter+1)*YDCGLWK(iter+1)%data(jj)*zwork(iter,3)
  enddo
!$OMP END PARALLEL DO
CALL GSTATS(1233,1)
  
  if (MOD(iter,2)==0) then
    istart=1
  else
    istart=2
  endif
CALL GSTATS(1231,0)

!$OMP PARALLEL PRIVATE(j,ji) IF(L_OPENMP_CV)

  if (istart==2) then
!$OMP DO SCHEDULE(STATIC)
    do ji=1,YD_PX%nsizel
      YD_PX%data(ji)    = YD_PX%data(ji) + YDCGLWK(1)%data(ji) * zwork(1,3)
      YD_PGRAD%data(ji) = YD_PGRAD%data(ji) + YDCGLWK(1)%data(ji)*zqg0(1)
    enddo
!$OMP END DO NOWAIT
!     Warning: NOWAIT is correct here for STATIC scheduling only.
  endif

  do j=istart,iter-1,2
!$OMP DO SCHEDULE(STATIC)
    do ji=1,YD_PX%nsizel
      YD_PX%data(ji)    = YD_PX%data(ji) + YDCGLWK(j  )%data(ji) * zwork(j  ,3) &
                       &                 + YDCGLWK(j+1)%data(ji) * zwork(j+1,3)
      YD_PGRAD%data(ji) = YD_PGRAD%data(ji) + YDCGLWK(j  )%data(ji)*zqg0(j  ) &
                       &                    + YDCGLWK(j+1)%data(ji)*zqg0(j+1)
    enddo
!$OMP END DO NOWAIT
!     Warning: NOWAIT is correct here for STATIC scheduling only.
  enddo

!$OMP END PARALLEL

CALL GSTATS(1231,1)
else
  YD_PGRAD = YL_ZGRAD0
  YD_PX    = YL_ZX0
  pwork=0.0_JPRB
endif

!--- transform control variable and gradient back to space with scalar
!--- product SCAAS

if (LMPCGL) then
  call precond(YD_PX,-2)
  call precond(YD_PGRAD,+2)
endif

CALL GSTATS(1233,0)
! YD_PGRAD%data = 2.0_JPRB*YD_PGRAD%data*YRSCALPSQRT%data
! YD_PX%data    =       YD_PX   %data*YRSCALPSQRT%data
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jj)
  do jj=1,YD_PGRAD%nsizel
    YD_PGRAD%data(jj) = YD_PGRAD%data(jj)*YRSCALPSQRT%data(jj)
    YD_PX%data(jj)    = YD_PX%data(jj)*YRSCALPSQRT%data(jj)
  enddo
!$OMP END PARALLEL DO
CALL GSTATS(1233,1)

!--- close files, etc.

call deallocate_ctlvec(YL_ZX0)
call deallocate_ctlvec(YL_ZGRAD0)
call deallocate_ctlvec(YL_ZW)
call deallocate_ctlvec(YL_ZLANC1)

!--- return the number of iterations actually performed

kmaxit=iter

IF (LHOOK) CALL DR_HOOK('CONGRAD',1,ZHOOK_HANDLE)

CONTAINS
subroutine STEQR

  !-----------------------------------------------------------------------
  !   STEQR - Simplified interface to LAPACK routines SSTEQR/DSTEQR
  !-----------------------------------------------------------------------

INTEGER(KIND=JPIM) :: info
REAL(KIND=JPRB) :: ZHOOK_HANDLE

IF (LHOOK) CALL DR_HOOK('CONGRAD:STEQR',0,ZHOOK_HANDLE)
if (JPRB == N_DEFAULT_REAL_KIND) then
  call SSTEQR ('I',iter,zwork(1,4),zwork,zv,kmaxit+1,zsstwrk,info)
ELSEIF (JPRB == N_DOUBLE_KIND) then
  call DSTEQR ('I',iter,zwork(1,4),zwork,zv,kmaxit+1,zsstwrk,info)
else
  call ABOR1 ('REAL(KIND=JPRB) is neither default real nor double precision')
endif

if (info /= 0) then
  write (NULOUT,*) 'Error in congrad: SSTEQR/DSTEQR returned info=',info
  call ABOR1 ('CONGRAD: SSTEQR/DSTEQR returned non-zero info')
endif

IF (LHOOK) CALL DR_HOOK('CONGRAD:STEQR',1,ZHOOK_HANDLE)
end subroutine STEQR

subroutine PTSV

  !-----------------------------------------------------------------------
  !   PTSV - Simplified interface to LAPACK routines SPTSV/DPTSV
  !-----------------------------------------------------------------------

INTEGER(KIND=JPIM) :: info
REAL(KIND=JPRB) :: ZHOOK_HANDLE

IF (LHOOK) CALL DR_HOOK('CONGRAD:PTSV',0,ZHOOK_HANDLE)
if (JPRB == N_DEFAULT_REAL_KIND) then
  call SPTSV (iter,1,zwork(1,1),zwork(2,2),zwork(1,3),kmaxit+1,info)
ELSEIF (JPRB == N_DOUBLE_KIND) then
  call DPTSV (iter,1,zwork(1,1),zwork(2,2),zwork(1,3),kmaxit+1,info)
else
  call ABOR1 ('REAL(KIND=JPRB) is neither default real nor double precision')
endif

if (info /= 0) then
  write (NULOUT,*) 'Error in congrad: SPTSV/DPTSV returned ',info
  call ABOR1 ('CONGRAD: SPTSV/DPTSV returned non-zero info')
endif

IF (LHOOK) CALL DR_HOOK('CONGRAD:PTSV',1,ZHOOK_HANDLE)
end subroutine PTSV
end subroutine CONGRAD
