SUBROUTINE SUSCAL

!**** *SUSCAL*  - Initialize scalar product for variational job

!     Purpose.
!     --------
!           Initialize scalar product used for e.g. the minimization
!        and testing of adjoints.
!**   Interface.
!     ----------
!        *CALL* *SUSCAL

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

!        Implicit arguments :
!        --------------------
!        Array SCALP in YOMCVA

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

!     Externals.    CAININ - inverse of the Canonical injection
!     ----------
!     Reference.
!     ----------
!        ECMWF Research Department documentation of the IFS

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

!     Modifications.
!     --------------
!     Original    87-10-15
!     W.HECKLEY   91-02-20
!     R.Buizza    92-02-25 : For computation of optimal pert
!     P.Courtier  92-06-15 : Bug if NLOSP=1
!     W.HECKLEY   92-09-22 : Provision for NCNTVAR=3
!     L.Labbe     93-04-13 : Term for orography in S.W.
!     F.Rabier    93-12-10 : For configutaion 801
!     L.Isaksen   95-06-06 : Reordering of spectral arrays
!     M.Hamrud    95-12-12 : Prep. for distr.mem.
!     M.Hamrud    95-12-15 : Remove  NCNTVAR=3
!     L.Isaksen   96-02-20 : Adapted for Message Passing
!     R.Buizza    96-03-08 : More norm choices for conf 601 (SVs)
!     R.B. & J.F.Mahfouf 96-03-08 : Wq weights for conf 601 (SVs)
!     R. Buizza   96-07-31 : Wq weights written in GRIB (conf 601)
!     E.Andersson 96-08-01 : Precalculate SQRT(SCALP)
!     E.Holm      97-12-15 : Ozone included
!     M.Hamrud    98-01-10 : Scalp etc. also as distributed vectors
!     M.Hamrud    98-03-06 : Stop over-writing spectral orography
!     E.Andersson 98-07-06 : TOVS control variable
!     T. Bergot   98-08    : SCALP in FA format (601)
!     Modified 01-08-30 by K. YESSAD: pruning and some other cleanings.
!     Y.Tremolet  02-08-06 : Use control_vectors.
!     D.Dee       04-01-23 : Variational bias correction
!     M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Fisher      17-Mar-2004 Wavelet Jb
!        Y.Tremolet    10-Jun-2004 Initial condition optional in control variable
!        P.Burton :  29-09-04 LVARBC cleanup
!        M.Hamrud      01-May-2006 Generalized IO scheme
!    ----------------------------------------------------------------

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

USE YOMDIM   , ONLY : NFLEVL   ,NSMAX    ,NUMP     , NFLEVG, NPROMA
USE YOMDYN   , ONLY : SIDELP   ,REFGEO   ,SITR     ,&
 & SIRPRG   ,SIRPRN  
USE YOMLUN   , ONLY : NULOUT   
USE YOMCT0   , ONLY : NCONF    ,NCNTVAR  ,LGUESS   ,LBACKG, LELAM
USE YOMCST   , ONLY : RCPD     ,RLVTT
USE YOMLAP   , ONLY : NASM0    ,MYMS     ,RLAPIN   ,RLAPDI
USE YOMSPJB  , ONLY : SPJB
USE YOMCVA   , ONLY : NVAPARAM, YSCALP ,YRSCALP, YSCALPSQRT, YRSCALPSQRT,&
 & NVA3D, NVA2D
USE YOMVAR   , ONLY : LTOVSCV, LJCDFI, LMODERR, LAVARC, LVARBC, LINITCV ,&
 & LTSCV
USE VARBC_SETUP, ONLY : YVARBC, NOBGROUP ,NOBPARAM
USE YOMLCZ   , ONLY : NLANNORM ,COEQTERM ,LSCALC   ,LFORCE, L_UNPREDICTABLE_COMPONENTS,& 
 & NRITZNUMB, NRITZGBH1, NRITZGBH2
USE YOMMP    , ONLY : MYLEVS   ,NPSP, MY_REGION_NS, MY_REGION_EW
USE YOMCT0B  , ONLY : LECMWF
USE YOMWAVELET,ONLY : LJBWAVELET, N_WAVELET_SCALES, GRID_DEFINITION
USE YOMGEM   , ONLY : VAH      ,VBH
USE IOSTREAM_MIX , ONLY : SETUP_IOSTREAM,TYPE_IOSTREAM,CLOSE_IOSTREAM
USE CONTROL_VECTORS, ONLY : CONTROL_VECTOR, ALLOCATE_CTLVEC, DEALLOCATE_CTLVEC, INVERSE
USE SPECTRAL_FIELDS_MOD, ONLY : ASSIGNMENT(=)

