SUBROUTINE SUAMV
!**** *SUAMV - Sets up additional parameters for AMV/SATOBs
!              AMVs/SATOBs

!     Niels Bormann     ECMWF        22/06/2001

!     PURPOSE
!     -------
!     Set up
!     1) SATOBGRP_TABLE for SATOB/AMV observation sets.
!     2) Set up other info, e.g., regarding AMV/SATOB bias correction.

!**   INTERFACE
!     ---------
!     *CALL* *SUAMV*

!     suamv is called by suobs.

!     METHOD
!     ------
!     The SATOBRGP_TABLE is set up based on an ODB request, providing
!     sets of compuational method, type, and satellite.

!     An AMV/SATOB info file is read (if provided) which allows
!     the control of the AMV/SATOB height reassignment, the
!     observation operator, and other parameters, for each
!     AMV/SATOB group. This info file is an ASCII file,
!     and it consists of subsequent blocks of the following,
!     one for each correction model: 

!     A suite of parameters is set between "&amv_pcor_in" and "/",
!     in the usual FORTRAN-90 namelist way. These parameters are:
!     isat_id            : The (BUFR) satellite ID of the group affected.
!     icomp_method_number: The "computational method" for the group affected.
!     clobs_oper:          A string describing the observation operator 
!                          to be used. Valid options are: 
!                          "Single level" (default), "Gauss average"
!                          "RT average"
!     zsigma:              The sigma [Pa] to be used in the "Gauss average"
!                          Default: 5000.0 Pa
!     zsat_lon:            Longitude of the sub-satellite point
!     ipreds:              Number of predictors used for height reassignment
!                          for this group. Default: 0 (= height reassignment
!                          is switched off, but predictor calculation is
!                          switched on)
!     clpred_names:        Names of the predictors used (e.g., 'tb','shear'...
!                          see routine amv_reassign for the implemented 
!                          predictors)
!     lasym_fgcheck:       Perform asymetric FG check: .TRUE. (default)
!     (For testing purposes:)
!     zrejmod_factor:      FG check limits factor (default: 1.)
!     zoerr_factor:        Obs error tuning factor (default: 1.)

!     The regression coefficients for the height reassignment are given 
!     after the keyword BEGIN REGRESSIONS. The date interval (2 integers 
!     yyyymmdd) for which the coefficients are valid is given first, 
!     then the intercept, then the coefficients for the predictors, 
!     in the order of their names given in clpred_names above.

!     Things outside "&amv_pcor_in" and "/" and before "BEGIN REGRESSIONS"
!     will be ignored.

!     EXTERNALS
!     ---------
!     getdb - get data from ODB
!     putdb - put data back to ODB

!     MODIFICATIONS
!     -------------
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        N.Bormann     14-Nov-2007 Adjustments for AVHRR winds 
!        Y.Tremolet    29-May-2008 Print Jo table by bins
!---------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE PARDIMO  , ONLY : JPXVAR
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

USE yom_amv_reassign, ONLY : tpc_info, npc_info, &
 & jpmax_nam_len, jpmax_npreds, amv_pc_info,jpmax_regfiles
USE yomlun   , ONLY : nulout, nulerr
USE yomana   , ONLY : nandat
USE YOMANCS  , ONLY : NMDI
USE yomvar   , ONLY : lamv_reassign_passive
USE YOMTVRAD , ONLY : SATOBGRP_TABLE,NSATOBGRP, MXGEOSATN, CHGEOSATN,CHMETHOD,&
 & MXMETHOD  
USE YOMCOSJO , ONLY : JOT      ,NJOTTSZ  ,NJOTISZ, NPRTBINS
USE YOMCOCTP , ONLY : NSATOB   ,CCMOOTP
USE YOMDB

IMPLICIT NONE

! Local parameters
CHARACTER(LEN=13) :: clamv_reassign_info='amv_bias_info'
INTEGER(KIND=JPIM), PARAMETER  :: iutmp=77

