SUBROUTINE cfcsens2obs

#ifdef DOC

!     *cfcsens2obs*  - Controls the forcast sensitivity to observation at 1 level.

!     Purpose.
!     --------
!          Controls the forcast sensitivity to observation at 1 level 

!     Interface.
!     ----------
!        *CALL* *cfcsens2obs
!     Reference.
!     ----------

!     Author.
!     -------
!        Carla Cardinali
!     ------------------------------------------------------------------
#endif

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

USE YOMVAR   , ONLY : NSIM4D, NUPTRA, EVBCGL, LWRIEVEC, RCVGE, NITER, LJCDFI, &
 &                    LFCOBS, NITER_MIN
USE YOMTNEWT , ONLY : LIDMODEL
USE PARKIND1  ,ONLY : JPIM
USE YOMCVA   , ONLY : YVAZX, YVAZG, YSCALPSQRT, YSCALP, NVA3D, NVA2D, NGRBVAR
USE YOMCT0   , ONLY : NCONF, LGUESS, LOBS, NSTOP
USE YOMLUN   , ONLY : NULOUT, NULERR 
USE YOMCMA   , ONLY : NRESUPD
USE YOMDIM   , ONLY : NFD2D , NS3D , NS2D, NS1D, NSPEC2, NFLSUR, NSMAX, NMSMAX
USE YOMMP    , ONLY : NPSP
USE YOMSP    , ONLY : SPA3, SPA2, SPQ, SPT, SPDIV, SPVOR, SPSP, SPO3
USE YOMGRB   , ONLY : NGRBVO, NGRBD, NGRBT, NGRBLNSP, NGRBQ
USE YOMVRTL  , ONLY : L131TL   ,LTLINT
USE YOMJG    , ONLY : LSUBBG
USE MPL_MODULE, ONLY : MPL_ALLREDUCE
USE CONTROL_VECTORS
USE SPECTRAL_FIELDS_MOD

IMPLICIT NONE

INTEGER(KIND=JPIM) :: INEVECS


INTEGER(KIND=JPIM) :: igribsp3(4), igribsp2(1)
CHARACTER(LEN=20) :: CL_CFILE, CL_CFILE1

TYPE(control_vector) :: YL_ZLANCZOS, YL_ZVAZGTLS, YL_ZVAZG, YL_ZVAZG2, YL_ZWEIGHTS, YL_SQRT_ZWEIGHTS, &
                        & YVAZX_SAVE
TYPE(control_vector) :: YLCGLWK(niter+1)
TYPE(spectral_field) :: YL_T_SENGRAD, YLSP_X

REAL(KIND=JPRB), ALLOCATABLE :: ZSENSPA3(:,:,:), ZSENSPA2(:,:), ZSPA3(:,:,:), ZSPA2(:,:), ZSPA1(:,:)
REAL(KIND=JPRB) :: zwork(niter+1,4)

INTEGER(KIND=JPIM) :: IDUM, ITER, jj

REAL(KIND=JPRB) :: ZEPS, ZF, ZSAVELANCZOS, ZFI, ZVAZGNO, ZGI, ZGOLUBL_INV, ZGOLUBU_INV,&
 & ZGOLUBL_LOG, ZGOLUBU_LOG  

LOGICAL :: LLGOLUB, LSGTOBSS, LASG, LBASG
REAL(KIND=JPRB) :: ZHOOK_HANDLE
REAL(KIND=JPRB) :: ZNORM, zz1, zz1save

#include "readvec.intfb.h"
#include "cnt3tl.intfb.h"
#include "congrad.intfb.h"
#include "copy_spa2spec.intfb.h"
#include "prosca.intfb.h"
#include "sim4d.intfb.h"
#include "spnorm.intfb.h"
#include "write_spec_grib.intfb.h"
#include "writeoba.intfb.h"
#include "chavarinad.intfb.h"
#include "chavarin.intfb.h"
#include "caininad.intfb.h"
#include "state2spec.intfb.h"

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

!        1.  Compute initial cost-function and gradient.
!            -------------------------------------------

IF (LHOOK) CALL DR_HOOK('CFCSENS2OBS',0,ZHOOK_HANDLE)
WRITE(NULOUT,*) '--- Variational job : initial call to ',&
 & 'simulator ----------------------------'  
IDUM=-999
ZF=0.0_JPRB
NSIM4D=0
LFCOBS=.false.
!LSUBBG=.false.

