SUBROUTINE SUJBSTD(CDJBTYPE,KPRT,PCOVTPS,PCOVP,PCOVD,PCOVQ,&
 & PCOVO3,KLEV,KNUMB)  

!**** *SUJBSTD* - Prepare gdpt standard errors for background constraint Jb

!     Purpose. Prepare the error covariance model.
!     --------

!     Interface. CALL SUJBSTD
!     ----------

!     Explicit arguments : In : CDJBTYPE = config string for Jb
!     -------------------- In : KPRT = print level
!                          In : PCOVx   = covariances for parameter x
!                               (only used by CDJBTYPE=NONSEP93)

!     Implicit arguments : common YOMJG and related files.
!     --------------------

!     Method.
!     -------
!         Compute total variance vertical profiles (sometimes using
!          an f-plane balance assumption).
!         Empirically reduce NMC-method variances to agree with 6-h
!          forecast std devs.
!         Compute length-scales as a parameter in the correlation model:
!          f(r)=A.exp(-r^2/(2a^2)) --> a=\sqrt{ \frac{-2 f(0)}{f''(0)} }
!          There is a 2 because we are in 2-D.

!     Externals: see below.
!     ----------

!     Author : Francois Bouttier *ECMWF*
!     --------

!     Modifications :
!     ---------------
!     96-02-07 F.Bouttier : write original
!     96-07-18 F.Bouttier : Implement STABAL96 tricks
!     96-08-01 M.Fisher   : calculate background errors for vorticity
!     96-11-06 M.Fisher   : Added variance profiles for total Tps and z
!     97-04-24 F.Bouttier : Support changing NFLEVG
!     97-10-27 F.Bouttier : Bugfix rlapin bounds and adjust mass fudge factor
!     97-09-25 E.Holm     : Included ozone
!     00-09-01 D.Dent     : MPE to MPL conversion
!     00-10-26 M.Fisher   : FCEMN is now a structure. SUECGES is now
!                           called directly from SU0YOMB.
!     01-08-07 R. El Khatib : Pruning options 
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMDIM   , ONLY : NFLEVG   ,NSMAX 
USE YOMCT0   , ONLY : NPROC    ,NCONF    ,LBACKG
USE YOMJG    , ONLY : REDNMC   ,FCEMN3D, FCEMN2D, FCEMN_DERIVED, &
                    & SPJB_VARS_INFO, N_SPJB_VARS
USE YOMLAP   , ONLY : RLAPIN
USE YOMGRB   , ONLY : NGRBVO, NGRBD, NGRBT, NGRBQ, NGRBO3, NGRBLNSP
USE YOMGEM   , ONLY : VP00     ,VAH      ,VBH
USE YOMLUN   , ONLY : NULOUT
USE MPL_MODULE

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV 
INTEGER(KIND=JPIM),INTENT(IN)    :: KNUMB 
CHARACTER(LEN=10) ,INTENT(IN)    :: CDJBTYPE 
INTEGER(KIND=JPIM),INTENT(IN)    :: KPRT 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCOVTPS(KLEV+1,KLEV+1,0:KNUMB-1) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCOVP(KLEV,KLEV,0:KNUMB-1) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCOVD(KLEV,KLEV,0:KNUMB-1) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCOVQ(KLEV,KLEV,0:KNUMB-1) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCOVO3(KLEV,KLEV,0:KNUMB-1) 
!        Arguments
REAL(KIND=JPRB) :: ZVARP(NFLEVG),ZVARD(NFLEVG),ZVARQ(NFLEVG),ZVARO3(NFLEVG),&
 & ZVART(NFLEVG),ZVARTU(NFLEVG),ZVARSP,ZVARSPU  
REAL(KIND=JPRB) :: ZVARVO(NFLEVG),ZVARU(NFLEVG)
REAL(KIND=JPRB) :: ZPRESF(NFLEVG+1),ZPRESH(0:NFLEVG+1)
REAL(KIND=JPRB) :: ZFUDGE, ZFCEMN_VO, ZFCEMN_D, ZFCEMN_TU, ZFCEMN_O3, ZFCEMN_Q
INTEGER(KIND=JPIM), PARAMETER :: JPKZ = KIND(ZFUDGE)

INTEGER(KIND=JPIM) :: IL, ILV950, J1, JJ, JLEV, IPTJBVO, IPTJBD, &
                    & IPTJBTU, IPTJBQ, IPTJBO3, IPTJBPSU, &
                    & JFIELD
LOGICAL :: LLO3JB
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"
#include "gppre.intfb.h"
#include "suecges.intfb.h"


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

!        0. Preliminary checks

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

LLO3JB=ANY(SPJB_VARS_INFO(:)%IGRIBCODE==NGRBO3)

WRITE(NULOUT,*) 'SUJBSTD: Jb std errors, config=',CDJBTYPE
IF ((CDJBTYPE=='STABAL96').OR.&
   & (CDJBTYPE=='TOTENRGY') ) THEN  
  IF((KLEV /= NFLEVG).OR.(KNUMB-1 /= NSMAX))&
   & CALL ABOR1('BAD INTERFACE TO SUJBCOR')  
