SUBROUTINE TESADJ

!**** *TESADJ*  - Routine which test the adjoint

!     Purpose.
!     --------
!           Verify the adjoint of the tangent linear model

!**   Interface.
!     ----------
!        *CALL* *TESADJ

!        Explicit arguments :
!        --------------------
!        None

!        Implicit arguments :
!        --------------------
!        None

!     Method.
!     -------
!        See documentation

!     Externals.   SU2YOM - initialize level 2 commons
!     ----------   SUALLT - allocate space for trajectory
!                  CNT3   - controls direct integration
!                  SUPERT - initialize perturbation
!                  CAIN   - canonical injection
!                  CNT3TL - controls tangent linear integration
!                  CAININ - inverse of the Canonical injection
!                  SCAAS  - scalar product
!                  CAININAD - adjoint of inverse Canonical injection
!                  CNT3AD - controls adjoint integration
!                  CAINAD - adjoint of Canonical injection
!     Reference.
!     ----------
!        ECMWF Research Department documentation of the IFS

!     Author.
!     -------
!        Mats Hamrud and Philippe Courtier  *ECMWF*

!     Modifications.
!     --------------
!        Original : 87-10-15
!        Modified by D. Vasiljevic : 90-11-23
!        Modified by P. Courtier   : 91-11-03
!        Modified by R Buizza      ; 93-10-25
!        Modified by A. Horanyi    : 95-08-07 for ALADIN
!        Modified by L. Isaksen    : 96-02-20 Change VATRA to ZVATRA
!        Modified by M.Hamrud      : 98-01-10 Minimisation parallelized
!        Modified by M.Janiskova   : 99-03-02 additional call for CNT3 to
!                                    compute rad.coef. for MF simpl.physics
!        Modified by R. El Khatib  : 01-05-09 reset yomct2 after changing NSTOP
!        Modified by Y.Tremolet    : 02-08-08 use control_vectors
!        Modified by M.Janiskova   : 03-07-01 using 2 spectral intervals for sw
!        Modified by C. Fischer    : 03-09-30 remove call to suellt
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Janiskova:  14-Dec-2005 Set cloud related perturbations to zero
!        M.Janiskova:  12-Mar-2009 Initialize switch for grid-point cloud diag.
!     ------------------------------------------------------------------------

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

USE YOMLUN   , ONLY : NULOUT
USE YOMCT0   , ONLY : NSTOP
USE YOMCT0B  , ONLY : LECMWF
USE YOMCT1   , ONLY : N1HIS    ,N1GDI
USE YOMCVA   , ONLY : YVAZX    ,YVAZG
USE YOMLCZ   , ONLY : LOCNORM
USE YOMSIMPHL, ONLY : LSIMPH   ,LRAYSP   ,LTRAJPS
USE YOMPHY   , ONLY : LMPHYS   ,LCVPP
USE YOMPHY0  , ONLY : ECMNP
USE YOMPHY2  , ONLY : XMULAF
USE YOMRCOEF , ONLY : LRCOEF   ,LTLADDIA
USE YOERAD   , ONLY : NTSW, NSW
USE YOPHNC   , ONLY : LERADSW2, LENCLD2
USE YOMDIM   , ONLY : NFLEVG
USE YOEPHY   , ONLY : LEPCLD
USE CONTROL_VECTORS
USE GFL_SUBS_MOD , ONLY : DEACT_CLOUD_GFL
USE YOMGFL   , ONLY : GFL
USE YOM_YGFL , ONLY : YA, YL, YI, YR, YS

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

IMPLICIT NONE

! * LOCAL TYPE "control_vector" VARIABLES:
TYPE(control_vector) :: YL_ZVATRA

REAL(KIND=JPRB) :: ZPS01, ZPS02, ZZ

! * PARAMETER INTEGER SCALARS:
INTEGER(KIND=JPIM), PARAMETER :: JPKS=KIND(ZZ)

INTEGER(KIND=JPIM) :: ISTOP, idum
INTEGER(KIND=JPIM) :: ISW, I1GDI

LOGICAL :: LLSWR2, LLDIAG
LOGICAL :: LLSIMPH
LOGICAL :: LLTRAJPS
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "cain.intfb.h"
#include "cainad.intfb.h"
#include "cainin.intfb.h"
#include "cnt3.intfb.h"
#include "cnt3ad.intfb.h"
#include "cnt3tl.intfb.h"
#include "lcnorad.intfb.h"
#include "lcnortl.intfb.h"
#include "scaas.intfb.h"
#include "su2yom.intfb.h"
#include "suaersn.intfb.h"
#include "suallt.intfb.h"
#include "suclopn.intfb.h"
#include "sulcz.intfb.h"
#include "supert.intfb.h"
#include "suswn.intfb.h"

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

!*       1.    Initializations.
!              ----------------

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

LLSWR2=.FALSE.
LLDIAG=.FALSE.

CALL ALLOCATE_CTLVEC(YL_ZVATRA)
idum=-999

!*       1.1   Initialize YOMCT2

CALL SU2YOM

IF(LOCNORM) CALL SULCZ

!*       1.2   ALLOCATE EXTRA SPACE FOR TRAJECTORY.

CALL SUALLT

!*       1.3   INITIALIZATION OF THE TWO PERTURBATIONS

