SUBROUTINE SUMODERR

!     Purpose.
!     --------
!       Initialise control of model error term in 4D-Var.

!     Author.
!     -------
!       Yannick Tremolet

!     Modifications.
!     --------------
!       Original : 03-01-17
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Hamrud      01-Dec-2003 CY28R1 Cleaning
!        Y.Tremolet    18-Mar-2004 Complete rewrite
!        Y.Tremolet    26-Jul-2004 Rewrite again
! ---------------------------------------------------------------------

USE PARKIND1,ONLY: JPRB, JPIM
USE YOMHOOK, ONLY: LHOOK, DR_HOOK
USE YOMCT0 , ONLY: LIFSMIN, LIFSTRAJ, NSTART, NSTOP
USE YOMDYN , ONLY: TSTEP
USE YOMLUN , ONLY: NULOUT
USE YOMGRB , ONLY: NGRBVO, NGRBD, NGRBU, NGRBV, NGRBT, NGRBQ, NGRBO3, &
                 & NGRBLNSP, NGRBSP2, NGRBSP3
USE YOMCVA , ONLY: NVA3D, NVA2D, NGRBVAR
USE YOMVAR , ONLY: LMODERR, NUPTRA, LINITCV
USE YOMRIP , ONLY: NSSSSS
USE YOM_YGFL,ONLY: YGFLC, YGFL
USE YOMGMV , ONLY: YT0
USE GOMS_MIX   , ONLY: YGOMV, MGOMGFL, NGOMGFL
USE YOMDIM , ONLY: NFLEVG
USE YOMCST , ONLY: RPI
USE YOMMODEL_ERROR, ONLY: NSERR, NVE3D, NVE2D, NVE3SP, NVE2SP, NVE3GP, NVE2GP, &
                     & NGRBMERRCTL, NGRBMERRSP, NGRBMERRGP, &
                     & SPMODERR, GPMODERR, &
                     & LFGMODERR, SPFGMODERR, GPFGMODERR, &
                     & NTYPE_MODERR, NCOMP_MODERR, NSTEP_MODERR, NDIM_MODERR, &
                     & WEAK4D_INTERV, TSTEP_ERR, LSCALERR, &
                     & MERRGFL, MERRGMV, MERRGMVS, MERROBS, MERRSP2, MERRSP3, &
                     & NORDER_MODERR, MSTEPERR, FSTEPERR, &
                     & SPGPMODERR, SPCTLMODERR, NPRTMODERR, &
                     & SPMODERR_HYB, GPMODERR_HYB, LOVERLAPPING4D, &
                     & ALPHAQ_Q,ALPHAQ_O, &
                     & L_WARM_START_MODERR, NPERIOD_4DVAR
USE GRIDPOINT_FIELDS_MIX
USE SPECTRAL_FIELDS_MOD
USE INDEXFIND_MOD, ONLY: INDXFIND

IMPLICIT NONE
INTEGER(KIND=JPIM) :: ii,jj,jc,istp4dv,istperr,jf,jorder,ioff
INTEGER(KIND=JPIM) :: IOBU, IOBV, IOBT, IOBGFL, IOBSP
REAL(KIND=JPRB) :: zjj,ztime,zstep,ztau
CHARACTER(LEN=14) :: clfile
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "rdmoderr.intfb.h"
#include "abor1.intfb.h"

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

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

