SUBROUTINE SEKF_BACKGERR(KL,KBLOCK,KVAR,PVARB,PVARG,PVARBT,PVARGT,PBERR,PCANER)

!**** *SEKF_BACKGERR*  - Compute state transition matrix M and
!                        propagate background error B

!     Input parameters.
!     -----------------

!     KL         :  Grid point index within NPROMA chunk
!     KBLOCK     :  NPROMA chunk index
!     KVAR       :  Number of control variables
!     PVARB      :  fg soil moisture at t = 0
!     PVARG      :  perturbed soil moisture at t = 0
!     PVARBT     :  fg soil moisture at t = end
!     PVARGT     :  perturbed soil moisture at t = end
!     PBERR      :  model error Q

!     Output parameters.
!     ------------------

!     PCANER     :  background error at t = 0 (in) t = end (out)

!     Purpose.
!     --------
!     (1) Compute state transition matrix M
!     (2) Propagate background error B

!**   Interface.
!     ----------
!        *CALL* *SEKF_BACKGERR(...)

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

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

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

!     Externals.
!     ----------

!     Reference.
!     ----------
!        ECMWF Research Department documentation of the IFS

!     Author.
!     -------
!        M. Drusch  *ECMWF*

!     Modifications.
!     --------------
!        2009-02-10 P. de Rosnay ECMWF coding standard

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

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

USE YOMSEKF   ,ONLY : NREF_GP, NREF_BLOCK

IMPLICIT NONE

INTEGER(KIND=JPIM), INTENT(IN) ::  KL,KBLOCK,KVAR

REAL(KIND=JPRB)     ::  ZHOOK_HANDLE

REAL(KIND=JPRB), INTENT(IN)    ::  PVARB(KVAR)
REAL(KIND=JPRB), INTENT(IN)    ::  PVARG(KVAR)
REAL(KIND=JPRB), INTENT(IN)    ::  PBERR(KVAR)
REAL(KIND=JPRB), INTENT(IN)    ::  PVARBT(KVAR)
REAL(KIND=JPRB), INTENT(IN)    ::  PVARGT(KVAR,KVAR)
REAL(KIND=JPRB), INTENT(INOUT) ::  PCANER(KVAR,KVAR)

INTEGER(KIND=JPIM)  ::  J1, J2, J3
REAL(KIND=JPRB)     ::  ZDIFT, ZDIF0, ZEPS
REAL(KIND=JPRB)     ::  ZMMAT(KVAR,KVAR)
REAL(KIND=JPRB)     ::  ZQMAT(KVAR,KVAR)
REAL(KIND=JPRB)     ::  ZIMAT(KVAR,KVAR)
REAL(KIND=JPRB)     ::  ZCANER(KVAR,KVAR)

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

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

ZEPS=100._JPRB*tiny(1._JPRB)

!*    1.0 Set up state transition matrix M
!     ------------------------------------

DO J1 = 1, KVAR
  ZDIFT = 0.0_JPRB
  ZDIF0 = PVARG(J1)-PVARB(J1)
  DO J2 = 1, KVAR 
    ZDIFT = PVARGT(J1,J2)-PVARBT(J2)
    IF (ABS(ZDIF0) > ZEPS) THEN
      ZMMAT(J1,J2) = ZDIFT / ZDIF0
    ELSE
      ZMMAT(J1,J2) = 0.0_JPRB
    ENDIF
  ENDDO
ENDDO

IF (KL==NREF_GP .AND. KBLOCK==NREF_BLOCK) THEN
  WRITE(NULOUT,*) 'State transition matrix M:'
  WRITE(NULOUT,*) 'Dimension: KVAR * KVAR'
  DO J1 = 1, KVAR
   WRITE(NULOUT,'(3(1x,f12.8))') (ZMMAT(J1,J2),J2=1,KVAR)
  ENDDO
ENDIF

!*    2.0 Set up model (diagonal) error matrix Q
!     ------------------------------------------

ZQMAT(:,:) = 0.0_JPRB
DO J1 = 1, KVAR
  ZQMAT(J1,J1) = PBERR(J1)**2.
ENDDO

!*    3.0 Propagate background error B following:
!*    B = M A Mt + Q
!     -------------------------------------------

!*    3.1 M * A
!     ---------

ZIMAT(:,:) = 0.0_JPRB
DO J1 = 1, KVAR
  DO J2 = 1, KVAR
    DO J3 = 1, KVAR
      ZIMAT(J1,J2) = ZIMAT(J1,J2) + ZMMAT(J1,J3) * PCANER(J3,J2)
    ENDDO
  ENDDO
ENDDO

!*    3.2 (M * A) * Mt
!     ----------------

ZCANER(:,:) = 0.0_JPRB
DO J1 = 1, KVAR
  DO J2 = 1, KVAR
    DO J3 = 1, KVAR
      ZCANER(J1,J2) = ZCANER(J1,J2) + ZIMAT(J1,J3) * ZMMAT(J2,J3)
    ENDDO
  ENDDO
ENDDO

!*    3.3 (M * A * Mt) + Q
!     --------------------

DO J1 = 1, KVAR
  DO J2 = 1, KVAR
    ZCANER(J1,J2) = ZCANER(J1,J2) + ZQMAT(J1,J2)
  ENDDO
ENDDO

!*    3.4 Update output variable
!     --------------------------

PCANER(:,:) = ZCANER(:,:)

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

IF (LHOOK) CALL DR_HOOK('SEKF_BACKGERR',1,ZHOOK_HANDLE)

END SUBROUTINE SEKF_BACKGERR