CALL SUPERT(YVAZX,1.0_JPRB)
CALL SUPERT(YVAZG,1.0_JPRB)

!*       1.4   COMPUTATION OF THE TRAJECTORY

!*       1.4.1 Computation of the radiation coefficients

IF (LTLADDIA .AND. .NOT.LMPHYS) THEN
  IF (LRCOEF.AND.LRAYSP) THEN

!         Storage of the basic state

    CALL CAININ(YL_ZVATRA)

    LLSIMPH=LSIMPH
    LLTRAJPS=LTRAJPS
    LMPHYS=.TRUE.
    LSIMPH=.FALSE.
    LTRAJPS=.FALSE.
    ISTOP=NSTOP
    NSTOP=2
    CALL SU2YOM

    N1HIS=1
    CALL CNT3

    LTRAJPS=LLTRAJPS
    LMPHYS=.FALSE.
    LSIMPH=LLSIMPH
    NSTOP=ISTOP
    CALL SU2YOM

!         Re-covering the initial state

    CALL CAIN(YL_ZVATRA)

  ENDIF
ENDIF

IF (LECMWF .AND. (LEPCLD .OR. LENCLD2)) THEN
  LLDIAG=.TRUE.
  I1GDI = N1GDI
  N1GDI = 1
ENDIF

N1HIS=1
CALL CNT3

IF (LLDIAG) THEN
  N1GDI = I1GDI
  LLDIAG=.FALSE.
ENDIF

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

!*       2.    CALCULATION OF < CNT3TL.YVAZX , YVAZG >.
!              --------------------------------------

! Prescribe parameter values as in configuration 131

IF (.NOT.LECMWF) THEN

  CALL DEACT_CLOUD_GFL

  LMPHYS=.FALSE.
  IF (LTRAJPS) THEN
    LSIMPH=.TRUE.
    LCVPP=.FALSE.
    ECMNP=7000._JPRB
    XMULAF=0.0_JPRB
  ENDIF
ENDIF

! Change to just 2 spectral intervals for shortwave radiation

IF (LERADSW2 .AND. NSW > 2) THEN
  LLSWR2=.TRUE.

  ISW=NSW
  NSW=2
  CALL SUSWN   (NTSW, NSW)
  CALL SUCLOPN (NTSW, NSW,NFLEVG)
  CALL SUAERSN (NTSW, NSW)
ENDIF

! Put perturbation of cloud variables to zero

IF (LENCLD2) THEN
  CALL DEACT_CLOUD_GFL
  GFL(:,:,YA%MP,:) = 0.0_JPRB
  GFL(:,:,YL%MP,:) = 0.0_JPRB
  GFL(:,:,YI%MP,:) = 0.0_JPRB
  GFL(:,:,YR%MP,:) = 0.0_JPRB
  GFL(:,:,YS%MP,:) = 0.0_JPRB

  N1GDI = 1
ENDIF

CALL CAIN (YVAZX)
N1HIS=0
CALL CNT3TL
N1HIS=1

!     - Call operator to localize the output field into a defined area
!       in gg space

IF(LOCNORM) CALL LCNORTL

YL_ZVATRA=0.0_JPRB
CALL CAINAD (YL_ZVATRA)
CALL SCAAS(idum,YL_ZVATRA,YVAZG,ZPS01)
!     ------------------------------------------------------------------

!*       3.    CALCULATION OF < YVAZX , CNT3AD.YVAZG >.
!              --------------------------------------

CALL CAIN (YVAZG)

!     - Adj of localization operator

IF(LOCNORM) CALL LCNORAD

N1HIS=0
CALL CNT3AD
N1HIS=1
YL_ZVATRA=0.0_JPRB
CALL CAINAD (YL_ZVATRA)
CALL SCAAS(idum,YL_ZVATRA,YVAZX,ZPS02)

! Change back to original number of spectral intervals for sw

IF (LLSWR2) THEN
  NSW=ISW
  CALL SUSWN   (NTSW, NSW)
  CALL SUCLOPN (NTSW, NSW,NFLEVG)
  CALL SUAERSN (NTSW, NSW)
ENDIF

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

!*       4.    PRINT OF THE TWO SCALAR PRODUCTS.
!              ---------------------------------

WRITE(UNIT=NULOUT,FMT='('' TEST OF THE ADJOINT '')')
WRITE(UNIT=NULOUT,FMT='(''                 '',''  12345678901234567890'')')
WRITE(UNIT=NULOUT,FMT='('' < F(X) , Y >  = '',E26.20)') ZPS01
WRITE(UNIT=NULOUT,FMT='('' < X , F*(Y) > = '',E26.20)') ZPS02
IF(ZPS01 == 0.0_JPRB)THEN
  ZZ=1.0_JPRB
ELSE
  ZZ=ZPS01
ENDIF
WRITE(UNIT=NULOUT,FMT='('' THE DIFFERENCE IS '',F9.3,&
 & '' TIMES THE ZERO OF THE MACHINE '')')&
 & ABS(REAL(REAL(ZPS01,JPKS)-REAL(ZPS02,JPKS),JPKS)/EPSILON(ZZ)/ZZ)  

CALL DEALLOCATE_CTLVEC(YL_ZVATRA)
!     ------------------------------------------------------------------

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