SUBROUTINE xformev(kmxvec,ldanerr)

!-----------------------------------------------------------------------
!   XFORMEV - Transform eigenvectors from CONGRAD to model variable
!             space.

!   Purpose.
!   -------- 

!   Interface.
!   ----------
!      CALL XFORMEV (kmxvec)

!      Explicit arguments: kmxvec - Max number of vectors
!                          ldanerr - Calculate analysis error variance?

!      Implicit input: eigenvalues and eigenvectors of the
!                      preconditioned Hessian in file CEVCGL

!   Externals.
!   ----------
!              PRECOND
!              CHAVARIN
!              WRMLPP
!              PPCLOSE
!              PPFLUSH
!              SETRAN
!              SIM4D
!              SCALEAE
!              SAVMINI
!              SAVMINI2

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

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

!   Modifications.
!   --------------
!       Original  94-04-29
!       L.Isaksen   95-06-06 - Reordering of spectral arrays
!       M.Fisher    95-06-06 - Output vectors in GRIB format
!       E.Andersson 96-08-01 - Precalculated SQRT(SCALP)
!       P. Unden    96-06-18 - Limit the alpha correction
!       M. Fisher   96-08-01 - Vectors optionally in memory
!       M. Fisher   96-11-26 - Use distributed_vectors_mix
!       M.Hamrud    98-01-10 - Minimisation fully parallelized
!       E.Andersson 98-05-19 - Sigma_b and BgQC for radiances
!       Y.Tremolet  00-08-15 - use module TRAJECTORY
!       G.Desroziers 02-09-16 - also treat Aladin mean wind trajectory
!       Y.Tremolet  02-08-06 - Use control_vectors.
!       M.Hamrud    01-Oct-2003 CY28 Cleaning
!       C.Cardinali 03-12-03 - Analysis Sensitivity to Observations
!       M.Hamrud      01-Dec-2003 CY28R1 Cleaning
!       M.Hamrud      10-Jan-2004 CY28R1 Cleaning
!       Y.Tremolet    24-Aug-2004 Model error diagnostics
!       D.Salmond     18-Apr-2007 Use multiple processors for I/O
!       T.Wilhelmsson 26-Aug-2009 Move multiprocessor I/O to SAVMINI2
!-----------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMDIM   , ONLY : NPROMA   ,NFD2D    ,NS3D     ,NS2D     ,NSPEC2   ,NFLSUR, NGPBLKS, NFLEVG
USE YOMGEM   , ONLY : NGPTOT
USE YOMSP    , ONLY : SP5A3    ,SP5A2   ,SPA3     ,SPA2
USE YOMGFL   , ONLY : GFL
USE YOM_YGFL , ONLY : YGFL
USE YOMCT0   , ONLY : LFDBOP   ,LOBS, NPROC
USE YOMCT3   , ONLY : NSTEP
USE YOMCVA   , ONLY : YRSCALPSQRT
USE YOMVAR   , ONLY : MCGLVEC  ,LMPCGL   ,LTWCGL   ,LWRIEVEC ,LBGM ,NOANEF ,&
 & LEVECCNTL,LEVECGRIB,NWRIEVEC ,NSSHEV_COUNT   ,NHEVECS, LANOBS
USE YOMJG    , ONLY : LSUBBG, LCTLFG
USE YOMLUN   , ONLY : NULERR, NULOUT
USE YOMVCGL  , ONLY : YVCGLPC   ,RCGLPC   ,YVCGLEV   ,&
 & RCGLEV   ,NVCGLPC  ,NVCGLEV  
USE YOMMP    , ONLY : NOUTTYPE ,NPSP
USE YOMIO    , ONLY : LPPTSF
USE YOMVRTL  , ONLY : L131TL   ,LTLINT
USE YOMANEB  , ONLY : ANEBUF
USE YOMMSC   , ONLY : N_DEFAULT_REAL_KIND, N_DOUBLE_KIND
USE TRAJECTORY_MOD, ONLY: ltrajgp, get_traj_spec
USE YOMOP    , ONLY : CFNCGL
USE CONTROL_VECTORS
USE YOMGETMINI, ONLY : MIOPROC, RZVAZX, NUM_IO_PROCS, NUM_PROCS_PER_IO_PROC
USE OML_MOD, ONLY : OML_MAX_THREADS, OML_MY_THREAD

IMPLICIT NONE

!    DUMMY REAL
INTEGER(KIND=JPIM),INTENT(IN)    :: KMXVEC 
LOGICAL           ,INTENT(IN)    :: LDANERR 
REAL(KIND=JPRB) :: ZDUM(1,1)
TYPE(control_vector), ALLOCATABLE, DIMENSION(:) :: YL_ZCGLWK
TYPE(control_vector) :: YL_ZY

