MODULE varbc_tcwv
!-----------------------------------------------------------------------
!   VARBC_TCWV - Module for variational bias correction (total column water vapour)

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

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

!   Modifications.
!   --------------
!   Original    2008/10/01
!   Anne Fouilloux 31/03/2010 Add a new codetype for meris (ntcwc)
!------------------------------------------------------------------------

USE parkind1  , ONLY : JPIM, JPRB
USE yomhook   , ONLY : LHOOK, DR_HOOK
USE yomlun    , ONLY : NULOUT, NULNAM
USE yomcoctp  , ONLY : NSATEM, NTCWC
USE yomcosjo  , ONLY : JOT
USE yomtvrad  , ONLY : SATGRP_TABLE, NSATGRP 
USE varbc_pred, ONLY : NPREDCS_RAD
USE yomdb

IMPLICIT NONE

SAVE

PRIVATE
PUBLIC lbc_tcwv
PUBLIC varbc_tcwv_config, varbc_tcwv_groups
PUBLIC varbc_tcwv_varbcix, varbc_tcwv_pred
PUBLIC varbc_tcwv_min, varbc_tcwv_groupdescr

INTERFACE varbc_tcwv_config
  MODULE PROCEDURE config
END INTERFACE varbc_tcwv_config

INTERFACE varbc_tcwv_groups
  MODULE PROCEDURE find_groups
END INTERFACE varbc_tcwv_groups

INTERFACE varbc_tcwv_groupdescr
  MODULE PROCEDURE groupdescr
END INTERFACE varbc_tcwv_groupdescr

INTERFACE varbc_tcwv_pred
  MODULE PROCEDURE get_predictors
END INTERFACE varbc_tcwv_pred

INTERFACE varbc_tcwv_varbcix
  MODULE PROCEDURE set_varbcix
END INTERFACE varbc_tcwv_varbcix

INTERFACE varbc_tcwv_min
  MODULE PROCEDURE get_min
END INTERFACE varbc_tcwv_min

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

! Table for available satellite/sensor combinations 
! -------------------------------------------------
TYPE type_sensors
  INTEGER(KIND=JPIM) :: nbufrid 
  INTEGER(KIND=JPIM) :: nsensor 
END TYPE type_sensors

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

INTEGER(KIND=JPIM), PARAMETER :: jpmxnp = SIZE(NPREDCS_RAD) ! 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)
LOGICAL            :: lbc_tcwv
LOGICAL            :: lbc_meris
INTEGER(KIND=JPIM) :: nbg_meris
LOGICAL            :: lconst             ! Keep all VarBC parameters fixed
LOGICAL            :: lmode              ! Correct pdf mode rather than mean

NAMELIST /NAMVARBC_TCWV/ yconfig, &
                      & lbc_tcwv, &
                      & lbc_meris, &
                      & nbg_meris, &
                      & 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 TCWV 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 TCWV VarBC'

DO is = 1, SIZE(yconfig,1)
  yconfig(is)%nparam       = 1  
  yconfig(is)%npredcs(:)   = 0            ! 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    = 'MERIS'
yconfig(1)%nsensor = 174
yconfig(1)%dfgdep  = 20.0_JPRB
yconfig(1)%nparam  = 2
yconfig(1)%npredcs(1:2) = (/0,4/)

! Switches by sensor:
! ------------------
lbc_meris = .true. 

! Background error parameters by sensor:
! -------------------------------------
nbg_meris = 5000 

! Panic button:
! ------------
lbc_tcwv = .true. ! If this is false then no TCWV bias correction

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

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

WRITE(NULOUT,'(a)') myname//': Reading namelist NAMVARBC_TCWV, first iteration'
CALL posnam(NULNAM,'NAMVARBC_TCWV')
READ(NULNAM,NAMVARBC_TCWV)
      
IF (.NOT. (lbc_tcwv .AND. lbc_meris)) yconfig( 1)%nparam = 0    

yconfig(1)%nbgstdv = nbg_meris    

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_TCWV, second iteration'
CALL posnam(NULNAM,'NAMVARBC_TCWV')
READ(NULNAM,NAMVARBC_TCWV)

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

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

SUBROUTINE encode_groupkey (cdkey, kbufrid, ksensor)

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

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