ELSE
  CALL ABOR1('SUJBCOR: Unknown Jb std errors config')
ENDIF

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

!        2. Standard errors, STABAL96-style (John Derber's balance)

IF ((CDJBTYPE=='STABAL96').OR.(CDJBTYPE=='TOTENRGY')) THEN
  WRITE(NULOUT,*) ' Setup vertical profiles from covariances'

!         2.1 Total variances implied by the 24/48 NMC method

!        Note that total T,ps,P and D are NOT Jb variables.
!        However, total D can be safely identified with  D.
  DO J1=1,NFLEVG
    ZVARVO(J1) = SUM(PCOVP(J1,J1,:))
    ZVARD(J1)  = SUM(PCOVD(J1,J1,:))
    ZVARTU(J1) = SUM(PCOVTPS(J1,J1,:))
    ZVARQ(J1)  = SUM(PCOVQ(J1,J1,:))
  ENDDO
  IF(LLO3JB)THEN
    DO J1=1,NFLEVG
      ZVARO3(J1) = SUM(PCOVO3(J1,J1,:))
    ENDDO
  ENDIF
  ZVARSPU=SUM(PCOVTPS(NFLEVG+1,NFLEVG+1,:))

!         2.2 Estimate variances for missing fields

!        The following massaging of the sigma-b profiles has no impact
!       on the Jb term, but it will affect the threshold for screening
!       and VarQC in the next analysis cycle. Weaknesses in the currently
!       assumed sigma-b's are compensated by the tuning of rejection
!       thresholds.  In the longer term, genuine 6-h sigma-b profiles shall 
!       be read from separate files, produced with the help of 
!       Hollingsworth/Lonnberg diagnostics. In the meantime, do not change
!       these values without retuning the screening/QC thresholds
!       accordingly. /FB

  WRITE(NULOUT,*) ' Total (T,ps) profile is given by',' scaling (T,ps)u'
  ZVART(:)=ZVARTU(:)*4._JPRB
  ZVARSP=ZVARSPU*4._JPRB

  WRITE(NULOUT,*) ' Wind profile is given by ',&
   & ' inverse Laplacian of vorticity'  
!       The factor 0.5 is necessary in 2-D.
  DO J1=1,NFLEVG
    ZVARU(J1)  = SUM(-0.5_JPRB*RLAPIN(0:NSMAX)*PCOVP(J1,J1,0:NSMAX))
  ENDDO

  WRITE(NULOUT,*) ' Total mass profile is given by ',&
   & ' scaled streamfunction above 950hPa'  
!       Find lowest level above 950hPa in std atm (alt 630m)
  ZPRESH(NFLEVG)=VP00
  CALL GPPRE(1,1,1,NFLEVG,VAH,VBH,ZPRESH,ZPRESF)
  ILV950=-HUGE(ILV950)
  DO JLEV=1,NFLEVG
    IF(ZPRESF(JLEV)<95000._JPRB) ILV950=JLEV
  ENDDO
  WRITE(NULOUT,*) '   profile is extrapolated below level ',ILV950
  DO J1=1,NFLEVG
    IL=MIN(J1,ILV950)
!         Do not try to understand this formula
    ZFUDGE=(1.6_JPRB+REAL(IL,JPKZ)/REAL(NFLEVG,JPKZ)*(1.3_JPRB-1.6_JPRB))* &
     & 0.00005_JPRB  
    ZVARP(J1)  = SUM( (RLAPIN(0:NSMAX)**2)*PCOVP(IL,IL,0:NSMAX) )&
     & * (ZFUDGE**2)  
  ENDDO

!         2.3 Load vertical profile arrays:
!             REDNMC is an empirical reduction to get the NMC-method
!             variances to agree with typical 6-hour forecast errors.
!             The f-plane approximation is ok for z except near the ground.

  IPTJBVO  = HUGE(IPTJBVO)
  IPTJBD   = HUGE(IPTJBD)
  IPTJBTU  = HUGE(IPTJBTU)
  IPTJBQ   = HUGE(IPTJBQ)
  IPTJBO3  = HUGE(IPTJBO3)
  IPTJBPSU = HUGE(IPTJBPSU)
  DO JFIELD=1,N_SPJB_VARS
    IF (SPJB_VARS_INFO(JFIELD)%IGRIBCODE==NGRBVO) THEN
      IPTJBVO = SPJB_VARS_INFO(JFIELD)%IPTJB
    ELSEIF (SPJB_VARS_INFO(JFIELD)%IGRIBCODE==NGRBD) THEN
      IPTJBD  = SPJB_VARS_INFO(JFIELD)%IPTJB
    ELSEIF (SPJB_VARS_INFO(JFIELD)%IGRIBCODE==NGRBT) THEN
      IPTJBTU = SPJB_VARS_INFO(JFIELD)%IPTJB
    ELSEIF (SPJB_VARS_INFO(JFIELD)%IGRIBCODE==NGRBQ) THEN
      IPTJBQ  = SPJB_VARS_INFO(JFIELD)%IPTJB
    ELSEIF (SPJB_VARS_INFO(JFIELD)%IGRIBCODE==NGRBO3) THEN
      IPTJBO3 = SPJB_VARS_INFO(JFIELD)%IPTJB
    ELSEIF (SPJB_VARS_INFO(JFIELD)%IGRIBCODE==NGRBLNSP) THEN
      IPTJBPSU= SPJB_VARS_INFO(JFIELD)%IPTJB
    ELSE
      WRITE (NULOUT,*) 'DON''T KNOW WHAT TO DO WITH GRIB CODE ', &
                      & SPJB_VARS_INFO(JFIELD)%IGRIBCODE
    ENDIF
  ENDDO

  DO JJ=1,NFLEVG
    IF (IPTJBVO/=HUGE(IPTJBVO)) THEN
      FCEMN3D(JJ,IPTJBVO )=REDNMC*SQRT(ZVARVO(JJ))
    ENDIF
    IF (IPTJBD/=HUGE(IPTJBD)) THEN
      FCEMN3D(JJ,IPTJBD  )=REDNMC*SQRT(ZVARD(JJ))
    ENDIF
    FCEMN_DERIVED%U(JJ) =REDNMC*SQRT(ZVARU(JJ))
    FCEMN_DERIVED%Z(JJ) =REDNMC*SQRT(ZVARP(JJ))
    FCEMN_DERIVED%T(JJ) =REDNMC*SQRT(ZVART(JJ))
    IF (IPTJBTU/=HUGE(IPTJBTU)) THEN
      FCEMN3D(JJ,IPTJBTU )=REDNMC*SQRT(ZVARTU(JJ))
    ENDIF
    IF (IPTJBQ/=HUGE(IPTJBQ)) THEN
      FCEMN3D(JJ,IPTJBQ  )=       SQRT(ZVARQ(JJ))     ! No rescaling of Q
    ENDIF
    IF (IPTJBO3/=HUGE(IPTJBO3)) THEN
      FCEMN3D(JJ,IPTJBO3)=REDNMC*SQRT(ZVARO3(JJ))
    ENDIF
  ENDDO
  IF (IPTJBPSU/=HUGE(IPTJBPSU)) THEN
    FCEMN2D(IPTJBPSU)= REDNMC*SQRT(ZVARSPU)
  ENDIF
  FCEMN_DERIVED%PS = REDNMC*SQRT(ZVARSP)

  IF(KPRT>=1)THEN
    WRITE(NULOUT,*) 'Jb preliminary vertical stdev profiles:'
    WRITE(NULOUT,*) '(-999.0 indicates variable is not in Jb)'
    IF (IPTJBPSU/=HUGE(IPTJBPSU)) THEN
      WRITE(NULOUT,*) ' unbal ps : ',FCEMN2D(IPTJBPSU)*VP00
    ELSE
      WRITE(NULOUT,*) ' unbal ps : ',-999.0_JPRB
    ENDIF
    WRITE(NULOUT,*) ' total ps : ',FCEMN_DERIVED%PS *VP00
    WRITE(NULOUT,*) '       Vor      unbal Div  '//&
     & '    Wind        mass    '//&
     & '     T       unbal T    '//&
     & '     Q       unbal O3'  
    DO JJ=1,NFLEVG
      IF (IPTJBVO/=HUGE(IPTJBVO)) THEN
        ZFCEMN_VO = FCEMN3D(JJ,IPTJBVO)
      ELSE
        ZFCEMN_VO = -999.0_JPRB
      ENDIF
      IF (IPTJBD/=HUGE(IPTJBD)) THEN
        ZFCEMN_D = FCEMN3D(JJ,IPTJBD)
      ELSE
        ZFCEMN_D = -999.0_JPRB
      ENDIF
      IF (IPTJBTU/=HUGE(IPTJBTU)) THEN
        ZFCEMN_TU = FCEMN3D(JJ,IPTJBTU)
      ELSE
        ZFCEMN_TU = -999.0_JPRB
      ENDIF
      IF (IPTJBO3/=HUGE(IPTJBO3)) THEN
        ZFCEMN_O3 = FCEMN3D(JJ,IPTJBO3)
      ELSE
        ZFCEMN_O3 = -999.0_JPRB
      ENDIF
      WRITE(NULOUT,'(I3,8(1X,G11.4))') JJ,ZFCEMN_VO,&
       & ZFCEMN_D,FCEMN_DERIVED%U(JJ) ,FCEMN_DERIVED%Z(JJ),&
       & FCEMN_DERIVED%T(JJ),ZFCEMN_TU,ZFCEMN_Q,&
       & ZFCEMN_O3
    ENDDO
  ENDIF
ENDIF

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

!        9. Initialize gridpoint sigma-b's from external file

WRITE(NULOUT,*) '2.Read sigma-b fields from GRIB gdpt file'
CALL FLUSH(NULOUT)
IF (NPROC>1) THEN
  CALL GSTATS(721,0)
  CALL MPL_BARRIER(CDSTRING='SUJBSTD:')
  CALL GSTATS(721,1)
ENDIF
IF(NCONF==801.AND. .NOT.LBACKG) CALL SUECGES

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