REAL(KIND=JPRB), ALLOCATABLE :: ZSPA3(:,:,:),ZSPA2(:,:)

REAL(KIND=JPRB) :: zmat(kmxvec,kmxvec)
REAL(KIND=JPRB), ALLOCATABLE :: zbge(:,:),zane(:,:), zgfl(:,:,:,:)
INTEGER(KIND=JPIM) :: inpcvs,invecs,ii,info &
 & ,IOUTTYPE,istc,iendc,ikl  

REAL(KIND=JPRB) :: za2bmin_ratio,zz
INTEGER(KIND=JPIM) :: j,jk,jj,ji,jm,jkg,jkglo,iblock,isize,ibeg,iend
INTEGER(KIND=JPIM) :: jvec_start, jvec_end, ICOUNT, jvec_last

logical :: llfdbop,LLPPTSF,LL131TL,LLOBS
CHARACTER :: CLFCGL*9
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"
#include "cainin.intfb.h"
#include "chavarin.intfb.h"
#include "cnt3tl.intfb.h"
#include "ppclose.intfb.h"
#include "ppflush.intfb.h"
#include "savmini.intfb.h"
#include "savmini2.intfb.h"
#include "sc2rdg.intfb.h"
#include "sc2wrg.intfb.h"
#include "stepo.intfb.h"
#include "stepotl.intfb.h"
#include "supp.intfb.h"
#include "write_ctlvec_grib.intfb.h"
#include "wrmlpp.intfb.h"
#include "sualldfi.intfb.h"
#include "dealldfi.intfb.h"
!     ------------------------------------------------------------------

IF (LHOOK) CALL DR_HOOK('XFORMEV',0,ZHOOK_HANDLE)

!--- read eigenvalues of the preconditioner

inpcvs = 0 ! Up to now always the case in operations...
if (LMPCGL) inpcvs = NVCGLPC

!--- read eigenvalues of the preconditioned Hessian

invecs = NVCGLEV

!--- assign buffer for work file

NHEVECS = min(kmxvec,invecs+inpcvs)
! The vectors are copied below regardless of the size of YL_ZCGLWK...
IF (NHEVECS<invecs+inpcvs) CALL ABOR1('XFORMEV: kmxvec too small')

ALLOCATE (YL_ZCGLWK(NHEVECS))
DO ii=1,NHEVECS
  CALL allocate_ctlvec(YL_ZCGLWK(ii))
ENDDO

!--- copy preconditioner vectors to work file

DO jk=1,inpcvs
  zz=sqrt(RCGLPC(jk)-1.0_JPRB)
  YL_ZCGLWK(jk)%data = zz * YVCGLPC(jk)%data
ENDDO

!--- copy and transform eigenvectors of preconditioned Hessian

call gstats(1238,0)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jk,ji,zz)
DO jk=1,invecs
  ji=jk+inpcvs
  zz=sqrt(RCGLEV(jk)-1.0_JPRB)
  YL_ZCGLWK(ji)%data = zz * YVCGLEV(jk)%data
ENDDO
!$OMP END PARALLEL DO
call gstats(1238,1)

!---  form the inner matrix for the Shermann-Morrison-Woodbury inversion

do jj=1,NHEVECS
  zmat(1:NHEVECS,jj) = DOT_PRODUCT (YL_ZCGLWK(1:NHEVECS),YL_ZCGLWK(jj))
  zmat(jj,jj) = zmat(jj,jj) + 1.0_JPRB
ENDDO

!--- Cholesky decompose

if (JPRB == N_DEFAULT_REAL_KIND) then
  call SPOTRF ('L',NHEVECS,zmat,kmxvec,info)
ELSEIF (JPRB == N_DOUBLE_KIND) then
  call DPOTRF ('L',NHEVECS,zmat,kmxvec,info)
else
  call ABOR1 ('REAL(KIND=JPRB) is neither default real nor double precision')
endif

if (info /= 0) then
  write (NULERR,*)'xformev: error computing Cholesky decomposition'
  write (NULERR,*) 'SPOTRF/DPOTRF returns info=',info
  call ABOR1('xformev: error computing Cholesky decomposition')
endif

!--- transform vectors


if(NHEVECS > 0)then
  isize=SIZE(YL_ZCGLWK(1)%data)
else
  isize=0
endif
iblock=(isize-1)/oml_max_threads()+1

if( isize > 0 )then
  call gstats(1238,0)
