MODULE VARBC_setup
!-----------------------------------------------------------------------
!   VARBC_setup - Module for variational bias correction

!   Purpose. 
!   --------
!   Set up data structures and controls for variational bias correction

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

!   Modifications.
!   --------------
!   Original    2008/03/01
!   Dingmin Li  2008/12/04  Fix O-B histogram calc.
!   Dee         2009/01/14  Introduce obsclass
!   G. Mozdzynski  03-Jun-2009 VarBC reproducibility rework
!   Alan Geer      07-Sep-2009 Predictor covariances calculated by obgroup
!   T. Wilhelmsson 08-Mar-2010 More VarBC reproducibility rework
!------------------------------------------------------------------------

USE parkind1, ONLY : JPIM, JPRB
USE yomhook , ONLY : LHOOK, DR_HOOK
USE yomdimo , ONLY : NOBTOT
USE yomct0  , ONLY : LSCREEN, LIFSTRAJ, NPROC, CNMEXP
USE yomana  , ONLY : NANDAT, NANTIM
USE yomancs , ONLY : RMDI 
USE yomlun  , ONLY : NULOUT, NULERR, NULNAM, NULTMP
USE yomvar  , ONLY : LREPRO4DVAR
USE yommp   , ONLY : MYPROC
USE oml_mod , ONLY : OML_MY_THREAD
USE yomdb

USE varbc_pred, ONLY: VARBC_PRED_STATS, JPMXNPRED, MPREDXCNT, &
                    & APREDMEAN, APREDXCOV, &
                    & NMIXBUF_LEN,  NMIXBUF_CNT, NAPREDBUF_LEN, NAPREDBUF_CNT, &
                    & MIXBUF, APREDBUF
USE varbc_rad, ONLY : LBC_RAD, &
                    & VARBC_RAD_CONFIG, VARBC_RAD_GROUPS,  &
                    & VARBC_RAD_PRED,   VARBC_RAD_VARBCIX, &
                    & VARBC_RAD_MIN,    VARBC_RAD_GROUPDESCR
USE varbc_allsky, ONLY :   &
                    & LBC_ALLSKY, &
                    & VARBC_ALLSKY_CONFIG, VARBC_ALLSKY_GROUPS,  &
                    & VARBC_ALLSKY_PRED,   VARBC_ALLSKY_VARBCIX, &
                    & VARBC_ALLSKY_MIN,    VARBC_ALLSKY_GROUPDESCR
USE varbc_to3, ONLY : LBC_TO3, &
                    & VARBC_TO3_CONFIG, VARBC_TO3_GROUPS,  &
                    & VARBC_TO3_PRED,   VARBC_TO3_VARBCIX, &
                    & VARBC_TO3_MIN,    VARBC_TO3_GROUPDESCR
USE varbc_tcwv, ONLY : LBC_TCWV, &
                    & VARBC_TCWV_CONFIG, VARBC_TCWV_GROUPS,  &
                    & VARBC_TCWV_PRED,   VARBC_TCWV_VARBCIX, &
                    & VARBC_TCWV_MIN,    VARBC_TCWV_GROUPDESCR
USE varbc_airep, ONLY: LBC_AIREP, &
                    & VARBC_AIREP_CONFIG, VARBC_AIREP_GROUPS,  &
                    & VARBC_AIREP_PRED,   VARBC_AIREP_VARBCIX, &
                    & VARBC_AIREP_MIN,    VARBC_AIREP_GROUPDESCR

USE varbc_table, ONLY : NOBGROUP, JPMXNGROUP

USE mpl_module, ONLY : MPL_ALLREDUCE, MPL_BARRIER
USE ORDER_INDEPENDENT_SUMMATION_MOD , ONLY : ORDER_INDEP_GLOBAL_SUM2

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

IMPLICIT NONE
SAVE

PRIVATE
PUBLIC varbc_setup_traj, varbc_setup_min
PUBLIC varbc_save, varbc_print, varbc_stats

PUBLIC yvarbc, nobgroup, nobparam, jpmxnparam, afjpcost 
PUBLIC imaskrs, nhstfgdep_comp, nhstbins
PUBLIC aparams_comp, nparams_comp
PUBLIC type_varbc

INTERFACE varbc_setup_traj
  MODULE PROCEDURE setup_traj
END INTERFACE varbc_setup_traj

INTERFACE varbc_setup_min
  MODULE PROCEDURE setup_min
END INTERFACE varbc_setup_min

INTERFACE varbc_save
  MODULE PROCEDURE dump_table
END INTERFACE varbc_save

INTERFACE varbc_print
  MODULE PROCEDURE print_table
END INTERFACE varbc_print

INTERFACE varbc_stats
  MODULE PROCEDURE compile_statistics
END INTERFACE varbc_stats


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

INTEGER(KIND=JPIM), PARAMETER :: jpversion  = 5    ! VarBC version number
INTEGER(KIND=JPIM), PARAMETER :: nhstbins   = 100  ! number of histogram bins
                    !  (must change VarBC version number when changing nhstbins)  

! Table for administration of bias groups
! ---------------------------------------
TYPE type_varbc
  INTEGER(KIND=JPIM)          :: nparam       ! number of bias parameters
  INTEGER(KIND=JPIM)          :: ncount       ! data count
  CHARACTER(LEN=8)            :: obsclass     ! observation class
  CHARACTER(LEN=80)           :: groupkey     ! class-dependent group description
  INTEGER(KIND=JPIM), POINTER :: npredcs(:)   ! list of predictors
  REAL(KIND=JPRB), POINTER    :: aparams(:)   ! bias parameters - latest estimate
  REAL(KIND=JPRB), POINTER    :: zparams(:)   ! bias parameters - prescribed values
  INTEGER(KIND=JPIM)          :: ncstart      ! coldstart option
  LOGICAL                     :: llbkgcon     ! flag for background constraint
  LOGICAL                     :: llmaskrs     ! flag for radiosonde masking
  LOGICAL                     :: llmaskcld    ! flag for cloud-cover masking
  LOGICAL                     :: llmode       ! flag for mode correction
  LOGICAL, POINTER            :: llconst(:)   ! flag for constant parameters
  REAL(KIND=JPRB)             :: obserr       ! rms obs error
  REAL(KIND=JPRB), POINTER    :: bkgerr(:)    ! background error std dev
  REAL(KIND=JPRB), POINTER    :: aparam0(:)   ! background parameter values
  REAL(KIND=JPRB), POINTER    :: aparam5(:)   ! trajectory parameter valuess
  REAL(KIND=JPRB), POINTER    :: achgvar(:,:) ! change-of-variable operator
  REAL(KIND=JPRB), POINTER    :: acvarin(:,:) ! inverse change-of-variable
  REAL(KIND=JPRB), POINTER    :: agrad(:)     ! gradient w/r to bias parameters
  REAL(KIND=JPRB), POINTER    :: agrad0(:)    ! initial gradient w/r to bias parameters
  INTEGER(KIND=JPIM), POINTER :: nhstfgdep(:) ! histogram of background departures
  REAL(KIND=JPRB)             :: dfgdep       ! histogram range
END TYPE type_varbc

TYPE(type_varbc) :: yvarbc(jpmxngroup)

CHARACTER(LEN=*),   PARAMETER :: cdfname = 'VARBC.cycle'  ! file name for cycling
 
INTEGER(KIND=JPIM), PARAMETER :: jpmxnparam = jpmxnpred+1 ! max number of parameters per group

CHARACTER(LEN=80), ALLOCATABLE :: ckeys(:)

INTEGER(KIND=JPIM) :: nobparam   ! total number of bias parameters

REAL(KIND=JPRB)    :: afjpcost = 0.0_JPRB  ! initial contribution to cost function

INTEGER(KIND=JPIM) :: imaskrs(360,181) ! Radio-sonde Mask (0/1)

! Arrays for parallel summation
! -----------------------------
REAL(KIND=JPRB),    ALLOCATABLE :: aparams_comp(:,:,:)   ! aparams partial sum 
REAL(KIND=JPRB),    ALLOCATABLE :: nparams_comp(:,:)     ! aparams number of terms
INTEGER(KIND=JPIM), ALLOCATABLE :: nhstfgdep_comp(:,:,:) ! nhstfgdep partial sum

!-----------------------------------------------------------------------
! Namelist parameters
!-----------------------------------------------------------------------
LOGICAL            :: lcoldstart   ! Coldstart on all groups
LOGICAL            :: lbgconstr    ! Use background constraint for bias parameters
INTEGER(KIND=JPIM) :: nbgstdv      ! Bkg error std dev in terms of eqv no of obs
LOGICAL            :: lconstant    ! Constant VarBC switch 
LOGICAL            :: lmaskrs      ! Radio-sonde mask switch
LOGICAL            :: lmode        ! Mode (not mean) correction switch
LOGICAL            :: lcleantable  ! Remove groups during screening if zero data 

NAMELIST /NAMVARBC/ lcoldstart, &
                  & lbgconstr, nbgstdv, &
                  & lconstant, lmaskrs, lmode, lcleantable
!-----------------------------------------------------------------------

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

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

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

SUBROUTINE setup_traj
!-----------------------------------------------------------------------
!   setup_traj - Set up variational bias correction of observations

!   Purpose. 
!   --------
!   Definition of bias groups and bias models; cycling of bias parameters
!   and group definitions.

!   Interface.
!   ----------
!   CALL setup_traj ()

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

