SUBROUTINE DJBDY(kiter,kmaxit,YDCGLWK,pwork,YDVAZX,YDVAZ0)

!     Purpose.
!     --------
!        Compute Jb,Jq sensitivities to obs using the adjoint of the approx
!        Kalman gain matrix provided by CONGRAD (i.e. dJb/dy and dJq/dy).

!     Author.
!     -------
!        Yannick Tremolet

!     Modifications.
!     --------------
!        Original : 22-Feb-2008
! ------------------------------------------------------------------

USE PARKIND1 , ONLY: JPIM     ,JPRB
USE YOMHOOK  , ONLY: LHOOK,   DR_HOOK
USE YOMVAR   , ONLY: NUPTRA, LMODERR, LINITCV, LJCDFI, MUPTRA
USE YOMCOSJO , ONLY: FJOADJ, LADJOBS, MOBSENS
USE YOMCVA   , ONLY: YSCALP, NVA3D, NVA2D
USE YOMDIM   , ONLY: NFLEVL, NSPEC2
USE YOMDIMO  , ONLY: NOBTOT
USE YOMLUN   , ONLY: NULOUT
USE YOMJG    , ONLY: LSUBBG, LCTLFG
USE YOMCT0   , ONLY: LGUESS
USE YOMMODEL_ERROR, ONLY: NDIM_MODERR
USE MPL_MODULE, ONLY: MPL_ALLREDUCE
USE CONTROL_VECTORS

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

IMPLICIT NONE

INTEGER(KIND=JPIM) , INTENT(IN) :: kiter,kmaxit
TYPE(CONTROL_VECTOR),INTENT(IN) :: YDCGLWK(kmaxit+1)
REAL(KIND=JPRB)     ,INTENT(IN) :: PWORK(kmaxit+1,4)
TYPE(CONTROL_VECTOR),INTENT(IN) :: YDVAZX
TYPE(CONTROL_VECTOR),INTENT(IN) :: YDVAZ0

TYPE(control_vector) :: YLVAZX, YLWORK
INTEGER(KIND=JPIM) :: jj,idum,isim4d,igrad,jgrad,jerr,ii,il
LOGICAL :: LLA,LLB,LLC
CHARACTER(LEN=4) :: clj
REAL(KIND=JPRB) :: zx,zy,zz,zf,zp,zb
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "sim4d.intfb.h"
#include "congrad_ad.intfb.h"

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

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

CALL allocate_ctlvec(YLVAZX)
CALL allocate_ctlvec(YLWORK)
ALLOCATE(FJOADJ(NOBTOT))

LLA=LSUBBG; LSUBBG=.false.
LLB=LGUESS; LGUESS=.false.
LLC=LJCDFI; LJCDFI=.false.

! ------------------------------------------------------------------
!   Observation impact computation
! ------------------------------------------------------------------

igrad=1
!YT IF (LINITCV) igrad=igrad+1
!YT IF (LMODERR) igrad=igrad+NDIM_MODERR
jerr=0
write(nulout,*)'djbdy: igrad=',igrad

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

DO jgrad=1,igrad
  MOBSENS=MOBSENS+1
  IF (MOBSENS>2) CALL ABOR1('DJBDY: MOBSENS max hardcoded in ODB')