IMPLICIT NONE

TYPE(control_vector) :: YL_ZSCAL
TYPE(TYPE_IOSTREAM)  :: YL_IOSTR_SCALW

INTEGER(KIND=JPIM) :: ILEV, IM, INM, IOMASTER, JIR,&
 & JLEV, JMLOC, JN, JSCALE, JLON, ISTLON, IENDLON, ILATG, JGLAT, &
 & IOFF1, IOFF2, IOFF3, JFLD, JG  

REAL(KIND=JPRB) :: ZMFACT, ZRGEO, ZSIQR, ZQFACT, ZFRAC, ZPRES, ZGAW
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

#include "abor1.intfb.h"
#include "cainin.intfb.h"
#include "scaljgg.intfb.h"
#include "scaljgs.intfb.h"
#include "supavarc.intfb.h"
#include "suprepjcdfi.intfb.h"
#include "wrtllcz.intfb.h"
#include "wrtsv.intfb.h"
#include "suscalmerr.intfb.h"

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

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

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

!*       1.    Initialize spectral array (used as work space).
!              -----------------------------------------------

!*       1.0   DEFAULT VALUES.

CALL GSTATS(1830,0)
SPJB = 1.0_JPRB
ZSIQR=1.E-5_JPRB

IF (LVARBC) THEN
  IF (NOBPARAM/=nvaparam) &
   & CALL ABOR1('SUSCAL: Parameter section of control variable wrong length')  
  DO jg = 1, NOBGROUP
    YVARBC(jg)%APARAMS(:) = 1.0_JPRB
  ENDDO
ENDIF

!     Energy in configuration 601 - Modification Roberto Buizza
!     - if NLANNORM=1 norm=total energy with q-term
!     - if NLANNORM=2 norm=kinetic energy
!     - if NLANNORM=3 norm=squared vorticity
!     - if NLANNORM=4 norm=squared stream-function
!     - if NLANNORM=5 norm=rotational kinetic energy
!     - if NLANNORM=6 norm=analytical function (to be coded)

!*       1.1  SCALAR PRODUCT ENERGY 3D