IF (LMODERR) THEN

  IF (NTYPE_MODERR==2) THEN
    NVE3SP=3
    NVE2SP=1
    NVE3GP=0
    NVE2GP=0
    IF (ALPHAQ_Q>0.0_JPRB) NVE3GP=NVE3GP+1
    IF (ALPHAQ_O>0.0_JPRB) NVE3GP=NVE3GP+1
    NVE3D=NVE3SP+NVE3GP
    NVE2D=NVE2SP+NVE2GP

    ALLOCATE(NGRBMERRCTL(NVE3D+NVE2D))
    NGRBMERRCTL(1)=NGRBVO
    NGRBMERRCTL(2)=NGRBD
    NGRBMERRCTL(3)=NGRBT
    ii=3
    IF (ALPHAQ_Q>0.0_JPRB) THEN
      ii=ii+1
      NGRBMERRCTL(ii)=NGRBQ
    ENDIF
    IF (ALPHAQ_O>0.0_JPRB) THEN
      ii=ii+1
      NGRBMERRCTL(ii)=NGRBO3
    ENDIF
    ii=ii+1
    NGRBMERRCTL(ii)=NGRBLNSP
  ELSE
    IF (NTYPE_MODERR==3) THEN
      NVE3SP=0
      NVE2SP=0
    ELSE
      NVE3SP=3
      NVE2SP=1
    ENDIF
    NVE2D=NVA2D
    NVE3D=NVA3D
    NVE2GP=NVE2D-NVE2SP
    NVE3GP=NVE3D-NVE3SP
    ALLOCATE(NGRBMERRCTL(NVE3D+NVE2D))
    NGRBMERRCTL(:)=NGRBVAR(:)
  ENDIF

  IF (NPRTMODERR>=1) write(nulout,*)'SUMODERR: NGRBMERRCTL=',NGRBMERRCTL

! We assume here that the spectral variables always come first.
! This is not really safe but it works for now...
  ALLOCATE(NGRBMERRSP(NVE3SP+NVE2SP))
  NGRBMERRSP(1:NVE3SP) = NGRBMERRCTL(1:NVE3SP)
  NGRBMERRSP(NVE3SP+1:NVE3SP+NVE2SP) = NGRBMERRCTL(NVE3D+1:NVE3D+NVE2SP)
  IF (NPRTMODERR>=1) write(nulout,*)'SUMODERR: NGRBMERRSP=',NGRBMERRSP

  ALLOCATE(NGRBMERRGP(NVE3GP+NVE2GP))
  NGRBMERRGP(1:NVE3GP) = NGRBMERRCTL(NVE3SP+1:NVE3SP+NVE3GP)
  NGRBMERRGP(NVE3GP+1:NVE3GP+NVE2GP) = &
                 & NGRBMERRCTL(NVE3D+NVE2SP+1:NVE3D+NVE2SP+NVE2GP)
  
! Allocate spectral work array for grid point transform
!  CALL ALLOCATE_SPEC(SPGPMODERR,NSERR,0,NVE3GP,NVE2GP,0,NGRBMERRGP,KPARAMID=NGRBMERRGP(:)+200000)
  CALL ALLOCATE_SPEC(SPGPMODERR,NSERR,0,NVE3GP,NVE2GP,0,NGRBMERRGP)

  WHERE (NGRBMERRGP(:)==NGRBVO) NGRBMERRGP(:)=NGRBU
  WHERE (NGRBMERRGP(:)==NGRBD ) NGRBMERRGP(:)=NGRBV
  IF (NPRTMODERR>=1) write(nulout,*)'SUMODERR: NGRBMERRGP=',NGRBMERRGP

  istp4dv=NSTOP-NSTART
  IF (istp4dv<=1) CALL ABOR1('SUMODERR: Cannot do model error in 3D-Var !!!')
  LSCALERR=.false.

  ALLOCATE(MSTEPERR(NSTART:NSTOP))
  MSTEPERR(:)=-999

  SELECT CASE (NTYPE_MODERR)

! Setup "full state" model error
! ------------------------------
  CASE(1,4,5)
    IF (LIFSMIN.OR.LIFSTRAJ) THEN
      zstep=WEAK4D_INTERV*3600.0_JPRB
      IF (zstep<TSTEP) CALL ABOR1('SUMODERR: WEAK4D_INTERV too short')
      istperr=NINT(zstep/TSTEP)
      IF (MOD(istp4dv,istperr)/=0) CALL ABOR1('SUMODERR: Error WEAK4D_INTERV')
      IF (LINITCV) THEN
        NSTEP_MODERR=istp4dv/istperr-1  ! first one is initial condition
        ii=NSTART+istperr
      ELSE
        NSTEP_MODERR=istp4dv/istperr    ! first one is "4D model state"
        ii=NSTART
      ENDIF
      IF (NSTEP_MODERR<1) CALL ABOR1('SUMODERR: WEAK4D_INTERV too long')
      DO jc=1,NSTEP_MODERR
        MSTEPERR(ii)=jc
        ii=ii+istperr
      ENDDO
      IF (NTYPE_MODERR==4.AND.LIFSTRAJ.AND.NUPTRA==0) MSTEPERR(:)=-999

      NCOMP_MODERR=1
      NDIM_MODERR=NSTEP_MODERR