!   Modifications.
!   --------------
!   Original    2004/03/19
!        P.Burton :  29-09-04 LVARBC cleanup
!        M Szyndel:  23-03-05 Add MSG, MTSAT and FY-2
!        T.Auligne:  09-12-05 Included scan bias correction (3 predictors)
!        T.Auligne:  09-12-05 Added Radiosonde mask option
!        D. Dee   :  19-12-05 Allow choice of predictors to change on the fly
!        N Bormann:  20-02-06 Add SSMIS, AMSRE, TMI
!        A Collard:  06-11-06 Add IASI   
!        D. Dee   :  2008/10/01 Generalise to support different types of observations             
!------------------------------------------------------------------------------------
INTEGER(KIND=JPIM) :: jg, ios
CHARACTER(LEN=*), PARAMETER :: myname = modname//' (setup_traj)'

REAL(KIND=JPRB) :: zhook_handle

IF (lhook) CALL dr_hook(myname,0,zhook_handle)

CALL GSTATS(1978,0)

WRITE(nulout,'(/,a)') myname//': Setting up variational bias correction (VarBC)'

! Configure class modules
! ----------------------- 
CALL varbc_rad_config
IF (.NOT. lbc_rad) &
  & WRITE(NULOUT,'(/,a)') myname//': VarBC switched OFF for data in class rad'

CALL varbc_allsky_config
IF (.NOT. lbc_allsky) &
  & WRITE(NULOUT,'(/,a)') myname//': VarBC switched OFF for data in class allsky'

CALL varbc_to3_config
IF (.NOT. lbc_to3) &
  & WRITE(NULOUT,'(/,a)') myname//': VarBC switched OFF for data in class to3'

CALL varbc_tcwv_config
IF (.NOT. lbc_tcwv) &
  & WRITE(NULOUT,'(/,a)') myname//': VarBC switched OFF for data in class tcwv'

CALL varbc_airep_config
IF (.NOT. lbc_airep) &
  & WRITE(NULOUT,'(/,a)') myname//': VarBC switched OFF for data in class airep'

! Load table with cycled group definitions and parameter info
! -----------------------------------------------------------
CALL load_table

! Set up VarBC groups and predictors
! ----------------------------------
CALL setup_groups

IF (LSCREEN) THEN

! Set group index in ODB
! ----------------------
  CALL set_varbcix

! Cold start where needed
! ----------------------
  CALL coldstart

! Set background parameters
! -------------------------
  DO jg = 1, nobgroup
    yvarbc(jg)%aparam0 = yvarbc(jg)%aparams
  ENDDO

ENDIF

IF (nobgroup==0) THEN
  WRITE(nulout,'(/,a)') myname//': Nothing else to do.'
  CALL GSTATS(1978,1)
  IF (lhook) CALL dr_hook(myname,1,zhook_handle)
  RETURN
ENDIF

! Get data counts and other group statistics from ODB
! ---------------------------------------------------
CALL data_stats

! Trajectory = latest estimate
! ----------------------------
DO jg = 1, nobgroup
  ALLOCATE(yvarbc(jg)%aparam5(yvarbc(jg)%nparam))
  yvarbc(jg)%aparam5 = yvarbc(jg)%aparams
ENDDO

! Reset fg-departure histograms
! -----------------------------
IF (LSCREEN) THEN
  DO jg = 1, nobgroup
    yvarbc(jg)%nhstfgdep(1:nhstbins) = 0
  ENDDO 
ENDIF

! Reset predictor statistics 
! --------------------------
IF (lifstraj) THEN
  mpredxcnt(0:jpmxnpred,0:jpmxnpred,1:nobgroup) = 0
  apredmean(0:jpmxnpred,1:nobgroup)             = 0.0_JPRB
  apredxcov(0:jpmxnpred,0:jpmxnpred,1:nobgroup) = 0.0_JPRB
ENDIF

! Allocate buffers for computing reprocible statistics
! ----------------------------------------------------
IF (lifstraj .AND. lrepro4dvar) THEN
  !
  ! 100 = estimated average of body entries per observation 
  !
  nmixbuf_len = nobtot*(2+100)
  napredbuf_len = nobtot*jpmxnparam
  ALLOCATE(mixbuf(nmixbuf_len))
  ALLOCATE(apredbuf(napredbuf_len))
  nmixbuf_cnt = 0
  napredbuf_cnt = 0
ENDIF

! Print the tables
! ----------------
CALL print_table(0)
CALL print_table(1)
CALL print_table(5)

CALL GSTATS(1978,1)

IF (lhook) CALL dr_hook(myname,1,zhook_handle)

END SUBROUTINE setup_traj

!-----------------------------------------------------------------------------
SUBROUTINE setup_groups

! 0. on entry:
!    - table from previous cycle has been loaded in yvarbc
!    - class modules have been initialised
! 1. initialise this module 
! 2. find VarBC data groups in ODB
! 3. append new groups to the table, with nparam=0
! 4. check entire table for modifications


INTEGER(KIND=JPIM) :: inparam, incstart
INTEGER(KIND=JPIM) :: ig, jg, ip
LOGICAL            :: llmodify, llreset, llmode
INTEGER(KIND=JPIM) :: jgkeep(jpmxngroup) 
INTEGER(KIND=JPIM) :: ipredcs(jpmxnparam), ipredcs_c(jpmxnparam)
REAL(KIND=JPRB)    :: zparams(jpmxnparam)
REAL(KIND=JPRB)    :: zdfgdep

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

REAL(KIND=JPRB) :: zhook_handle

IF (lhook) CALL dr_hook(myname,0,zhook_handle)

WRITE(nulout,'(/,a)') myname//': Defining groups'

! Default settings:
! ----------------
lcoldstart = .false. ! Do not force a coldstart  
lcleantable = .false. ! Do not remove items from table when no data 

! Read namelist parameters for settings applying to all groups:
! ------------------------------------------------------------
WRITE(nulout,'(a)') myname//': Reading namelist NAMVARBC, first iteration'
CALL posnam(nulnam,'NAMVARBC')
READ(nulnam,NAMVARBC)

IF (LSCREEN) THEN

! Force coldstart on all data (UNUSUAL)
! ---------------------------
  IF (lcoldstart) THEN  ! Ignore the cycled table
    nobgroup = 0
    nobparam = 0
    WRITE(nulout,'(a)') myname//': Forced cold start: Building new group table'
  ENDIF

! Clean the table
! ---------------
  ig = 0
  DO jg = 1, nobgroup
    IF (yvarbc(jg)%obsclass=='none') THEN
      WRITE(nulout,'(a,i0,a)') myname//': Marking group ', jg, &
     &                       ' for deletion (class=none)'
    ELSEIF (lcleantable .AND. yvarbc(jg)%ncount==0) THEN  
      WRITE(nulout,'(a,i0,a)') myname//': Marking group ', jg, &
     &                       ' for deletion (ncount=0)'
    ELSE
      ig = ig + 1
      jgkeep(ig) = jg
    ENDIF
  ENDDO
  IF (ig/=nobgroup) THEN
    nobgroup = ig
    CALL compress_table (jgkeep)
  ENDIF

! Add new data groups present in ODB
! ----------------------------------
  ALLOCATE(ckeys(jpmxngroup))

  IF (LBC_RAD) THEN
    CALL varbc_rad_groups (ckeys, ig)
    CALL add_groups ('rad', ckeys, ig)
  ENDIF
  IF (LBC_ALLSKY) THEN
    CALL varbc_allsky_groups (ckeys, ig)
    CALL add_groups ('allsky', ckeys, ig)
  ENDIF
  IF (LBC_TO3) THEN
    CALL varbc_to3_groups (ckeys, ig)
    CALL add_groups ('to3', ckeys, ig)
  ENDIF
  IF (LBC_TCWV) THEN
    CALL varbc_tcwv_groups (ckeys, ig)
    CALL add_groups ('tcwv', ckeys, ig)
  ENDIF
  IF (LBC_AIREP) THEN
    CALL varbc_airep_groups (ckeys, ig)
    CALL add_groups ('airep', ckeys, ig)
  ENDIF

  DEALLOCATE(ckeys)

ENDIF

! Check all groups in the table; modify or delete any groups that
! are inconsistent with the current bias group definitions
! ---------------------------------------------------------------
IF (nobgroup>0) THEN

  WRITE(nulout,'(a)') myname//': Checking existing group tables'
! WRITE(nulout,'('' LBC_AIREP= '',L1)') LBC_AIREP
  
  ig = 0   
  DO jg = 1, nobgroup
!   WRITE(nulout,'('' jg= '',i10,x,a)') jg,yvarbc(jg)%obsclass
    llmode = .false.
!   Get the a-priori predictor information for this group.

    IF     (LBC_RAD .AND. yvarbc(jg)%obsclass=='rad') THEN

      CALL varbc_rad_pred ( yvarbc(jg)%groupkey, inparam, &
                          & ipredcs, zparams, llreset, llmode, incstart, zdfgdep )      

    ELSEIF (LBC_ALLSKY .AND. yvarbc(jg)%obsclass=='allsky') THEN

      CALL varbc_allsky_pred ( yvarbc(jg)%groupkey, inparam, &
                          & ipredcs, zparams, llreset, incstart, zdfgdep )

    ELSEIF (LBC_TO3 .AND. yvarbc(jg)%obsclass=='to3') THEN

      CALL varbc_to3_pred ( yvarbc(jg)%groupkey, inparam, &
                          & ipredcs, zparams, llreset, incstart, zdfgdep )

    ELSEIF (LBC_TCWV .AND. yvarbc(jg)%obsclass=='tcwv') THEN

      CALL varbc_tcwv_pred ( yvarbc(jg)%groupkey, inparam, &
                          & ipredcs, zparams, llreset, incstart, zdfgdep )

    ELSEIF (LBC_AIREP .AND. yvarbc(jg)%obsclass=='airep') THEN

      CALL varbc_airep_pred ( yvarbc(jg)%groupkey, inparam, &
                          & ipredcs, zparams, llreset, incstart, zdfgdep )
    ELSE

      inparam = 0        ! Triggers deletion from the table

    ENDIF