WRITE(NULOUT,*) '-@@------cfcsen2obs----0'
call spnorm(0)
WRITE(NULOUT,*) '1)before SIM4D  LSUBBG=',LSUBBG
CALL SIM4D(4,IDUM,YVAZX,ZF,YVAZG,NSIM4D)
WRITE(NULOUT,*) '-@@------cfcsen2obs----1'
call spnorm(0)
ZVAZGNO=0.0_JPRB
ZFI=ZF
CALL PROSCA(IDUM,YVAZG,YVAZG,ZVAZGNO)
call spnorm(0)
WRITE(NULOUT,*) '-@@------cfcsen2obs----2'
ZGI=ZVAZGNO
WRITE(UNIT=NULOUT,FMT='('' INITIAL GRADIENT NORM SQUARED : ''&
 & ,E14.7,'' COST FUNCTION : '',E14.7)')&
 & ZGI,ZFI  
!     ------------------------------------------------------------------

!        2.    Solve a linerar system equations

!        2.1   Initialize and Read the Sensitivity Gradient.

CALL ALLOCATE_CTLVEC(YL_ZLANCZOS)
CALL ALLOCATE_SPEC(YLSP_X,NSMAX,NMSMAX,NVA3D,NVA2D,0,NGRBVAR)

ZEPS=RCVGE
ITER=NITER

WRITE(NULOUT,*) '-@@------cfcsen2obs----3---'
call spnorm(0)
!ALLOCATE(ZSPA3(NFLSUR,NSPEC2,NS3D))
!ALLOCATE(ZSPA2(NSPEC2,NS2D))
!IF(NPSP == 1) then
!  ZSPA2(:,1:NFD2D) = SPA2(:,1:NFD2D)
!  SPA2(:,1:NFD2D) = 0.0_JPRB
!ENDIF
!ZSPA3(:,:,:)=SPA3(:,:,:)
!SPA3(:,:,:)=0.0_JPRB

LFCOBS=.true.
CALL READVEC('sensgrad',LDJB=.false.)
LFCOBS=.false.

!SPQ(:,:)=0.0_JPRB
!SPO3(:,:)=0.0_JPRB
!IF(NPSP==1) SPSP(:)=0.0_JPRB
!SPT(:,:)=0.0_JPRB
!SPVOR(:,:)=0.0_JPRB
!SPDIV(:,:)=0.0_JPRB

!dot product computation valid from spectral to grid point 
YLSP_X=0.0_JPRB
CALL STATE2SPEC(YLSP_X)
zz1 = DOT_PRODUCT(YLSP_X,YLSP_X,.TRUE.)
WRITE(NULOUT,*) '-@@------cfcsen2obs----3.5---'
WRITE(NULOUT,*) 'Consistent dot product <dx,dx>= ', zz1
WRITE(NULERR,*) 'Consistent dot product <dx,dx>= ', zz1



WRITE(NULOUT,*) '-@@------cfcsen2obs----4---'
call spnorm(0)




!============= trasform SPA3 in ZLANCZOS control vector

YL_ZLANCZOS%data = 0.0_JPRB

LSUBBG=.false.
CALL CHAVARINAD(YL_ZLANCZOS)
LSUBBG=.true.

!No projection on B (!CALL CHAVARINAD)
!CALL CAININ(YL_ZLANCZOS)


!===================================interpolate  Spectral Field   dj/dxa in Observation Space=======
LSGTOBSS=.false.
IF(LSGTOBSS) THEN

  CALL ALLOCATE_CTLVEC(YL_ZVAZG)
  ALLOCATE(ZSPA1(NFLSUR,NS1D))
  YL_ZVAZG%data=YL_ZLANCZOS%data
  CALL CAININAD(YL_ZVAZG)
  igribsp3(1)=NGRBVO
  igribsp3(2)=NGRBD
  igribsp3(3)=NGRBT
  igribsp3(4)=NGRBQ
  igribsp2(1)=NGRBLNSP
  CL_CFILE(1:20)='ldsolBLCSgrad'

  CALL ALLOCATE_SPEC(YL_T_SENGRAD,NSMAX,0,NS3D,1,NS1D,igribsp3) 
  CALL COPY_SPA2SPEC(NS3D,1,NS1D,SPA3,SPA2,ZSPA1,YL_T_SENGRAD)
  CALL WRITE_SPEC_GRIB(CL_CFILE,YL_T_SENGRAD)
  CALL DEALLOCATE_SPEC(YL_T_SENGRAD)
  DEALLOCATE(ZSPA1)
  CALL DEALLOCATE_CTLVEC(YL_ZVAZG)