! Local variables
TYPE(amv_pc_info), ALLOCATABLE, DIMENSION(:)   :: YL_TMP_PC_INFO ! Temporary 
!                                           storage for reassignment info
INTEGER(KIND=JPIM)             :: istat                    ! I/O status
INTEGER(KIND=JPIM)             :: idate_st, idate_end      ! YYYYMMDD read in
INTEGER(KIND=JPIM)             :: jcor
CHARACTER(LEN=256)     :: cldum
LOGICAL, ALLOCATABLE, DIMENSION(:)   :: llgood_pc_info
LOGICAL               :: llfileok
INTEGER(KIND=JPIM)    :: IDCHANNEL_PER_METHOD
CHARACTER(LEN=8)      :: CLIDCHANNEL_PER_METHOD

INTEGER(KIND=JPIM) :: IRET_SATOB,IMETHOD,INFO(1),ILEN,ICDTYP,ICDTYP_LAST,J,IGEOSATN
REAL(KIND=JPRB)    :: ZINFO(1)

! Namelist variables
INTEGER(KIND=JPIM)                   :: isat_id          ! SATID for which cor. is valid
INTEGER(KIND=JPIM)                   :: icomp_method_number! Comp. method number
INTEGER(KIND=JPIM)                   :: ipreds             ! Number of predictors used
CHARACTER(LEN=jpmax_nam_len),       &
 & DIMENSION(jpmax_npreds)           :: clpred_names       ! Names of predictors used  
REAL(KIND=JPRB)                      :: zsat_lon           ! Longitude of satellite
LOGICAL                              :: lasym_fgcheck      ! Asym check on/off
CHARACTER(LEN=32)                    :: clobs_oper         ! Obs operator method
REAL(KIND=JPRB)                      :: zsigma             ! Sigma used for obs operator
REAL(KIND=JPRB)                      :: zrejmod_factor     ! Factor for fg check tuning
REAL(KIND=JPRB)                      :: zoerr_factor       ! Factor for obs error tuning
REAL(KIND=JPRB) :: ZHOOK_HANDLE

NAMELIST  /amv_pcor_in/  isat_id, icomp_method_number, ipreds,&
 & clpred_names, zsat_lon, clobs_oper, zsigma, lasym_fgcheck,zrejmod_factor,&
 & zoerr_factor  

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

#include "abor1.intfb.h"

#include "openmp_obs.h"

!========================================================

!*       1. SET UP LOGISTIC PARAMETERS FOR SATOB COMPUTATIONS
!           -------------------------------------------------

IF (LHOOK) CALL DR_HOOK('SUAMV',0,ZHOOK_HANDLE)
IRET_SATOB = 0
NSATOBGRP=0
JOT(NSATOB)%size=0

!     1.1.1 ODB is asked to deliver a unique list of
!           satid, codetype and comp_method, for obstype=satob.

CALL GSTATS(1785,0)
CALL GETDB('GETSATOBID', 0, IRET_SATOB, INFO, 0, ZINFO,0,-1,-1,-1,-1,-1,-1)
CALL GSTATS(1785,1)

!     1.1.2 The ROBSU-array may contain duplicates; one per PE
!           The duplicates are removed in this loop.
ILEN=0
IF(IRET_SATOB > 0) THEN
  ICDTYP_LAST=ROBSU(1,MDB_CODETYPE_AT_HDR)
  ILEN=1
ENDIF
DO J=2,IRET_SATOB
  ICDTYP=ROBSU(J,MDB_CODETYPE_AT_HDR)
  IF(ROBSU(J,MDB_SATID_AT_SAT) /= ROBSU(ILEN,MDB_SATID_AT_SAT) .OR. &
     & ICDTYP                    /= ICDTYP_LAST .OR. &
     & ROBSU(J,MDBSBCMM)         /= ROBSU(ILEN,MDBSBCMM) ) THEN  
    ILEN=ILEN+1
    ROBSU(ILEN,MDB_SATID_AT_SAT)   =ROBSU(J,MDB_SATID_AT_SAT)
    ROBSU(ILEN,MDB_CODETYPE_AT_HDR)=ROBSU(J,MDB_CODETYPE_AT_HDR)
    ROBSU(ILEN,MDBSBCMM)           =ROBSU(J,MDBSBCMM)
    ICDTYP_LAST=ROBSU(ilen,MDB_CODETYPE_AT_HDR)
  ENDIF