!   We now have information for this group:

!     inparam            : number of predictors, if any 
!     ipredcs(1:inparam) : list of predictors, if any 
!     zparams(1:inparam) : prescribed parameter values, if any
!     llreset            : if true then reset parameters to prescribed values
!     llmode             : if true then correct mode instead of mean
!     incstart           : coldstart method, if needed
!     zdfgdep            : range to use for binning first-guess departures

!   There are five possibilities:

!     keep, new addition
!     keep, as is
!     keep, but modify predictors
!     keep, but reset parameter values
!     delete (if inparam==0)
  
    IF (inparam>0) THEN 

      ig = ig + 1
      jgkeep(ig) = jg
      yvarbc(jg)%llmode  = llmode
      yvarbc(jg)%ncstart = incstart
      yvarbc(jg)%dfgdep  = zdfgdep

!     Modify if the predictor selection has changed

      llmodify = (llreset .OR. inparam/=yvarbc(jg)%nparam)
      IF (.NOT. llmodify) THEN
        ipredcs_c(1:yvarbc(jg)%nparam) = yvarbc(jg)%npredcs
        DO ip = 1, inparam
          llmodify = (llmodify .OR. (ipredcs(ip)/=ipredcs_c(ip)))
        ENDDO
      ENDIF

      IF (llmodify) THEN
        WRITE(nulout,'(a,i0,a)') myname//': Modifying group ', jg, &
                 & ' (class '//TRIM(yvarbc(jg)%obsclass)//', key '//TRIM(yvarbc(jg)%groupkey)//')'
        CALL modify (jg, inparam, ipredcs, zparams, llreset)
      ENDIF

    ELSE

      WRITE(nulout,'(a,i0,a)') myname//': Marking for deletion group ', jg, &
                 & ' (class '//TRIM(yvarbc(jg)%obsclass)//', key '//TRIM(yvarbc(jg)%groupkey)//')'

    ENDIF

  ENDDO

! If there are any groups to delete, then push the table entries

  IF (ig/=nobgroup) THEN
    nobgroup = ig
    CALL compress_table (jgkeep)
  ENDIF

ENDIF

! Read namelist parameters to override settings applying to individual groups:
! ---------------------------------------------------------------------------
WRITE(nulout,'(a)') myname//': Reading namelist NAMVARBC, second iteration'
CALL posnam(nulnam,'NAMVARBC')
READ(nulnam,NAMVARBC)

WRITE(nulout,'(a,i5)') myname//': Total number of bias groups = ', nobgroup
WRITE(nulout,'(a,i5)') myname//': Total number of parameters  = ', nobparam

IF (lhook) CALL dr_hook(myname,1,zhook_handle)

END SUBROUTINE setup_groups
!-----------------------------------------------------------------------------

SUBROUTINE add_groups (cdclass, cdkeys, kng)

! Add groups to the table if not already there

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

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

INTEGER(KIND=JPIM) :: in, ig, jg
LOGICAL            :: llnew
REAL(KIND=JPRB)    :: zhook_handle

IF (lhook) CALL dr_hook(myname,0,zhook_handle)