IF((NCONF == 131 .AND..NOT.LGUESS).OR.&
   & (NCONF == 601 .AND. .NOT.L_UNPREDICTABLE_COMPONENTS) .OR. &
   & ANY(SPREAD(NCONF,1,4) == (/1,401,501,801/))) THEN  
  SPJB = 0.0_JPRB
  DO JMLOC=1,NUMP
    IM=MYMS(JMLOC)
    ZMFACT=1.0_JPRB+REAL(MIN(1,IM),JPRB)
    DO JIR=0,MIN(1,IM)
      DO JN=IM,NSMAX
        INM=NASM0(IM)+(JN-IM)*2+JIR
        DO JLEV=1,NFLEVL
          ILEV=MYLEVS(JLEV)
          IF(NCONF == 601) THEN
            IF(NLANNORM == 1) THEN
              SPJB%VOR(JLEV,INM)=-ZMFACT*RLAPIN(JN)*SIDELP(ILEV)/2.0_JPRB
              SPJB%DIV(JLEV,INM)=-ZMFACT*RLAPIN(JN)*SIDELP(ILEV)/2.0_JPRB
              SPJB%TEM(JLEV,INM)=ZMFACT*RCPD*SIDELP(ILEV)/SITR/2.0_JPRB
              SPJB%HUM(JLEV,INM)=COEQTERM*ZMFACT &
               & *( (RLVTT**2)/(RCPD*SITR) )&
               & *SIDELP(ILEV)/2.0_JPRB  
            ELSEIF(NLANNORM == 2) THEN
              SPJB%VOR(JLEV,INM)=-ZMFACT*RLAPIN(JN)*SIDELP(ILEV)/2.0_JPRB
              SPJB%DIV(JLEV,INM)=-ZMFACT*RLAPIN(JN)*SIDELP(ILEV)/2.0_JPRB
              SPJB%TEM(JLEV,INM)=0.0_JPRB
              SPJB%HUM(JLEV,INM)=0.0_JPRB
            ELSEIF(NLANNORM == 3) THEN
              SPJB%VOR(JLEV,INM)=-ZMFACT*SIDELP(ILEV)/2.0_JPRB
              SPJB%DIV(JLEV,INM)=0.0_JPRB
              SPJB%TEM(JLEV,INM)=0.0_JPRB
              SPJB%HUM(JLEV,INM)=0.0_JPRB
            ELSEIF(NLANNORM == 4) THEN
              SPJB%VOR(JLEV,INM)=+ZMFACT*(RLAPIN(JN)**2)*SIDELP(ILEV)/2.0_JPRB
              SPJB%DIV(JLEV,INM)=0.0_JPRB
              SPJB%TEM(JLEV,INM)=0.0_JPRB
              SPJB%HUM(JLEV,INM)=0.0_JPRB
            ELSEIF(NLANNORM == 5) THEN
              SPJB%VOR(JLEV,INM)=-ZMFACT*RLAPIN(JN)*SIDELP(ILEV)/2.0_JPRB
              SPJB%DIV(JLEV,INM)=0.0_JPRB
              SPJB%TEM(JLEV,INM)=0.0_JPRB
              SPJB%HUM(JLEV,INM)=0.0_JPRB
            ELSEIF(NLANNORM == 6) THEN
              SPJB%VOR(JLEV,INM)=1.0_JPRB
              SPJB%DIV(JLEV,INM)=1.0_JPRB
              SPJB%TEM(JLEV,INM)=1.0_JPRB
              SPJB%HUM(JLEV,INM)=1.0_JPRB
            ENDIF
          ELSE
            SPJB%VOR(JLEV,INM)=-ZMFACT*RLAPIN(JN)*SIDELP(ILEV)/2.0_JPRB
            SPJB%DIV(JLEV,INM)=-ZMFACT*RLAPIN(JN)*SIDELP(ILEV)/2.0_JPRB
            SPJB%TEM(JLEV,INM)=ZMFACT*RCPD*SIDELP(ILEV)/SITR/2.0_JPRB
            IF(NCONF == 801) THEN
              ZQFACT=0.0_JPRB
              ZFRAC =0.8
              ZPRES=VAH(ILEV)+VBH(ILEV)*1013.0E2
              IF ((ZPRES>3.E4).AND.(ZPRES<=8.E4)) THEN
                ZQFACT=(ZPRES-30000.)/50000.
              ELSEIF(ZPRES>8.E4) THEN
                ZQFACT=((ZFRAC-1.)*ZPRES+1013.0E2-&
                 & 80000.*ZFRAC)/(1013.0E2-80000.)  
              ENDIF
              IF (ZQFACT /= 0.0_JPRB) ZQFACT=1./ZQFACT 

              SPJB%HUM(JLEV,INM)=  COEQTERM*ZMFACT*ZQFACT &
               & *( (RLVTT**2)/(RCPD*SITR) )&
               & *SIDELP(ILEV)/2.0_JPRB  
            ELSE
              SPJB%HUM(JLEV,INM)=ZMFACT*RLVTT*SIDELP(ILEV)/ZSIQR/2.0_JPRB
            ENDIF
          ENDIF
        ENDDO
      ENDDO
    ENDDO
  ENDDO

  IF (NPSP==1) THEN
    DO JMLOC=1,NUMP
      IM=MYMS(JMLOC)
      ZMFACT=1.0_JPRB+REAL(MIN(1,IM),JPRB)
      DO JIR=0,MIN(1,IM)
        DO JN=IM,NSMAX
          INM=NASM0(IM)+(JN-IM)*2+JIR
          IF(NCONF == 601) THEN
            IF(NLANNORM == 1) THEN
              SPJB%SPR(INM)=ZMFACT*SIRPRG/SIRPRN/2.0_JPRB
            ELSEIF(NLANNORM > 1.AND.NLANNORM <= 5) THEN
              SPJB%SPR(INM)=0.0_JPRB
            ELSEIF(NLANNORM == 6) THEN
              SPJB%SPR(INM)=1.0_JPRB
            ENDIF
          ELSE
            SPJB%SPR(INM)=ZMFACT*SIRPRG/SIRPRN/2.0_JPRB
          ENDIF
          IF(LFORCE) SPJB%SPR(INM)=0.0_JPRB
        ENDDO
      ENDDO
    ENDDO
  ENDIF
ENDIF

IF( NCONF == 801 .AND. LBACKG) THEN
  NCNTVAR=2
  CALL SCALJGS
  NCNTVAR=1
  SPJB%HUM(:,:)=COEQTERM*SPJB%HUM(:,:)
ENDIF