ENDDO
NSATOBGRP=ILEN

WRITE(nulout,*) 'SUAMV: NSATOBGRP=',NSATOBGRP
IF(NSATOBGRP > 99)THEN
  WRITE(NULERR,*)'***PROGRAMMING ERROR IN SUAMV: NSATOBGRP > 99'
  CALL ABORTDB('SUAMV','NSATOBGRP > 99',NSATOBGRP)
ENDIF

ALLOCATE(SATOBGRP_TABLE(NSATOBGRP))
ALLOCATE(JOT(NSATOB)%jost(NSATOBGRP))
JOT(NSATOB)%size=NSATOBGRP
JOT(NSATOB)%name=CCMOOTP(NSATOB)
NJOTTSZ = NJOTTSZ + NSATOBGRP*NJOTISZ

do J=1,NSATOBGRP
  ICDTYP=ROBSU(J,MDB_CODETYPE_AT_HDR)
  IMETHOD=ROBSU(J,MDBSBCMM)

  SATOBGRP_TABLE(J)%bufrid   = ROBSU(j,MDB_SATID_AT_SAT)
  SATOBGRP_TABLE(J)%codetype = ICDTYP
  SATOBGRP_TABLE(J)%method   = IMETHOD
  SATOBGRP_TABLE(J)%satgroup = J
  SATOBGRP_TABLE(J)%obs_oper = 'Single level'
! Boxcar average implemeted, but remains passive
!  SATOBGRP_TABLE(J)%obs_oper = 'Boxcar average'
  SATOBGRP_TABLE(J)%asym_fgcheck = .TRUE.
!  SATOBGRP_TABLE(J)%sigma    = 0.0_JPRB
  SATOBGRP_TABLE(J)%sigma    = 5000.0_JPRB
  SATOBGRP_TABLE(J)%zrejmod_factor = 1.0_JPRB
  SATOBGRP_TABLE(J)%oerr_factor = 1.0_JPRB
  SATOBGRP_TABLE(J)%ipcor = 0

  SATOBGRP_TABLE(J)%rtid         = -9
  SATOBGRP_TABLE(J)%rtseries     = -9
  SATOBGRP_TABLE(J)%rtsubtype    = -9
  SATOBGRP_TABLE(J)%rtcoef_pos   = -9

  ALLOCATE(JOT(NSATOB)%jost(j)%cost (JPXVAR,NPRTBINS))
  ALLOCATE(JOT(NSATOB)%jost(j)%count(JPXVAR,NPRTBINS))
  ALLOCATE(JOT(NSATOB)%jost(j)%obimpact(JPXVAR,NPRTBINS))

  JOT(NSATOB)%jost(J)%codetype    = ICDTYP
  JOT(NSATOB)%jost(J)%cost(:,:)   = 0.0_JPRB
  JOT(NSATOB)%jost(J)%obserr(:)   = 0.0_JPRB
  JOT(NSATOB)%jost(J)%bgerr(:)    = 0.0_JPRB
  JOT(NSATOB)%jost(J)%obimpact(:,:) = 0.0_JPRB
  JOT(NSATOB)%jost(J)%count(:,:)    = 0
  JOT(NSATOB)%jost(J)%sname(1:32) = '                                '
  WRITE(JOT(NSATOB)%jost(J)%sname(10:14),'(I5)') &
         &    SATOBGRP_TABLE(J)%bufrid

  IGEOSATN=MOD(SATOBGRP_TABLE(J)%bufrid/100,10)
  IF(IGEOSATN >=0 .AND. IGEOSATN <= MXGEOSATN) THEN
    JOT(NSATOB)%jost(J)%sname(1:9)=CHGEOSATN(IGEOSATN)(1:9)
  ENDIF
  JOT(NSATOB)%jost(J)%sname(16:22) = 'METHOD='


  IF(ABS(IMETHOD) /= NMDI) THEN
      IDCHANNEL_PER_METHOD=IMETHOD/100
      IMETHOD=MOD(IMETHOD,100)
      IF(IMETHOD >= 0 .AND. IMETHOD <= MXMETHOD) THEN
         CLIDCHANNEL_PER_METHOD='        '
         IF(IDCHANNEL_PER_METHOD > 0 .AND. IDCHANNEL_PER_METHOD <= 9) THEN
            WRITE(CLIDCHANNEL_PER_METHOD,'(I1)') IDCHANNEL_PER_METHOD
         ELSEIF(IDCHANNEL_PER_METHOD >= 10 .AND. IDCHANNEL_PER_METHOD <= 99) THEN
            WRITE(CLIDCHANNEL_PER_METHOD,'(I2)') IDCHANNEL_PER_METHOD
         ELSEIF(IDCHANNEL_PER_METHOD >= 100 .AND. IDCHANNEL_PER_METHOD <= 999) THEN
            WRITE(CLIDCHANNEL_PER_METHOD,'(I3)') IDCHANNEL_PER_METHOD
         ENDIF
         JOT(NSATOB)%jost(J)%sname(23:32) = TRIM(CHMETHOD(IMETHOD))//TRIM(CLIDCHANNEL_PER_METHOD)
      ELSE
         JOT(NSATOB)%jost(J)%sname(23:32) = 'UNKNOWN'
         WRITE(nulerr,*) '***WARNING IN SUAMV: IMETHOD=',IMETHOD,' OUT OF RANGE', &
    &                   'CHECK IS NEEDED !'
