SUBROUTINE GRTEST(SIMUL,SCAPR,YD_PX,PDXINI,KNBMAX,KOUT)

!***   *GRTEST* - Test of the cost-function and its gradient

!     Explicit arguments : (all input)
!     --------------------
!  SIMUL : External simulator with following interface:
!    subroutine SIMUL(KI,KDIM,ZX,ZF,ZG,KIT)
!    integer, intent(in) :: KI,KD,KIT    ! unused var, dimension, index
!    real, intent(in) :: ZX(KDIM)      ! vector X
!    real, intent(out) :: ZF,ZG(KDIM)  ! cost J(X), gradJ(X)
!  SCAPR : External scalar product with following interface:
!    subroutine SCAPR(KDIM,ZX,ZY,ZP)
!    integer, intent(in) :: KDIM            ! dimension
!    real, intent(in) :: ZX(KDIM),ZY(KDIM)  ! vectors X and Y
!    real, intent(out) :: ZP                ! inner product <X,Y>
!  KDIM : input space dimension
!  PX(KDIM) : point X at which the testing will be done
!  PF : precomputed value of cost function J at point X
!  PG(KDIM) : precomputed vector gradJ at point X
!  PDXINI : initial size for the test perturbation
!  KNBMAX : max number of test steps allowed
!  KOUT : unit for printouts

!     Externals : SCALAI, SCAPR dummy arguments of this subroutine
!     -----------

!     Method :
!     --------
!     The aim is to characterize mathematically the cost-function J on a
!  line in the KDIM-dimensional space defined by point X and direction H.
!  Arbitrarily H is defined by -gradJ(X), the useful direction for
!  minimization. Let us denote by f the real function f(a)=J(X+a.H). A
!  sequence of characteristic quantities are computed and displayed for
!  various values of a :
!           a=PDX, PDX*10, PDX*100 ... PDX*10**KNBMAX
!  The sequence is prematuraly terminated if f(a)-f(0) changes of sign,
!  which normally indicates we are overshooting the minimum of f (assuming
!  J is convex and H points downwards the slope of J). The characteristic
!  quantities TC0,T1,TC1,T2... test increasingly high orders of regularity.
!  Refer to the comments below for the explanation of each quantity.
!    Owing to numerical truncation errors, the tests normally fail for very 
!  small perturbations. The maximum quality of the test results, even for a
!  bug-free simulator, is limited to a few digits, depending on the machine.

!     Reference : 
!     -----------
!  Comments in this source code.
!  ECMWF Research Department documentation of the IFS
!     Modifications :
!     ---------------
!  87-10-15 M.Hamrud and P.Courtier ECMWF : Original version
!  95-11-30 F.Bouttier ECMWF : f90 rewriting to test quadraticity/convexity,
!                              distinguish gradient and perturbation concepts,
!                              do the test even if gradJ=0
!  00-01-27 Y.Tremolet : Compute initial point inside the subroutine,
!                        Deallocate arrays at the end.
!  00-11-10 W.Sadiki   : ajouter condition (IBEST /= -1) lorsque (IBEST <= ITEST-2)
!                        dans le test qualite du gradient.
!  02-08-06 Y.Tremolet : Use control_vectors.
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!-----------------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMCT0    ,ONLY : NCONF
USE YOMVAR  , ONLY: NSIM4D, NITER4D
USE YOMVRTL  , ONLY : L801TL
USE CONTROL_VECTORS

IMPLICIT NONE

!       Interface
EXTERNAL SIMUL,SCAPR
TYPE(CONTROL_VECTOR),INTENT(IN)  :: YD_PX 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PDXINI 
INTEGER(KIND=JPIM),INTENT(IN)    :: KNBMAX 
INTEGER(KIND=JPIM),INTENT(IN)    :: KOUT 

!       Main local variables
TYPE(control_vector) :: YL_ZH ! test direction
TYPE(control_vector) :: YL_ZY,YL_ZGY ! perturbed X, gradJ(X)
REAL(KIND=JPRB) :: ZABUF(0:KNBMAX),ZFABUF(0:KNBMAX),ZDFABUF(0:KNBMAX)  ! test storage
REAL(KIND=JPRB) :: ZFY          !  J(X)
REAL(KIND=JPRB) :: ZF0,ZDF0,ZA,ZFA,ZDFA,ZB,ZFB     ! f(0),df(0),a,f(a),df(a),f(b),df(b)
REAL(KIND=JPRB) :: ZTC0,ZT1,ZTC1,ZTC1A,ZT2,ZTC2,ZTF2,ZT3    ! regularity test functions
REAL(KIND=JPRB) :: ZAL,ZFAL,ZBL,ZFBL,ZTF2L         ! last a,f(a),b,f(b),TF2-test
REAL(KIND=JPRB) :: ZTC00,ZTC02,ZTC10,ZTC12         ! first (i.e. small-scale) tests
REAL(KIND=JPRB) :: ZERMIN,ZT1TST,ZT2SMA,ZREF
INTEGER(KIND=JPIM) :: ITEST,IBEST,IDIG,JJ,idum,isave1,isave2

REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"
#include "restart_cnt3.intfb.h"

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

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

idum=-999
isave1=NITER4D
isave2=NSIM4D
NITER4D=1
NSIM4D=1

!       printing output unit number
WRITE(KOUT,*) 'GRTEST: TEST COST-FUNCTION AND ITS GRADIENT'
IF(PDXINI < EPSILON(PDXINI))THEN
  WRITE(KOUT,*) ' ERROR GRTEST, PDXINI=',PDXINI
  CALL ABOR1(' ERROR PDXINI IN GRTEST ')
ENDIF
CALL ALLOCATE_CTLVEC(YL_ZH)
CALL ALLOCATE_CTLVEC(YL_ZY)
CALL ALLOCATE_CTLVEC(YL_ZGY)

!       1.0 Initial point
!           -------------

YL_ZY=YD_PX
WRITE(KOUT,*) '   calling simulator...'
if( .not. l801tl.AND.nconf/100==8 ) call restart_cnt3
CALL SIMUL(4,idum,YL_ZY,ZFY,YL_ZGY,0)
ZF0=ZFY

!          1.1 Define perturbation direction ZH

WRITE(KOUT,*) 'The test direction is the opposite ','of the gradient'
YL_ZH%data=-YL_ZGY%data

!          1.2 Set function f value and derivative at origin

CALL SCAPR(idum,YL_ZGY,YL_ZH,ZDF0)
WRITE(KOUT,*) 'GRTEST F(0)=',ZF0,' DF(0)=',ZDF0
IF(ZDF0 > 0.0_JPRB)WRITE(KOUT,*) 'GRTEST Warning, DF should be negative'
IF(ABS(ZDF0) < SQRT(EPSILON(ZDF0)))THEN
  WRITE(KOUT,*) 'GRTEST WARNING, DERIVATIVE IS TOO SMALL'
ENDIF

!       2. Loop on test point
!          ------------------

ITEST=0
TSTLOOP : DO
  ZA=PDXINI*(10._JPRB**ITEST)
  IF(ZA <= SQRT(TINY(ZA))) CALL ABOR1('GRTEST INTERNAL ERROR ZA<EPS')
  WRITE(KOUT,*) 'GRTEST TEST NO.',ITEST+1,' ALPHA=',ZA

!           2.1 Compute f and df at new point y=x+a.h

  YL_ZY%data=YD_PX%data+ZA*YL_ZH%data
  WRITE(KOUT,*) '   calling simulator...'
  if( .not. l801tl.AND.nconf/100==8 ) call restart_cnt3
  CALL SIMUL(4,idum,YL_ZY,ZFY,YL_ZGY,ITEST+1)
  ZFA=ZFY
  CALL SCAPR(idum,YL_ZGY,YL_ZH,ZDFA)
  WRITE(KOUT,*) '   results from simulator with ALPHA=',ZA,' :'
  WRITE(KOUT,*) 'GRTEST F(a)=',ZFA,' DF(a)=',ZDFA
  ZABUF(ITEST)=ZA
  ZFABUF(ITEST)=ZFA
  ZDFABUF(ITEST)=ZDFA

!          2.2 Quantity TC0=f(a)/f(0)-1

!         if f is continuous then TC0->1 at origin,
!         at least linearly with a.

  IF(ABS(ZF0) < TINY(ZF0))THEN
!           do not compute T1 in this unlikely case
    WRITE(KOUT,*) 'GRTEST Warning: ZF0 is suspiciously small.'
    WRITE(KOUT,*) 'GRTEST F(a)-F(0)=',ZFA-ZF0
  ELSE
    ZTC0=ZFA/ZF0-1.0_JPRB
    WRITE(KOUT,*) 'GRTEST continuity TC0=',ZTC0
  ENDIF
!                           f(a)-f(0)
!          2.3 Quantity T1=-----------
!                            a.df(0)