!     Print values
      IF (NPRTMODERR>=1) THEN
        zstep=TSTEP/3600.0_JPRB
        ztime=REAL(NSSSSS,JPRB)/3600.0_JPRB
        DO jj=NSTART,NSTOP
          zjj=MOD(ztime,24.0_JPRB)
          WRITE(NULOUT,'(A,2X,I3,2X,F6.2,A,2X,I4)') &
           & 'SUMODERR: Step, Time, MSTEPERR=',jj,zjj,'h',MSTEPERR(jj)
          ztime=ztime+zstep
        ENDDO
      ENDIF
    ELSE
      NCOMP_MODERR=1
      NSTEP_MODERR=1
      NDIM_MODERR=1
      MSTEPERR(NSTART)=1
    ENDIF

    ALLOCATE(LOVERLAPPING4D(NSTEP_MODERR))
    LOVERLAPPING4D(:)=.false.

    IF (NPRTMODERR>=1) WRITE(NULOUT,*)'SUMODERR: LSCALERR=',LSCALERR
    IF (NTYPE_MODERR == 5) THEN
      IF (NUPTRA == 0 .AND. L_WARM_START_MODERR) THEN
        zstep=WEAK4D_INTERV*3600.0_JPRB
        istperr=NINT(zstep/TSTEP)
        IF (LINITCV) THEN
          ! first one is initial condition
          ii=NSTART+istperr
        ELSE
          ! first one is "4D model state"
          ii=NSTART
        ENDIF
        DO jj=1,NSTEP_MODERR
          IF (ii < NSTOP-3600*NPERIOD_4DVAR/NINT(TSTEP)) LOVERLAPPING4D(jj)=.true.
          ii=ii+istperr
        ENDDO
      ENDIF
    ENDIF

! Setup model error forcing
! -------------------------
  CASE(2)
    IF (WEAK4D_INTERV>0.0_JPRB) THEN
      zstep=WEAK4D_INTERV*3600.0_JPRB
      istperr=NINT(zstep/TSTEP)
      IF (zstep<TSTEP    ) CALL ABOR1('SUMODERR: WEAK4D_INTERV too short')
      IF (istperr>istp4dv) CALL ABOR1('SUMODERR: WEAK4D_INTERV too long')
      IF (MOD(istp4dv,istperr)/=0) CALL ABOR1('SUMODERR: Error WEAK4D_INTERV')
      NSTEP_MODERR=istp4dv/istperr
    ELSE
      istperr=istp4dv
      NSTEP_MODERR=1
    ENDIF

    ii=NSTART
    DO jc=1,NSTEP_MODERR
      DO jj=1,istperr
        MSTEPERR(ii)=jc
        ii=ii+1
      ENDDO
    ENDDO
    IF (ii/=NSTOP) CALL ABOR1('SUMODERR: Error NSTEP_MODERR*istperr')

!   Apply model error only when needed
    IF (TSTEP_ERR>0.0_JPRB) THEN
      IF (MOD(TSTEP_ERR,TSTEP)/=0.0_JPRB) &
        & CALL ABOR1('SUMODERR: TSTEP_ERR not a multiple of TSTEP')
      istperr=NINT(TSTEP_ERR/TSTEP)
      DO jj=NSTART,NSTOP-1
        ii=jj-NSTART+1
        IF (MOD(ii,istperr)/=0) THEN
          MSTEPERR(jj)=-999
        ENDIF
      ENDDO
      MSTEPERR(NSTOP)=-999
    ENDIF