!$OMP PARALLEL PRIVATE(ibeg,iend,ji,jm)
  ibeg=(oml_my_thread()-1)*iblock+1
  iend=min(isize,oml_my_thread()*iblock)
  do ji=1,NHEVECS
    do jm=1,ji-1
      YL_ZCGLWK(ji)%data(ibeg:iend) = YL_ZCGLWK(ji)%data(ibeg:iend) - zmat(ji,jm)*YL_ZCGLWK(jm)%data(ibeg:iend)
    enddo
    YL_ZCGLWK(ji)%data(ibeg:iend) = YL_ZCGLWK(ji)%data(ibeg:iend) / zmat(ji,ji)
  enddo
!$OMP END PARALLEL
  call gstats(1238,1)
endif


!--- Apply the change of variable to the eigenvectors and accumulate

if (LWRIEVEC .AND. .NOT.LEVECCNTL .AND. NWRIEVEC>0) then
  LTWCGL = .true.
  llfdbop = LFDBOP
  LFDBOP = .false.
  IOUTTYPE=NOUTTYPE
  NOUTTYPE=1
  LLPPTSF = LPPTSF
  LPPTSF = .TRUE.
  call SUPP (' ')
endif

call allocate_ctlvec(YL_ZY)

!--- Take bg to Fourier space, if necessary.
IF (ldanerr .and. .NOT.(LBGM .OR. LTRAJGP)) THEN
  CALL GSTATS(15,0)
  CALL get_traj_spec(SP5A3,SP5A2,ZDUM)
  CALL GSTATS(15,1)
  call STEPO('0E0000000')
ENDIF

!--- Save background errors in memory.
IF (ldanerr .and. LBGM) THEN
  ALLOCATE(zbge(NGPTOT,NOANEF))
  ALLOCATE(zane(NPROMA,NOANEF))
  call gstats(1238,0)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jkglo,istc,iendc,jkg,ikl)
  do jkglo=1,NGPTOT,NPROMA
    istc=1
    iendc=min(NPROMA,NGPTOT-jkglo+1)
    call SC2RDG(ANEBUF,jkglo,istc,iendc,zane)
    do jkg=jkglo-1+istc,jkglo-1+iendc
      ikl = jkg-jkglo+1
      zbge(jkg,:) = zane(ikl,:)
    enddo
  enddo
!$OMP END PARALLEL DO
  call gstats(1238,1)
ENDIF

LL131TL=L131TL
LLOBS=LOBS
IF(.NOT.LANOBS) THEN
  L131TL=.FALSE.
  LOBS=.FALSE.
ENDIF
IF(LANOBS .OR. LBGM) CALL SUALLDFI(NULOUT)

NUM_PROCS_PER_IO_PROC=MAX(1,NPROC/NWRIEVEC)
NUM_IO_PROCS=NPROC/NUM_PROCS_PER_IO_PROC

IF(NUM_IO_PROCS > 1 .AND. .NOT.LEVECGRIB)THEN
  ALLOCATE(MIOPROC(NHEVECS))
  jvec_last=0

  DO ICOUNT=1,(NHEVECS-1)/NUM_IO_PROCS+1

    ALLOCATE(RZVAZX(1))
    jvec_start=jvec_last+1
    jvec_last=MIN(NHEVECS,jvec_start+NUM_IO_PROCS-1)
    jvec_end=MIN(NWRIEVEC,jvec_start+NUM_IO_PROCS-1)
    jvec_end=MIN(jvec_end,jvec_last)

    DO jj=jvec_start,jvec_last
      MCGLVEC = jj

      CALL gstats(1238,0)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(j)
      DO j=1,SIZE(YL_ZY%data)
        YL_ZCGLWK(jj)%data(j) = YL_ZCGLWK(jj)%data(j) * YRSCALPSQRT%data(j)
      enddo
!$OMP END PARALLEL DO
      CALL gstats(1238,1)
    
      IF (LWRIEVEC .AND. LEVECCNTL .AND. LEVECGRIB) THEN
        CLFCGL = CFNCGL
        CALL WRITE_CTLVEC_GRIB (CLFCGL,YL_ZCGLWK(jj))
      ENDIF
    ENDDO

    IF (LWRIEVEC .AND. LEVECCNTL .AND. .NOT.LEVECGRIB .AND. jvec_start<=jvec_end) THEN
      CLFCGL = CFNCGL
      CALL SAVMINI2 (YL_ZCGLWK,CLFCGL,jvec_start,jvec_end)
    ENDIF
    
    DO jj=jvec_start,jvec_last
      MCGLVEC = jj

      LSUBBG = .FALSE.
      CALL CHAVARIN (YL_ZCGLWK(jj))
      LSUBBG = .NOT.LCTLFG

      IF (LWRIEVEC .AND. .NOT.LEVECCNTL) THEN
        IF (LEVECGRIB) THEN
          CALL wrmlpp ('?')
          CALL PPFLUSH
          CALL PPCLOSE
        ELSE
          CALL CAININ (YL_ZCGLWK(jj))
        ENDIF
      ENDIF      