ENDIF

!=================================== SG  Norm Test with ZLANCZOS =======
CALL ALLOCATE_CTLVEC(YL_ZVAZG)
YL_ZVAZG%data=YL_ZLANCZOS%data*YSCALPSQRT%data
ZF = SQRT(DOT_PRODUCT (YL_ZVAZG,YL_ZVAZG))
ZSAVELANCZOS=ZF
write (NULOUT,*) 'ZLANCZOS--> SG Norm=   ',ZF
write (NULOUT,*) 'Compare SPA3', zz1,' versus ZLANCZOS Norm',ZF
CALL DEALLOCATE_CTLVEC(YL_ZVAZG)

!================= Test linear equation solver version of congrad:    code block 1

!--- save starting gradient for the test in block 2
call allocate_ctlvec (YL_ZVAZGTLS)
call allocate_ctlvec(YL_ZVAZG)
YL_ZVAZGTLS%data = YVAZG%data

!================ END test code block 1 =============

!        2.2   Solve the linear system

DO jj=1,niter+1
  CALL allocate_ctlvec(YLCGLWK(jj))
ENDDO

INEVECS=ITER+1
LLGOLUB = .FALSE.
CALL CONGRAD (YVAZX,YVAZG,YL_ZLANCZOS,ZEPS,EVBCGL,ITER,INEVECS, &
 & NITER_MIN, &
 & ZGOLUBU_INV,ZGOLUBL_INV, ZGOLUBU_LOG, ZGOLUBL_LOG, &
 & YLCGLWK,zwork, &
 & LDEVECS=LWRIEVEC, LDSOLVE=.TRUE., LD_LGOLUB=LLGOLUB, &
 & LD_INFO_CONVERGENCE=.FALSE.)

!save the solution
call allocate_ctlvec (YVAZX_SAVE)
YVAZX_SAVE%data = YVAZX%data
 
DO jj=1,niter+1
  CALL deallocate_ctlvec(YLCGLWK(jj))
ENDDO

WRITE(NULOUT,*) '-@@------cfcsens2obs--check the CONGRAD X'
YL_ZVAZG%data=YVAZX%data*YSCALPSQRT%data
ZF = SQRT(DOT_PRODUCT (YL_ZVAZG,YL_ZVAZG))
write (NULOUT,*) 'Norm after CONGRAD=',ZF

!===================================WRITE Spectral Field   Adj/dxa=======
LASG=.false.
IF(LASG) THEN

  ALLOCATE(ZSPA1(NFLSUR,NS1D))
  CALL ALLOCATE_CTLVEC(YL_ZVAZG2)
  YL_ZVAZG2%data=YVAZX%data
  CALL CAININAD(YL_ZVAZG2)
  igribsp3(1)=NGRBVO
  igribsp3(2)=NGRBD
  igribsp3(3)=NGRBT
  igribsp3(4)=NGRBQ
  igribsp2(1)=NGRBLNSP
  CL_CFILE1(1:20)='ldsolASgrad'

  CALL ALLOCATE_SPEC(YL_T_SENGRAD,NSMAX,0,NS3D,1,NS1D,igribsp3) 
  CALL COPY_SPA2SPEC(NS3D,1,NS1D,SPA3,SPA2,ZSPA1,YL_T_SENGRAD)
  CALL WRITE_SPEC_GRIB(CL_CFILE1,YL_T_SENGRAD)
  CALL DEALLOCATE_SPEC(YL_T_SENGRAD)
  DEALLOCATE(ZSPA1)
  CALL DEALLOCATE_CTLVEC(YL_ZVAZG2)

ENDIF

!================= Test linear equation solver version of congrad:    code block 2

!--- CONGRAD returns x such that J"(x-x_0) = ZLANCZOS
!--- check the solution. First calculate J"(x-x_0) = grad(J(x))-grad(J(x_0))


ZF=0.0_JPRB
CALL SIM4D(4,IDUM,YVAZX,ZF,YVAZG,NSIM4D)
YL_ZVAZG%data = YVAZG%data - YL_ZVAZGTLS%data

!--- subtract ZLANCZOS and calculate the norm -- it should be small, and
!--- roughly equal to the final "Estimated gradient norm" from congrad