!         CALL ABORTDB('SUAMV','IMETHOD OUT OF RANGE', IMETHOD)
      ENDIF
  ENDIF
enddo
CALL GSTATS(1785,0)
CALL PUTDB('GETSATOBID', 0, IRET_SATOB, INFO, 0, ZINFO, 0)
CALL GSTATS(1785,1)

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

!*      2.  READ HEIGHT REASSIGNMENT FILE
!       ---------------------------------

!       2.1 Open file and set up
   
IF(.NOT. lamv_reassign_passive) THEN
  WRITE(nulout,*) 'suamv: No additional info for AMV/SATOBs.'
  WRITE(nulout,*) '  No height reassignment.'
  npc_info = 0
  WRITE(nulout,*) 'SATOBGRPs:'
  WRITE(nulout,*) '=========='
  DO j=1,nsatobgrp
    WRITE(nulout,*) 'Satellite ID: ', satobgrp_table(j)%bufrid
    WRITE(nulout,*) 'Computational method: '//     &
     & TRIM(chmethod(MOD(satobgrp_table(j)%method,100)))
    WRITE(nulout,*) '  (',satobgrp_table(j)%method,')'
    WRITE(nulout,*) 'Asymmetric check: ',satobgrp_table(j)%asym_fgcheck
    WRITE(nulout,*) 'Obs operator method: ',satobgrp_table(j)%obs_oper
    IF(TRIM(satobgrp_table(j)%obs_oper) == 'Gauss average' .OR.&
      & TRIM(satobgrp_table(j)%obs_oper) == 'Boxcar average')THEN
      WRITE(nulout,*) '  Sigma: ',satobgrp_table(j)%sigma
    ENDIF
    WRITE(nulout,*) '-----------------------------------------------------'
  ENDDO
  IF (LHOOK) CALL DR_HOOK('SUAMV',1,ZHOOK_HANDLE)
  RETURN
ENDIF

INQUIRE(FILE=TRIM(clamv_reassign_info),EXIST=llfileok )

IF(.NOT. llfileok)THEN
  WRITE(nulout,*) 'ERROR suamv: Cannot read file '//TRIM(clamv_reassign_info) 
  WRITE(nulout,*) 'No pressure corrections applied.'
  npc_info = 0
  IF (LHOOK) CALL DR_HOOK('SUAMV',1,ZHOOK_HANDLE)
  RETURN
ELSE
  WRITE(nulout,*) 'INFO suamv: Opening '//TRIM(clamv_reassign_info)
  OPEN(iutmp,FORM='FORMATTED',ACTION='READ',STATUS='OLD',   &
   & FILE=TRIM(clamv_reassign_info))  
ENDIF

npc_info =  jpmax_regfiles   ! Maximum number of correction models
ALLOCATE(YL_TMP_PC_INFO(npc_info))
ALLOCATE(llgood_pc_info(npc_info))
llgood_pc_info = .FALSE.