!--- Integrate TL model, and call obs. operators LANOBS: swith for self-sensitivity
!---                                             LBGM  : swith to propagate variances
      IF(LBGM) THEN
        LTLINT=.TRUE.
        NSSHEV_COUNT=jj
        CALL CNT3TL
        LTLINT=.FALSE.
      ELSEIF(LANOBS) THEN
        ALLOCATE(ZSPA3(NFLSUR,NSPEC2,NS3D))
        ALLOCATE(ZSPA2(NSPEC2,NS2D))
        ALLOCATE(ZGFL(NPROMA,NFLEVG,YGFL%NDIM,NGPBLKS))
        CALL gstats(1238,0)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(j)
        DO j=1,NSPEC2
          ZSPA3(:,j,:)=SPA3(:,j,:)
        ENDDO
!$OMP END PARALLEL DO
        CALL gstats(1238,1)
        IF(NPSP == 1) ZSPA2(:,1:NFD2D) = SPA2(:,1:NFD2D)
        call gstats(1238,0)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(j)
        do j=1,NGPBLKS
              zgfl(:,:,:,j)=gfl(:,:,:,j)
        enddo
!$OMP END PARALLEL DO
        call gstats(1238,1)
        LTLINT=.TRUE.
        NSSHEV_COUNT=jj
        CALL CNT3TL
        LTLINT=.FALSE.
        CALL gstats(1238,0)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(j)
        DO j=1,NSPEC2
          SPA3(:,j,:)=ZSPA3(:,j,:)
        ENDDO
!$OMP END PARALLEL DO
        CALL gstats(1238,1)
        IF(NPSP == 1) SPA2(:,1:NFD2D) = ZSPA2(:,1:NFD2D)
        DEALLOCATE(ZSPA3)
        DEALLOCATE(ZSPA2)
        call gstats(1238,0)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(j)
        do j=1,NGPBLKS
           gfl(:,:,:,j)=zgfl(:,:,:,j)
        enddo
!$OMP END PARALLEL DO
        call gstats(1238,1)
        deallocate(zgfl)
      ENDIF
    
!--- transform to grid space and accumulate

!--- radiance computation needs trajectory, so use TL routines.
      IF (LANOBS) NSTEP=0
      IF (ldanerr) THEN
        NSTEP=0
        CALL STEPOTL('0AA00B000')
      ENDIF
    ENDDO

    IF (LWRIEVEC .AND. .NOT.LEVECCNTL .AND. .NOT.LEVECGRIB.AND. jvec_start<=jvec_end) THEN
      CLFCGL = CFNCGL
      CALL SAVMINI2 (YL_ZCGLWK,CLFCGL,jvec_start,jvec_end)
    ENDIF

    DEALLOCATE(RZVAZX)

  ENDDO

  DEALLOCATE(MIOPROC)

ELSE

DO jj=1,NHEVECS
  MCGLVEC = jj

  CALL gstats(1238,0)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(j)
  DO j=1,SIZE(YL_ZY%data)
    YL_ZY%data(j) = YL_ZCGLWK(jj)%data(j) * YRSCALPSQRT%data(j)
  ENDDO
!$OMP END PARALLEL DO
  CALL gstats(1238,1)

  IF (LWRIEVEC .AND. LEVECCNTL .AND. jj<=NWRIEVEC) THEN
    CLFCGL = CFNCGL
    WRITE(CLFCGL(7:),'(I3.3)') jj

    IF (LEVECGRIB) THEN
      CALL WRITE_CTLVEC_GRIB (CLFCGL,YL_ZY)
    ELSE
      CALL SAVMINI (YL_ZY,CLFCGL)
    ENDIF
  ENDIF

  LSUBBG = .false.
  CALL CHAVARIN (YL_ZY)
  LSUBBG = .NOT.LCTLFG

  IF (LWRIEVEC .AND. .NOT.LEVECCNTL .AND. jj<=NWRIEVEC) THEN
    IF (LEVECGRIB) THEN
      CALL wrmlpp ('?')
      CALL PPFLUSH
      CALL PPCLOSE
    ELSE
      CALL CAININ (YL_ZY)
      CLFCGL = CFNCGL
      WRITE(CLFCGL(7:),'(I3.3)') jj
      CALL savmini (YL_ZY,CLFCGL)
    ENDIF
  ENDIF

