MODULE varbc_airep
!-----------------------------------------------------------------------
!   VARBC_AIREP - Module for variational bias correction (temperature)

!   Purpose. 
!   --------
!   Data structures and controls for variational bias correction (AIREP data)

!   Author.
!   -------
!   Dick Dee (ECMWF)

!   Modifications.
!   --------------
!   Original    2008/10/01
!------------------------------------------------------------------------

USE parkind1  , ONLY : JPIM, JPRB
USE yomhook   , ONLY : LHOOK, DR_HOOK
USE yomlun    , ONLY : NULOUT, NULNAM
USE yomcosjo  , ONLY : JOT
USE varbc_pred, ONLY : NPREDCS_AIREP
USE yomdb

IMPLICIT NONE

SAVE

PRIVATE
PUBLIC lbc_airep
PUBLIC varbc_airep_config, varbc_airep_groups
PUBLIC varbc_airep_varbcix, varbc_airep_pred
PUBLIC varbc_airep_min, varbc_airep_groupdescr

INTERFACE varbc_airep_config
  MODULE PROCEDURE config
END INTERFACE varbc_airep_config

INTERFACE varbc_airep_groups
  MODULE PROCEDURE find_groups
END INTERFACE varbc_airep_groups

INTERFACE varbc_airep_groupdescr
  MODULE PROCEDURE groupdescr
END INTERFACE varbc_airep_groupdescr

INTERFACE varbc_airep_pred
  MODULE PROCEDURE get_predictors
END INTERFACE varbc_airep_pred

INTERFACE varbc_airep_varbcix
  MODULE PROCEDURE set_varbcix
END INTERFACE varbc_airep_varbcix

INTERFACE varbc_airep_min
  MODULE PROCEDURE get_min
END INTERFACE varbc_airep_min

CHARACTER(LEN=*), PARAMETER :: modname = 'VarBC_AIREP'

! Table for available satellite/sensor combinations 
! -------------------------------------------------
INTEGER(KIND=JPIM), PARAMETER :: len_statid = 8   ! length of station id string in ODB
TYPE type_sensors
  CHARACTER(LEN=len_statid) :: ccstatid 
  INTEGER(KIND=JPIM) :: nsensor 
END TYPE type_sensors

INTEGER(KIND=JPIM), PARAMETER :: jpmxns = 10000   ! max number of sat/sensor combinations
TYPE(type_sensors) :: YSENSORS(1:jpmxns)

INTEGER(KIND=JPIM), PARAMETER :: jpmxnp = SIZE(NPREDCS_AIREP) ! max number of parameters per group

! Table for settings by instrument
! --------------------------------
TYPE type_config
  CHARACTER(LEN=20)  :: name              ! instrument name
  INTEGER(KIND=JPIM) :: nsensor           ! sensor id
  INTEGER(KIND=JPIM) :: nparam            ! number of parameters
  INTEGER(KIND=JPIM) :: npredcs(jpmxnp)   ! list of predictors
  LOGICAL            :: llconst(jpmxnp)   ! flags for constant parameters
  REAL(KIND=JPRB)    :: zparams(jpmxnp)   ! a priori parameter values
  REAL(KIND=JPRB)    :: dfgdep            ! histogram range, for estimating the mode
  INTEGER(KIND=JPIM) :: ncstart           ! cold start option
  INTEGER(KIND=JPIM) :: nbgstdv           ! eqv #obs for background constraint
  LOGICAL            :: lreset            ! flag to reset parameters
  LOGICAL            :: llmode            ! flag for mode correction
END TYPE type_config

!-----------------------------------------------------------------------
! Namelist parameters
!-----------------------------------------------------------------------
TYPE(type_config)  :: yconfig(1:5)
LOGICAL            :: lbc_airep
LOGICAL            :: lbc_airct, lbc_codar, lbc_colba, lbc_amdar, lbc_acars
INTEGER(KIND=JPIM) :: nbg_airct, nbg_codar, nbg_colba, nbg_amdar, nbg_acars
LOGICAL            :: lconst             ! Keep all VarBC parameters fixed
LOGICAL            :: lmode              ! Correct pdf mode rather than mean