!         if df is the gradient then T1->1 at origin,
!         linearly with a. T1 is undefined if df(0)=0.
  IF(ABS(ZA*ZDF0) < SQRT(TINY(ZF0)))THEN
    WRITE(KOUT,*) 'GRTEST Warning: could not compute ',&
     & 'gradient test T1, a.df(0)=',ZA*ZDF0  
  ELSE
    ZT1=(ZFA-ZF0)/(ZA*ZDF0)
    WRITE(KOUT,*) 'GRTEST gradient T1=',ZT1
  ENDIF

!         2.4 Quantity TC1=( f(a)-f(0)-a.df(0) )/a

!         if df is the gradient and df is continuous,
!         then TC1->0 linearly with a.
  ZTC1=(ZFA-ZF0-ZA*ZDF0)/ZA
  WRITE(KOUT,*) 'GRTEST grad continuity TC1=',ZTC1

!         2.5 Quantity T2=( f(a)-f(0)-a.df(0) )*2/a**2

!         if d2f exists then T2 -> d2f(0) linearly with a.
  ZT2=(ZFA-ZF0-ZA*ZDF0)*2.0_JPRB/(ZA**2)
  WRITE(KOUT,*) 'GRTEST second derivative T2=',ZT2

!         2.6 Quantity TC1A=df(a)-df(0)

!         if df is the gradient in a and df is continuous,
!         then TC1A->0 linearly with a.
  ZTC1A=ZDFA-ZDF0
  WRITE(KOUT,*) 'GRTEST a-grad continuity TC1A=',ZTC1A