!   Periodic forcing
    NCOMP_MODERR=1+2*NORDER_MODERR
    NDIM_MODERR=NSTEP_MODERR*NCOMP_MODERR

    IF (NORDER_MODERR>0) THEN
      ALLOCATE(FSTEPERR(NSTART:NSTOP,2*NORDER_MODERR))
      FSTEPERR(:,:)=0.0_JPRB
      DO jorder=1,NORDER_MODERR
        ioff=2*(jorder-1)
        ztau=24.0_JPRB/REAL(jorder,JPRB)
        zstep=TSTEP/3600.0_JPRB
        ztime=REAL(NSSSSS,JPRB)/3600.0_JPRB
        DO jj=NSTART,NSTOP
          IF (MSTEPERR(jj)>0) THEN
            zjj=2.0_JPRB*RPI*ztime/ztau
            FSTEPERR(jj,ioff+1)=COS(zjj)
            FSTEPERR(jj,ioff+2)=SIN(zjj)
          ELSE
            FSTEPERR(jj,ioff+1)=0.0_JPRB
            FSTEPERR(jj,ioff+2)=0.0_JPRB
          ENDIF
          ztime=ztime+zstep
        ENDDO
      ENDDO
    ENDIF

!   Print values
    IF (NPRTMODERR>=1) THEN
      zstep=TSTEP/3600.0_JPRB
      ztime=REAL(NSSSSS,JPRB)/3600.0_JPRB
      DO jj=NSTART,NSTOP
        zjj=MOD(ztime,24.0_JPRB)
        IF (NORDER_MODERR>0) THEN
          WRITE(NULOUT,'(A,2X,I3,2X,F6.2,A,2X,I4,2(2X,F6.3))') &
           & 'SUMODERR: Step, Time, MSTEPERR=',jj,zjj,'h',MSTEPERR(jj), &
           & (FSTEPERR(jj,jorder),jorder=1,2*NORDER_MODERR)
        ELSE
          WRITE(NULOUT,'(A,2X,I3,2X,F6.2,A,2X,I4)') &
           & 'SUMODERR: Step, Time, MSTEPERR=',jj,zjj,'h',MSTEPERR(jj)
        ENDIF
        ztime=ztime+zstep
      ENDDO
    ENDIF

    IF (NINT(TSTEP_ERR)/=3600) LSCALERR=.true.
    IF (NPRTMODERR>=1) WRITE(NULOUT,*)'SUMODERR: LSCALERR=',LSCALERR

! Setup model bias
! ----------------
  CASE(3)
    NCOMP_MODERR=1
    NSTEP_MODERR=1
    NDIM_MODERR=1

  END SELECT

  WRITE(NULOUT,*)'SUMODERR: NTYPE_MODERR=',NTYPE_MODERR
  WRITE(NULOUT,*)'SUMODERR: NCOMP_MODERR=',NCOMP_MODERR
  WRITE(NULOUT,*)'SUMODERR: NSTEP_MODERR=',NSTEP_MODERR
  WRITE(NULOUT,*)'SUMODERR: NDIM_MODERR =',NDIM_MODERR
  WRITE(NULOUT,*)'SUMODERR: WEAK4D_INTERV=',WEAK4D_INTERV

! Allocate model error arrays
! ---------------------------
!  CALL ALLOCATE_SPEC(SPCTLMODERR,NSERR,0,NVE3D,NVE2D,0,NGRBMERRCTL,KPARAMID=NGRBMERRCTL(:)+200000)
  CALL ALLOCATE_SPEC(SPCTLMODERR,NSERR,0,NVE3D,NVE2D,0,NGRBMERRCTL)
  ALLOCATE(SPMODERR(NDIM_MODERR))
  ALLOCATE(GPMODERR(NDIM_MODERR))
  DO jj=1,NDIM_MODERR