NAMELIST /NAMVARBC_AIREP/ yconfig, &
                      & lbc_airep, &
                      & lbc_airct, lbc_codar, lbc_colba, lbc_amdar, lbc_acars, &
                      & nbg_airct, nbg_codar, nbg_colba, nbg_amdar, nbg_acars, &
                      & lconst, lmode
!-----------------------------------------------------------------------

INTERFACE
#include "getdb.h"
#include "putdb.h"
END INTERFACE

#include "abor1.intfb.h"
#include "posnam.intfb.h"

! ========
CONTAINS
! ========

SUBROUTINE config

!-----------------------------------------------------------------------
!   config - Configure VarBC for AIREP data

!   Interface.
!   ----------
!   CALL config

!   Author.
!   -------
!   Dick Dee (ECMWF)

!   Modifications.
!   --------------
!   Original    2008/03/01
!-----------------------------------------------------------------------

INTEGER(KIND=JPIM) :: is
REAL(KIND=JPRB)    :: zhook_handle

CHARACTER(LEN=*), PARAMETER :: myname = modname//' (config)'

IF (LHOOK) CALL DR_HOOK(myname,0,zhook_handle)

WRITE(NULOUT,'(/,a)') myname//': Configuring AIREP VarBC'

DO is = 1, SIZE(yconfig,1)
  yconfig(is)%nparam       = 1  
  yconfig(is)%npredcs(:)   = NPREDCS_AIREP ! p0
  yconfig(is)%zparams(:)   = 0.0_JPRB      ! a priori parameter estimates
  yconfig(is)%llconst(:)   = .false.       ! keep this parameter fixed
  yconfig(is)%ncstart      = 0             ! cold start from 0
  yconfig(is)%nbgstdv      = 0             ! background constraint
  yconfig(is)%llmode       = .false.       ! correct mode of pdf, rather than mean
ENDDO

yconfig(1)%name    = 'AIRCT'
yconfig(1)%nsensor = 141
yconfig(1)%dfgdep  = 20.0_JPRB
!yconfig(1)%nparam  = 2
!yconfig(1)%npredcs(1:2) = (/0,4/)
 yconfig(1)%nparam  = 1
 yconfig(1)%npredcs(1  ) = 0

yconfig(2)%name    = 'CODAR'
yconfig(2)%nsensor =  41
yconfig(2)%dfgdep  = 20.0_JPRB
!yconfig(2)%nparam  = 2
!yconfig(2)%npredcs(1:2) = (/0,4/)
yconfig(2)%nparam  = 1
yconfig(2)%npredcs(1  ) = 0

yconfig(3)%name    = 'COLBA'
yconfig(3)%nsensor = 241
yconfig(3)%dfgdep  = 20.0_JPRB
!yconfig(3)%nparam  = 2
!yconfig(3)%npredcs(1:2) = (/0,4/)
yconfig(3)%nparam  = 1
yconfig(3)%npredcs(1  ) = 0

yconfig(4)%name    = 'AMDAR'
yconfig(4)%nsensor = 144
yconfig(4)%dfgdep  = 20.0_JPRB
!yconfig(4)%nparam  = 2
!yconfig(4)%npredcs(1:2) = (/0,4/)
yconfig(4)%nparam  = 1
yconfig(4)%npredcs(1  ) = 0

yconfig(5)%name    = 'ACARS'
yconfig(5)%nsensor = 145
yconfig(5)%dfgdep  = 20.0_JPRB
!yconfig(5)%nparam  = 2
!yconfig(5)%npredcs(1:2) = (/0,4/)
 yconfig(5)%nparam  = 1
 yconfig(5)%npredcs(1  ) = 0


