subroutine balanced_reduction (pkappa,kmaxit,kmaxevecs)

!-----------------------------------------------------------------------
!   Balanced_Reduction - Modified Lanczos algorithm to calculate
!                        balancing vectors for balance model reduction.

!   Purpose. Calculate balancing vectors for balance model reduction.
!   -------- 

!   Interface.
!   ----------
!      CALL BALANCED_REDUCTION (pkappa,kmaxit,kmaxevecs)

!      Explicit arguments: 

!      Inputs: 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
!      Outputs: kmaxit      -- the number of iterations actually performed
!               kmaxevecs   -- the number of eigenpairs actually converged

!      Implicit input:  SCALP from YOMCVA

!      Implicit output: Balancing vectors are written to svifs and svevo.

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

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

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

!   Modifications.
!   --------------
!       Original      2003/03/25  (Based on CONGRAD)
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Hamrud      01-Dec-2003 CY28R1 Cleaning
!        M.Hamrud      01-May-2006 Generalized IO scheme
!-----------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMCT0B  , ONLY : LECMWF
USE YOMCVA   , ONLY : YSCALPSQRT, YRSCALPSQRT
USE YOMLUN   , ONLY : NULOUT
USE YOMLCZ   , ONLY : L_SOS, L_EOFS, NRITZREAD, NRITZNUMB, NRITZGBH1, NRITZGBH2
USE YOMCT0   , ONLY : LOPDIS
USE YOMCT1   , ONLY : N1POS    ,N1HIS    ,N1GDI    ,N1SDI
USE YOMVAR   , ONLY : NSIM4D
USE YOMMSC   , ONLY : N_DEFAULT_REAL_KIND, N_DOUBLE_KIND
USE IOSTREAM_MIX , ONLY : SETUP_IOSTREAM,TYPE_IOSTREAM,CLOSE_IOSTREAM
USE GFL_SUBS_MOD , ONLY : DEACT_CLOUD_GFL

USE CONTROL_VECTORS

IMPLICIT NONE

REAL(KIND=JPRB)   ,INTENT(IN)    :: PKAPPA 
INTEGER(KIND=JPIM),INTENT(INOUT) :: KMAXIT 
INTEGER(KIND=JPIM),INTENT(IN)    :: KMAXEVECS 
REAL(KIND=JPRB) :: Z_DLA

type(control_vector) :: YL_ZV(kmaxit+1),YL_ZZ(kmaxit+1),YL_ZW
type(control_vector), allocatable :: YL_ZY(:), YL_ZX(:)
TYPE(TYPE_IOSTREAM)  :: YL_IOSTR_SVEVO, YL_IOSTR_SVIFS

REAL(KIND=JPRB) :: z_beta(kmaxit+1), z_alpha(kmaxit), zbnds(kmaxit), &
 & zritz(kmaxit), zwork(kmaxit,4), ztheta(kmaxit), zsstwrk(2*kmaxit), &
 & z_ev_matrix(kmaxit,kmaxit)  

INTEGER(KIND=JPIM) :: iter, j, jm, imaxevecs, ing, itheta1, ingood, ij, jk, iomaster, &
 & info  


REAL(KIND=JPRB) :: zeta, zbndlm, ztheta1
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"
#include "cnt3.intfb.h"
#include "opk.intfb.h"
#include "spnorm.intfb.h"
#include "su2yom.intfb.h"
#include "suallt.intfb.h"
#include "supert.intfb.h"
#include "wrtllcz.intfb.h"

IF (LHOOK) CALL DR_HOOK('BALANCED_REDUCTION',0,ZHOOK_HANDLE)
write (NULOUT,*) '---- Balanced Reduction Solver ----'

!--- Initialize YOMCT2

CALL SU2YOM

!     1.2  Allocate extra space for trajectory

IF (LECMWF) THEN
  CALL SUALLT
ENDIF

!     1.4 Trajectory computation (if LECMWF else -> cun1 : TB)

IF (LECMWF) THEN
  CALL SPNORM(0)
  WRITE(NULOUT,'('' >> Sub CUN2 : COMPUTE TRAJECTORY'')')
  N1HIS=1
  CALL CNT3
ENDIF

!*    2.1 Define parameters

NSIM4D=0
N1SDI=0
N1GDI=0
N1POS=0
LOPDIS=.false.

!     Re-set some variable used in the prognostic cloud scheme to
!     run TL and AD

CALL DEACT_CLOUD_GFL

!--- allocate distributed storage

