SUBROUTINE CAINAD(YDVAZG)

!     Purpose.
!     --------
!       Adjoint canonical injection.

!     Explicit arguments :
!     --------------------
!       YDVAZG  : PART OF CONTROL VARIABLE (INPUT)

!     Author.
!     -------
!       Y.Tremolet (from CAINAD_SCALE_HELPER)

!     Modifications.
!     --------------
!        Original : 02-08-05
!     C.Fischer   03-04-02 Aladin spectral treatment added.
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Fisher 17-03-2004 Abort if wavelet Jb
!        Y.Tremolet    18-Mar-2004 Fix 2D arrays
!        D.Dee    19-Mar-2003  Variational bias correction
!        Y.Tremolet    10-Jun-2004 Initial condition optional in control vector
!        Y.Tremolet    27-Jul-2004 Improve model error
!        P.Burton :  29-09-04 LVARBC cleanup
!        L.Isaksen     05-Sep-2005 Adapt for grid point q
!        A.Dethof      23-Jan-2007 Add GEMS GRG fields
!     ------------------------------------------------------------------

USE PARKIND1, ONLY: JPIM, JPRB
USE YOMHOOK , ONLY: LHOOK, DR_HOOK
USE YOMDIM  , ONLY: NSMAX, NSPEC2, NFLEVL, NPROMA, NS3D
USE YOMMP   , ONLY: NPSP, NBSETLEV, MYSETW, NPROCM
USE YOMCT0  , ONLY: LELAM
USE YOMLAP  , ONLY: NASM0
USE YOMSP   , ONLY: SPA3, SPA2, SPA1
USE YOMGFL  , ONLY: GFL
USE YOM_YGFL, ONLY: YQ, YO3, YGHG, NGHG, YGRG, NGRG
USE YOMTVRAD, ONLY: TOVSCVX,NVATOVLEN
USE YOMDIMO , ONLY: NOBNTV
USE YOMCVA  , ONLY: NVA3D, NVA2D, NVA1D, NVATOVV, YRSCALP
USE YOMVAR  , ONLY: LVARBC
USE VARBC_SETUP, ONLY: YVARBC, NOBGROUP, NOBPARAM
USE YOMMODEL_ERROR, ONLY: NDIM_MODERR, SPMODERR, GPMODERR, SPCTLMODERR, SPGPMODERR
USE YOMWAVELET, ONLY: LJBWAVELET
USE CONTROL_VECTORS, ONLY : CONTROL_VECTOR
USE SPECTRAL_FIELDS_MOD, ONLY : SPECTRAL_FIELD, ASSIGNMENT(=)
USE YOMTS   , ONLY:TSCVX


IMPLICIT NONE

TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YDVAZG 
INTEGER(KIND=JPIM) :: jl, jf, js, ii, jg, ibeg, iend, il, jj, jn
INTEGER(KIND=JPIM) :: jghg, jgrg
REAL(KIND=JPRB) :: zmulm(NSPEC2)
REAL(KIND=JPRB), ALLOCATABLE :: ZTMP(:), ZSP(:,:)
REAL(KIND=JPRB) :: ZHOOK_HANDLE

INTERFACE
#include "inv_transad.h"
END INTERFACE

#include "abor1.intfb.h"
#include "spec2gridad.intfb.h"
#include "spec_concat.intfb.h"
!     ------------------------------------------------------------------
IF (LHOOK) CALL DR_HOOK('CAINAD',0,ZHOOK_HANDLE)
IF (LJBWAVELET) CALL ABOR1 ('CAINAD CANNOT BE USED WITH WAVELET JB')
IF (LELAM) THEN
! LAM case - no filtering of coefficients
  zmulm(:) = 1.0_JPRB
ELSE
  zmulm(:) = 2.0_JPRB
  IF (MYSETW == NPROCM(0)) THEN
    DO jn=0,NSMAX
      zmulm(NASM0(0)+2*jn  ) = 1.0_JPRB  ! Real part
      zmulm(NASM0(0)+2*jn+1) = 0.0_JPRB  ! Imaginary part
    ENDDO
  ENDIF
ENDIF

! Initial condition
! -----------------
IF (YDVAZG%linitcv) THEN
  ii=0
  IF (NPSP==1) THEN
    DO jf=1,NVA2D
      DO js=1,NSPEC2
        ii=ii+1
        YDVAZG%initcv(ii) = YDVAZG%initcv(ii) &
         & + SPA2(js,jf) * zmulm(js) * YRSCALP%initcv(ii)  
      ENDDO
    ENDDO
  ENDIF
  IF (NS3D > NVA3D) THEN
    CALL ABOR1('CAINAD: UNEXPECTED INCONSITENCY NS3D > NVA3D ')
  ENDIF
  DO jf=1,NS3D
    DO js=1,NSPEC2 
      DO jl=1,NFLEVL
        ii=ii+1
        YDVAZG%initcv(ii) = YDVAZG%initcv(ii) &
         & + SPA3(jl,js,jf) * zmulm(js) * YRSCALP%initcv(ii)  
      ENDDO
    ENDDO
  ENDDO
