SUBROUTINE ROKFCOVAR

!     *ROKFCOVAR*  - Propagate the covariance matrix for the Farrell/Ioannou reduced-order KF

!     Purpose.
!     --------
!           Propagate a projection of the covariance matrix

!     Interface.
!     ----------
!        *CALL* *ROKFCOVAR

!     Externals.   SIM4D  - simulator (for X computes J and grad(J) )
!     ----------

!     Reference.
!     ----------
!        ECMWF Research Department documentation of the IFS

!     Author.
!     -------
!        M. Fisher

!     Modifications.
!     --------------
!        Original : 02-07-01
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Hamrud      10-Jan-2004 CY28R1 Cleaning
!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMCVA   , ONLY :           YSCALPSQRT, YSCALP
USE YOMVAR   , ONLY : LJCDFI
USE YOMCT0   , ONLY : NCONF    ,LOBS, LFDBOP
USE YOMMP    , ONLY : NOUTTYPE
USE YOMIO    , ONLY : LPPTSF
USE YOMLUN   , ONLY : NULOUT   
USE YOMSP    , ONLY : SPA3, SPA2, SPO3
USE YOMJG    , ONLY : LSUBBG
USE YOMVRTL  , ONLY : L131TL
USE YOMGRB   , ONLY : NSEC1
USE YOMSKF   , ONLY : LSKF, NCOVARVECS, CINCOVARX  ,CINCOVARY, LTWSKFZ, MSKFVEC
USE YOMMSC, ONLY : N_DEFAULT_REAL_KIND, N_DOUBLE_KIND
USE CONTROL_VECTORS
USE YOM_YGFL , ONLY : YO3

IMPLICIT NONE

TYPE (CONTROL_VECTOR) :: YL_ZSQRT_ENERGY_WEIGHTS, YL_ZXVEC(NCOVARVECS), YL_ZYVEC(NCOVARVECS), &
 & YL_ZGRAD0, YL_ZX, YL_ZGRAD, YL_ZXHAT(NCOVARVECS)  


INTEGER(KIND=JPIM) :: ji,jj,jk,jl,jvec,indic,iter,ivadim,info


REAL(KIND=JPRB) :: zdots(NCOVARVECS,NCOVARVECS), zdummy, ZPA(NCOVARVECS,NCOVARVECS), ztrace, &
 & ZMODL(NCOVARVECS,NCOVARVECS),ZWORK(10*NCOVARVECS),ZWKMAT(NCOVARVECS,NCOVARVECS), &
 & ZU(1),ZVT(1),ZSVALS(NCOVARVECS),ZPF(NCOVARVECS,NCOVARVECS)  

CHARACTER(LEN=16) :: clfile
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"
#include "cain.intfb.h"
#include "cainin.intfb.h"
#include "chavar.intfb.h"
#include "cnt3tl.intfb.h"
#include "ppclose.intfb.h"
#include "ppflush.intfb.h"
#include "readvec.intfb.h"
#include "sim4d.intfb.h"
#include "supp.intfb.h"
#include "suscal.intfb.h"
#include "wrmlpp.intfb.h"

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

IF (LHOOK) CALL DR_HOOK('ROKFCOVAR',0,ZHOOK_HANDLE)
CALL ALLOCATE_CTLVEC (YL_ZSQRT_ENERGY_WEIGHTS)
CALL ALLOCATE_CTLVEC (YL_ZGRAD0)
CALL ALLOCATE_CTLVEC (YL_ZGRAD)
CALL ALLOCATE_CTLVEC (YL_ZX)
DO jvec=1,NCOVARVECS  
  CALL ALLOCATE_CTLVEC (YL_ZXVEC(jvec))
  CALL ALLOCATE_CTLVEC (YL_ZYVEC(jvec))
  CALL ALLOCATE_CTLVEC (YL_ZXHAT(jvec))
ENDDO

!        1.  Compute weights for the energy inner product
!            -------------------------------------------

NCONF=601
CALL SUSCAL
YL_ZSQRT_ENERGY_WEIGHTS = YSCALPSQRT
NCONF=131
CALL SUSCAL

!        2.  Read the X and Y vectors, and convert to Euclidean space
!            --------------------------------------------------------

LSKF   = .true.
DO jvec=1,NCOVARVECS  
  SPA3(:,:,:) = 0.0_JPRB
  SPA2(:,:)   = 0.0_JPRB

  clfile = CINCOVARX
  WRITE(clfile(7:9),'(I3.3)') jvec
  CALL readvec (clfile,LDJB=.FALSE.)
  IF (YO3%LSP) SPO3(:,:)=0.0_JPRB
  CALL CAININ (YL_ZXVEC(jvec))
  YL_ZXVEC(jvec)%data=YL_ZXVEC(jvec)%data*YL_ZSQRT_ENERGY_WEIGHTS%data

  clfile = CINCOVARY
  WRITE(clfile(7:9),'(I3.3)') jvec
  CALL readvec (clfile,LDJB=.FALSE.)
  IF (YO3%LSP) SPO3(:,:)=0.0_JPRB
  CALL CAININ (YL_ZYVEC(jvec))
  YL_ZYVEC(jvec)%data=YL_ZYVEC(jvec)%data*YL_ZSQRT_ENERGY_WEIGHTS%data