IF (kng>0) THEN

  in = nobgroup
  DO ig = 1, kng  
    llnew = .true. 
    DO jg = 1, nobgroup    ! see if this group is already in the table
      IF (yvarbc(jg)%obsclass /= cdclass) CYCLE
      IF (yvarbc(jg)%groupkey == cdkeys(ig)) THEN
        llnew = .false.
        EXIT
      ENDIF
    ENDDO
    IF (llnew) THEN
      in = in + 1
      IF (in>size(yvarbc)) &
      & CALL ABOR1(myname//': Insufficient allocation - increase jpmxngroup')
      WRITE(nulout,'(a,i0,a)') myname//': Adding group ', in, &
                 & ' (class '//TRIM(cdclass)//', key '//TRIM(cdkeys(ig))//')'

      yvarbc(in)%obsclass  = cdclass    ! class for this group
      yvarbc(in)%groupkey  = cdkeys(ig)
      yvarbc(in)%nparam    = 0          ! this will trigger new predictor settings   
      yvarbc(in)%ncount    = 0          !     
      ALLOCATE(yvarbc(in)%nhstfgdep(nhstbins)) 
      yvarbc(in)%nhstfgdep = 0          ! histogram of bkg departures
    
    ENDIF
  ENDDO

  IF (in > nobgroup) THEN
    WRITE(nulout,'(a,i4,a)') myname//': Added ', in-nobgroup, &
                                      & ' groups in class '//TRIM(cdclass) 
    nobgroup = in
  ENDIF

ENDIF

IF (lhook) CALL dr_hook(myname,1,zhook_handle)

END SUBROUTINE add_groups
!-----------------------------------------------------------------------------

SUBROUTINE modify (kgroup, kparam, kpredcs, pparams, ldreset)

! Modify predictors and parameter values for group kgroup in yvarbc.
! This also includes new groups (if yvarbc(jg)%nparam==0) and
! resetting parameters in existing groups (if ldreset=.true.)
 
INTEGER(KIND=JPIM), INTENT(IN) :: kgroup
INTEGER(KIND=JPIM), INTENT(IN) :: kparam
INTEGER(KIND=JPIM), INTENT(IN) :: kpredcs(jpmxnparam)
REAL(KIND=JPRB)   , INTENT(IN) :: pparams(jpmxnparam)
LOGICAL           , INTENT(IN) :: ldreset

INTEGER(KIND=JPIM) :: jg, ip, jp, inparam_c 
LOGICAL            :: llnew
INTEGER(KIND=JPIM) :: ipredcs_c(jpmxnparam)
REAL(KIND=JPRB)    :: zparams_c(jpmxnparam)

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

REAL(KIND=JPRB) :: zhook_handle

IF (lhook) CALL dr_hook(myname,0,zhook_handle)

! Reallocate arrays if necessary
! ------------------------------
jg = kgroup
inparam_c = yvarbc(jg)%nparam
llnew = (inparam_c==0)
IF (kparam/=inparam_c) THEN ! reallocate arrays
  IF (.NOT. llnew) THEN ! save and deallocate
    ipredcs_c(1:inparam_c) = yvarbc(jg)%npredcs
    zparams_c(1:inparam_c) = yvarbc(jg)%aparams
    DEALLOCATE(yvarbc(jg)%npredcs) 
    DEALLOCATE(yvarbc(jg)%aparams) 
    DEALLOCATE(yvarbc(jg)%aparam0) 
  ENDIF
  yvarbc(jg)%nparam = kparam
  ALLOCATE(yvarbc(jg)%npredcs(kparam))
  ALLOCATE(yvarbc(jg)%aparams(kparam))
  ALLOCATE(yvarbc(jg)%aparam0(kparam))
  nobparam = nobparam + kparam - inparam_c  ! update the total parameter count
ENDIF

! Set the list of predictors and parameter values
! -----------------------------------------------
yvarbc(jg)%npredcs(1:kparam) = kpredcs(1:kparam)

IF (llnew .or. ldreset) THEN    ! Set to a priori parameter values where available
 
  yvarbc(jg)%aparams(1:kparam) = pparams(1:kparam)   

ELSE               ! Existing group: Use cycled parameter values where predictors match

  yvarbc(jg)%aparams = 0.0_JPRB   
  DO ip = 1, kparam
    DO jp = 1, inparam_c
      IF (kpredcs(ip)==ipredcs_c(jp)) yvarbc(jg)%aparams(ip) = zparams_c(jp)
    ENDDO
  ENDDO

ENDIF

IF (lhook) CALL dr_hook(myname,1,zhook_handle)

END SUBROUTINE modify
!-----------------------------------------------------------------------------

SUBROUTINE coldstart

INTEGER(KIND=JPIM) :: ix, ib(1)
REAL(KIND=JPRB)    :: zhook_handle, zm

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

IF (lhook) CALL dr_hook(myname,0,zhook_handle)

DO ix = 1, nobgroup

! Cold start (or restart) is triggered by RMDI parameter values
! -------------------------------------------------------------
  IF (.NOT. (ANY(yvarbc(ix)%aparams==RMDI)) ) CYCLE 

! Several options:
! ---------------
  IF (yvarbc(ix)%ncstart==0) THEN

!   Initialise to zero
!   ------------------
    yvarbc(ix)%aparams = 0.0_JPRB
    WRITE(nulout,'(a,i0,a)') myname//': Bias parameters set to zero for group ', ix, &
                 & ' (class '//TRIM(yvarbc(ix)%obsclass)//', key '//TRIM(yvarbc(ix)%groupkey)//')'

  ELSEIF (yvarbc(ix)%ncstart==1) THEN

    yvarbc(ix)%aparams = yvarbc(ix)%zparams
    WRITE(nulout,'(a,i0,a)') myname//': Bias parameters set to prescribed values for group ', ix, &
                 & ' (class '//TRIM(yvarbc(ix)%obsclass)//', key '//TRIM(yvarbc(ix)%groupkey)//')'

  ELSEIF (yvarbc(ix)%ncstart==2) THEN
  
!   Use the mode of the first-guess departures if possible 
!   ------------------------------------------------------     
    IF (SUM(yvarbc(ix)%nhstfgdep(:))>0) THEN ! Histogram of uncorrected departures is defined

      yvarbc(ix)%aparams(:) = 0.0_JPRB

      IF (yvarbc(ix)%npredcs(1)==0) THEN   ! Only makes sense for p0 (constant)
        ib = MAXLOC(yvarbc(ix)%nhstfgdep(:))       
        zm = yvarbc(ix)%dfgdep * (REAL(ib(1))/REAL(nhstbins) - 0.5_JPRB)       
        yvarbc(ix)%aparams(1:1) = zm
        WRITE(nulout,'(a,g10.2e2,a,i0,a)') &
      & myname//': Bias parameters set to mode = ', zm,' for group ', ix, &
                 & ' (class '//TRIM(yvarbc(ix)%obsclass)//', key '//TRIM(yvarbc(ix)%groupkey)//')'
        WRITE(nulout,'(a,i0,a)') &
      & myname//': Using the mode of uncorrected departures to initialise group ', ix, &
                 & ' (class '//TRIM(yvarbc(ix)%obsclass)//', key '//TRIM(yvarbc(ix)%groupkey)//')'
      ELSE
        WRITE(nulout,'(a,i0,a)') myname//': Bias parameters set to zero for group ', ix, &
                 & ' (class '//TRIM(yvarbc(ix)%obsclass)//', key '//TRIM(yvarbc(ix)%groupkey)//')'
      ENDIF  
      
    ELSE
      yvarbc(ix)%aparams(:) = RMDI
    ENDIF    
    
  ENDIF

! quality control
! ---------------
  IF (ABS(SUM(yvarbc(ix)%aparams))>=999.0_JPRB) THEN 
    yvarbc(ix)%aparams = RMDI
    WRITE(nulout,'(a,i0,a)') myname//': Bias parameters set to RMDI for group ', ix, &
                 & ' (class '//TRIM(yvarbc(ix)%obsclass)//', key '//TRIM(yvarbc(ix)%groupkey)//')'
  ELSEIF (ABS(SUM(yvarbc(ix)%aparams))>30.0_JPRB) THEN
    yvarbc(ix)%aparams = 0.0_JPRB
    WRITE(nulout,'(a,i0,a)') myname//': Bias parameters set to zero for group ', ix, &
                 & ' (class '//TRIM(yvarbc(ix)%obsclass)//', key '//TRIM(yvarbc(ix)%groupkey)//')'
  ENDIF
          
  yvarbc(ix)%aparam0 = yvarbc(ix)%aparams

ENDDO

IF (lhook) CALL dr_hook(myname,1,zhook_handle)

END SUBROUTINE coldstart   
!-----------------------------------------------------------------------------

SUBROUTINE compress_table (kgkeep)

INTEGER(KIND=JPIM), INTENT(IN) :: kgkeep(jpmxngroup) 

INTEGER(KIND=JPIM) :: ig, jg, inparam

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

REAL(KIND=JPRB) :: zhook_handle

IF (lhook) CALL dr_hook(myname,0,zhook_handle)

nobparam = 0
DO ig = 1, nobgroup
  jg = kgkeep(ig)
  IF (jg/=ig) THEN
    yvarbc(ig)%obsclass  = yvarbc(jg)%obsclass 
    yvarbc(ig)%groupkey  = yvarbc(jg)%groupkey
    yvarbc(ig)%ncount    = yvarbc(jg)%ncount
    yvarbc(ig)%ncstart   = yvarbc(jg)%ncstart
    yvarbc(ig)%nhstfgdep = yvarbc(jg)%nhstfgdep
    yvarbc(ig)%dfgdep    = yvarbc(jg)%dfgdep
    IF (yvarbc(ig)%nparam/=yvarbc(jg)%nparam) THEN
      DEALLOCATE(yvarbc(ig)%npredcs) 
      DEALLOCATE(yvarbc(ig)%aparams) 
      DEALLOCATE(yvarbc(ig)%aparam0) 
      inparam = yvarbc(jg)%nparam  
      yvarbc(ig)%nparam = inparam 
      ALLOCATE(yvarbc(ig)%npredcs(inparam))
      ALLOCATE(yvarbc(ig)%aparams(inparam))
      ALLOCATE(yvarbc(ig)%aparam0(inparam))
    ENDIF
    yvarbc(ig)%npredcs = yvarbc(jg)%npredcs
    yvarbc(ig)%aparams = yvarbc(jg)%aparams
    yvarbc(ig)%aparam0 = yvarbc(jg)%aparams
  ENDIF
  nobparam = nobparam + yvarbc(ig)%nparam
ENDDO

IF (lhook) CALL dr_hook(myname,1,zhook_handle)

END SUBROUTINE compress_table
!-----------------------------------------------------------------------------

SUBROUTINE setup_min (kparam)   

! During minimisation, parameter increments are defined with 
! respect to the estimates used in the latest trajectory run.
! The minimisation therefore always starts with zero increments 
! for the parameters (see SUVAZX). In order to correctly 
! compute the background term (if any), the change-of-variable 
! routines for the parameter section of the control variable 
! therefore require the background parameters as well as the 
! estimates used in the latest trajectory run.

!   Externals.
!   ----------
!   DSYTRD, DSTEQR from LAPACK


! Proper conditioning of the minimisation depends on knowledge
! of the active data count for each bias group, and the (typical)
! observation error standard deviation for those data.

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

INTEGER(KIND=JPIM) :: incount, inparam
INTEGER(KIND=JPIM) :: i, j, ix, jp, ip, info(1) 
REAL(KIND=JPRB)    :: zhook_handle

INTEGER(KIND=JPIM) :: inbkg(jpmxngroup)

REAL(KIND=JPRB)    :: zhessian(jpmxnparam,jpmxnparam)
REAL(KIND=JPRB)    :: zeignvec(jpmxnparam,jpmxnparam)
REAL(KIND=JPRB)    :: zeignval(jpmxnparam)
REAL(KIND=JPRB)    :: zsubdiag(jpmxnparam-1), ztau(jpmxnparam-1) 
REAL(KIND=JPRB)    :: zwork(jpmxnparam*jpmxnparam)

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

IF (lhook) CALL dr_hook(myname,0,zhook_handle)

CALL GSTATS(1979,0)

WRITE(nulout,'(/,a)') myname//': Setting up for minimisation'

! Default settings:
! ----------------
lbgconstr  = .true.  ! Use background constraint for parameter values
nbgstdv    =  10000  ! Equivalent obs count for bkg constraint
lconstant  = .false. ! Do not keep varbc parameters constant
lmaskrs    = .false. ! Do not use radiosonde mask
lmode      = .false. ! Do not correct the mode

! Read namelist parameters for default settings:
! ---------------------------------------------
WRITE(nulout,'(2a)') myname//': Reading namelist NAMVARBC for ', &
                    & 'minimisation options'
CALL posnam(nulnam,'NAMVARBC')
READ(nulnam,NAMVARBC)

! Configure class modules
! ----------------------- 
CALL varbc_rad_config
CALL varbc_allsky_config
CALL varbc_to3_config
CALL varbc_tcwv_config
CALL varbc_airep_config

! Load table with cycled group definitions and parameter info
! -----------------------------------------------------------
CALL load_table 
kparam = nobparam                      

! Collect settings in main varbc table
! ------------------------------------
DO ix = 1, nobgroup

! Default settings

  inbkg(ix) = nbgstdv  ! used for defining bkg error std dev, below
  yvarbc(ix)%llbkgcon  = lbgconstr
  yvarbc(ix)%llmaskrs  = lmaskrs
  yvarbc(ix)%llmaskcld = .false.
  yvarbc(ix)%llmode    = lmode
  ALLOCATE(yvarbc(ix)%llconst(1:yvarbc(ix)%nparam))
  ALLOCATE(yvarbc(ix)%aparam5(1:yvarbc(ix)%nparam))
  yvarbc(ix)%llconst(:) = lconstant
  yvarbc(ix)%aparam5(:) = yvarbc(ix)%aparams(:)
! Override with class-dependent settings
! -----------------------------------------
  IF     (yvarbc(ix)%obsclass=='rad'   ) THEN
        
    CALL varbc_rad_min (yvarbc(ix)%groupkey, yvarbc(ix)%nparam, &
                      & yvarbc(ix)%llconst, inbkg(ix), yvarbc(ix)%llmaskrs, &
                      & yvarbc(ix)%llmode, yvarbc(ix)%dfgdep, &
                      & yvarbc(ix)%llmaskcld )

  ELSEIF (yvarbc(ix)%obsclass=='allsky') THEN

    CALL varbc_allsky_min (yvarbc(ix)%groupkey, yvarbc(ix)%nparam, &
                      & yvarbc(ix)%llconst, inbkg(ix), yvarbc(ix)%llmaskrs, &
                      & yvarbc(ix)%llmode, yvarbc(ix)%dfgdep )

  ELSEIF (yvarbc(ix)%obsclass=='to3'   ) THEN

    CALL varbc_to3_min (yvarbc(ix)%groupkey, yvarbc(ix)%nparam, &
                      & inbkg(ix), yvarbc(ix)%dfgdep)

  ELSEIF (yvarbc(ix)%obsclass=='tcwv'  ) THEN

    CALL varbc_tcwv_min (yvarbc(ix)%groupkey, yvarbc(ix)%nparam, &
                      & inbkg(ix), yvarbc(ix)%dfgdep)

  ELSEIF (yvarbc(ix)%obsclass=='airep'  ) THEN

    CALL varbc_airep_min (yvarbc(ix)%groupkey, yvarbc(ix)%nparam, &
                      & inbkg(ix), yvarbc(ix)%dfgdep)

  ELSE

    CALL ABOR1(myname//': unsupported class.')

  ENDIF

  IF (inbkg(ix)<0) yvarbc(ix)%llbkgcon = .false.  ! no background constraint

! Override from NAMVARBC to keep all parameters constant:
! ------------------------------------------------------
  IF (lconstant) yvarbc(ix)%llconst(:) = .true.
        
ENDDO

! Load radiosonde mask if needed
! ------------------------------
imaskrs(:,:)  =  0
DO ix = 1, nobgroup
  IF (yvarbc(ix)%llmaskrs) THEN
    WRITE(NULOUT,'(a)') myname//': Opening radiosonde mask file'
    OPEN(169,FILE='mask_asc')
    READ(169,'(1X,90I1)') imaskrs
    CLOSE(169)
    EXIT
  ENDIF  
ENDDO

! Get data counts and rms(obs error stdv) from ODB
! ------------------------------------------------
CALL data_stats

! For each parameter group, set the background error std dev and
! precompute the transformation needed for change-of-variable routines
! --------------------------------------------------------------------
DO ix = 1, nobgroup
  inparam = yvarbc(ix)%nparam
  incount = yvarbc(ix)%ncount

  ALLOCATE(yvarbc(ix)%bkgerr(inparam))
  ALLOCATE(yvarbc(ix)%achgvar(inparam,inparam))
  ALLOCATE(yvarbc(ix)%acvarin(inparam,inparam))

! Initialize (1st and final) gradients w/r to the bias parameters
! ---------------------------------------------------------------
  ALLOCATE(yvarbc(ix)%agrad0(inparam))
  ALLOCATE(yvarbc(ix)%agrad(inparam))
  yvarbc(ix)%agrad0(:) = 0.0_JPRB
  yvarbc(ix)%agrad(:)  = 0.0_JPRB

! Set the background error, based on equivalent number of observations
! --------------------------------------------------------------------
  IF (inbkg(ix)>0) THEN
    yvarbc(ix)%bkgerr(1:inparam) = yvarbc(ix)%obserr/SQRT(REAL(inbkg(ix)))
  ELSE
    yvarbc(ix)%llbkgcon  = .false.
    yvarbc(ix)%bkgerr(1:inparam) = -1.0_JPRB
  ENDIF

  IF (incount==0) THEN ! this parameter group is not active in minimisation;
                       ! use the identity for change-of-variable routines
    yvarbc(ix)%llbkgcon = .false.
    yvarbc(ix)%achgvar = 0.0_JPRB
    yvarbc(ix)%acvarin = 0.0_JPRB
    DO ip = 1, inparam
      yvarbc(ix)%achgvar(ip,ip) = 1.0_JPRB
      yvarbc(ix)%acvarin(ip,ip) = 1.0_JPRB
    ENDDO

  ELSE  ! this parameter group is active
  
! Approximate the Hessian for this group, based on predictor 
! statistics collected in the previous trajectory run
! ----------------------------------------------------------
    DO ip = 1, inparam
      i = yvarbc(ix)%npredcs(ip)
      DO jp = ip, inparam
        j = yvarbc(ix)%npredcs(jp)
        zhessian(ip,jp) = (incount/yvarbc(ix)%obserr**2)*(APREDXCOV(i,j,ix) + &
                                              & APREDMEAN(i,ix)*APREDMEAN(j,ix))
        zhessian(jp,ip) = zhessian(ip,jp) ! (not necessary)
      ENDDO
      IF (yvarbc(ix)%llbkgcon) &
      & zhessian(ip,ip) = 1.0_JPRB/yvarbc(ix)%bkgerr(ip)**2 + zhessian(ip,ip)
    ENDDO

! Compute the symmetric square root (using LAPACK routines DSYTRD and DSTEQR)

    IF (inparam==1) THEN      ! scalar case (one predictor)
                              ! ---------------------------
      zeignval(1) = zhessian(1,1)
      IF (zeignval(1)<=0) THEN
        WRITE(nulerr,*) myname//': group ', ix, ' eigenvalue: ', zeignval(1)
        CALL ABOR1(myname//': non-positive hessian')
      ENDIF
      yvarbc(ix)%achgvar(1,1) =          SQRT(zeignval(1))
      yvarbc(ix)%acvarin(1,1) = 1.0_JPRB/SQRT(zeignval(1))

    ELSE                      ! matrix case (more than one predictor)
                              ! -------------------------------------
      CALL dsytrd('U',inparam,zhessian,jpmxnparam,zeignval,zsubdiag,&
                 &    ztau,zwork,jpmxnparam*jpmxnparam,info(1))
      IF (info(1)/=0) THEN
        WRITE(nulerr,*) myname//': info = ', info(1), ' on return from DSYTRD'
        CALL ABOR1(myname//': problem with DSYTRD')
      ENDIF
      CALL dsteqr('I',inparam,zeignval,zsubdiag,zeignvec,jpmxnparam,zwork,info(1))
      IF (info(1)/=0) THEN
        WRITE(nulerr,*) myname//': info = ', info(1), ' on return from DSTEQR'
        CALL ABOR1(myname//': problem with DSTEQR')
      ENDIF
      IF (ANY(zeignval(1:inparam)<=0)) THEN
        WRITE(nulerr,*) myname//': group ', ix, ' eigenvalues: ', &
                                  & zeignval(1:inparam)
        CALL ABOR1(myname//': non-positive hessian')
      ENDIF
      DO ip = 1, inparam
        DO jp = ip, inparam
          yvarbc(ix)%achgvar(ip,jp) = SUM(zeignvec(ip,1:inparam) * &
           & SQRT(         zeignval(1:inparam))*zeignvec(jp,1:inparam))  
          yvarbc(ix)%achgvar(jp,ip) = yvarbc(ix)%achgvar(ip,jp)
          yvarbc(ix)%acvarin(ip,jp) = SUM(zeignvec(ip,1:inparam) * &
           & SQRT(1.0_JPRB/zeignval(1:inparam))*zeignvec(jp,1:inparam))  
          yvarbc(ix)%acvarin(jp,ip) = yvarbc(ix)%acvarin(ip,jp)
        ENDDO
      ENDDO

    ENDIF

  ENDIF

ENDDO

! Print the table
! ---------------
CALL print_table(0)
CALL print_table(1)
CALL print_table(6)

CALL GSTATS(1979,1)

IF (lhook) CALL dr_hook(myname,1,zhook_handle)

END SUBROUTINE setup_min   
!-----------------------------------------------------------------------------

SUBROUTINE data_stats

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

INTEGER(KIND=JPIM) :: iret, info(1), ilen, ix, jobs, jlev
REAL(KIND=JPRB)    :: zinfo(0), zhook_handle, zerr

INTEGER(KIND=JPIM) :: indata(jpmxngroup)
REAL(KIND=JPRB)    :: zsfoesq(jpmxngroup)
REAL(KIND=JPRB)    :: zobserr(jpmxngroup)

REAL(KIND=JPRB), ALLOCATABLE :: zsfoesq_comp(:,:)

#include "openmp_obs.h"

IF (lhook) CALL dr_hook(myname,0,zhook_handle)

WRITE (nulout,'(/,a)') myname//': Get data counts and obs errors'

! Get data counts and typical obs error std dev
! ---------------------------------------------
CALL GETDB('VARBC_SETUP', 0, iret, info, 0, zinfo, 0, -1, -1, -1, -1, -1, -1)  

ilen = iret

IF (LREPRO4DVAR) ALLOCATE(zsfoesq_comp(nobgroup,ilen))

indata(:) = 0
zsfoesq(:) = 0.0_JPRB
DO jobs = 1, ilen
  DO jlev = MLNKH2B(jobs), MLNKH2B(jobs+1)-1
    ix   = ROBODY(jlev,MDB_VARBC_IX_AT_BODY)
    zerr = ROBODY(jlev,MDBFOE)
    IF (ix>0 .AND. zerr/=RMDI) THEN
      indata(ix)  = indata(ix)  + 1
      zsfoesq(ix) = zsfoesq(ix) + zerr**2
      IF (LREPRO4DVAR) zsfoesq_comp(ix,indata(ix)) = zerr**2
    ENDIF
  ENDDO
ENDDO
  
CALL PUTDB('VARBC_SETUP',0,iret,info,0,zinfo,0)

! Sum over all PE's

CALL GSTATS(309,0)
IF (.NOT. LREPRO4DVAR) THEN
  CALL mpl_allreduce(zsfoesq,'sum',ldreprod=.true.,CDSTRING=myname)
ELSE
  CALL order_indep_global_sum2(zsfoesq_comp,zsfoesq,nobgroup,2,indata)
ENDIF

CALL mpl_allreduce(indata ,'sum',ldreprod=.true.,CDSTRING=myname)
CALL GSTATS(309,1)

DO ix = 1, nobgroup
  zobserr(ix) = 0.0_JPRB
  IF (indata(ix)>0) THEN
    zobserr(ix) = SQRT(zsfoesq(ix)/indata(ix))
    IF (zobserr(ix)==0) CALL ABOR1(myname//': Active data with zero obs error')
  ENDIF
  yvarbc(ix)%ncount = indata(ix)
  yvarbc(ix)%obserr = zobserr(ix)
ENDDO

IF (LREPRO4DVAR) DEALLOCATE(zsfoesq_comp)

IF (lhook) CALL dr_hook(myname,1,zhook_handle)

END SUBROUTINE data_stats   
!-----------------------------------------------------------------------------

SUBROUTINE set_varbcix

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

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

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

INTEGER(KIND=JPIM)              :: jg, ig
INTEGER(KIND=JPIM), ALLOCATABLE :: ix(:)
REAL(KIND=JPRB)                 :: zhook_handle

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

IF (lhook) CALL dr_hook(myname,0,zhook_handle)

WRITE (nulout,'(/,a)') myname//': Defining VarBC group indices'

ALLOCATE(ix(nobgroup), ckeys(nobgroup)) 

! Set indices for each class
! --------------------------
ig = 0
DO jg = 1, nobgroup
  IF (yvarbc(jg)%obsclass /= 'rad') CYCLE
  ig        = ig + 1
  ckeys(ig) = yvarbc(jg)%groupkey
  ix(ig)    = jg
ENDDO
CALL varbc_rad_varbcix (ckeys, ix, ig)

ig = 0
DO jg = 1, nobgroup
  IF (yvarbc(jg)%obsclass /= 'allsky') CYCLE
  ig        = ig + 1
  ckeys(ig) = yvarbc(jg)%groupkey
  ix(ig)    = jg
ENDDO
CALL varbc_allsky_varbcix (ckeys, ix, ig)

ig = 0
DO jg = 1, nobgroup
  IF (yvarbc(jg)%obsclass /= 'to3') CYCLE
  ig        = ig + 1
  ckeys(ig) = yvarbc(jg)%groupkey
  ix(ig)    = jg
ENDDO
CALL varbc_to3_varbcix (ckeys, ix, ig)

ig = 0
DO jg = 1, nobgroup
  IF (yvarbc(jg)%obsclass /= 'tcwv') CYCLE
  ig        = ig + 1
  ckeys(ig) = yvarbc(jg)%groupkey
  ix(ig)    = jg
ENDDO
CALL varbc_tcwv_varbcix (ckeys, ix, ig)

ig = 0
DO jg = 1, nobgroup
  IF (yvarbc(jg)%obsclass /= 'airep') CYCLE
  ig        = ig + 1
  ckeys(ig) = yvarbc(jg)%groupkey
  ix(ig)    = jg
ENDDO
CALL varbc_airep_varbcix (ckeys, ix, ig)

DEALLOCATE(ix, ckeys) 

IF (lhook) CALL dr_hook(myname,1,zhook_handle)

END SUBROUTINE set_varbcix

!-----------------------------------------------------------------------------
SUBROUTINE groupdescr (cdclass, cdkey, cdescr)

!-----------------------------------------------------------------------
! Returns group description for printing

! cdclass:    class that the group belongs to
! cdkey:      class-dependent key
! cdescr:     string suitable for printing

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

CHARACTER(LEN=100) :: clw  ! local workspace
INTEGER(KIND=JPIM) :: ilen
REAL(KIND=JPRB)    :: zhook_handle

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

IF (lhook) CALL dr_hook(myname,0,zhook_handle)

clw(:) = ' '
IF (cdclass=='rad') THEN
  CALL varbc_rad_groupdescr (cdkey, clw)
ELSEIF (cdclass=='allsky') THEN
  CALL varbc_allsky_groupdescr (cdkey, clw)
ELSEIF (cdclass=='to3') THEN
  CALL varbc_to3_groupdescr (cdkey, clw)
ELSEIF (cdclass=='tcwv') THEN
  CALL varbc_tcwv_groupdescr (cdkey, clw)
ELSEIF (cdclass=='airep') THEN
  CALL varbc_airep_groupdescr (cdkey, clw)
ELSE
  IF (LEN(cdclass)+LEN(TRIM(cdkey))>=LEN(clw)) CALL ABOR1(myname//': Increase LEN(clw)')  
  clw = cdclass//' '//TRIM(cdkey)
ENDIF

ilen = LEN(TRIM(clw))
IF (LEN(cdescr)<ilen) CALL ABOR1(myname//': Increase LEN(cdescr)')
cdescr(:) = ' '
cdescr(1:ilen) = TRIM(clw)

IF (lhook) CALL dr_hook(myname,1,zhook_handle)

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

SUBROUTINE dump_table
!-----------------------------------------------------------------------
!   dump_table - Write file with variational bias parameter information

!   Purpose.
!   --------
!   Cycling of variational bias parameter information

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

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

INTEGER(KIND=JPIM) :: ioproc, ios, jg, inparam
REAL(KIND=JPRB)    :: zhook_handle
CHARACTER(LEN=100) :: clabel

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

IF (lhook) CALL dr_hook(myname,0,zhook_handle)

WRITE(nulout,'(/,a)') &
 & myname//': Writing VarBC information to file '//trim(cdfname)  
WRITE(nulout,'(/,a,a4,a,i8,a,i6)') &
 & myname//': expid = ', cnmexp(1:4), &
 &          ' date = ', nandat, &
 &          ' time = ', nantim
 
!  Write the table to file
!  -----------------------
ioproc = 1
IF (myproc==ioproc) THEN

  OPEN(nultmp,file=trim(cdfname),form='formatted',status='replace',iostat=ios)
  IF (ios/=0) CALL ABOR1(myname//': Cannot open file '//trim(cdfname))

! Header information
! ------------------
  WRITE(nultmp,'(a,i3.3)') 'VARBC_cycle.version', jpversion
  WRITE(nultmp,*) cnmexp(1:4), nandat, nantim
  WRITE(nultmp,*) nobgroup, nobparam

! Record for each bias group
! --------------------------
  inparam = 0
  DO jg = 1, nobgroup
    CALL groupdescr ( yvarbc(jg)%obsclass, yvarbc(jg)%groupkey, clabel )
    WRITE(nultmp,'(a,i0)')              'ix='    , jg 
    WRITE(nultmp,'(a,a)')               'class=' , TRIM(yvarbc(jg)%obsclass) 
    WRITE(nultmp,'(a,a)')               'key='   , TRIM(yvarbc(jg)%groupkey)   
    WRITE(nultmp,'(a,a)')               'label=' , TRIM(clabel)
    WRITE(nultmp,'(a,i0)')              'ndata=' , yvarbc(jg)%ncount 
    WRITE(nultmp,'(a,i0)')              'npred=' , yvarbc(jg)%nparam
    WRITE(nultmp,'(a,999(i0,x))')       'predcs=', yvarbc(jg)%npredcs
    WRITE(nultmp,'(a,999(es10.3e2,x))') 'param0=', yvarbc(jg)%aparam0
    WRITE(nultmp,'(a,999(es10.3e2,x))') 'params=', yvarbc(jg)%aparams
    WRITE(nultmp,'(a,999(i0,x))')       'hstgrm=', yvarbc(jg)%nhstfgdep
    inparam = inparam + yvarbc(jg)%nparam
  ENDDO

  IF (nobparam /= inparam) CALL ABOR1(myname//': Inconsistent parameter count.')

! Predictor statistics
! --------------------
  WRITE(nultmp,'(a,i0)')              'numpreds=', SIZE(MPREDXCNT,1)
  DO jg = 1, nobgroup
    WRITE(nultmp,'(a,i0)')              'ix='      , jg 
    WRITE(nultmp,'(a,999(i0,x))')       'predxcnt=', MPREDXCNT(:,:,jg)
    WRITE(nultmp,'(a,999(es10.3e2,x))') 'predmean=', APREDMEAN(:,jg)
    WRITE(nultmp,'(a,999(es10.3e2,x))') 'predxcov=', APREDXCOV(:,:,jg)
  ENDDO
  
  CLOSE(nultmp)

ENDIF

WRITE(nulout,'(a,i4,a,i5,a)') &
 & myname//': Wrote ', nobgroup, ' groups with ', nobparam, ' parameters'  
WRITE(nulout,'(a)') &
 & myname//': Wrote predictor statistics'  

IF (lhook) CALL dr_hook(myname,1,zhook_handle)

END SUBROUTINE dump_table
!-----------------------------------------------------------------------------

SUBROUTINE load_table ()
!-----------------------------------------------------------------------
!   LOAD_TABLE - Read VarBC table from file

!   Purpose.
!   --------
!   Cycling of variational bias parameter information 

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

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

INTEGER(KIND=JPIM)  :: ios, ig, jg, inparam, idate, itime, iversion
INTEGER(KIND=JPIM) :: ipred, incheck, icdtype
CHARACTER(LEN=4)    :: clexpid
CHARACTER(LEN=80)   :: clheader
CHARACTER(LEN=10000):: cline
LOGICAL             :: llexist
REAL(KIND=JPRB)     :: zhook_handle

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

IF (lhook) CALL dr_hook(myname,0,zhook_handle)

WRITE(nulout,'(/,a)') myname//': Reading bias information from file '//trim(cdfname)  

INQUIRE(file=trim(cdfname),exist=llexist)

IF (.NOT. llexist) THEN

  WRITE(nulout,'(a)') myname//': No such file '//trim(cdfname)
  nobgroup = 0
  nobparam = 0

ELSE ! Read on all processors

  OPEN(nultmp,file=trim(cdfname),form='formatted',status='old',iostat=ios)
  IF (ios/=0) CALL ABOR1(myname//': Cannot open file '//trim(cdfname))

! Read header information
! -----------------------
  READ(nultmp,'(a)') clheader
  IF(clheader(1:11) == 'VARBC_cycle') THEN
    READ(clheader,'(19x,i3)') iversion
    READ(nultmp,*) clexpid, idate, itime
  ELSE
    iversion = 0
    READ(clheader,*) clexpid, idate, itime
  ENDIF
  WRITE(nulout,'(a,a4,a,i8,a,i6,a,i3)') & 
 & myname//': expid = ', clexpid(1:4), &
 &          ' date = ', idate, &
 &          ' time = ', itime,&
 &          ' file version ',iversion
  IF (iversion /= jpversion) &
 &  WRITE(nulout,'(a,i3)') myname//': Current VarBC version is ', jpversion 
 
  READ(nultmp,*) nobgroup, nobparam
  IF (nobgroup>jpmxngroup) CALL ABOR1(myname//': Increase jpmxngroup')

! Read parameter information for each data group
! ----------------------------------------------
  incheck = 0
  DO jg = 1, nobgroup
    IF (iversion == jpversion .OR. iversion >= 4) THEN

      READ(nultmp,'(a)') cline
      READ(cline(4:),*) ig

      IF (jg /= ig) CALL ABOR1(myname//': Inconsistent group index.')

      READ(nultmp,'(a)') cline
      yvarbc(jg)%obsclass = cline(7:)

      READ(nultmp,'(a)') cline
      yvarbc(jg)%groupkey = cline(5:)

      READ(nultmp,'(a)') cline               ! skip label

      READ(nultmp,'(a)') cline
      READ(cline(7:),*) yvarbc(jg)%ncount

      READ(nultmp,'(a)') cline
      READ(cline(7:),*) yvarbc(jg)%nparam

      inparam = yvarbc(jg)%nparam
      ALLOCATE(yvarbc(jg)%npredcs(inparam), yvarbc(jg)%aparam0(inparam), &
             & yvarbc(jg)%aparams(inparam), yvarbc(jg)%nhstfgdep(nhstbins))

      READ(nultmp,'(a)') cline
      READ(cline(8:),*) yvarbc(jg)%npredcs

      READ(nultmp,'(a)') cline
      READ(cline(8:),*) yvarbc(jg)%aparam0
      WHERE (ABS(yvarbc(jg)%aparam0/RMDI - 1.0)<0.01) yvarbc(jg)%aparam0 = RMDI
      
      READ(nultmp,'(a)') cline
      READ(cline(8:),*) yvarbc(jg)%aparams
      WHERE (ABS(yvarbc(jg)%aparams/RMDI - 1.0)<0.01) yvarbc(jg)%aparams = RMDI
      
      READ(nultmp,'(a)') cline
      READ(cline(8:),*) yvarbc(jg)%nhstfgdep
      
    ELSE ! older versions
      CALL read_oldtables (iversion, jg, inparam)
    ENDIF
    incheck = incheck + inparam
  ENDDO

  WRITE(nulout,'(a,i5,a,i5,a)') &
     & myname//': Read ', nobgroup, ' groups with ', nobparam, ' parameters'  

  IF (nobparam /= incheck) CALL ABOR1(myname//': Inconsistent parameter count.')

! Read predictor statistics
! -------------------------
  IF (iversion==jpversion .or. iversion>=4) THEN

    READ(nultmp,'(a)') cline
    READ(cline(10:),*) ipred
    IF (ipred-1>JPMXNPRED) CALL ABOR1(myname//': Increase JPMXNPRED.') 

    IF (iversion==4) THEN
      
      READ(nultmp,'(a)') cline
      READ(cline(10:),*) mpredxcnt(0:ipred-1,0:ipred-1,1)
      
      READ(nultmp,'(a)') cline
      READ(cline(10:),*) apredmean(0:ipred-1,1)
      
      READ(nultmp,'(a)') cline
      READ(cline(10:),*) apredxcov(0:ipred-1,0:ipred-1,1)

      ! In old versions, predictor stats are global. As first approximation, copy this to all groups
      DO jg = 2, nobgroup
        mpredxcnt(0:ipred-1,0:ipred-1,jg) = mpredxcnt(0:ipred-1,0:ipred-1,1)
        apredmean(0:ipred-1,jg)           = apredmean(0:ipred-1,1)
        apredxcov(0:ipred-1,0:ipred-1,jg) = apredxcov(0:ipred-1,0:ipred-1,1)
      ENDDO

    ELSE
     
      DO jg = 1, nobgroup
      
        READ(nultmp,'(a)') cline
        READ(cline(4:),*) ig

        IF (jg /= ig) CALL ABOR1(myname//': Inconsistent group index in predictor stats')

        READ(nultmp,'(a)') cline
        READ(cline(10:),*) mpredxcnt(0:ipred-1,0:ipred-1,jg)
      
        READ(nultmp,'(a)') cline
        READ(cline(10:),*) apredmean(0:ipred-1,jg)
      
        READ(nultmp,'(a)') cline
        READ(cline(10:),*) apredxcov(0:ipred-1,0:ipred-1,jg)

      ENDDO
    ENDIF

  ELSE ! older versions
    IF (iversion==0) THEN
      ipred = 10
    ELSEIF (iversion==1) THEN
      ipred = 11
    ELSEIF (iversion==2 .or. iversion==3) THEN  
      READ(nultmp,*) ipred
    ENDIF
     
    READ(nultmp,*) mpredxcnt(0:ipred,0:ipred,1), apredmean(0:ipred,1), apredxcov(0:ipred,0:ipred,1)
    ! In old versions, predictor stats are global. As first approximation, copy this to all groups
    DO jg = 2, nobgroup
      mpredxcnt(0:ipred-1,0:ipred-1,jg) = mpredxcnt(0:ipred-1,0:ipred-1,1)
      apredmean(0:ipred-1,jg)           = apredmean(0:ipred-1,1)
      apredxcov(0:ipred-1,0:ipred-1,jg) = apredxcov(0:ipred-1,0:ipred-1,1)
    ENDDO
  ENDIF

  WRITE(nulout,'(a)') &
     & myname//': Read predictor statistics'  

  CLOSE(nultmp)

  IF (nproc>1) CALL MPL_BARRIER(CDSTRING=myname)

ENDIF

IF (lhook) CALL dr_hook(myname,1,zhook_handle)

END SUBROUTINE load_table
!-----------------------------------------------------------------------------

SUBROUTINE read_oldtables (kversion, kg, knparam)

! Deal with older versions of the VARBC.cycle file
! (radiance data only prior to version 3)
! ------------------------------------------------

INTEGER(KIND=JPIM), INTENT(IN)    :: kversion, kg 
INTEGER(KIND=JPIM), INTENT(OUT)   :: knparam

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

INTEGER(KIND=JPIM)           :: iinfo(1:6), ig, icdtype
REAL(KIND=JPRB), ALLOCATABLE :: zdummy(:)
REAL(KIND=JPRB)              :: zhook_handle

IF (lhook) CALL dr_hook(myname,0,zhook_handle)

IF (kversion == 0) THEN

  READ(nultmp,*) iinfo(1:5)
  yvarbc(kg)%obsclass = 'rad'   ! radiance data only
  yvarbc(kg)%nparam   = iinfo(4)         
  yvarbc(kg)%ncount   = iinfo(5)  
  WRITE(yvarbc(kg)%groupkey,'(3(i0,x))') iinfo(1:3)

ELSEIF (kversion <= 2) THEN

  READ(nultmp,*) iinfo(1:6)
  yvarbc(kg)%obsclass = 'rad'   ! radiance data only
  yvarbc(kg)%nparam   = iinfo(5)         
  yvarbc(kg)%ncount   = iinfo(6)
  
  IF (iinfo(3)==210) THEN
    WRITE(yvarbc(kg)%groupkey,'(3(i0,x))') iinfo(1:2),iinfo(4)
  ELSE
    yvarbc(kg)%obsclass = 'none'     ! to be removed
  ENDIF

ELSEIF (kversion == 3) THEN

  READ(nultmp,'(i6,x,i2,x,i7,x,i3,4x,a80)') ig,       &
               & yvarbc(kg)%nparam,  &
               & yvarbc(kg)%ncount,  & 
               & icdtype,           & 
               & yvarbc(kg)%groupkey
  IF (kg /= ig) CALL ABOR1(myname//': Inconsistent group index.')
  IF     (icdtype==210) THEN
    yvarbc(kg)%obsclass = 'rad'      ! radiance data
  ELSEIF (icdtype==215) THEN       
    yvarbc(kg)%obsclass = 'allsky'   ! allsky radiance data
  ELSEIF (icdtype==206) THEN       
    yvarbc(kg)%obsclass = 'to3'      ! ozone data
  ELSE
    yvarbc(kg)%obsclass = 'none'     ! to be removed
  ENDIF

ELSE

  CALL ABOR1(myname//': Cannot read this version.')

ENDIF

knparam = yvarbc(kg)%nparam
ALLOCATE(yvarbc(kg)%npredcs(knparam))
ALLOCATE(yvarbc(kg)%aparams(knparam))
ALLOCATE(yvarbc(kg)%aparam0(knparam))
ALLOCATE(yvarbc(kg)%nhstfgdep(nhstbins))

IF (kversion <= 2) THEN

  ALLOCATE(zdummy(knparam))
  READ(nultmp,*) yvarbc(kg)%npredcs, yvarbc(kg)%aparams, yvarbc(kg)%aparam0, zdummy 
  yvarbc(kg)%nhstfgdep = 0  ! No histograms
  DEALLOCATE(zdummy)

ELSEIF (kversion == 3) THEN

  READ(nultmp,*) yvarbc(kg)%npredcs
  READ(nultmp,*) yvarbc(kg)%aparam0
  READ(nultmp,*) yvarbc(kg)%aparams
  READ(nultmp,*) yvarbc(kg)%nhstfgdep

ENDIF  

IF (lhook) CALL dr_hook(myname,1,zhook_handle)

END SUBROUTINE read_oldtables
!-----------------------------------------------------------------------------

SUBROUTINE print_table (ktable)
!-----------------------------------------------------------------------
!   print_table - Print variational bias parameter information

!   Purpose.
!   --------
!   Print variational bias parameter information

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

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

INTEGER(KIND=JPIM),INTENT(IN) :: ktable 

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

INTEGER(KIND=JPIM) :: jg, jp, ip
CHARACTER(LEN=10)  :: clpred(0:jpmxnpred)
CHARACTER(LEN=22)  :: cldesc
CHARACTER(LEN=100) :: cldesc_long
REAL(KIND=JPRB)    :: zhook_handle

IF (lhook) CALL dr_hook(myname,0,zhook_handle)

DO ip = 0, jpmxnpred
   
  IF (ip<10) THEN
    WRITE(clpred(ip),'(a1,i1,8x)') 'p', ip
  ELSE
    WRITE(clpred(ip),'(a1,i2,7x)') 'p', ip
  ENDIF
ENDDO

SELECT CASE (ktable)

CASE (0) ! group definitions

  WRITE(nulout,'(/,a)') 'VarBC indices and group descriptions:'  
  WRITE(nulout,'(a)') '(begin varbc table 0)'
  DO jg = 1, nobgroup
    cldesc_long(:) = ' '
    IF (yvarbc(jg)%obsclass=='rad') &
        & CALL VARBC_RAD_GROUPDESCR (yvarbc(jg)%groupkey, cldesc_long)
    IF (yvarbc(jg)%obsclass=='allsky') &
        & CALL VARBC_ALLSKY_GROUPDESCR (yvarbc(jg)%groupkey, cldesc_long)
    IF (yvarbc(jg)%obsclass=='to3') &
        & CALL VARBC_TO3_GROUPDESCR (yvarbc(jg)%groupkey, cldesc_long)
    IF (yvarbc(jg)%obsclass=='tcwv') &
        & CALL VARBC_TCWV_GROUPDESCR (yvarbc(jg)%groupkey, cldesc_long)
    IF (yvarbc(jg)%obsclass=='airep') &
        & CALL VARBC_AIREP_GROUPDESCR (yvarbc(jg)%groupkey, cldesc_long)
    WRITE(nulout,'(a,i4,a,4x,a)') 'varbcix=', jg, ':', cldesc_long
  ENDDO
  WRITE(nulout,'(a)') '(end varbc table 0)'

CASE (1) ! parameter values

  WRITE(nulout,'(/,a,31x,a)') 'Bias groups:','Bias parameters:'  
  WRITE(nulout,'(a,12x,99a10)') ' varbcix class (groupkey) count', clpred
  WRITE(nulout,'(a)') '(begin varbc table 1)'
  DO jg = 1, nobgroup
    clpred(0:jpmxnpred) = '   --       '
    DO jp = 1, yvarbc(jg)%nparam
      ip = yvarbc(jg)%npredcs(jp)
      IF (yvarbc(jg)%aparams(jp)==rmdi) THEN
              clpred(ip) = '  RMDI    '
      ELSE
        WRITE(clpred(ip),'(g10.2e2)') yvarbc(jg)%aparams(jp)
      ENDIF
    ENDDO
      cldesc = '('//yvarbc(jg)%groupkey(1:20)//')'
      IF (LEN_TRIM(yvarbc(jg)%groupkey)>20) cldesc(21:21)='>'
    WRITE(nulout,'(i4,1x,a8,1x,a22,2x,i8,1x,99a10)') &
                 & jg, yvarbc(jg)%obsclass, cldesc, yvarbc(jg)%ncount, clpred     
  ENDDO
  WRITE(nulout,'(a)') '(end varbc table 1)'

CASE (2) ! active data, background errors

  WRITE(nulout,'(/,a,31x,a)') 'Bias groups:','Background errors:'  
  WRITE(nulout,'(a,12x,99a10)') ' varbcix class (groupkey) count', clpred
  WRITE(nulout,'(a)') '(begin varbc table 2)'
  DO jg = 1, nobgroup
    IF (yvarbc(jg)%ncount>0) THEN
      clpred(0:jpmxnpred) = '   --     '
      DO jp = 1, yvarbc(jg)%nparam
        ip = yvarbc(jg)%npredcs(jp)
        IF (yvarbc(jg)%bkgerr(jp)>=0) THEN
          WRITE(clpred(ip),'(g10.2e1)') yvarbc(jg)%bkgerr(jp)
        ELSE
          clpred(ip) = '  Inf     '
        ENDIF
      ENDDO
      cldesc = '('//yvarbc(jg)%groupkey(1:20)//')'
      IF (LEN_TRIM(yvarbc(jg)%groupkey)>20) cldesc(21:21)='>'
      WRITE(nulout,'(i4,1x,a8,1x,a22,2x,i8,1x,99a10)') &
                   & jg, yvarbc(jg)%obsclass, cldesc, yvarbc(jg)%ncount, clpred     
    ENDIF
  ENDDO
  WRITE(nulout,'(a)') '(end varbc table 2)'

CASE (3) ! gradients

  WRITE(nulout,'(/,a,31x,a)') 'Bias groups:','Gradients:'  
  WRITE(nulout,'(a,12x,99a10)') ' varbcix class (groupkey) count', clpred
  WRITE(nulout,'(a)') '(begin varbc table 3)'
  DO jg = 1, nobgroup
    IF (yvarbc(jg)%ncount>0) THEN
      clpred(0:jpmxnpred) = '   --     '
      DO jp = 1, yvarbc(jg)%nparam
        ip = yvarbc(jg)%npredcs(jp)
        WRITE(clpred(ip),'(g10.2e2)') yvarbc(jg)%agrad(jp)
      ENDDO
      cldesc = '('//yvarbc(jg)%groupkey(1:20)//')'
      IF (LEN_TRIM(yvarbc(jg)%groupkey)>20) cldesc(21:21)='>'
      WRITE(nulout,'(i4,1x,a8,1x,a22,2x,i8,1x,99a10)') &
                   & jg, yvarbc(jg)%obsclass, cldesc, yvarbc(jg)%ncount, clpred     
    ENDIF
  ENDDO
  WRITE(nulout,'(a)') '(end varbc table 3)'

CASE (4) ! gradient reductions

  WRITE(nulout,'(/,a,31x,a)') 'Bias groups:','Gradient reductions:'  
  WRITE(nulout,'(a,12x,99a10)') ' varbcix class (groupkey) count', clpred
  WRITE(nulout,'(a)') '(begin varbc table 4)'
  DO jg = 1, nobgroup
    IF (yvarbc(jg)%ncount>0) THEN
      clpred(0:jpmxnpred) = '   --     '
      DO jp = 1, yvarbc(jg)%nparam
        ip = yvarbc(jg)%npredcs(jp)
        IF (yvarbc(jg)%agrad0(jp)/=0.0_JPRB) THEN
          WRITE(clpred(ip),'(g10.2e2)') ABS(yvarbc(jg)%agrad(jp)/yvarbc(jg)%agrad0(jp))
        ELSE
          WRITE(clpred(ip),'(g10.2e2)') 0.0_JPRB
        ENDIF
      ENDDO
      cldesc = '('//yvarbc(jg)%groupkey(1:20)//')'
      IF (LEN_TRIM(yvarbc(jg)%groupkey)>20) cldesc(21:21)='>'
      WRITE(nulout,'(i4,1x,a8,1x,a22,2x,i8,1x,99a10)') &
                   & jg, yvarbc(jg)%obsclass, cldesc, yvarbc(jg)%ncount, clpred     
    ENDIF
  ENDDO
  WRITE(nulout,'(a)') '(end varbc table 4)'

CASE (5) ! configuration options (traj)

  WRITE(nulout,'(/,a)') 'Bias group options (traj):'  
  WRITE(nulout,'(a)') '(begin varbc table 5)'
  DO jg = 1, nobgroup
    WRITE(nulout,'(2(a,i0),2(a,es6.1e1),2(a,i0),(a,l1))') &
                 & 'varbcix=', jg, &
                 & ' ndata=', yvarbc(jg)%ncount, &
                 & ' obserr=', yvarbc(jg)%obserr, &
                 & ' dfgdep=', yvarbc(jg)%dfgdep, &
                 & ' nparam=', yvarbc(jg)%nparam, &
                 & ' ncstart=', yvarbc(jg)%ncstart,&
                 & ' lmode=',   yvarbc(jg)%llmode
  ENDDO
  WRITE(nulout,'(a)') '(end varbc table 5)'

CASE (6) ! configuration options (min)

  WRITE(nulout,'(/,a)') 'Bias group options (min):'  
  WRITE(nulout,'(a)') '(begin varbc table 6)'
  DO jg = 1, nobgroup
    WRITE(nulout,'(2(a,i0),a,es6.1e1,a,i0,4(a,l1),a,99(l1,x))') &
                 & 'varbcix=', jg, &
                 & ' ndata=', yvarbc(jg)%ncount, &
                 & ' obserr=', yvarbc(jg)%obserr, &
                 & ' nparam=', yvarbc(jg)%nparam, &
                 & ' lbkgcon=', yvarbc(jg)%llbkgcon, &
                 & ' lmode=',   yvarbc(jg)%llmode, &
                 & ' lmaskrs=', yvarbc(jg)%llmaskrs, &
                 & ' lmaskcld=', yvarbc(jg)%llmaskcld, &
                 & ' lconst=', yvarbc(jg)%llconst(:)
  ENDDO
  WRITE(nulout,'(a)') '(end varbc table 6)'

END SELECT

IF (lhook) CALL dr_hook(myname,1,zhook_handle)

END SUBROUTINE print_table
!-----------------------------------------------------------------------------

SUBROUTINE compile_statistics

! Finalise histograms of background departures collected in HOP

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

INTEGER(KIND=JPIM) :: i, j, ii, iwork(nobgroup*nhstbins)
REAL(KIND=JPRB)    :: zhook_handle

IF (lhook) CALL dr_hook(myname,0,zhook_handle)

! Compile histograms of background departures collected in hop->taskob
! --------------------------------------------------------------------
IF (LSCREEN) THEN
  ii = 0
  DO i = 1, nobgroup
    DO j = 1, nhstbins
      ii = ii + 1
      iwork(ii)= yvarbc(i)%nhstfgdep(j)
    ENDDO
  ENDDO
  CALL GSTATS(309,0)
  CALL mpl_allreduce(iwork,'sum',ldreprod=.false.,CDSTRING=myname)
  CALL GSTATS(309,1)
  ii = 0
  DO i = 1, nobgroup
    DO j = 1, nhstbins
      ii = ii + 1
      yvarbc(i)%nhstfgdep(j) = iwork(ii)
    ENDDO
  ENDDO
ENDIF

! Compile predictor statistics collected in varbc_pred
! ----------------------------------------------------
CALL varbc_pred_stats

IF (lhook) CALL dr_hook(myname,1,zhook_handle)

END SUBROUTINE compile_statistics
!-----------------------------------------------------------------------------

END MODULE VARBC_setup