DO j=1,kmaxit+1
  CALL allocate_ctlvec(YL_ZZ(j))
  CALL allocate_ctlvec(YL_ZV(j))
ENDDO

call allocate_ctlvec(YL_ZW)

!--- Generate initial Laczos vector

call SUPERT (YL_ZZ(1),1.0_JPRB)

!--- Apply P (EOF matrix)

L_EOFS=.true.
CALL OPK (YL_ZZ(1),YL_ZV(1))
L_EOFS=.false.

!--- Calculate normalization factor (diagonal of the tri-diagonal matrix)

z_beta(1) = SQRT(DOT_PRODUCT(YL_ZZ(1),YL_ZV(1)))

!--- Normalize z and v

YL_ZZ(1)%data = YL_ZZ(1)%data/z_beta(1)
YL_ZV(1)%data = YL_ZV(1)%data/z_beta(1)

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

zeta  = 1e-4_JPRB
ingood = 0

!--- Lanczos loop

iter=1
Lanczos_Loop: DO 

!--- Apply Q (Stochastic Optimal matrix)

  L_SOS=.true.
  CALL OPK (YL_ZV(iter),YL_ZW)
  L_SOS=.false.

!--- Calculate the off-diagonal of the tri-diagonal matrix

  z_alpha(iter) = DOT_PRODUCT (YL_ZV(iter),YL_ZW)

!--- Generate the next Lanczos vector

  YL_ZZ(iter+1)%data = YL_ZW%data - z_alpha(iter)*YL_ZZ(iter)%data
  IF (iter > 1) THEN
    YL_ZZ(iter+1)%data = YL_ZZ(iter+1)%data - z_beta(iter)*YL_ZZ(iter-1)%data
  ENDIF

!--- P-orthogonalize against previous Lanczos vectors

  DO j=1,iter
    Z_DLA = DOT_PRODUCT (YL_ZZ(iter+1),YL_ZV(j))
    YL_ZZ(iter+1)%data = YL_ZZ(iter+1)%data - Z_DLA*YL_ZZ(j)%data
  ENDDO

!--- Apply P (EOF matrix)

  L_EOFS=.true.
  CALL OPK (YL_ZZ(iter+1),YL_ZV(iter+1))
  L_EOFS=.false.

!--- Calculate normalization factor (diagonal of the tri-diagonal matrix)

  z_beta(iter+1) = SQRT(DOT_PRODUCT(YL_ZZ(iter+1),YL_ZV(iter+1)))

!--- Normalize z and v

  YL_ZZ(iter+1)%data = YL_ZZ(iter+1)%data/z_beta(iter+1)
  YL_ZV(iter+1)%data = YL_ZV(iter+1)%data/z_beta(iter+1)

!--- Calculate eigenvalues of the tri-diagonal matrix

  zwork(1:iter  ,4) = z_alpha(1:iter)
  zwork(1:iter-1,1) = z_beta(2:iter)

  if (iter /= 1) then
    if (JPRB == N_DEFAULT_REAL_KIND) then
      call SSTEQR ('I',iter,zwork(1,4),zwork,z_ev_matrix,kmaxit,zsstwrk,info)
    ELSEIF (JPRB == N_DOUBLE_KIND) then
      call DSTEQR ('I',iter,zwork(1,4),zwork,z_ev_matrix,kmaxit,zsstwrk,info)
    else
      call ABOR1 ('REAL(KIND=JPRB) is neither default real nor double precision')
    endif

    if (info /= 0) then
      write (NULOUT,*) 'Error in balanced_reduction: SSTEQR/DSTEQR returned info=',info
      call ABOR1 ('BALANCED_REDUCTION: SSTEQR/DSTEQR returned non-zero info')
    endif
  else
    z_ev_matrix(1,1) = 1.0_JPRB
  endif

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

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

!--- estimate error bounds

  zbndlm = zeta*zritz(iter)

  zbnds(1:iter) = abs(z_beta(iter+1)*z_ev_matrix(iter,1:iter))
  write (NULOUT,*) 'balanced reduction: error bounds are: ',zbnds(1:iter)

!--- Check for exploding or negative Ritz values

  if (ANY(zritz(1:iter) < 0.0_JPRB)) then
    write (NULOUT,*) 'ABORTING: negative ritz value'
    CALL ABOR1 ('Negative ritz value')
  endif

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