! Switches by sensor:
! ------------------
lbc_airct = .true. 
lbc_codar = .true. 
lbc_colba = .true. 
lbc_amdar = .true. 
lbc_acars = .true. 

! Background error parameters by sensor:
! -------------------------------------
nbg_airct = 100
nbg_codar = 100
nbg_colba = 100
nbg_amdar = 100
nbg_acars = 100

! Panic button:
! ------------
lbc_airep = .false. ! If this is false then no AIREP bias correction

! All parameters constant:
! -----------------------
lconst = .false.

! Correct mode rather than mean:
! -----------------------------
lmode = .false.

WRITE(NULOUT,'(a)') myname//': Reading namelist NAMVARBC_AIREP, first iteration'
CALL posnam(NULNAM,'NAMVARBC_AIREP')
READ(NULNAM,NAMVARBC_AIREP)
      
IF (.NOT. (lbc_airep .AND. lbc_airct)) yconfig( 1)%nparam = 0    
IF (.NOT. (lbc_airep .AND. lbc_codar)) yconfig( 2)%nparam = 0    
IF (.NOT. (lbc_airep .AND. lbc_colba)) yconfig( 3)%nparam = 0    
IF (.NOT. (lbc_airep .AND. lbc_amdar)) yconfig( 4)%nparam = 0    
IF (.NOT. (lbc_airep .AND. lbc_acars)) yconfig( 5)%nparam = 0    

yconfig(1)%nbgstdv = nbg_airct    
yconfig(2)%nbgstdv = nbg_codar    
yconfig(3)%nbgstdv = nbg_colba    
yconfig(4)%nbgstdv = nbg_amdar    
yconfig(5)%nbgstdv = nbg_acars    

DO is = 1, SIZE(yconfig,1)
  yconfig(is)%llconst(:) = lconst
  yconfig(is)%llmode     = lmode
ENDDO

! Override settings for individual layers/predictors:
! ---------------------------------------------------
WRITE(NULOUT,'(a)') myname//': Reading namelist NAMVARBC_AIREP, second iteration'
CALL posnam(NULNAM,'NAMVARBC_AIREP')
READ(NULNAM,NAMVARBC_AIREP)

IF (LHOOK) CALL DR_HOOK(myname,1,zhook_handle)

END SUBROUTINE config
!-----------------------------------------------------------------------------

SUBROUTINE encode_groupkey (cdkey, cdstatid, ksensor)

!-----------------------------------------------------------------------
! Encodes group description

! cdkey:  encoded string defining a group of AIREP data
!-----------------------------------------------------------------------
CHARACTER(LEN=*)  , INTENT(OUT) :: cdkey
CHARACTER(LEN=*)  , INTENT(IN)  :: cdstatid
INTEGER(KIND=JPIM), INTENT(IN)  :: ksensor

REAL(KIND=JPRB) :: zhook_handle

CHARACTER(LEN=*), PARAMETER :: myname = modname//' (encode_groupkey)'

IF (LHOOK) CALL DR_HOOK(myname,0,zhook_handle)

!WRITE(cdkey,'(a,x,i0)') cdstatid, ksensor
WRITE(cdkey,'(a8,x,i10)') cdstatid, ksensor

IF (LHOOK) CALL DR_HOOK(myname,1,zhook_handle)

END SUBROUTINE encode_groupkey
!-----------------------------------------------------------------------

SUBROUTINE decode_groupkey (cdkey, cdstatid, ksensor)

!-----------------------------------------------------------------------
! Decodes group description

! cdkey:  encoded string defining a group of AIREP data
!-----------------------------------------------------------------------
CHARACTER(LEN=*)  , INTENT(IN)  :: cdkey
CHARACTER(LEN=*)  , INTENT(OUT) :: cdstatid
INTEGER(KIND=JPIM), INTENT(OUT) :: ksensor

REAL(KIND=JPRB) :: zhook_handle

CHARACTER(LEN=*), PARAMETER :: myname = modname//' (decode_groupkey)'

IF (LHOOK) CALL DR_HOOK(myname,0,zhook_handle)