WRITE(nulout,*) 'INFO suamv: Reading correction info for ',nandat

!       2.2   Read the correction file

DO jcor = 1,npc_info 
  icomp_method_number = 1
  ipreds = 0
  isat_id = -1
  lasym_fgcheck = .TRUE.
  clobs_oper = 'Single level'
  zsigma = 5000._JPRB
  zrejmod_factor = 1.0_JPRB
  zoerr_factor = 1.0_JPRB

!       2.2.1  Read the namelist part 

  READ(UNIT = iutmp, NML = amv_pcor_in, IOSTAT = istat)
  IF (istat /= 0) THEN
    EXIT
  ENDIF

!       2.2.2  Check that this satob group actually exists
  
  llgood_pc_info(jcor) = ANY(icomp_method_number == satobgrp_table%method    &
   & .AND. isat_id       == satobgrp_table%bufrid)  
 
!       2.2.3 Store values

  IF(zsigma < 1._JPRB)THEN
    WRITE(nulout,*) 'ERROR suamv: zsigma too small :',zsigma
    WRITE(nulout,*) ' satid, comp_method',isat_id,icomp_method_number 
    CALL ABOR1('Check corrections file '//TRIM(clamv_reassign_info))
  ENDIF
  WHERE(icomp_method_number == satobgrp_table%method    &
     & .AND. isat_id       == satobgrp_table%bufrid)  
    satobgrp_table%obs_oper     = clobs_oper
    satobgrp_table%sigma        = zsigma
    satobgrp_table%asym_fgcheck = lasym_fgcheck 
    satobgrp_table%zrejmod_factor = zrejmod_factor
    satobgrp_table%oerr_factor    = zoerr_factor
  ENDWHERE

  YL_TMP_PC_INFO(jcor)%sat_id      = isat_id
  YL_TMP_PC_INFO(jcor)%comp_method = icomp_method_number
  IF( ipreds > jpmax_npreds ) THEN
    WRITE(nulout,*) 'ERROR suamv: Too many predictors used: ipreds, max:', &
     & ipreds, jpmax_npreds  
    WRITE(nulout,*) 'No corrections for comp_method, satid',  &
     & icomp_method_number,isat_id  
    llgood_pc_info(jcor) = .FALSE.
    CYCLE
  ENDIF
  YL_TMP_PC_INFO(jcor)%npreds       = ipreds
  YL_TMP_PC_INFO(jcor)%pred_name(1:ipreds) = clpred_names(1:ipreds)
  YL_TMP_PC_INFO(jcor)%sat_lon      = zsat_lon

  IF (ipreds > 0) THEN
!       2.2.4  Search for next "REGRESSIONS" keyword

    DO 
      READ(UNIT = iutmp,FMT='(A20)',IOSTAT = istat) cldum
      IF(istat < 0) THEN
        WRITE(nulout,*) 'ERROR suamv: Missing BEGIN REGRESSIONS.'
        WRITE(nulout,*) 'No corrections for comp_method, satid',  &
         & icomp_method_number,isat_id        
        llgood_pc_info(jcor) = .FALSE.
        EXIT
      ENDIF
      IF(TRIM(cldum) == 'BEGIN REGRESSIONS') EXIT
      IF(TRIM(cldum) == 'END REGRESSIONS') THEN
        istat = 1
        EXIT
      ENDIF
    ENDDO

    IF(istat < 0) THEN
      EXIT
    ENDIF
    IF(istat == 1) THEN
      WRITE(nulout,*) 'INFO suamv: END REGRESSIONS before BEGIN REGRESSIONS.'
      WRITE(nulout,*) 'No corrections for comp_method, satid',  &
       & icomp_method_number,isat_id  
      llgood_pc_info(jcor) = .FALSE.
      CYCLE
    ENDIF

!       2.2.5  Read the coefficients and pick the one requested

    DO 
      READ(UNIT = iutmp,FMT='(A256)',IOSTAT = istat) cldum
      IF(TRIM(cldum) == 'END REGRESSIONS' .OR. istat < 0) THEN
        WRITE(nulout,*) 'INFO suamv: No coefficients for ',nandat
        WRITE(nulout,*) 'No corrections for comp_method, satid',  &
         & icomp_method_number,isat_id  
        llgood_pc_info(jcor) = .FALSE.
        EXIT
      ENDIF
      READ(cldum,FMT=*) idate_st, idate_end, &
       & YL_TMP_PC_INFO(jcor)%coef(0:ipreds)  
      IF( idate_st < nandat .AND. idate_end >= nandat) EXIT
    ENDDO
  ENDIF
ENDDO
CLOSE(iutmp)

!       2.3   Throw out unsuccessful or superflous correction models
!             Store reassignment info in final place

npc_info = COUNT(llgood_pc_info)

IF( npc_info == 0 )THEN
  WRITE(nulout,*) 'INFO suamv: No correction models provided'
  IF (LHOOK) CALL DR_HOOK('SUAMV',1,ZHOOK_HANDLE)
  RETURN
ENDIF

ALLOCATE(tpc_info(npc_info))
tpc_info = PACK(YL_TMP_PC_INFO, MASK = llgood_pc_info)
DEALLOCATE(YL_TMP_PC_INFO,llgood_pc_info)

!       2.4   Match up satobgrp_table and correction models

DO jcor=1,npc_info
  WHERE(tpc_info(jcor)%comp_method == satobgrp_table%method   &
     & .AND.tpc_info(jcor)%sat_id == satobgrp_table%bufrid)  
    satobgrp_table%ipcor = jcor
  ENDWHERE
ENDDO
IF(ANY( SATOBGRP_TABLE%ipcor <= 0         &
   & .AND. (.NOT. SATOBGRP_TABLE%asym_fgcheck)))THEN  
  WRITE(nulout,*) 'WARNING suamv: Asymmetric FG check should only be switched'
  WRITE(nulout,*) '  off for bias corrected winds. Switch has been overwritten'
  WRITE(nulout,*) '  for some wind.'
  WHERE(SATOBGRP_TABLE%ipcor <= 0 .AND. (.NOT. SATOBGRP_TABLE%asym_fgcheck))
    SATOBGRP_TABLE%asym_fgcheck = .TRUE.
  ENDWHERE
ENDIF

!       2.5   Give overview of information read

WRITE(nulout,*) 'Correction/obs operator information'
WRITE(nulout,*) '==================================='

DO j=1,nsatobgrp
  WRITE(nulout,*) 'Satellite ID: ', satobgrp_table(j)%bufrid
  WRITE(nulout,*) 'Computational method: '//     &
   & TRIM(chmethod(MOD(satobgrp_table(j)%method,100)))  
  WRITE(nulout,*) '  (',satobgrp_table(j)%method,')'
  WRITE(nulout,*) 'Asymmetric check: ',satobgrp_table(j)%asym_fgcheck
  WRITE(nulout,*) 'Obs operator method: ',satobgrp_table(j)%obs_oper
  IF(TRIM(satobgrp_table(j)%obs_oper) == 'Gauss average' .OR.&
    & TRIM(satobgrp_table(j)%obs_oper) == 'Boxcar average')THEN
    WRITE(nulout,*) '  Sigma: ',satobgrp_table(j)%sigma
  ENDIF
  WRITE(nulout,*) 'zrejmod_factor: ',SATOBGRP_TABLE(j)%zrejmod_factor
  WRITE(nulout,*) 'oerr_factor: ',SATOBGRP_TABLE(j)%oerr_factor
  IF(satobgrp_table(j)%ipcor > 0)THEN
    jcor = satobgrp_table(j)%ipcor
    WRITE(nulout,*) 'Satellite longitude: ', tpc_info(jcor)%sat_lon
    IF(tpc_info(jcor)%npreds > 0)THEN
      WRITE(nulout,FMT='(10(A10,1x))') ' Intercept',     &
       & ADJUSTR(tpc_info(jcor)%pred_name(1:tpc_info(jcor)%npreds))  
      WRITE(nulout,FMT='(10(F10.6,1x))') &
       & tpc_info(jcor)%coef(0:tpc_info(jcor)%npreds)  
    ENDIF
  ENDIF
  WRITE(nulout,*) '-----------------------------------------------------'
ENDDO

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

END SUBROUTINE SUAMV