!--- Count the converged eigenvectors

  ing = 0
  do jm=1,iter
    if (zbnds(jm) <= zbndlm) then
      ing = ing+1
      write (NULOUT,*) 'Balanced Redction: Converged Hankel Singular value ',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,*) 'Balanced Reduction: End of iteration: ',iter
  write (NULOUT,'(/)')

!--- count how many eigenpairs have converged to PKAPPA precision and have eigenvalue >1
!--- (We are not interested in Hankel Singular values less than one.)

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

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

  if (ingood > 0) itheta1 = itheta1+1

  if (iter >= kmaxit) then
    write (nulout,*) 'Balanced Reduction: WARNING - iteration limit reached'
    EXIT Lanczos_Loop
  endif

  iter = iter + 1
ENDDO Lanczos_loop

write (NULOUT,'(/)')
write (NULOUT,*)'Summary of Lanczos iteration:'
write (NULOUT,*) '   Number of iterations performed: ',iter
write (NULOUT,*) '   Number of sufficiently-converged eigenpairs: ',imaxevecs

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

zbnds(1:iter) = zbnds(1:iter)/zritz(1:iter)

ingood = 0
do jm=iter,1,-1
  if (zbnds(jm) <= pkappa .AND. zritz(jm) > 1.0_JPRB) then
    ingood=ingood+1
    ztheta(ingood) = SQRT(zritz(jm)) ! Hankel singualar value=sqrt(eigenvalue)
  endif
ENDDO

write (NULOUT,'(/)')
write (NULOUT,*)'Calculating vectors for the following Hankel singular values:'
write (NULOUT,*) ztheta(1:ingood)
write (NULOUT,'(/)')

!--- Allocate storage for the X and Y vectors

allocate (YL_ZX(ingood))
allocate (YL_ZY(ingood))
DO j=1,ingood
  CALL allocate_ctlvec(YL_ZX(j))
  CALL allocate_ctlvec(YL_ZY(j))
ENDDO

!--- Calculate Y and X

ij=0
do jm=iter,1,-1

  if (zbnds(jm) <= pkappa .AND. zritz(jm) > 1.0_JPRB) then
    ij = ij+1
    YL_ZX(ij)%data = 0.0_JPRB
    YL_ZY(ij)%data = 0.0_JPRB
    do jk=1,iter
      YL_ZX(ij)%data = YL_ZX(ij)%data + YL_ZV(jk)%data * z_ev_matrix(jk,jm)
      YL_ZY(ij)%data = YL_ZY(ij)%data + YL_ZZ(jk)%data * z_ev_matrix(jk,jm)
    enddo
    YL_ZX(ij)%data = YL_ZX(ij)%data * YRSCALPSQRT%data / SQRT(ztheta(ij))
    YL_ZY(ij)%data = YL_ZY(ij)%data * YRSCALPSQRT%data * SQRT(ztheta(ij))
  endif
ENDDO

!--- Finished with zw, zz and zv

DO j=1,kmaxit+1
  call deallocate_ctlvec(YL_ZZ(j))
  call deallocate_ctlvec(YL_ZV(j))
ENDDO

call deallocate_ctlvec(YL_ZW)

!--- Open svifs and svevo files

IOMASTER=1
CALL SETUP_IOSTREAM(YL_IOSTR_SVIFS,'CIO','svifs',CDMODE='w',KIOMASTER=IOMASTER)
CALL SETUP_IOSTREAM(YL_IOSTR_SVEVO,'CIO','svevo',CDMODE='w',KIOMASTER=IOMASTER)

!--- Write the vectors Y->svifs, X->svevo

NRITZREAD=ingood

DO jm=1,ingood
  NRITZNUMB=jm
  NRITZGBH1=NINT( LOG10(ztheta(jm))-5 )
  NRITZGBH2=NINT( ztheta(jm)/(EXP(LOG(10._JPRB)*NRITZGBH1)) )

  call WRTLLCZ (YL_IOSTR_SVIFS,YL_ZY(jm))
  call WRTLLCZ (YL_IOSTR_SVEVO,YL_ZX(jm))
ENDDO

!---  Close the svifs and svevo files

IF (LECMWF) THEN
  CALL CLOSE_IOSTREAM(YL_IOSTR_SVIFS)
  CALL CLOSE_IOSTREAM(YL_IOSTR_SVEVO)
ENDIF

!============================================================
!--- Test bi-orthogonality

DO j=1,ingood
  YL_ZY(j)%data = YL_ZY(j)%data * YSCALPSQRT%data
  YL_ZX(j)%data = YL_ZX(j)%data * YSCALPSQRT%data
ENDDO
  