ENDDO
LSKF   = .false.

!        2.5  Check that the vectors are bi-orthogonal
!             ----------------------------------------

DO jvec=1,NCOVARVECS  
  DO jj=1,NCOVARVECS
    Zdots(jj,jvec)=DOT_PRODUCT(YL_ZYVEC(jj),YL_ZXVEC(jvec))
  ENDDO
  Zdots(jvec,jvec)=Zdots(jvec,jvec)-1.0_JPRB
ENDDO

IF (MAXVAL(ABS(Zdots(:,:)))>1E-4_JPRB) THEN
  WRITE (NULOUT,*) 'ROKFCOVAR: X and Y vectors are not bi-orthogonal.'
  WRITE (NULOUT,*) 'ROKFCOVAR: Possibly the singular vector job used a different inner product.'
  WRITE (NULOUT,*) 'ROKFCOVAR: Check that SIPR, SITR and LSLAG are the same as in the sv job.'
  WRITE (NULOUT,*) 'ROKFCOVAR: Y''X-I is: (elements should normaly be O(1e-6))'
  DO jvec=1,NCOVARVECS
    WRITE (NULOUT,*) 'ROKFCOVAR: row ',jvec,': ',Zdots(:,jvec)
  ENDDO
ENDIF

!        2.75 Take the X matrix to control space
!             ----------------------------------

LSUBBG = .false.
DO jvec=1,NCOVARVECS
  WHERE (YL_ZSQRT_ENERGY_WEIGHTS%data(:) /= 0.0_JPRB)
    YL_ZX%data(:)=YL_ZXVEC(jvec)%data(:)/YL_ZSQRT_ENERGY_WEIGHTS%data(:)
  ELSEWHERE
    YL_ZX%data(:)=0.0_JPRB
  ENDWHERE
  CALL CAIN   (YL_ZX)
  CALL CHAVAR (YL_ZXHAT(jvec))
ENDDO

!        3.  Calculate the projection of the Hessian
!            ---------------------------------------

indic=4
ivadim=YL_ZX%nsizeg

iter=0
YL_ZX=0.0_JPRB
LSUBBG = .true.
CALL SIM4D (indic,ivadim,YL_ZX,zdummy,YL_ZGRAD0,iter)
LSUBBG = .false.
YL_ZGRAD0%data(:) = 0.5_JPRB*YL_ZGRAD0%data(:)*YSCALP%data(:)

DO jvec=1,NCOVARVECS
  iter=jvec
  LSUBBG = .true.
  CALL SIM4D (indic,ivadim,YL_ZXHAT(jvec),zdummy,YL_ZGRAD,iter)
  LSUBBG = .false.
  YL_ZGRAD%data(:) = 0.5_JPRB*YL_ZGRAD%data(:)*YSCALP%data(:) - YL_ZGRAD0%data(:)

  DO jj=1,NCOVARVECS
    ZPA(jj,jvec) = DOT_PRODUCT(YL_ZXHAT(jj),YL_ZGRAD)
  ENDDO
  WRITE (NULOUT,*) 'ROKFCOVAR: Projected Hessian row ',jvec,' is ',ZPA(:,jvec)
ENDDO

DO jvec=1,NCOVARVECS
  IF (ZPA(jvec,jvec)<0.0_JPRB) THEN
    WRITE (NULOUT,*) 'ROKFCOVAR: Projected Hessian has a non-positive diagonal'
    WRITE (NULOUT,*) 'ROKFCOVAR: ZPA(',jvec,',',jvec,')=',ZPA(jvec,jvec)
    CALL ABOR1 ('ROKFCOVAR: Projected Hessian has a non-positive diagonal')
  ENDIF
ENDDO

DO jvec=1,NCOVARVECS
  DO jj=1,jvec-1
    IF (ABS(ZPA(jj,jvec)-ZPA(jvec,jj)) > &
       & 1E-4_JPRB *MAX(SQRT(ZPA(jj,jj))*SQRT(ZPA(jvec,jvec)),    &
       & ABS(ZPA(jj,jvec)+ZPA(jvec,jj))        ) ) THEN  
      WRITE (NULOUT,*) 'ROKFCOVAR: Projected Hessian is not symmetric for row ',jj,' column ',jvec
      WRITE (NULOUT,*) 'ROKFCOVAR: ZPA(',jj,',',jvec,')=',ZPA(jj,jvec)
      WRITE (NULOUT,*) 'ROKFCOVAR: ZPA(',jvec,',',jj,')=',ZPA(jvec,jj)
      CALL ABOR1 ('ROKFCOVAR: Projected Hessian is not symmetric')
    ENDIF
  ENDDO
