SUBROUTINE CGR1

!**** *CGR1*  - Controls the sensitivity job at level 1.

!     Purpose.
!     --------
!           Controls the job at level 1.
!           Sensitivity to boundary conditions (orography)

!**   Interface.
!     ----------
!        *CALL* *CGR1

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

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

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

!     Externals.
!     ----------     SU1YOM - initialize level 1 commons
!                    SIM4D  - Computes gradient
!                    SCAAS  - Scalar product
!                    GRTEST - Test of the gradient
!                    M1QN3  - Minimisation routine

!     Reference.
!     ----------
!        ...

!     Author.
!     -------
!        Laurent LABBE *CNRM/GMAP*

!     Modifications.
!     --------------
!        Original : 93-01-25 (from routine CVA1)
!        Modified : 93-12-10 by Florence RABIER (post-processing active in 801)
!        Modified : 94-03-09 by Laurent Labbe (minimisation for 821)
!        Modified : 94-09-12 by Florence RABIER (compute step size for 801)
!        Modified : 94-09-20 by Mike Fisher (determine convergence using RCVGE)
!        Modified : 96-01-16 by F. Bouttier (rm VATRA, update GRTEST)
!        Modified : 96-09-25 by F. Rabier (compute trajectory full physics 
!                                         if LTRAJ=F and L801TL=T)
!        Modified : 97-07-18 by G. Hello (compute trajectory full physics
!                                         for MF
!        Modified : 98-01-06 by F. Rabier (Update for new suhess)
!        Modified : 98-01-10 by M.Hamrud (Minimisation parallelized)
!        Modified : 99-10-10 by JN Thepaut (to accomodate for new suhess)
!        Modified : 00-10-10 by C. Temperton (to allow clouds etc. in    
!                                  trajectory while not in semi-Lag. TL/AD)
!        Modified : 02-08-08 by Y.Tremolet (use control_vectors)
!        Modified : 03-09-30 by C. Fischer remove calls to suellt, suellt7
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        K. Yessad (Sep 2008): prune enhanced diffusion (lfrein).
!        F. Vana, R. Brozkova 13-Jan-2009 : switching off physics and GFL
!                                           advection after NL M-F integration
!     --------------------------------------------------------------------------

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

USE YOMCT0   , ONLY : NCONF    ,LELAM
USE YOMCT0B  , ONLY : LECMWF
USE YOMCVA   , ONLY : YVAZX     ,YVAZG
USE YOMCT1   , ONLY : N1POS    ,N1GDI    ,N1SDI
USE YOMLUN   , ONLY : NULOUT
USE YOMVAR   , ONLY : NITER    ,NSIMU    ,NINFRA   ,NMIMP    ,&
 & NSIM4D   ,NSIM4DL  ,RDX      ,RXMIN    ,RCVGE    ,&
 & LTEST    ,LTWANA   ,LWREINI  
USE YOMSENS  , ONLY : LMINI
USE YOMVRTL  , ONLY : L801TL
USE YOMIOMI  , ONLY : NMUPD    ,LWARM_RD
USE YOEPHY   , ONLY : LEPHYS   ,LECOND   ,LECUMF   ,&
 & LEDCLD   ,LEEVAP   ,LEGWDG   ,LEOZOC   ,LEQNGT   ,&
 & LERADI   ,LERADS   ,LESICE   ,&
 & LESURF   ,LEVDIF   ,LAGPHY   ,&
 & LEPCLD   ,LEO3CH  
USE YOMPHY   , ONLY : LMPHYS   ,LNEIGE   ,LCVRA    ,LGWD     ,&
 & LHMTO    ,LNEBCO   ,LNEBN    ,LRAY    ,L3MT     ,LCVPRO   ,&
 & LSFHYD   ,LSTRA    ,LTHERMO  ,LVDIF   ,LCVPP   ,LCDDPRO  ,&
 & LCONDWT  ,LPTKE
USE YOMSIMPHL, ONLY : LSIMPH   ,LTRAJPS
USE YOPHLC   , ONLY : LSPHLC
USE YOMPHY0  , ONLY : ECMNP    ,GWDCD    ,GWDSE
USE YOMPHY2  , ONLY : XMULAF
USE YOPHNC   , ONLY : LETRAJP
USE CONTROL_VECTORS
USE YOM_YGFL, ONLY : YGFL     ,YGFLC, YQ
USE GFL_SUBS_MOD ,ONLY  : DEACT_CLOUD_GFL

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

IMPLICIT NONE

! * EXTERNALS:
EXTERNAL CTONB,CTCAB
! * LOCAL TYPE "control_vector":
TYPE(control_vector) :: YLVAZX2,YLVAZG2,YL_ZD
TYPE(control_vector) :: YL_ZYBAR(NMUPD),YL_ZSBAR(NMUPD)
TYPE(control_vector) :: YL_ZDIAG

INTEGER(KIND=JPIM) :: I, IMP, INDIC, INFO, INMUPD, IO, ISIM, ITER, JUPD, &
 & IDUM, IVADIM, IILM, JGFL

INTEGER(KIND=JPIM) :: ITBMIN(5),ILM(NMUPD+3)

REAL(KIND=JPRB) :: ZDF1, ZDX, ZEPS, ZF, ZFI, ZG2, ZGF, ZGI, ZGN
REAL(KIND=JPRB) :: ZCOST2,ZSTEP,ZTRIAL
REAL(KIND=JPRB) :: ZSIZE
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "cain.intfb.h"
#include "cnt2.intfb.h"
#include "ewreini.intfb.h"
#include "grtest.intfb.h"
#include "scaas.intfb.h"
#include "sim4d.intfb.h"
#include "stepo.intfb.h"
#include "su1yom.intfb.h"
#include "suallt.intfb.h"
#include "suallt7.intfb.h"
#include "suhess.intfb.h"
#include "suslb.intfb.h"

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

!*       1.    Initialize YOMCT1 and control variable
!              --------------------------------------

IF (LHOOK) CALL DR_HOOK('CGR1',0,ZHOOK_HANDLE)
CALL ALLOCATE_CTLVEC(YLVAZX2)
CALL ALLOCATE_CTLVEC(YLVAZG2)
CALL ALLOCATE_CTLVEC(YL_ZD)
CALL SU1YOM
IF (NCONF /= 801) THEN
  N1POS=0
ENDIF
N1GDI=0
N1SDI=1

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

!*          1.5 dummy initialisation for SUHESS.

IILM=1
IDUM=-999
IVADIM=YVAZX%NSIZEG

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

!*       2.    Call level 2 control routine.
!              -----------------------------

!*       2.1  Trajectory computation if L801TL
!             --------------------------------
IF(L801TL) THEN
  CALL SUALLT7
  CALL CNT2
  IF (LECMWF) THEN
    LEPHYS=.FALSE.
    LEVDIF=.FALSE.
    LESURF=.FALSE.
    LECOND=.FALSE.
    LECUMF=.FALSE.
    LEEVAP=.FALSE.
    LEGWDG=.FALSE.
    LEOZOC=.FALSE.
    LEQNGT=.FALSE.
    LERADI=.FALSE.
    LERADS=.FALSE.
    LESICE=.FALSE.
    LEDCLD=.FALSE.
    LAGPHY=.FALSE.
    LEO3CH=.FALSE.
    LEPCLD=.FALSE.
   ! TL and AD models do not support cloud fields. yet.
    CALL DEACT_CLOUD_GFL
  ELSE
    LMPHYS=.FALSE.
    LCVPP=.FALSE.
    LTHERMO=.FALSE.
    LVDIF=.FALSE.
    LRAY=.FALSE.
    LGWD=.FALSE.
    LCVRA=.FALSE.
    LSTRA=.FALSE.
    LSFHYD=.FALSE.
    LNEBCO=.FALSE.
    LNEBN=.FALSE.
    L3MT=.FALSE.
    LCVPRO=.FALSE.
    LCDDPRO=.FALSE.
    LPTKE=.FALSE.
    LCONDWT=.FALSE.
    LNEIGE=.FALSE.
    LHMTO=.FALSE.
    DO JGFL=1,YGFL%NUMFLDS
      YGFLC(JGFL)%LADV=.FALSE.
    ENDDO
    IF (LTRAJPS) THEN
      LSIMPH=.TRUE.
      YQ%LADV=.TRUE.
      LNEIGE=.TRUE.
      LSPHLC=.FALSE.
      ECMNP=7000._JPRB
      GWDCD=6._JPRB
      GWDSE=3.5E-03_JPRB
      XMULAF=0.0_JPRB
    ENDIF
  ENDIF
  CALL SUSLB   !! (recompute semi-Lagrangian buffer pointers for TL/AD)
ENDIF

IF (LETRAJP) THEN
!  LSPHLC=.FALSE.
  LEPHYS=.TRUE.
  LAGPHY=.TRUE.
  CALL SUSLB   !! (recompute semi-Lagrangian buffer pointers for TL/AD)
ENDIF

!*       2.2  First call to simulator
!             -----------------------
!!
IF (LELAM) THEN
  CALL SUALLT
ENDIF
!!
ZF=0.0_JPRB
INDIC=4
CALL SIM4D(INDIC,IDUM,YVAZX,ZF,YVAZG,0)
ZFI=ZF

ZGI=0.0_JPRB
CALL SCAAS(IDUM,YVAZG,YVAZG,ZGI)
WRITE(UNIT=NULOUT,FMT='('' INITIAL GRADIENT NORM SQUARED :''&
 & ,E14.7,''COST FUNCTION : '',E14.7)')&
 & ZGI,ZF  
!      ------------------------------------------------------------------

!*       3.    Test of the gradient.
!              ---------------------
IF(LTEST)THEN
  CALL GRTEST(SIM4D,SCAAS,YVAZX,RDX,15,NULOUT)
ELSEIF(LELAM .AND. LWREINI) THEN

!        3.1   Write perturbed initial file for Aladin 
!              --------------------------------------
  CALL EWREINI(SIM4D,YVAZX,YVAZG,RDX)
ENDIF
!      -----------------------------------------------------------------

!*       4.   Cost function minimisation
!             --------------------------

IF(LMINI.AND..NOT.L801TL)THEN

!*       4.1  Various initializations
!             -----------------------
  DO I=1,5
    ITBMIN(I)=0
  ENDDO
  ZDX=RXMIN
  ZDF1=ZF/NINFRA
  ZEPS=RCVGE
  IMP=NMIMP
  IO=NULOUT
  INFO=0
  ITER=NITER
  ISIM=NSIMU
  CALL ALLOCATE_CTLVEC(YL_ZDIAG)
  INMUPD=NMUPD
  DO JUPD=1,INMUPD
    CALL ALLOCATE_CTLVEC(YL_ZYBAR(JUPD))
    CALL ALLOCATE_CTLVEC(YL_ZSBAR(JUPD))
  ENDDO

!*       4.2  Quasi Newton minimisation
!             -------------------------
  CALL SUHESS(NMUPD,YL_ZDIAG,YL_ZYBAR,YL_ZSBAR,&
   & ITBMIN,ILM,IILM,ZSIZE,LWARM_RD)  
  CALL M1QN3(SIM4D,SCAAS,CTONB,CTCAB,IVADIM,YVAZX,ZF,YVAZG,ZDX,&
   & ZDF1,ZEPS,IMP,IO,INFO,&
   & ITER,ISIM,ITBMIN,NMUPD,INMUPD,YL_ZDIAG,YL_ZYBAR,YL_ZSBAR)  

  WRITE(NULOUT,*) 'Output mode of m1qn3=',INFO,' which means :'
  IF(INFO<0)  WRITE(NULOUT,*) ' simulator returned indic<0'
  IF(INFO==0) WRITE(NULOUT,*) ' simulator returned indic=0'
  IF(INFO==1) WRITE(NULOUT,*) ' gradient test is satisfied'
  IF(INFO==2) WRITE(NULOUT,*) ' error in m1qn3 input arguments'
  IF(INFO==3) WRITE(NULOUT,*) ' line-search blocked on tmax'
  IF(INFO==4) WRITE(NULOUT,*) ' max number of iterations reached'
  IF(INFO==5) WRITE(NULOUT,*) ' max number of simulations reached'
  IF(INFO==6) WRITE(NULOUT,*) ' line-search blocked on dxmin'
  IF(INFO==7) WRITE(NULOUT,*) ' bad gradient, line-search failed'
  IF(INFO>7)  WRITE(NULOUT,*) '   (unknown output mode ???)'

!*       4.3  Writes the optimized orography on file
!             --------------------------------------

  CALL CAIN(YVAZX)

  NSIM4D=NSIM4DL
  LTWANA=.TRUE.
  CALL STEPO('A00000000')
  LTWANA=.FALSE.

!*       4.4  Test of the quality of the gradient
!             -----------------------------------
  ZF=0.0_JPRB
  INDIC=4
  CALL SIM4D(INDIC,IDUM,YVAZX,ZF,YVAZG,NSIM4D)

  ZGF=0.0_JPRB
  CALL SCAAS(IDUM,YVAZG,YVAZG,ZGF)
  WRITE(UNIT=NULOUT,FMT='('' FINAL GRADIENT NORM SQUARED :''&
   & ,E14.7,''COST FUNCTION : '',E14.7)')&
   & ZGF,ZF  
  WRITE(UNIT=NULOUT,FMT='('' RATIO FINAL/INITIAL GRADIENT :''&
   & ,E14.7,''COST FUNCTION : '',E14.7)')&
   & ZGF/ZGI,ZF/ZFI  

  CALL DEALLOCATE_CTLVEC(YL_ZDIAG)
  DO JUPD=1,INMUPD
    CALL DEALLOCATE_CTLVEC(YL_ZYBAR(JUPD))
    CALL DEALLOCATE_CTLVEC(YL_ZSBAR(JUPD))
  ENDDO
ENDIF

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

!*       5.   Cost function minimisation in the case 801
!             ------------------------------------------

IF ( L801TL .AND. LMINI ) THEN

!*       5.1  Various initializations
!             -----------------------
  DO I=1,5
    ITBMIN(I)=0
  ENDDO
  ZDX=RXMIN
  ZDF1=ZF/NINFRA
  ZEPS=RCVGE
  IMP=NMIMP
  IMP=10
  IO=NULOUT
  INFO=0
  ITER=NITER
  ISIM=NSIMU
  CALL ALLOCATE_CTLVEC(YL_ZDIAG)
  INMUPD=NMUPD
  DO JUPD=1,INMUPD
    CALL ALLOCATE_CTLVEC(YL_ZYBAR(JUPD))
    CALL ALLOCATE_CTLVEC(YL_ZSBAR(JUPD))
  ENDDO

!*       5.2  Quasi Newton minimisation
!             -------------------------
  IF (LMINI) THEN
    CALL SUHESS(NMUPD,YL_ZDIAG,YL_ZYBAR,YL_ZSBAR,&
     & ITBMIN,ILM,IILM,ZSIZE,LWARM_RD)  
    CALL M1QN3(SIM4D,SCAAS,CTONB,CTCAB,IVADIM,&
     & YVAZX,ZF,YVAZG,ZDX,&
     & ZDF1,ZEPS,IMP,IO,INFO,&
     & ITER,ISIM,ITBMIN,NMUPD,INMUPD,YL_ZDIAG,YL_ZYBAR,YL_ZSBAR)  

    IF (ZFI<=0.) ZFI=1.
    IF (ZGI<=0.) ZGI=1.
    ZGF=0.
    CALL SCAAS(IDUM,YVAZG,YVAZG,ZGF)
    WRITE(UNIT=NULOUT,FMT='('' FINAL GRADIENT NORM SQUARED :''&
     & ,E14.7,''COST FUNCTION : '',E14.7)') ZGF,ZF  
    WRITE(UNIT=NULOUT,FMT='('' RATIO FINAL/INITIAL GRADIENT :''&
     & ,E14.7,''COST FUNCTION : '',E14.7)') ZGF/ZGI,ZF/ZFI  

    ! Re-test gradient after minimization
    IF (LTEST) &
     & CALL GRTEST(SIM4D,SCAAS,YVAZX,RDX,15,NULOUT)  

    CALL DEALLOCATE_CTLVEC(YL_ZDIAG)
    DO JUPD=1,INMUPD
      CALL DEALLOCATE_CTLVEC(YL_ZYBAR(JUPD))
      CALL DEALLOCATE_CTLVEC(YL_ZSBAR(JUPD))
    ENDDO

  ELSE

!*       5.3  Compute step-size
!             -----------------
!           ZD= DESCENT DIRECTION
    YL_ZD%data = -YVAZG%data
    ZGI=0.0_JPRB
    CALL SCAAS(IDUM,YL_ZD,YL_ZD,ZGI)
    WRITE(UNIT=NULOUT,FMT='('' INITIAL GRADIENT NORM SQUARED :'',E14.7)') ZGI
    ZTRIAL=1.0_JPRB/SQRT(ZGI)
!           TRIAL POINT
    YLVAZX2%data = YVAZX%data + ZTRIAL * YL_ZD%data
    INDIC=4
    ZCOST2=0.0_JPRB
    CALL SIM4D(INDIC,IDUM,YLVAZX2,ZCOST2,YLVAZG2,0)
    ZGN=0.0_JPRB
    CALL SCAAS(IDUM,YLVAZG2,YLVAZG2,ZGN)
    WRITE(UNIT=NULOUT &
     & ,FMT='('' AT TRIAL POINT  GRADIENT NORM SQUARED :''&
     & ,E14.7,''COST FUNCTION : '',E14.7)')&
     & ZGN,ZCOST2  
!           CALCULATE OPTIMAL STEP LENGTH
    ZGN=0.0_JPRB
    CALL SCAAS(IDUM,YVAZG,YL_ZD,ZGN)
    ZG2=0.0_JPRB
    CALL SCAAS(IDUM,YLVAZG2,YL_ZD,ZG2)
    ZSTEP=ZGN*ZTRIAL/(ZGN-ZG2)
    WRITE(UNIT=NULOUT,FMT='('' STEP SIZE :'',E14.7)') ZSTEP
!           EVALUATION OF THE COST AND GRADIENT AT NEW POINT
    YLVAZX2%data = YVAZX%data + ZSTEP * YL_ZD%data
    INDIC=4
    ZCOST2=0.0_JPRB
    CALL SIM4D(INDIC,IDUM,YLVAZX2,ZCOST2,YLVAZG2,0)
    ZGN=0.0_JPRB
    CALL SCAAS(IDUM,YLVAZG2,YLVAZG2,ZGN)
    WRITE(UNIT=NULOUT &
     & ,FMT='('' AT NEW POINT  GRADIENT NORM SQUARED :''&
     & ,E14.7,''COST FUNCTION : '',E14.7)')&
     & ZGN,ZCOST2  
  ENDIF
ENDIF

CALL DEALLOCATE_CTLVEC(YLVAZX2)
CALL DEALLOCATE_CTLVEC(YLVAZG2)
CALL DEALLOCATE_CTLVEC(YL_ZD)
!      ------------------------------------------------------------------

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