!    CALL ALLOCATE_SPEC(SPMODERR(jj),NSERR,0,NVE3SP,NVE2SP,0,NGRBMERRSP,KPARAMID=NGRBMERRSP(:)+200000)
    CALL ALLOCATE_SPEC(SPMODERR(jj),NSERR,0,NVE3SP,NVE2SP,0,NGRBMERRSP)
    CALL ALLOCATE_GRID(GPMODERR(jj),NVE3GP,NVE2GP,NGRBMERRGP)
  ENDDO
  WRITE(NULOUT,*)'SUMODERR: SPMODERR, GPMODERR  allocated'
  IF (NTYPE_MODERR == 5) THEN
    ALLOCATE(SPMODERR_HYB(NDIM_MODERR))
    ALLOCATE(GPMODERR_HYB(NDIM_MODERR))
    DO jj=1,NDIM_MODERR
!      CALL ALLOCATE_SPEC(SPMODERR_HYB(jj),NSERR,0,NVE3SP,NVE2SP,0,NGRBMERRSP,KPARAMID=NGRBMERRSP(:)+200000)
      CALL ALLOCATE_SPEC(SPMODERR_HYB(jj),NSERR,0,NVE3SP,NVE2SP,0,NGRBMERRSP)
      CALL ALLOCATE_GRID(GPMODERR_HYB(jj),NVE3GP,NVE2GP,NGRBMERRGP)
    ENDDO
    WRITE(NULOUT,*)'SUMODERR: SPMODERR_HYB, GPMODERR_HYB  allocated'
  ENDIF
  IF (NPRTMODERR>=1) THEN
    WRITE(NULOUT,*)'SUMODERR: SPMODERR 3D,2D,2G=', &
                 & SPMODERR(1)%NS3D,SPMODERR(1)%NS2D,SPMODERR(1)%NS2G
    WRITE(NULOUT,*)'SUMODERR: GPMODERR 3D,2D=', &
                 & GPMODERR(1)%NG3D,GPMODERR(1)%NG2D
  ENDIF

! Setup first guess for minimisation
  IF (LIFSMIN.AND.LFGMODERR) THEN
    ALLOCATE(SPFGMODERR(NDIM_MODERR))
    ALLOCATE(GPFGMODERR(NDIM_MODERR))
    DO jj=1,NDIM_MODERR
      CALL ALLOCATE_SPEC(SPFGMODERR(jj),NSERR,0,NVE3SP,NVE2SP,0,NGRBMERRSP)
      CALL ALLOCATE_GRID(GPFGMODERR(jj),NVE3GP,NVE2GP,NGRBMERRGP)
    ENDDO
    WRITE(NULOUT,*)'SUMODERR: SPFGMODERR, GPFGMODERR allocated'
    DO jj=1,NDIM_MODERR
      IF (NTYPE_MODERR == 5) THEN
        clfile(1:14)='spmoderrjqXXYY'
      ELSE
        clfile(1:14)='spmoderrfgXXYY'
      ENDIF
      WRITE(clfile(11:12),'(I2.2)')NUPTRA
      WRITE(clfile(13:14),'(I2.2)')jj
      WRITE(NULOUT,*)'SUMODERR: Reading first guess from ',clfile
      CALL RDMODERR(clfile,SPFGMODERR(jj),GPFGMODERR(jj))
    ENDDO
  ENDIF