write (nulout,*) 'Check bi-orthogonality of internal vectors'
DO j=1,ingood
  DO jm=1,ingood
    ztheta(jm) = DOT_PRODUCT (YL_ZY(j),YL_ZX(jm))
  ENDDO
  write (nulout,*) '<Y('   , j ,  ') , X(:)>='  ,  ztheta(1:ingood)
ENDDO

!!$GOTO 1234
!!$IOMASTER=1
!!$IF(MYPROC == IOMASTER) THEN
!!$  IRET=0
!!$  CALL PBOPEN(I_LUN_Y,'svifs','R',IRET)
!!$  IF(IRET /= 0) THEN
!!$    WRITE(NULOUT,'('' >> BALANCED_REDUCTION: PBOPEN FAILED on svifs'')')
!!$    WRITE(NULOUT,'(''                IRET='',I10)') IRET
!!$    CALL ABOR1('BALANCED_REDUCTION: PBOPEN ERROR')
!!$  ENDIF
!!$  CALL PBOPEN(I_LUN_X,'svevo','R',IRET)
!!$  IF(IRET /= 0) THEN
!!$    WRITE(NULOUT,'('' >> BALANCED_REDUCTION: PBOPEN FAILED on svevo'')')
!!$    WRITE(NULOUT,'(''                IRET='',I10)') IRET
!!$    CALL ABOR1('BALANCED_REDUCTION: PBOPEN ERROR')
!!$  ENDIF
!!$ENDIF
!!$
!!$!--- read the vectors Y<-svifs, X<-svevo
!!$
!!$DO jm=1,ingood
!!$  YL_ZY(jm)%data = 0.0_JPRB
!!$  YL_ZX(jm)%data = 0.0_JPRB
!!$  call RDTLLCZ (I_LUN_Y,YL_ZY(jm))
!!$  call RDTLLCZ (I_LUN_X,YL_ZX(jm))
!!$ENDDO
!!$
!!$!--- re-check bi-orthogonality
!!$
!!$DO j=1,ingood
!!$  YL_ZY(j)%data = YL_ZY(j)%data * YSCALPSQRT%data
!!$  YL_ZX(j)%data = YL_ZX(j)%data * YSCALPSQRT%data
!!$ENDDO
!!$  
!!$write (nulout,*) 'Check bi-orthogonality of written vectors'
!!$DO j=1,ingood
!!$  DO jm=1,ingood
!!$    ztheta(jm) = DOT_PRODUCT (YL_ZY(j),YL_ZX(jm))
!!$  ENDDO
!!$  write (nulout,*) '<Y('   , j ,  ') , X(:)>='  ,  ztheta(1:ingood)
!!$ENDDO
!!$
!!$!---  Close the svifs and svevo files
!!$
!!$IF (LECMWF) THEN
!!$  IF(MYPROC == IOMASTER) THEN
!!$    IRET=0
!!$    CALL PBCLOSE(I_LUN_Y,IRET)
!!$    IF(IRET /= 0) THEN
!!$      WRITE(NULOUT,'('' >> BALANCED_REDUCTION: PBCLOSE FAILED on svifs'')')
!!$      WRITE(NULOUT,'(''                IRET='',I10)') IRET
!!$      CALL ABOR1('BALANCED_REDUCTION: PBCLOSE ERROR')
!!$    ENDIF
!!$  ENDIF
!!$  IF(MYPROC == IOMASTER) THEN
!!$    IRET=0
!!$    CALL PBCLOSE(I_LUN_X,IRET)
!!$    IF(IRET /= 0) THEN
!!$      WRITE(NULOUT,'('' >> BALANCED_REDUCTION: PBCLOSE FAILED on svevo'')')
!!$      WRITE(NULOUT,'(''                IRET='',I10)') IRET
!!$      CALL ABOR1('BALANCED_REDUCTION: PBCLOSE ERROR')
!!$    ENDIF
!!$  ENDIF
!!$ENDIF
!!$1234 CONTINUE
!============================================================

!--- Deallocate storage for the X and Y vectors

DO j=1,ingood
  CALL deallocate_ctlvec(YL_ZX(j))
  CALL deallocate_ctlvec(YL_ZY(j))
ENDDO
deallocate (YL_ZX)
deallocate (YL_ZY)

!--- return the number of iterations actually performed

kmaxit=iter

IF (LHOOK) CALL DR_HOOK('BALANCED_REDUCTION',1,ZHOOK_HANDLE)
end subroutine balanced_reduction