!*       1.2   VORTICITY EQUATION MODEL
!           (SCALAR PRODUCT ENSTROPHY OR ENERGY)

IF(ANY(SPREAD(NCONF,1,3) == (/202,422,522/))) THEN
  DO JMLOC=1,NUMP
    IM=MYMS(JMLOC)
    ZMFACT=1.0_JPRB+REAL(MIN(1,IM),JPRB)
    DO JIR=0,MIN(1,IM)
      DO JN=IM,NSMAX
        INM=NASM0(IM)+(JN-IM)*2+JIR
        SPJB%VOR(1,INM)=-ZMFACT*RLAPIN(JN)/2.0_JPRB
        SPJB%DIV(1,INM)=0.0_JPRB
        IF (NPSP == 1) SPJB%SPR(  INM)=0.0_JPRB
      ENDDO
    ENDDO
  ENDDO
ENDIF

!*       1.3   SHALLOW-WATER

IF(ANY(SPREAD(NCONF,1,3) == (/201,421,521/))) THEN
!        --- SCALAR PRODUCT ENERGY ---
  ZRGEO=REFGEO
  DO JMLOC=1,NUMP
    IM=MYMS(JMLOC)
    ZMFACT=1.0_JPRB+REAL(MIN(1,IM),JPRB)
    DO JIR=0,MIN(1,IM)
      DO JN=IM,NSMAX
        INM=NASM0(IM)+(JN-IM)*2+JIR
        SPJB%VOR(1,INM)=-ZMFACT*RLAPIN(JN)*ZRGEO/2.0_JPRB
        SPJB%DIV(1,INM)=-ZMFACT*RLAPIN(JN)*ZRGEO/2.0_JPRB
        IF (NPSP == 1) THEN
          SPJB%SPR (  INM)= ZMFACT/2.0_JPRB
        ENDIF
      ENDDO
    ENDDO
  ENDDO
ENDIF

!*       1.5   3-D VARIATIONAL JOB

IF (NCONF == 131 .AND. LGUESS) THEN
!        COMPUTE INNER PRODUCT FOR JG - grid point computations
  IF (NCNTVAR == 1) THEN
    IF (LJBWAVELET) CALL ABOR1 ('WAVELET JB IS INCOMPATIBLE WITH NCNTVAR==1')
    CALL SCALJGG
  ENDIF

!        COMPUTE INNER PRODUCT FOR JG - spectral space computations

  IF (.NOT. LJBWAVELET) CALL SCALJGS
ENDIF

!*       1.6   FORECAST MODEL ENTROPY JOB

IF (NCONF==601 .AND. L_UNPREDICTABLE_COMPONENTS) THEN
  write (NULOUT,*) 'UNPREDICTABLE COMPONENTS JOB: SCALAR PRODUCT IS SPECTRAL INNER PRODUCT'
  NCNTVAR=2
  CALL SCALJGS
  NCNTVAR=1
ENDIF

CALL GSTATS(1830,1)

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

!*       2.    Initialize scalar product array.
!              --------------------------------

IF (LINITCV) THEN
  IF (LJBWAVELET) THEN
    YSCALP%initcv = 0.0_JPRB

    DO JSCALE=1,N_WAVELET_SCALES+1
      IOFF1=0
      IOFF3=0
      ILATG=GRID_DEFINITION(JSCALE)%NPTRFLOFF
      DO JGLAT=GRID_DEFINITION(JSCALE)%NFRSTLAT(MY_REGION_NS), &
         & GRID_DEFINITION(JSCALE)%NLSTLAT(MY_REGION_NS)  

        ILATG=ILATG+1
        ISTLON  = GRID_DEFINITION(JSCALE)%NSTA(ILATG,MY_REGION_EW)
        IENDLON = ISTLON-1 + GRID_DEFINITION(JSCALE)%NONL(ILATG,MY_REGION_EW)
        ZGAW = GRID_DEFINITION(JSCALE)%GW(JGLAT)/GRID_DEFINITION(JSCALE)%NLOENG(JGLAT)
 
        DO JLON=ISTLON,IENDLON

          IOFF2=0
          DO JFLD=1,NVA3D
            DO JLEV=1,NFLEVG
              YSCALP%initcv(YSCALP%ibgn_scale(JSCALE)+IOFF1+IOFF2+IOFF3) = ZGAW
              IOFF2=IOFF2+NPROMA
            ENDDO
          ENDDO
          DO JFLD=1,NVA2D
            YSCALP%initcv(YSCALP%ibgn_scale(JSCALE)+IOFF1+IOFF2+IOFF3) = ZGAW
            IOFF2=IOFF2+NPROMA
          ENDDO

          IOFF1=IOFF1+1

          IF (MOD(IOFF1,NPROMA)==0) THEN
            IOFF1=0
            IOFF3=IOFF3 + NPROMA*(NFLEVG*NVA3D+NVA2D)
          ENDIF

        ENDDO
      ENDDO
    ENDDO
  ELSE
    YSCALP%INITCV=SPJB
  ENDIF
