module oneobmod
!$$$ module documentation block
!           .      .    .                                       .
! module:   oneobmod
!   prgmmr: kleist      org: np20                date: 2003-10-20
!
! abstract: module contains everything necessary for running single
!           observation experiments
!
! program history log:
!   2003-10-20  kleist
!   2004-05-13  kleist, documentation
!   2005-04-04  todling, fixed little endian ouput of prepqc file
!   2009-04-28  sienkiewicz - add text output for ozone level obs testing
!
! subroutines included:
!   sub init_oneobmod
!   sub oneobmakebufr
!   sub oneobo3lv
!
! variable definitions:
!   def maginnov   - magnitude of innovation for one ob exp
!   def magoberr   - magnitude of observational error for one ob exp
!   def oblat      - observation latitude for one ob exp
!   def oblon      - observation longitude for one ob exp
!   def obhourset  - observation delta time from analysis time for 
!                    one ob exp
!   def obpres     - observation pressure (hPa) or one ob exp
!   def obdattim   - observation date for one ob exp
!   def oneob_type - observation type for one ob exp
!   def oneobtest  - single observation test flag (true=on)
!   def pctswitch  - if true, innovation and error expressed as percentage
!                        of background value
!
!$$$
  use kinds, only: r_kind,i_kind

  implicit none

! set default to private
  private
! set subroutines to public
  public :: init_oneobmod
  public :: oneobmakebufr
  public :: oneobo3lv
! set passed variables to public
  public :: oneobtest,oneob_type,magoberr,pctswitch,maginnov
  public :: oblat,oblon,obpres,obdattim,obhourset

  real(r_kind) maginnov, magoberr, oblat, oblon,&
    obhourset, obpres
  integer(i_kind) obdattim
  character(10) oneob_type
  logical oneobtest
  logical pctswitch

contains

  subroutine init_oneobmod
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    init_oneobmod
!   prgmmr: kleist           org: np20                date: 2003-10-20
!
! abstract: initialize defaults for single ob experiment vars
!
! program history log:
!   2003-10-20  kleist
!   2004-05-13  kleist, documentation
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!$$$
    use constants, only: zero, one, r1000
    implicit none

    oneobtest=.false.
    maginnov=one
    magoberr=one
    oneob_type=' '
    oblat=zero
    oblon=zero
    obpres=r1000
    obdattim=2000010100_i_kind
    obhourset=zero
    pctswitch=.false.

    return
  end subroutine init_oneobmod

  subroutine oneobmakebufr
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    oneobmakebufr
!   prgmmr: kleist           org: np20                date: 2003-10-20
!
! abstract: create prepbufr file for single ob experiment
!
! program history log:
!   2003-10-20  kleist
!   2004-05-13  kleist  documentation
!   2006-04-06  middlecoff - changed lumk from 52 to lendian_in so one-obs prepqc 
!                            file can be read as little endian
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!$$$
    use constants, only: ione, zero, one, five, one_tenth
    use gsi_io, only: lendian_in
    use obsmod, only: offtime_data,iadate
    implicit none

    real(r_kind),parameter:: r0_01=0.01_r_kind
    real(r_kind),parameter:: r20=20.0_r_kind
    real(r_kind),parameter:: r100=100.0_r_kind

    integer(i_kind) ludx,nobs,nlev,idate
    character(8) subset,sid(1)
    real(r_kind),dimension(1):: typ
    real(r_kind),dimension(1,1):: qob,tob,zob,uob,vob,cat
    real(r_kind),dimension(1,1):: pqm,qqm,tqm,zqm,wqm
    real(r_kind),dimension(1,1):: poe,qoe,toe,woe
    real(r_kind),dimension(1):: xob,yob,dhr
    real(r_kind),dimension(1,1):: pob
    integer(i_kind) n,k,iret
    real(r_kind):: bmiss=10.e10_r_kind
    real(r_kind) hdr(10),obs(10,255),qms(10,255),err(10,255)
    character(80):: hdrstr='SID XOB YOB DHR TYP'
    character(80):: obsstr='POB QOB TOB ZOB UOB VOB CAT'
    character(80):: qmsstr='PQM QQM TQM ZQM WQM'
    character(80):: errstr='POE QOE TOE WOE'

    if (oneob_type == 'o3lev') then
       call oneobo3lv
       return
    end if
! set values from parameter list
    xob=oblon
    yob=oblat
    dhr=obhourset
    idate=iadate(1)*1000000+iadate(2)*10000+iadate(3)*100+iadate(4)
    write(6,*)idate
    pob=obpres
! set default values for this routine
    ludx=22_i_kind
    nobs=ione
    nlev=ione
    subset='ADPUPA'
    sid='SID00001'
    qob=r100
    tob=r20
    zob=zero
    uob=five
    vob=five
    pqm=one
    qqm=one
    tqm=one
    zqm=one
    wqm=one
    offtime_data=.true.
    if (oneob_type=='ps') then
       typ(1)=87._r_kind
       cat(1,1)=zero
    else
       typ(1)=20._r_kind
       cat(1,1)=one
    endif