REAL(KIND=JPRB) :: zhook_handle

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

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

WRITE(cdkey,'(2(i0,x))') kbufrid, ksensor

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

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

SUBROUTINE decode_groupkey (cdkey, kbufrid, ksensor)

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

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

REAL(KIND=JPRB) :: zhook_handle

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

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

READ(cdkey,*) kbufrid, 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 TCWV data
! cdescr:     string suitable for printing

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

CHARACTER(LEN=80)  :: cldesc
INTEGER(KIND=JPIM) :: ibufrid, 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, ibufrid, isensor)

! Fallback string

cldesc(:) = ' '
WRITE(cldesc,'(a,4x,2(a,i0),a,f0.2)') 'TCWV', &
          & ' satid=', ibufrid, ' sensor=', isensor

! Try to get string from SATGRP_TABLE

DO j = 1, NSATGRP
  IF (SATGRP_TABLE(j)%codetype/=ntcwc  ) CYCLE  
  IF (SATGRP_TABLE(j)%bufrid  /=ibufrid) CYCLE  
  IF (SATGRP_TABLE(j)%sensor  /=isensor) CYCLE 
  WRITE(cldesc,'(a,4x,a,4x,a,f0.2)') 'TCWV', &
          & TRIM(JOT(NSATEM)%jost(j)%sname)
ENDDO

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

INTEGER(KIND=JPIM) :: ibufrid, 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 TCWV data groups..'

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

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

  DO is = 1, ins  ! Look at each sensor

    ibufrid = YSENSORS(is)%nbufrid
    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), ibufrid, isensor)
      ENDIF
    ENDDO

  ENDDO

  WRITE(NULOUT,'(a,i3,a)') myname//': ', kng, ' TCWV 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) :: ibufrid, is, isensor
INTEGER(KIND=JPIM) :: iret, info(1), ic, j
REAL(KIND=JPRB)    :: zinfo(0)
REAL(KIND=JPRB)    :: zhook_handle

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 bufrid/sensor combinations'

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

! ROBSU(:,MDB_SATID_AT_SAT   ) contains bufrid
! ROBSU(:,MDBSSIA            ) contains sensor
! ROBSU(:,MDB_CODETYPE_AT_HDR) contains codetype

ic = 0
DO is = 1, size(yconfig) ! For each sensor, ..
  isensor = yconfig(is)%nsensor
  ibufrid = -1
  DO j = 1, NROWS_ROBSU ! .. find all distinct bufrid's
    IF (ROBSU(j,MDBSSIA            )/=isensor) CYCLE
    IF (ROBSU(j,MDB_CODETYPE_AT_HDR)/=NTCWC  ) CYCLE
    IF (ROBSU(j,MDB_SATID_AT_SAT)   ==ibufrid) CYCLE ! duplicate
    ibufrid = ROBSU(j,MDB_SATID_AT_SAT)
    ic = ic + 1
    IF (ic>jpmxns) &
      & CALL ABOR1(myname//': Insufficient allocation - increase jpmxnsAT')
    YSENSORS(ic)%NBUFRID = ibufrid
    YSENSORS(ic)%NSENSOR = isensor
    WRITE(NULOUT,'(2(a,i0))') myname//': bufrid=', ibufrid, ' sensor=', isensor
  ENDDO
ENDDO
kns = ic

CALL putdb('GETSATID', 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)'

LOGICAL            :: llmatch
INTEGER(KIND=JPIM) :: ibufrid, isensor, js
REAL(KIND=JPRB)    :: zhook_handle

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

CALL decode_groupkey (cdkey, ibufrid, 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 TCWV 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, ibufrid, isensor
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, ibufrid, 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) :: ibufrid, isensor
REAL(KIND=JPRB)    :: zinfo(0), zhook_handle

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_TCWV',0,iret,info,0,zinfo,0, -1, -1, -1, -1, -1, -1)  

ilen = iret
DO jg = 1, kng

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

  DO jobs = 1, ilen

    IF (ROBHDR(jobs,MDB_SATID_AT_SAT) == ibufrid .AND. &
      & ROBHDR(jobs,MDBSSIA         ) == isensor       ) THEN 

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

    ENDIF

  ENDDO
  
ENDDO

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

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

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

END MODULE VARBC_TCWV