ENDIF

IF (LMODERR) CALL SUSCALMERR(YSCALP)
IF (LTOVSCV)    YSCALP%TOVSCV(:)=1.0_JPRB
IF (LELAM)      YSCALP%LAMCV (:)=1.0_JPRB
IF (NVAPARAM>0) YSCALP%PARAMS(:)=1.0_JPRB
IF (LTSCV)      YSCALP%TSCV(:)=1.0_JPRB

!     Overwrite SPA3-SPA2 and SPA1 to define the inner product for the Jc
!     cost function based on the digital filter.

IF (LJCDFI) THEN
  CALL SUPREPJCDFI(NULOUT)
ENDIF
IF (LAVARC) THEN
  CALL SUPAVARC(NULOUT)
ENDIF

!     2.1   For nconf=801, scalp multiplied by 2 to get the gradient equal to
!           the final difference field at nstep=nstop
!           J=SCALP*(Xnstop - Xref)**2 ===> GradJ = Xnstop - Xref

IF (NCONF == 801) THEN
  YSCALP%data=2.0_JPRB*YSCALP%data
ENDIF

!*    2.2   Check positivness.

IF (MINVAL(YSCALP%data)<0.0_JPRB) CALL ABOR1('SUSCAL:SCALP NEGATIVE')

YSCALPSQRT%data = SQRT(YSCALP%data)
CALL INVERSE(YSCALP, YRSCALP)
CALL INVERSE(YSCALPSQRT, YRSCALPSQRT)

!     2.4   Write the weight SCALP  

IF(NCONF == 601) THEN
  IF(LSCALC) THEN
    IF (LECMWF) THEN

! grib format

      IOMASTER=1
      CALL SETUP_IOSTREAM(YL_IOSTR_SCALW,'CIO','scalw',CDMODE='w',KIOMASTER=IOMASTER)


!     Set some local sectors: set the singular vector number NSEC1(42),
!     and the ritz value NSEC1(54,55) to 0

      NRITZNUMB=0
      NRITZGBH1=0
      NRITZGBH2=0

!     Write using wrtllcz subroutine
      CALL WRTLLCZ(YL_IOSTR_SCALW,YSCALP)

      CALL CLOSE_IOSTREAM(YL_IOSTR_SCALW)
    ELSE

! FA format

      WRITE(NULOUT,'('' >> Sub SUSCAL: ecriture fic FA'')')
      DO JMLOC=1,NUMP
        IM=MYMS(JMLOC)
        ZMFACT=1.0_JPRB+REAL(MIN(1,IM),JPRB)
        DO JIR=0,MIN(1,IM)
          DO JN=IM,NSMAX
            INM=NASM0(IM)+(JN-IM)*2+JIR
            DO JLEV=1,NFLEVL
              ILEV=MYLEVS(JLEV)
              SPJB%VOR(JLEV,INM)=SPJB%VOR(JLEV,INM)&
               & *RLAPDI(JN)*RLAPDI(JN)*RLAPDI(JN)  
              SPJB%DIV(JLEV,INM)=SPJB%DIV(JLEV,INM)&
               & *RLAPDI(JN)*RLAPDI(JN)*RLAPDI(JN)  
            ENDDO
          ENDDO
        ENDDO
      ENDDO
      CALL ALLOCATE_CTLVEC(YL_ZSCAL)
      CALL CAININ(YL_ZSCAL)
      CALL WRTSV(YL_ZSCAL,0)
      CALL DEALLOCATE_CTLVEC(YL_ZSCAL)
    ENDIF
  ENDIF
ENDIF
!      -----------------------------------------------------------
9910 FORMAT(' >> Subroutine SUSCAL <<')
9915 FORMAT(' - write SCALP in unit IESCA= ',I3)
!      -----------------------------------------------------------
IF (LHOOK) CALL DR_HOOK('SUSCAL',1,ZHOOK_HANDLE)
END SUBROUTINE SUSCAL