!--- Integrate TL model, and call obs. operators LANOBS: swith for self-sensitivity
!---                                             LBGM  : swith to propagate variances
  IF(LBGM) THEN
    LTLINT=.TRUE.
    NSSHEV_COUNT=jj
    CALL CNT3TL
    LTLINT=.FALSE.
  ELSEIF(LANOBS) THEN
    ALLOCATE(ZSPA3(NFLSUR,NSPEC2,NS3D))
    ALLOCATE(ZSPA2(NSPEC2,NS2D))
    ALLOCATE(ZGFL(NPROMA,NFLEVG,YGFL%NDIM,NGPBLKS))
    CALL gstats(1238,0)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(j)
    DO j=1,NSPEC2
      ZSPA3(:,j,:)=SPA3(:,j,:)
    ENDDO
!$OMP END PARALLEL DO
    CALL gstats(1238,1)
    IF(NPSP == 1) ZSPA2(:,1:NFD2D) = SPA2(:,1:NFD2D)
    call gstats(1238,0)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(j)
    do j=1,NGPBLKS
       zgfl(:,:,:,j)=gfl(:,:,:,j)
    enddo
!$OMP END PARALLEL DO
    call gstats(1238,1)
    LTLINT=.TRUE.
    NSSHEV_COUNT=jj
    CALL CNT3TL
    LTLINT=.FALSE.
    CALL gstats(1238,0)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(j)
    DO j=1,NSPEC2
      SPA3(:,j,:)=ZSPA3(:,j,:)
    ENDDO
!$OMP END PARALLEL DO
    CALL gstats(1238,1)
    IF(NPSP == 1) SPA2(:,1:NFD2D) = ZSPA2(:,1:NFD2D)
    call gstats(1238,0)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(j)
    do j=1,NGPBLKS
       gfl(:,:,:,j)=zgfl(:,:,:,j)
    enddo
!$OMP END PARALLEL DO
    call gstats(1238,1)
    DEALLOCATE(ZSPA3)
    DEALLOCATE(ZSPA2)
    DEALLOCATE(ZGFL)
  ENDIF

!--- transform to grid space and accumulate

!--- radiance computation needs trajectory, so use TL routines.
  IF (LANOBS) NSTEP=0
  IF (ldanerr) THEN
    NSTEP=0
    CALL STEPOTL('0AA00B000')
  ENDIF

ENDDO

ENDIF

CALL deallocate_ctlvec(YL_ZY)
L131TL=LL131TL
LOBS=LLOBS
NSSHEV_COUNT=0
IF(LANOBS) CALL DEALLDFI(NULOUT)

!--- Make sure the analysis error is not too small.
!--- The minimum allowed AN-error (zane) is a percentage
!--- of the BG-error (zbge). Both are variances.
IF (ldanerr .and. LBGM) THEN
  za2bmin_ratio=(0.30_JPRB**2.0_JPRB)
  CALL gstats(1238,0)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(jkglo,istc,iendc,jkg,ikl)
  DO jkglo=1,NGPTOT,NPROMA
    istc=1
    iendc=MIN(NPROMA,NGPTOT-jkglo+1)
    CALL SC2RDG(ANEBUF,jkglo,istc,iendc,zane)
    DO jkg=jkglo-1+istc,jkglo-1+iendc
      ikl = jkg-jkglo+1
      zane(ikl,:) = MAX(za2bmin_ratio*zbge(jkg,:),zane(ikl,:))
    ENDDO
    CALL SC2WRG(ANEBUF,jkglo,istc,iendc,zane)
  ENDDO
!$OMP END PARALLEL DO
  CALL gstats(1238,1)
  DEALLOCATE(zane)
  DEALLOCATE(zbge)
ENDIF

IF (LWRIEVEC .AND. .NOT.LEVECCNTL .AND. NWRIEVEC>0) THEN
  LTWCGL = .FALSE.
  LFDBOP = llfdbop
  NOUTTYPE=IOUTTYPE
  LPPTSF = LLPPTSF
  CALL SUPP (' ')
ENDIF

DO ii=1,SIZE(YL_ZCGLWK)
  CALL deallocate_ctlvec(YL_ZCGLWK(ii))
ENDDO
DEALLOCATE (YL_ZCGLWK)

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

9990 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8)

END SUBROUTINE xformev