!         2.7 Quantity TC2=( 2(f(0)-f(a))+ a(df(0)+df(a))/a**2

!         if f is exactly quadratic, then TC2=0, always: numerically
!         it has to -> 0 when a is BIG. Otherwise TC2->0 linearly for
!         small a is trivially implied by TC1A and T2.
  ZTC2=(2.0_JPRB*(ZF0-ZFA)+ZA*(ZDF0+ZDFA))/(ZA**2)
  WRITE(KOUT,*) 'GRTEST quadraticity TC2=',ZTC2

!         2.7 Quantity T3=( 2(f(0)-f(a)) + a (df(0)+df(a)) )*6/a**3

!         if d3f exists then T3-> d3f(0) linearly with a.
!         (you don't believe it ? Eliminate d2f(0) between Taylor
!         formulae for f(a) and df(a) in the vicinity of 0).
!         Corollary: if f is quadratic then T3->0 linearly with a.
!         Warning: this quantity is truncation error-prone.
  ZT3=(2.0_JPRB*(ZF0-ZFA)+ZA*(ZDF0+ZDFA))*6._JPRB/(ZA**3)
  WRITE(KOUT,*) 'GRTEST third derivative T3=',ZT3

!                           2   f(0)-f(b)   f(a)-f(b)
!         2.8 Quantity TF2=---( --------- + --------- )
!                           a       b          a-b
!         if 0, a and b are distinct and f is quadratic then
!         TF2=d2f, always. The estimate is most stable when a,b are big.
!         This test works only after two loops, but it is immune against
!         gradient bugs. 
  IF(ITEST >= 1)THEN
    ZB=ZABUF(ITEST-1)
    ZFB=ZFABUF(ITEST-1)
    IF((ZB == ZA).OR.(ZA == 0.0_JPRB).OR.(ZB == 0))THEN
      WRITE(KOUT,*) 'GRTEST ERROR A=',ZA,' B=',ZB
      CALL ABOR1('GRTEST NULL PERTURBATION(S)')
    ENDIF
    ZTF2=2.0_JPRB/ZA*((ZF0-ZFB)/ZB+(ZFA-ZFB)/(ZA-ZB))
    WRITE(KOUT,*) 'GRTEST convexity ZTF2=',ZTF2
  ENDIF

!          2.9 End loop

  IF( (ITEST > 1) .AND. ( ZDF0*(ZFA-ZF0) < 0.0_JPRB) )THEN
    WRITE(KOUT,*) 'GRTEST PREMATURE END, cost function ',&
     & 'variations disagree with initial gradient.'  
    EXIT TSTLOOP
  ENDIF
  IF(ITEST == KNBMAX-1)THEN
    WRITE(KOUT,*) 'GRTEST End, max number of tests reached.'
    EXIT TSTLOOP
  ENDIF
  ITEST=ITEST+1
ENDDO TSTLOOP
WRITE(KOUT,*) 'GRTEST ',ITEST+1,' tests have been performed.'

!          3. Comment on the results

!       less than 4 tests -> bad gradient or too small PDXINI
!       TC0(0)/TC0(2)<.011 -> df looks continuous
!       item with (T1<1 and 1-T1 is min) = best grad test item
!       TC1(bgti)/TC1(bgti+2)<.011 -> df looks continuous
!       T2(bgti+2) = Taylor d2f estimate(small-scale)
!       log10(1-T1) at bgti = gradient quality
!       T2(last) = Taylor d2f estimate (large-scale)
!       TF2(last)= finite-difference d2f estimate (large-scale)
!       TC3(last)= Taylor d3f estimate (large-scale)
!       reldif(TF2(last),TF2(last-1)) = precision on quadraticity

!          3.1 Fundamental checks

WRITE(KOUT,*) 'GRTEST TENTATIVE CONCLUSIONS :'
IF(ITEST < 4)THEN
  WRITE(KOUT,*) 'GRTEST too few tests have been done to say anything.'
  WRITE(KOUT,*) 'GRTEST The gradient is bad, or the initial',&
   & ' test step (RDX) is too big or too small.'  
ELSE
  ZTC00=ABS(ZFABUF(0)-ZF0)
  ZTC02=ABS(ZFABUF(2)-ZF0)
  IF( ZTC00/ZABUF(0)  <=  1.5_JPRB*(ZTC02/ZABUF(2)) )THEN
    WRITE(KOUT,*) 'GRTEST function f looks continous.'
  ELSE
    WRITE(KOUT,*) 'GRTEST WARNING f does not look continuous',&
     & ' (perhaps truncation problem)'  
  ENDIF

!          3.2 Gradient quality

  IBEST=-1
  IF(ABS(ZDF0) < SQRT(TINY(ZF0)))THEN
    WRITE(KOUT,*) 'GRTEST The gradient is 0, which is unusual !'
    ZTC10=ABS(ZFABUF(0)-ZF0)
    ZTC12=ABS(ZFABUF(2)-ZF0)
    IF( ZTC10/ZABUF(0)**2  <=  1.1_JPRB*ZTC12/ZABUF(2)**2)THEN
      WRITE(KOUT,*) 'GRTEST The gradient looks good anyway.'
    ENDIF
  ELSE
!           Find best gradient test index (IBEST preinitialized before)
    ZERMIN=HUGE(ZERMIN)
    DO JJ=0,ITEST
      ZT1TST=(ZFABUF(JJ)-ZF0)/(ZABUF(JJ)*ZDF0)
      ZT1TST=ABS(ZT1TST-1.0_JPRB)
      IF (ZT1TST<ZERMIN) THEN
        IBEST=JJ
        ZERMIN=ZT1TST
      ENDIF
    ENDDO
    IF(IBEST == -1)THEN
      WRITE(KOUT,*) 'GRTEST gradient test problem : bad ',&
       & 'gradient, non-convex cost, or truncation errors ?'  
    ELSE
      IDIG=INT(-LOG(ZERMIN+TINY(ZERMIN))/LOG(10._JPRB))
      WRITE(KOUT,*) 'GRTEST the best gradient test found has ',&
       & IDIG,' satisfactory digits.'  
      IF(IDIG <= 1)THEN
        WRITE(KOUT,*) 'GRTEST SAYS: THE GRADIENT IS VERY BAD.'
      ELSEIF(IDIG <= 3)THEN
        WRITE(KOUT,*) 'GRTEST SAYS: THE GRADIENT IS SUSPICIOUS.'
      ELSEIF(IDIG <= 5)THEN
        WRITE(KOUT,*) 'GRTEST SAYS: THE GRADIENT IS ACCEPTABLE.'
      ELSE
        WRITE(KOUT,*) 'GRTEST SAYS: THE GRADIENT IS EXCELLENT.'
      ENDIF
    ENDIF
!    IF(IBEST <= ITEST-2)THEN
    IF((IBEST /= -1).AND.(IBEST <= ITEST-2))THEN
      ZTC10=ABS(ZFABUF(IBEST)-ZF0-ZABUF(IBEST)*ZDF0)/ZABUF(IBEST)
      ZTC12=ABS(ZFABUF(IBEST+2)-ZF0-ZABUF(IBEST+2)*ZDF0)/ZABUF(IBEST+2)
      IF(ZTC10/ZABUF(IBEST) <=  1.1_JPRB*ZTC12/ZABUF(IBEST+2) )THEN
        WRITE(KOUT,*) 'GRTEST Gradient convergence looks good.'
      ELSE
        WRITE(KOUT,*) 'GRTEST Gradient convergence is suspicious'
      ENDIF
    ELSE
      WRITE(KOUT,*) 'GRTEST could not check grad convergence.'
    ENDIF
  ENDIF

!            3.3 Quadraticity

  IF((IBEST /= -1).AND.(IBEST < ITEST-2))THEN
!           Use T2 no.ibest+2 because it seems the most stable one
    ZT2SMA=(ZFABUF(IBEST+2)-ZF0-ZABUF(IBEST+2)*ZDF0)&
     & *2.0_JPRB/(ZABUF(IBEST+2)**2)  
    WRITE(KOUT,*) 'GRTEST small-scale Taylor estimate of ','d2f=',ZT2SMA
    ZREF=(ABS(ZT2SMA)+ABS(ZT2))/2.0_JPRB
    IF(ZREF > TINY(ZREF))THEN
      IF(ABS(ZT2SMA-ZT2)/ZREF > 1.E-4_JPRB)THEN
        WRITE(KOUT,*) 'GRTEST WARNING: small- and large scale ',&
         & ' d2f estimates disagree.'  
      ENDIF
    ENDIF
  ENDIF
!           Last T2/TC3 are still in ZT2/ZTC3
  WRITE(KOUT,*) 'GRTEST large-scale Taylor estimate of ','d2f=',ZT2
  IF(ABS(ZT2) > SQRT(TINY(ZT2)))THEN
    WRITE(KOUT,*) 'GRTEST large-scale d3f/d2f=',ZT3/ZT2
    IDIG=INT(-LOG(ABS(ZT3/ZT2)+TINY(ZT3))/LOG(10._JPRB)+1.0_JPRB)
    WRITE(KOUT,*) 'GRTEST the Taylor quadraticity',&
     & ' test has ',IDIG,' satisfactory digits.'  
    IF(IDIG <= 2)THEN
      WRITE(KOUT,*) 'GRTEST: THE T-QUADRATICITY IS BAD.'
    ELSEIF(IDIG <= 4)THEN
      WRITE(KOUT,*) 'GRTEST: THE T-QUADRATICITY IS SUSPICIOUS.'
    ELSEIF(IDIG <= 6)THEN
      WRITE(KOUT,*) 'GRTEST: THE T-QUADRATICITY IS ACCEPTABLE.'
    ELSE
      WRITE(KOUT,*) 'GRTEST: THE T-QUADRATICITY IS EXCELLENT.'
    ENDIF
  ELSE
    WRITE(KOUT,*) 'GRTEST could not test Taylor quadraticity,',&
     & ' second derivative is too small (this is suspicious)'  
  ENDIF

!         finite difference quadraticity test (gradient-free)
  ZAL=ZABUF(ITEST-1)
  ZFAL=ZFABUF(ITEST-1)
  ZBL=ZABUF(ITEST-2)
  ZFBL=ZFABUF(ITEST-2)
  ZTF2L=2.0_JPRB/ZAL*((ZF0-ZFBL)/ZBL+(ZFAL-ZFBL)/(ZAL-ZBL))
  WRITE(KOUT,*) 'GRTEST finite diff. d2f estimate no1:',ZTF2
  WRITE(KOUT,*) 'GRTEST finite diff. d2f estimate no2:',ZTF2L
  ZREF=(ABS(ZTF2L)+ABS(ZTF2))/2.0_JPRB
  IF(ZREF < TINY(ZREF))THEN
    WRITE(KOUT,*) 'GRTEST they are too small to decide whether ',&
     & 'they agree or not.'  
  ELSE
    IDIG=INT(-LOG(ABS(ZTF2L-ZTF2)/ZREF+TINY(ZTF2))/LOG(10._JPRB))
    WRITE(KOUT,*) 'GRTEST the fin.dif. estimates of d2f ',&
     & 'have ',IDIG,' satisfactory digits.'  
    IF(IDIG <= 1)THEN
      WRITE(KOUT,*) 'GRTEST: THE FD-QUADRATICITY IS BAD.'
    ELSEIF(IDIG <= 3)THEN
      WRITE(KOUT,*) 'GRTEST: THE FD-QUADRATICITY IS SUSPICIOUS.'
    ELSEIF(IDIG <= 5)THEN
      WRITE(KOUT,*) 'GRTEST: THE FD-QUADRATICITY IS ACCEPTABLE.'
    ELSE
      WRITE(KOUT,*) 'GRTEST: THE FD-QUADRATICITY IS EXCELLENT.'
    ENDIF
  ENDIF

ENDIF

NITER4D=isave1
NSIM4D=isave2
CALL DEALLOCATE_CTLVEC(YL_ZH)
CALL DEALLOCATE_CTLVEC(YL_ZY)
CALL DEALLOCATE_CTLVEC(YL_ZGY)

WRITE(KOUT,*) 'GRTEST Goodbye.'

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