!READ(cdkey,*) cdstatid, ksensor
READ(cdkey,'(a8,x,i10)') cdstatid, ksensor

IF (LHOOK) CALL DR_HOOK(myname,1,zhook_handle)

END SUBROUTINE decode_groupkey
!-----------------------------------------------------------------------

SUBROUTINE groupdescr (cdkey, cdescr)

!-----------------------------------------------------------------------
! Returns group description

! cdkey:      encoded string defining a group of AIREP data
! cdescr:     string suitable for printing

!-----------------------------------------------------------------------
CHARACTER(LEN=*), INTENT(IN)  :: cdkey
CHARACTER(LEN=*), INTENT(OUT) :: cdescr

CHARACTER(LEN=len_statid)   :: clstatid
CHARACTER(LEN=80)           :: cldesc
INTEGER(KIND=JPIM) :: isensor, j, ilen
REAL(KIND=JPRB)    :: zhook_handle

CHARACTER(LEN=*), PARAMETER :: myname = modname//' (groupdescr)'

IF (LHOOK) CALL DR_HOOK(myname,0,zhook_handle)

CALL decode_groupkey (cdkey, clstatid, isensor)

cldesc(:) = ' '
WRITE(cldesc,'(a,4x,3a,i0)') 'AIREP', &
          & ' statid=', clstatid, ' sensor=', isensor