! keep errs small so the single ob passes the QC check
    poe=r0_01
    qoe=one_tenth
    toe=one_tenth
    woe=one_tenth

    open(ludx,file='prepobs_prep.bufrtable',action='read')
#if defined(__osf__) || defined(__ia64__) && (__INTEL_COMPILER>799)
    open(lendian_in,file='prepqc',action='write',form='unformatted',convert='little_endian')
#else
    open(lendian_in,file='prepqc',action='write',form='unformatted')
#endif

    call datelen(10)
    call openbf(lendian_in,'OUT',ludx)
    do n=1,nobs
       hdr(1)=transfer(sid(n),hdr(1))
       hdr(2)=xob(n)
       hdr(3)=yob(n)
       hdr(4)=dhr(n)
       hdr(5)=r100+typ(n)
       obs=bmiss
       qms=bmiss
       err=bmiss
       do k=1,nlev
          obs(1,k)=pob(k,n)
          obs(2,k)=qob(k,n)
          obs(3,k)=tob(k,n)
          obs(4,k)=zob(k,n)
          obs(7,k)=cat(k,n)
          qms(1,k)=pqm(k,n)
          qms(2,k)=qqm(k,n)
          qms(3,k)=tqm(k,n)
          qms(4,k)=zqm(k,n)
          err(1,k)=poe(k,n)
          err(2,k)=qoe(k,n)
          err(3,k)=toe(k,n)
       enddo
       call openmb(lendian_in,subset,idate)
       call ufbint(lendian_in,hdr,10_i_kind,ione,iret,hdrstr)
       call ufbint(lendian_in,obs,10_i_kind,nlev,iret,obsstr)
       call ufbint(lendian_in,qms,10_i_kind,nlev,iret,qmsstr)
       call ufbint(lendian_in,err,10_i_kind,nlev,iret,errstr)
       call writsb(lendian_in)
       hdr(1)=transfer(sid(n),hdr(1))
       hdr(2)=xob(n)
       hdr(3)=yob(n)
       hdr(4)=dhr(n)
       hdr(5)=200_r_kind+typ(n)
       obs=bmiss
       qms=bmiss
       err=bmiss
       do k=1,nlev
          obs(1,k)=pob(k,n)
          obs(5,k)=uob(k,n)
          obs(6,k)=vob(k,n)
          obs(7,k)=cat(k,n)
          qms(1,k)=pqm(k,n)
          qms(5,k)=wqm(k,n)
          err(1,k)=poe(k,n)
          err(4,k)=woe(k,n)
       enddo
       call openmb(lendian_in,subset,idate)
       call ufbint(lendian_in,hdr,10_i_kind,ione,iret,hdrstr)
       call ufbint(lendian_in,obs,10_i_kind,nlev,iret,obsstr)
       call ufbint(lendian_in,qms,10_i_kind,nlev,iret,qmsstr)
       call ufbint(lendian_in,err,10_i_kind,nlev,iret,errstr)
       call writsb(lendian_in)
    enddo
    call closbf(lendian_in)

    return
  end subroutine oneobmakebufr

  subroutine oneobo3lv
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    oneobmls
!
! abstract: create ozone level text file for single ob experiment
!
! program history log:
!   2007-09-11  Sienkiewicz - extend to create MLS text file on request
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:  ?
!
!$$$
    use constants, only: izero, ione, zero, one
    implicit none

    integer(i_kind) lumk                          ! output unit
    integer(i_kind) ilev, isnd
    integer(i_kind) ildat(8),jldat(8)             ! "local" date/time
    real(r_kind)    rsec,rlnc(5)
    real(r_kind)    ppmv

2   format(i5,4i3,f6.2,i7,i5,f10.4,f11.4,e16.7,i7,i5,g16.7,g15.7,f6.3)

    lumk = 22_i_kind
    ilev = ione               ! ilev > 24 is passive
    isnd = ione
    ppmv = one                ! dummy value 

!    obdattim=2000010100

    rlnc = zero
    rlnc(2) = obhourset
    ildat(1) = obdattim  / 1000000                   ! year
    ildat(2) = mod(obdattim,1000000_i_kind)/10000    ! month
    ildat(3) = mod(obdattim,10000_i_kind)/100        ! day
    ildat(4) = izero
    ildat(5) = mod(obdattim,100_i_kind)              ! hour

    ildat(6:8) = izero                               ! (no minute/sec in obdattim)

    call w3movdat(rlnc,ildat,jldat)

    rsec = jldat(7)+jldat(8)*1.e-3_r_kind

! open data file for output.  for oneobtype gsimain sets the dfile(1) 
! to be prepqc
    open(unit=lumk,file='prepqc',form='formatted')

    write(lumk,2) jldat(1),jldat(2),jldat(3),jldat(5),jldat(6),rsec,isnd,&
         ilev,oblat,oblon,ppmv,isnd,isnd,magoberr,obpres,magoberr
    close(lumk)

    return

  end subroutine oneobo3lv

end module oneobmod