! Transform spectral control vector fields to grid point model state fields where required
  IF (NS3D < NVA3D) THEN
    ALLOCATE(ZSP(NFLEVL,NSPEC2))
    ZSP(:,:)=0.0_JPRB
    IF (YQ%LGP) THEN
      CALL INV_TRANSAD(PSPSCALAR=ZSP,KVSETSC=NBSETLEV,KPROMA=NPROMA,&
       & PGP=GFL(:,:,YQ%MP,:))
      DO js=1,NSPEC2
        DO jl=1,NFLEVL
          ii=ii+1
          YDVAZG%initcv(ii) = YDVAZG%initcv(ii) &
           & + ZSP(jl,js) * zmulm(js) * YRSCALP%initcv(ii)
        ENDDO
      ENDDO
    ENDIF
    IF (YO3%LGP) THEN
      ZSP(:,:)=0.0_JPRB
      CALL INV_TRANSAD(PSPSCALAR=ZSP,KVSETSC=NBSETLEV,KPROMA=NPROMA,&
       & PGP=GFL(:,:,YO3%MP,:))
      DO js=1,NSPEC2
        DO jl=1,NFLEVL
          ii=ii+1
          YDVAZG%initcv(ii) = YDVAZG%initcv(ii) &
           & + ZSP(jl,js) * zmulm(js) * YRSCALP%initcv(ii)
        ENDDO
      ENDDO
    ENDIF
    DO JGHG=1,NGHG
      IF (YGHG(JGHG)%LGP) THEN
        CALL INV_TRANSAD(PSPSCALAR=ZSP,KVSETSC=NBSETLEV,KPROMA=NPROMA,&
         & PGP=GFL(:,:,YGHG(JGHG)%MP,:))
        DO js=1,NSPEC2
          DO jl=1,NFLEVL
            ii=ii+1
            YDVAZG%initcv(ii) = YDVAZG%initcv(ii) &
             & + ZSP(jl,js) * zmulm(js) * YRSCALP%initcv(ii)
          ENDDO
        ENDDO
      ENDIF
    ENDDO
    DO JGRG=1,NGRG
      IF (YGRG(JGRG)%LGP) THEN
        CALL INV_TRANSAD(PSPSCALAR=ZSP,KVSETSC=NBSETLEV,KPROMA=NPROMA,&
         & PGP=GFL(:,:,YGRG(JGRG)%MP,:))
        DO js=1,NSPEC2
          DO jl=1,NFLEVL
            ii=ii+1
            YDVAZG%initcv(ii) = YDVAZG%initcv(ii) &
             & + ZSP(jl,js) * zmulm(js) * YRSCALP%initcv(ii)
          ENDDO
        ENDDO
      ENDIF
    ENDDO
    DEALLOCATE(ZSP)
  ENDIF
  IF (SIZE(YDVAZG%initcv)/=ii) CALL ABOR1('CAINAD: initcv wrong length')
ENDIF

! Model error
! -----------
IF (YDVAZG%nmoderr>0) THEN
  ii=0
  il=SPCTLMODERR%nspsizel
  ALLOCATE(ZTMP(il))
  DO jj=1,NDIM_MODERR
    SPGPMODERR=0.0_JPRB
    CALL SPEC2GRIDAD(SPGPMODERR,GPMODERR(jj))
    CALL SPEC_CONCAT(SPMODERR(jj),SPGPMODERR,SPCTLMODERR)
    ZTMP=SPCTLMODERR
    YDVAZG%moderr(ii+1:ii+il)=YDVAZG%moderr(ii+1:ii+il)+ZTMP(1:il)
    ii=ii+il
  ENDDO
  DEALLOCATE(ZTMP)
  IF (ii/=SIZE(YDVAZG%MODERR)) CALL ABOR1('CAINAD: moderr wrong length')
ENDIF

! TOVS control variable
! ---------------------
IF (YDVAZG%ltovscv) THEN
  ii=0
  DO jf=1,NVATOVV
    DO js=1,NVATOVLEN
      ii=ii+1
      YDVAZG%tovscv(ii) = YDVAZG%tovscv(ii) + TOVSCVX(js,jf)
    ENDDO
  ENDDO
  IF (ii/=SIZE(YDVAZG%tovscv)) &
   & CALL ABOR1('CAINAD: TOVS control variable wrong length')  
ENDIF

! TS control variable
! ---------------------
 IF (YDVAZG%ltscv) THEN
   ii=0
     DO js=1,NOBNTV
       ii=ii+1
       YDVAZG%tscv(ii) = YDVAZG%tscv(ii) + TSCVX(js)
   ENDDO
   IF (ii/=SIZE(YDVAZG%tscv)) CALL ABOR1('CAIN: TS control variable wrong length')
 ENDIF


! MEAN WIND (LAM)
! ---------------
IF (YDVAZG%lam1d) THEN
  ii=0
  DO jf=1,NVA1D
    DO jl=1,NFLEVL
      ii=ii+1
      YDVAZG%lamcv(ii) = YDVAZG%lamcv(ii) + SPA1(jl,jf) * YRSCALP%lamcv(ii)
    ENDDO
  ENDDO
  IF (ii/=SIZE(YDVAZG%lamcv)) &
   & CALL ABOR1('CAINAD: LAM control variable wrong length')  
ENDIF

! Variational bias parameters
! ---------------------------
IF (LVARBC) THEN
  IF (NOBPARAM/=SIZE(YDVAZG%params)) &
   & CALL ABOR1('CAINAD: Parameter section of control variable wrong length')  
  ibeg = 1
  DO jg = 1, NOBGROUP
    iend = ibeg + YVARBC(jg)%NPARAM - 1
    YDVAZG%params(ibeg:iend) = YDVAZG%params(ibeg:iend) + YVARBC(jg)%APARAMS
    ibeg = iend + 1
  ENDDO
ENDIF


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