ENDDO

!        4.  Invert to get the analysis error covariance matrix
!            --------------------------------------------------

CALL INVERT (ZPA)

DO jvec=1,NCOVARVECS
  WRITE (NULOUT,*) 'ROKFCOVAR: Reduced Analysis Error Covariance row ',jvec,' is ',ZPA(:,jvec)
ENDDO

ztrace=0.0_JPRB
DO jj=1,NCOVARVECS
  ztrace=ztrace+ZPA(jj,jj)
ENDDO
WRITE (NULOUT,*) 'ROKFCOVAR: Trace of reduced analysis error covariance=',ztrace
WRITE (NULOUT,*) 'ROKFCOVAR: Variances of reduced analysis error=',(ZPA(jj,jj),jj=1,NCOVARVECS)

!        5.  Calculate the reduced-order dynamics
!            ------------------------------------

LOBS=.FALSE.
L131TL=.FALSE.
LJCDFI=.FALSE.

DO jvec=1,NCOVARVECS
  WHERE (YL_ZSQRT_ENERGY_WEIGHTS%data(:) /= 0.0_JPRB)
    YL_ZX%data(:)=YL_ZXVEC(jvec)%data(:)/YL_ZSQRT_ENERGY_WEIGHTS%data(:)
  ELSEWHERE
    YL_ZX%data(:)=0.0_JPRB
  ENDWHERE

  CALL CAIN (YL_ZX)
  CALL CNT3TL
  CALL CAININ (YL_ZGRAD)
  YL_ZGRAD%data = YL_ZGRAD%data*YL_ZSQRT_ENERGY_WEIGHTS%data

  DO jj=1,NCOVARVECS
    ZMODL(jj,jvec) = DOT_PRODUCT(YL_ZYVEC(jj),YL_ZGRAD)
  ENDDO
  WRITE (NULOUT,*) 'ROKFCOVAR: Reduced dynamics row ',jvec,' is ',ZMODL(:,jvec)
ENDDO

ZWKMAT(:,:) = ZMODL(:,:)

IF (JPRB == N_DEFAULT_REAL_KIND) THEN
  call SGESVD ('N','N',NCOVARVECS,NCOVARVECS,ZWKMAT,NCOVARVECS,ZSVALS,ZU,1,ZVT,1, &
   & ZWORK,SIZE(ZWORK),info)  
  IF (INFO /= 0) THEN
    WRITE (NULOUT,*) 'ROKFCOVAR: SGESVD failed. INFO=',info
    CALL ABOR1 ('SPOTRI failed')
  ENDIF
ELSEIF (JPRB == N_DOUBLE_KIND) THEN
  call DGESVD ('N','N',NCOVARVECS,NCOVARVECS,ZWKMAT,NCOVARVECS,ZSVALS,ZU,1,ZVT,1, &
   & ZWORK,SIZE(ZWORK),info)  
  IF (INFO /= 0) THEN
    WRITE (NULOUT,*) 'ROKFCOVAR: DGESVD failed. INFO=',info
    CALL ABOR1 ('SPOTRI failed')
  ENDIF
ELSE
  call ABOR1 ('REAL(KIND=JPRB) is neither default real nor double precision')
ENDIF

WRITE (NULOUT,*) 'ROKFCOVAR: The singular values of the reduced dynamics are: ',ZSVALS

!        6.  Propagate the covariance matrix
!            -------------------------------

DO ji=1,NCOVARVECS
  DO jj=ji,NCOVARVECS
    ZPF(ji,jj) = 0.0_JPRB
    DO jk=1,NCOVARVECS
      DO jl=1,NCOVARVECS
        ZPF(ji,jj) = ZPF(ji,jj) + ZPA(jk,jl)*ZMODL(ji,jk)*ZMODL(jj,jl)
      ENDDO
    ENDDO
  ENDDO
ENDDO

DO ji=1,NCOVARVECS
  DO jj=1,ji-1
    ZPF(ji,jj) = ZPF(jj,ji)
  ENDDO
ENDDO

DO jvec=1,NCOVARVECS
  WRITE (NULOUT,*) 'ROKFCOVAR: Reduced Forecast Error Covariance row ',jvec,' is ',ZPF(:,jvec)
ENDDO

ztrace=0.0_JPRB
DO jj=1,NCOVARVECS
  ztrace=ztrace+ZPF(jj,jj)