ilen = LEN(cldesc)
IF (LEN(cdescr)<ilen) CALL ABOR1(myname//': Increase string length')

cdescr(1:ilen) = cldesc

IF (LHOOK) CALL DR_HOOK(myname,1,zhook_handle)

END SUBROUTINE groupdescr
!-----------------------------------------------------------------------

SUBROUTINE find_groups (cdkeys, kng)

!-----------------------------------------------------------------------
!   find_groups - Find data groups present in ODB requiring VarBC

!   Interface.
!   ----------
!   CALL find_groups (cdkeys, kng)

!       cdkeys(1:kng)    group descriptions

!   Author.
!   -------
!   Dick Dee (ECMWF)

!   Modifications.
!   --------------
!   Original    2008/03/01
!-----------------------------------------------------------------------

CHARACTER(LEN=*)  , INTENT(OUT) :: cdkeys(:)
INTEGER(KIND=JPIM), INTENT(OUT) :: kng

CHARACTER(LEN=len_statid)   :: clstatid
INTEGER(KIND=JPIM) :: isensor
INTEGER(KIND=JPIM) :: is, js, ins
REAL(KIND=JPRB)    :: zhook_handle

CHARACTER(LEN=*), PARAMETER :: myname = modname//' (find_groups)'

IF (LHOOK) CALL DR_HOOK(myname,0,zhook_handle)

WRITE(NULOUT,'(a)') myname//': Looking for AIREP data groups..'

! Find all satellite/sensor combinations for this codetype 
! --------------------------------------------------------
CALL find_sensors (ins)

! Return group descriptions for VarBC
! -----------------------------------
kng = 0
IF (lbc_airep .AND. ins>0) THEN

  DO is = 1, ins  ! Look at each sensor

    clstatid = YSENSORS(is)%ccstatid
    isensor  = YSENSORS(is)%nsensor

    DO js = 1, size(yconfig)
      IF (yconfig(js)%nsensor==isensor .AND. yconfig(js)%nparam>0) THEN 
        kng = kng + 1
        IF (kng>size(cdkeys)) CALL ABOR1(myname//': Insufficient allocation.')
        CALL encode_groupkey (cdkeys(kng), clstatid, isensor)
      ENDIF
    ENDDO

  ENDDO

  WRITE(NULOUT,'(a,i3,a)') myname//': ', kng, ' AIREP data groups for VarBC'

ENDIF

IF (LHOOK) CALL DR_HOOK(myname,1,zhook_handle)

END SUBROUTINE find_groups
!-----------------------------------------------------------------------------

SUBROUTINE find_sensors (kns)

INTEGER(KIND=JPIM), INTENT(OUT) :: kns

INTEGER(KIND=JPIM)  :: is, isensor
INTEGER(KIND=JPIM)  :: iret, info(1), ic, j
REAL(KIND=JPRB)     :: zinfo(0)
REAL(KIND=JPRB)     :: zhook_handle
CHARACTER (LEN=len_statid) :: clstatid

CHARACTER(LEN=*), PARAMETER :: myname = modname//' (find_sensors)'


#include "openmp_obs.h"

IF (LHOOK) CALL DR_HOOK(myname,0,zhook_handle)

WRITE(NULOUT,'(a)') &
 &   myname//': Checking ODB for available statid/sensor combinations'

 CALL getdb('GETAIREPID', 0, iret, info, 0, zinfo, 0, &
           & -1, -1, -1, -1, -1, -1)  

ic = 0
DO is = 1, size(yconfig) ! For each sensor, ..
  isensor  = yconfig(is)%nsensor
  clstatid = '        '
  DO j = 1, NROWS_ROBSU ! .. find all distinct statid's
    IF (ROBSU(j,MDB_CODETYPE_AT_HDR)/=isensor) CYCLE
    ic = ic + 1
    clstatid  = TRANSFER(ROBSU(j,MDBSID), clstatid)
    IF (ic>jpmxns) THEN
      WRITE(NULOUT,'(" Insufficient allocation - increase jpmxns: ",i10)') jpmxns
      CALL FLUSH(NULOUT)
      CALL ABOR1(myname//': Insufficient allocation - increase jpmxns')
    ENDIF
    YSENSORS(ic)%ccstatid = clstatid
    YSENSORS(ic)%NSENSOR = isensor
  ENDDO
ENDDO
kns = ic

CALL putdb('GETAIREPID', 0, iret, info, 0, zinfo, 0)

IF (LHOOK) CALL DR_HOOK(myname,1,zhook_handle)

END SUBROUTINE find_sensors
!-----------------------------------------------------------------------------

SUBROUTINE get_predictors (cdkey, knparam, &
                         & kpredcs, pparams, ldreset, kcstart, pdfgdep)

! Return list of predictors, a-priori parameter values, ..
 
CHARACTER(LEN=*)  , INTENT(IN)  :: cdkey
INTEGER(KIND=JPIM), INTENT(OUT) :: knparam, kcstart
LOGICAL           , INTENT(OUT) :: ldreset
INTEGER(KIND=JPIM), INTENT(OUT) :: kpredcs(jpmxnp)
REAL(KIND=JPRB)   , INTENT(OUT) :: pparams(jpmxnp)
REAL(KIND=JPRB)   , INTENT(OUT) :: pdfgdep

CHARACTER(LEN=*), PARAMETER :: myname = modname//' (get_predictors)'
CHARACTER(LEN=len_statid)   :: clstatid
LOGICAL            :: llmatch
INTEGER(KIND=JPIM) :: isensor, js

REAL(KIND=JPRB)    :: zhook_handle

IF (LHOOK) CALL DR_HOOK(myname,0,zhook_handle)

CALL decode_groupkey (cdkey, clstatid, isensor)

llmatch = .false.
DO js = 1, size(yconfig)
  IF (yconfig(js)%nsensor==isensor) THEN
    knparam            = yconfig(js)%nparam
    kpredcs(1:knparam) = yconfig(js)%npredcs(1:knparam)
    pparams(1:knparam) = yconfig(js)%zparams(1:knparam) 
    kcstart            = yconfig(js)%ncstart
    ldreset            = yconfig(js)%lreset
    pdfgdep            = yconfig(js)%dfgdep
    llmatch = .true.
    EXIT   
  ENDIF
ENDDO

IF (.NOT. llmatch) CALL ABOR1(myname//': No match.')

IF (LHOOK) CALL DR_HOOK(myname,1,zhook_handle)

END SUBROUTINE get_predictors
!-----------------------------------------------------------------------------

SUBROUTINE get_min ( cdkey, knparam, kbgstdv, pdfgdep )

!-----------------------------------------------------------------------
!   get_min - Return parameters used in the minimisation for a particular 
!             group of AIREP data

!   Author.
!   -------
!   Dick Dee (ECMWF)

!   Modifications.
!   --------------
!   Original    2008/03/01
!-----------------------------------------------------------------------

CHARACTER(LEN=*)  , INTENT(IN)  :: cdkey
INTEGER(KIND=JPIM), INTENT(IN)  :: knparam
INTEGER(KIND=JPIM), INTENT(OUT) :: kbgstdv
REAL(KIND=JPRB)   , INTENT(OUT) :: pdfgdep

INTEGER(KIND=JPIM) :: js, isensor
CHARACTER(LEN=len_statid) :: clstatid
REAL(KIND=JPRB)    :: zhook_handle
LOGICAL            :: llmatch

CHARACTER(LEN=*), PARAMETER :: myname = modname//' (get_min)'

IF (LHOOK) CALL DR_HOOK(myname,0,zhook_handle)

CALL decode_groupkey (cdkey, clstatid, isensor)

llmatch = .false.    
DO js = 1, size(yconfig)
  IF (yconfig(js)%nsensor==isensor) THEN
    kbgstdv = yconfig(js)%nbgstdv
    pdfgdep = yconfig(js)%dfgdep
    llmatch = .true.
    EXIT
  ENDIF
ENDDO

IF (.NOT. llmatch) CALL ABOR1(myname//': No match.')

IF (LHOOK) CALL DR_HOOK(myname,1,zhook_handle)

END SUBROUTINE get_min
!-----------------------------------------------------------------------------

SUBROUTINE set_varbcix (cdkeys, kix, kng)

!-----------------------------------------------------------------------
!   set_varbcix - Set VarBC group indices in ODB

!   Author.
!   -------
!   Dick Dee (ECMWF)

!   Modifications.
!   --------------
!   Original    2008/03/01
!-----------------------------------------------------------------------

INTEGER(KIND=JPIM), INTENT(IN) :: kix(kng), kng
CHARACTER(LEN=*)  , INTENT(IN) :: cdkeys(kng)

INTEGER(KIND=JPIM) :: iret, ilen, jg, info(1), jobs, ibody
INTEGER(KIND=JPIM) :: isensor
REAL(KIND=JPRB)    :: zinfo(0), zhook_handle
CHARACTER (LEN=len_statid) :: clstatid, clstid
CHARACTER(LEN=*), PARAMETER :: myname = modname//' (set_varbcix)'

#include "openmp_obs.h"

IF (LHOOK) CALL DR_HOOK(myname,0,zhook_handle)

WRITE (NULOUT,'(/,a)') myname//': Setting VarBC group indices (varbc_ix@body) in ODB'

CALL GETDB('VARBC_AIREP',0,iret,info,0,zinfo,0, -1, -1, -1, -1, -1, -1)  

ilen = iret

DO jg = 1, kng

  CALL decode_groupkey (cdkeys(jg), clstatid, isensor)

  DO jobs = 1, ilen

    clstid    = TRANSFER(ROBHDR(jobs,MDBSID), clstid)
    IF (clstid                           == clstatid .AND. &
      & ROBHDR(jobs,MDB_CODETYPE_AT_HDR) == isensor        ) THEN 

      ibody = MLNKH2B(jobs+1) - 1
      ROBODY(ibody,MDB_VARBC_IX_AT_BODY) = kix(jg)

    ENDIF

  ENDDO
  
ENDDO

CALL PUTDB('VARBC_AIREP',0,iret,info,0,zinfo,0)

IF (LHOOK) CALL DR_HOOK(myname,1,zhook_handle)

END SUBROUTINE set_varbcix
!-----------------------------------------------------------------------------

END MODULE VARBC_AIREP