! Set input sensitivity
! ---------------------
  YLVAZX=0.0_JPRB
  SELECT CASE (jgrad)
  CASE(1)       ! Jb+Jq+Jp: full impact
    IF (LCTLFG) THEN
      YLVAZX=YDVAZX
    ELSE
      YLVAZX%data(:)=YDVAZX%data(:)-YDVAZ0%data(:)
    ENDIF
    clj='Full'
  CASE(2)       ! Jb
    IF (LCTLFG) THEN
      YLVAZX%initcv(:)=YDVAZX%initcv(:)
    ELSE
      YLVAZX%initcv(:)=YDVAZX%initcv(:)-YDVAZ0%initcv(:)
    ENDIF
    clj='Jb  '
  CASE DEFAULT  ! Jq
    il=(NFLEVL*NVA3D+NVA2D)*NSPEC2
    ii=jerr*il
    write(nulout,*)'djbdy: il,ii,nerr=',il,ii,SIZE(YLVAZX%moderr(:))
    DO jj=1,il
      IF (LCTLFG) THEN
        YLVAZX%moderr(ii+jj)=YDVAZX%moderr(ii+jj)
      ELSE
        YLVAZX%moderr(ii+jj)=YDVAZX%moderr(ii+jj)-YDVAZ0%moderr(ii+jj)
      ENDIF
    ENDDO
    jerr=jerr+1
    IF (jerr>NDIM_MODERR) CALL ABOR1('DJBDY: Error MODERR')
    clj='Jq  '
    write(clj(3:4),'(I2)')jerr
  END SELECT
  write(nulout,*)'djbdy: jgrad,clj,mobsens,lctlfg=',jgrad,clj,mobsens,lctlfg

! Scalar product in control space
! -------------------------------
  zx=0.5_JPRB*DOT_PRODUCT(YLVAZX,YLVAZX,YSCALP)

! Apply adjoint of minimisation matrix
! ------------------------------------
  write(nulout,*)'djbdy: calling congrad_ad'
  CALL CONGRAD_AD(YLVAZX,kmaxit,kiter,pwork,YDCGLWK)

! Correction due to previous outer loops
! --------------------------------------
  zb=0.0_JPRB
  IF (NUPTRA>0) zb=0.5_JPRB*DOT_PRODUCT(YLVAZX,YDVAZ0,YSCALP)

! Apply R^{-1}.H
! --------------
  isim4d=2
  zf=0.0_JPRB
  LADJOBS=.TRUE.
  FJOADJ(:)=0.0_JPRB

  write(nulout,*)'djbdy: calling sim4d'
  CALL SIM4D(idum,idum,YLVAZX,zf,YLWORK,isim4d)

  LADJOBS=.FALSE.

! Scalar product in obs space
! ---------------------------
  write(nulout,*)'djbdy: calling allreduce'
  zy=0.0_JPRB
  IF (SIZE(FJOADJ)>0) zy=0.5_JPRB*SUM(FJOADJ)
  CALL MPL_ALLREDUCE(zy,'SUM',LDREPROD=.TRUE.,CDSTRING='DJBDY:')

! Print diagnostics
! -----------------
  write(NULOUT,'(A,X,A)')clj,'impact of obs.      1.234567890123456789'
  write(NULOUT,'(A,X,A,ES25.18)')clj,'impact: <dF/dy,d>= ',zy
  write(NULOUT,'(A,X,A,ES25.18)')clj,'impact: <dx,b>   = ',zb
  write(NULOUT,'(A,X,A,ES25.18)')clj,'impact: <dx,dx>  = ',zx
  write(NULOUT,'(A,X,A,ES25.18)')clj,'impact: <dx,dx+b>= ',zx+zb
  IF ( abs(zx)>sqrt(tiny(zx)) ) THEN
    zz=abs((zy-zb-zx)/zx)
    write(NULOUT,'(A,X,A,ES25.18)')clj,'impact rel. error= ',zz
  ELSE
    zz=abs(zy-zb-zx)
    write(NULOUT,'(A,X,A,ES25.18)')clj,'impact abs. error= ',zz
  ENDIF
  zp=zz/epsilon(zz)
  WRITE(NULOUT,'(A,X,A,F8.1,A)')clj,'impact: the difference is ', &
   & zp,' times machine precision.'
ENDDO

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

LSUBBG=LLA; LGUESS=LLB; LJCDFI=LLC
DEALLOCATE(FJOADJ)
CALL deallocate_ctlvec(YLVAZX)
CALL deallocate_ctlvec(YLWORK)

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