ENDDO
WRITE (NULOUT,*) 'ROKFCOVAR: Trace of reduced forecast error covariance=',ztrace
WRITE (NULOUT,*) 'ROKFCOVAR: Variances of reduced forecast error=',(ZPF(jj,jj),jj=1,NCOVARVECS)

!        6.5 Add a small amount of I to shift the eigenvalues and reduce the conditioning
!            If you don't like it, think of it as adding a model error term!
!            ----------------------------------------------------------------------------

DO jj=1,NCOVARVECS
  ZPF(jj,jj) = ZPF(jj,jj) + 1E-2_JPRB
ENDDO

!        7.  Invert the forecast error covariance matrix
!            -------------------------------------------

CALL INVERT (ZPF)

!        8.  Calculate and output the Z vectors 
!            ----------------------------------

LFDBOP = .false.
NOUTTYPE=1
LPPTSF = .TRUE.
CALL SUPP (' ')
NSEC1(54)=1
NSEC1(50)=1

DO jvec=1,NCOVARVECS
  YL_ZGRAD = 0.0_JPRB
  DO jj=1,NCOVARVECS
    YL_ZGRAD%data = YL_ZGRAD%data + YL_ZYVEC(jj)%data*ZPF(jj,jvec)
  ENDDO
  YL_ZGRAD%data = YL_ZGRAD%data*YL_ZSQRT_ENERGY_WEIGHTS%data

  CALL CAIN (YL_ZGRAD)
  MSKFVEC=jvec
  LTWSKFZ=.true.
  CALL WRMLPP ('?')
  LTWSKFZ=.false.
  CALL PPFLUSH
  CALL PPCLOSE
ENDDO

!       99.  Deallocate allocated arrays
!            ---------------------------

CALL DEALLOCATE_CTLVEC (YL_ZSQRT_ENERGY_WEIGHTS)
CALL DEALLOCATE_CTLVEC (YL_ZGRAD0)
CALL DEALLOCATE_CTLVEC (YL_ZGRAD)
CALL DEALLOCATE_CTLVEC (YL_ZX)
DO jvec=1,NCOVARVECS  
  CALL DEALLOCATE_CTLVEC (YL_ZXVEC(jvec))
  CALL DEALLOCATE_CTLVEC (YL_ZYVEC(jvec))
  CALL DEALLOCATE_CTLVEC (YL_ZXHAT(jvec))
ENDDO

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

CONTAINS
SUBROUTINE INVERT (P_ZMAT)

REAL(KIND=JPRB),INTENT(INOUT) :: P_ZMAT(:,:)
INTEGER(KIND=JPIM) :: idim,jrow,jcol
REAL(KIND=JPRB) :: ZHOOK_HANDLE

IF (LHOOK) CALL DR_HOOK('ROKFCOVAR:INVERT',0,ZHOOK_HANDLE)
idim = SIZE(P_ZMAT,1)

IF (JPRB == N_DEFAULT_REAL_KIND) THEN
  CALL SPOTRF ('U',idim,P_ZMAT,idim,info)
  IF (INFO /= 0) THEN
    WRITE (NULOUT,*) 'ROKFCOVAR: SPOTRF failed. INFO=',info
    CALL ABOR1 ('SPOTRF failed')
  ENDIF

  call SPOTRI ('U',idim,P_ZMAT,idim,info)
  IF (INFO /= 0) THEN
    WRITE (NULOUT,*) 'ROKFCOVAR: SPOTRI failed. INFO=',info
    CALL ABOR1 ('SPOTRI failed')
  ENDIF
ELSEIF (JPRB == N_DOUBLE_KIND) THEN
  CALL DPOTRF ('U',idim,P_ZMAT,idim,info)
  IF (INFO /= 0) THEN
    WRITE (NULOUT,*) 'ROKFCOVAR: DPOTRF failed. INFO=',info
    CALL ABOR1 ('DPOTRF failed')
  ENDIF

  CALL DPOTRI ('U',idim,P_ZMAT,idim,info)
  IF (INFO /= 0) THEN
    WRITE (NULOUT,*) 'ROKFCOVAR: DPOTRI failed. INFO=',info
    CALL ABOR1 ('DPOTRI failed')
  ENDIF
ELSE
  call ABOR1 ('REAL(KIND=JPRB) is neither default real nor double precision')
ENDIF

DO jrow=1,idim
  DO jcol=1,jrow-1
    P_ZMAT(jrow,jcol) = P_ZMAT(jcol,jrow)
  ENDDO
ENDDO

IF (LHOOK) CALL DR_HOOK('ROKFCOVAR:INVERT',1,ZHOOK_HANDLE)
END SUBROUTINE INVERT
END SUBROUTINE ROKFCOVAR