YL_ZVAZG%data=(YL_ZVAZG%data-YL_ZLANCZOS%data)*YSCALPSQRT%data
ZF = SQRT(DOT_PRODUCT (YL_ZVAZG,YL_ZVAZG))
write (NULOUT,*) 'equation solver test: norm of residual=',ZF
write (NULOUT,*) 'roughly equal to the final Estimated gradient norm from congrad'

!--- calculate with norm of right hand side
YL_ZLANCZOS%data=YL_ZLANCZOS%data*YSCALPSQRT%data
ZF = SQRT(DOT_PRODUCT (YL_ZLANCZOS,YL_ZLANCZOS))
write (NULOUT,*) 'norm right-hand-side =',ZF, ' should be the same of norm of YL_ZLANCZOS =', ZSAVELANCZOS
CALL DEALLOCATE_CTLVEC(YL_ZVAZGTLS)
call deallocate_ctlvec(YL_ZVAZG)
!=============================================================== END test =============


! when A=I
!YVAZX%data=YL_ZLANCZOS%data

YVAZX%data = YVAZX_SAVE%data
call deallocate_ctlvec(YVAZX_SAVE)

! apply the back square root B trasformation before the interpolation

LSUBBG=.false.
CALL CHAVARIN(YVAZX)
LSUBBG=.true.

! NO projection on the B matrix (!CALL CHAVARIN)
!CALL CAIN(YVAZX)

!SPQ(:,:)=0.0_JPRB
!SPO3(:,:)=0.0_JPRB
!IF(NPSP==1) SPSP(:)=0.0_JPRB
!SPT(:,:)=0.0_JPRB
!SPVOR(:,:)=0.0_JPRB
!SPDIV(:,:)=0.0_JPRB

!dot product computation valid from spectral to grid point 
zz1save=zz1  !save the first spa3 norm
YLSP_X=0.0_JPRB
CALL STATE2SPEC(YLSP_X)
zz1 = DOT_PRODUCT(YLSP_X,YLSP_X,.TRUE.)
WRITE(NULOUT,*) '-@@------cfcsen2obs----5---'
WRITE (NULOUT,*)'        after readvec                 befor CNT3TL'
WRITE (NULOUT,*)'SPA3-norm at the start = ', zz1save, ' and at the end = ', zz1

WRITE (NULERR,*)'        after readvec                 befor CNT3TL'
WRITE (NULERR,*)'SPA3-norm at the start = ', zz1save, ' and at the end = ', zz1

CALL DEALLOCATE_CTLVEC(YL_ZLANCZOS)
CALL DEALLOCATE_SPEC(YLSP_X)

!===================================WRITE Spectral Field   BAdj/dxa=======
LBASG=.false.
IF(LBASG) THEN

  ALLOCATE(ZSPA1(NFLSUR,NS1D))
  igribsp3(1)=NGRBVO
  igribsp3(2)=NGRBD
  igribsp3(3)=NGRBT
  igribsp3(4)=NGRBQ
  igribsp2(1)=NGRBLNSP
  CL_CFILE1(1:20)='ldsolBASgrad'

  CALL ALLOCATE_SPEC(YL_T_SENGRAD,NSMAX,0,NS3D,1,NS1D,igribsp3) 
  CALL COPY_SPA2SPEC(NS3D,1,NS1D,SPA3,SPA2,ZSPA1,YL_T_SENGRAD)
  CALL WRITE_SPEC_GRIB(CL_CFILE1,YL_T_SENGRAD)
  CALL DEALLOCATE_SPEC(YL_T_SENGRAD)
  DEALLOCATE(ZSPA1)

ENDIF
!=========================================================================

! LIDMODEL=.true.  to test the single obs experiment
! LIDMODEL=.true. works only if in var/sualltl GVM_DEPART are allocated by taking out LFD3GAT from the if
!LIDMODEL=.true. 


!        2.3   Interpolate to the Observation space

LFCOBS=.true.
LTLINT=.true.
LJCDFI=.false.
CALL CNT3TL 

CALL FLUSH(NULOUT)

!      3.2 Save observation files with feed-back diagnostics.

IF (LOBS ) THEN
  CALL GSTATS(47,0)
  WRITE(NULOUT,*) '--- Variational job : write final obs ',&
   & 'files -------------------------------'
  WRITE(NULOUT,'('' ** WRITE-OUT OBS.  '')')
  CALL WRITEOBA
  CALL GSTATS(47,1)
ENDIF

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

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