! Pointers into SPA/GFL/GMV arrays
! --------------------------------
  ALLOCATE(MERRSP2(NVE2SP))
  ALLOCATE(MERRSP3(NVE3SP))
  DO jf=1,NVE2SP
    ii=INDXFIND(NGRBSP2,SPMODERR(1)%NGRIB2(jf))
    MERRSP2(jf)=ii
  ENDDO
  DO jf=1,NVE3SP
    ii=INDXFIND(NGRBSP3,SPMODERR(1)%NGRIB3(jf))
    MERRSP3(jf)=ii
  ENDDO
  IF (NPRTMODERR>=1) write(nulout,*)'SUMODERR: MERRSP2=',MERRSP2
  IF (NPRTMODERR>=1) write(nulout,*)'SUMODERR: MERRSP3=',MERRSP3

  SELECT CASE (NTYPE_MODERR)

  CASE(1,2,4,5)
    ALLOCATE(MERRGFL(NVE3GP))
    ALLOCATE(MERRGMV(NVE3GP))
    MERRGFL(:)=-999
    MERRGMV(:)=-999
    DO jf=1,NVE3GP
      IF (GPMODERR(1)%NGRIB3(jf)==NGRBU) THEN
        MERRGMV(jf)=YT0%MU
      ELSEIF (GPMODERR(1)%NGRIB3(jf)==NGRBV) THEN
        MERRGMV(jf)=YT0%MV
      ELSEIF (GPMODERR(1)%NGRIB3(jf)==NGRBT) THEN
        MERRGMV(jf)=YT0%MT
      ELSE
        ii=0
        DO WHILE (ii<YGFL%NUMFLDS .AND. MERRGFL(jf)<0)
          ii=ii+1
          IF (GPMODERR(1)%NGRIB3(jf)==YGFLC(ii)%IGRBCODE) &
            & MERRGFL(jf)=YGFLC(ii)%MP
        ENDDO
      ENDIF
    ENDDO
    IF (NPRTMODERR>=1) write(nulout,*)'SUMODERR: MERRGMV=',MERRGMV
    IF (NPRTMODERR>=1) write(nulout,*)'SUMODERR: MERRGFL=',MERRGFL
    DO jf=1,NVE3GP
      IF (MERRGFL(jf)*MERRGMV(jf)>=0) CALL ABOR1('SUMODERR: Error MERRGFL/GMV')
    ENDDO

    ALLOCATE(MERRGMVS(NVE2GP))
    MERRGMVS(:)=-999
    DO jf=1,NVE2GP
      IF (GPMODERR(1)%NGRIB2(jf)==NGRBLNSP) MERRGMVS(jf)=YT0%MSP
    ENDDO
    IF (NPRTMODERR>=1) write(nulout,*)'SUMODERR: MERRGMVS=',MERRGMVS
    IF (ANY(MERRGMVS(:)==-999)) CALL ABOR1('SUMODERR: Error MERRGMVS')

  CASE(3)
!   The following indices are hard-coded in COBS* subroutines.
!   Should be made more flexible in the future...
    IOBU  = 1
    IOBV  = IOBU   + NFLEVG
    IOBT  = IOBV   + NFLEVG
    IOBGFL= IOBT   + NFLEVG
    IOBSP = IOBGFL + NFLEVG*NGOMGFL

    ALLOCATE(MERROBS(NVE3GP+NVE2GP))
    MERROBS(:)=-999
    DO jf=1,NVE3GP
      IF     (GPMODERR(1)%NGRIB3(jf)==NGRBU) THEN
        MERROBS(jf)=IOBU
      ELSEIF (GPMODERR(1)%NGRIB3(jf)==NGRBV) THEN
        MERROBS(jf)=IOBV
      ELSEIF (GPMODERR(1)%NGRIB3(jf)==NGRBT) THEN
        MERROBS(jf)=IOBT
      ELSEIF (GPMODERR(1)%NGRIB3(jf)==NGRBQ) THEN
        MERROBS(jf)=IOBGFL+ (MGOMGFL(YGOMV%MQ) -1)*NFLEVG
      ELSEIF (GPMODERR(1)%NGRIB3(jf)==NGRBO3) THEN
        MERROBS(jf)=IOBGFL+ (MGOMGFL(YGOMV%MO3)-1)*NFLEVG
      ENDIF
    ENDDO
    DO jf=1,NVE2GP
      IF (GPMODERR(1)%NGRIB2(jf)==NGRBLNSP) MERROBS(NVE3GP+jf)=IOBSP
    ENDDO
    IF (NPRTMODERR>=1) write(nulout,*)'SUMODERR: MERROBS=',MERROBS
    IF (ANY(MERROBS(:)==-999)) CALL ABOR1('SUMODERR: Error MERROBS')

  END SELECT
ENDIF

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