PROGRAM obsop_tprof
!===============================================================================
! PROGRAM: obsop_tprof
!
! USES:
!  use common
!  use params_model
!  use vars_model
!  use common_oceanmodel
!  use params_obs
!  use vars_obs
!  use common_obs_oceanmodel
!  use params_letkf,     ONLY: DO_ALTIMETRY, DO_SLA, DO_ADT, DO_DRIFTERS
!
!
! DESCRIPTION:
!   This program acts as the observation operator for salinity profiles.
!   It inputs observations of salinity profiles (yo)
!   and a single forecast (xf) and computes the H(xf) used to form the
!   innovations (yo-H(xf)) associated with that member.
!
! USAGE:
!   A separate instance is run independently for each member and timeslot
!   All observations are typically preprocessed to the letkf obs format, then
!   here they are read in and converted to the letkf obs2 format w/ H(x) data
!   for each member added in a new column.
!
! !REVISION HISTORY:
!   03/17/2016 Steve Penny separated obsop.f90 into separate files
!   04/03/2014 Steve Penny modified for use with OCEAN at NCEP.
!   04/03/2013 Takemasa Miyoshi created for SPEEDY atmospheric model.
!
!-------------------------------------------------------------------------------
! $Author: Steve Penny, Takemasa Miyoshi $
!===============================================================================

  USE common
  USE params_model
  USE vars_model
  USE common_oceanmodel
  USE params_obs,                ONLY: nobs, id_s_obs
  USE params_obs,                ONLY: DO_REMOVE_65N
  USE vars_obs
  USE common_obs_oceanmodel
  USE read_argo,                 ONLY: obs_data, read_argo_nc

  IMPLICIT NONE

  CHARACTER(slen) :: obsinfile='obsin.nc'     !IN (default)
  CHARACTER(slen) :: guesfile='gues'          !IN (default) i.e. prefix to '.ocean_temp_salt.res.nc'
  CHARACTER(slen) :: obsoutfile='obsout.dat'  !OUT(default)

  REAL(r_size), ALLOCATABLE :: elem(:)
  REAL(r_size), ALLOCATABLE :: rlon(:)
  REAL(r_size), ALLOCATABLE :: rlat(:)
  REAL(r_size), ALLOCATABLE :: rlev(:)
  REAL(r_size), ALLOCATABLE :: odat(:)
  REAL(r_size), ALLOCATABLE :: oerr(:)
  REAL(r_size), ALLOCATABLE :: ohx(:)
  REAL(r_size), ALLOCATABLE :: obhr(:)
  INTEGER     , ALLOCATABLE :: oqc(:)
  REAL(r_size), ALLOCATABLE :: v3d(:,:,:,:)
  REAL(r_size), ALLOCATABLE :: v2d(:,:,:)
  REAL(r_size) :: dk,tg,qg
  REAL(r_size) :: ri,rj,rk
  INTEGER :: i,j,k,n

  REAL(r_size) :: obserr_scaling=1.0d0 !STEVE: use this to scale the input observations
  REAL(r_size) :: obs_randselect=1.0d0 !STEVE: use this to select random input observations
  REAL(r_size), DIMENSION(1) :: rand

  LOGICAL :: remap_obs_coords = .true.

  !-----------------------------------------------------------------------------
  ! Debugging parameters
  !-----------------------------------------------------------------------------
  INTEGER :: bdyobs=2                 !STEVE: use of boundary obs.
                                      !       1 := less restrictive, remove obs inside boundary
                                      !       2 := remove all observations touching a boundary
  LOGICAL :: debug_obsfilter = .false.
  !STEVE: to adjust writing to output file
  LOGICAL :: verbose = .false.
  LOGICAL :: dodebug1 = .false.
  LOGICAL :: print1st = .true.

  INTEGER :: cnt_obs_u=0, cnt_obs_v=0, cnt_obs_t=0, cnt_obs_s=0
  INTEGER :: cnt_obs_ssh=0, cnt_obs_sst=0, cnt_obs_sss=0, cnt_obs_eta=0
  INTEGER :: cnt_obs_x=0, cnt_obs_y=0, cnt_obs_z=0
  INTEGER, DIMENSION(nv3d+nv2d), SAVE :: cnt_obs = 0

  !STEVE: for debugging observation culling:
  INTEGER :: cnt_yout=0, cnt_xout=0, cnt_zout=0, cnt_triout=0
  INTEGER :: cnt_rigtnlon=0, cnt_nearland=0, cnt_oerlt0=0, cnt_altlatrng=0

  !-----------------------------------------------------------------------------
  ! Instantiations specific to this observation type:
  !-----------------------------------------------------------------------------
  LOGICAL :: DO_REMOVE_BLACKSEA=.true.
  INTEGER :: cnt_blacksea=0
  !(none)

  !-----------------------------------------------------------------------------
  ! Initialize the common_oceanmodel module, and process command line options
  !-----------------------------------------------------------------------------
  CALL set_common_oceanmodel
  CALL process_command_line !(get: -obsin <obsinfile> -gues <guesfile> -obsout <obsoutfile>)

  !-----------------------------------------------------------------------------
  ! Read observations from file
  !-----------------------------------------------------------------------------
  CALL read_argo_nc(obsinfile,id_s_obs,obs_data,nobs)
  ALLOCATE( elem(nobs) )
  ALLOCATE( rlon(nobs) )
  ALLOCATE( rlat(nobs) )
  ALLOCATE( rlev(nobs) )
  ALLOCATE( odat(nobs) )
  ALLOCATE( oerr(nobs) )
  ALLOCATE( ohx(nobs) )
  ALLOCATE( oqc(nobs) )
  ALLOCATE( obhr(nobs) )

  print *, "obsop_sprof.f90:: starting nobs = ", nobs
  do i=1,nobs
    elem(i) = obs_data(i)%typ
    rlon(i) = obs_data(i)%x_grd(1)
    rlat(i) = obs_data(i)%x_grd(2)
    rlev(i) = obs_data(i)%x_grd(3)
    odat(i) = obs_data(i)%value
    oerr(i) = obs_data(i)%oerr
    ohx(i)  = 0
    oqc(i)  = 0
    obhr(i) = obs_data(i)%hour
  enddo
  if (print1st) then
    print *, "elem(1),rlon(1),rlat(1),obhr(1) = ", elem(1),rlon(1),rlat(1),obhr(1)
    print *, "odat(1:40) = ", odat(1:40)
    print *, "oerr(1:40) = ", oerr(1:40)
  endif

  DEALLOCATE(obs_data)

  !-----------------------------------------------------------------------------
  ! Update the coordinate to match the model grid
  !-----------------------------------------------------------------------------
  if (remap_obs_coords) then
    CALL center_obs_coords(rlon,oerr,nobs)
  endif

  !-----------------------------------------------------------------------------
  ! Read model forecast for this member
  !-----------------------------------------------------------------------------
  ALLOCATE( v3d(nlon,nlat,nlev,nv3d) )
  ALLOCATE( v2d(nlon,nlat,nv2d) )
  WRITE(6,*) "Reading background/forecast data on model grid..."
  CALL read_diag(guesfile,v3d,v2d)
  WRITE(6,*) '****************'

  !-----------------------------------------------------------------------------
  ! Cycle through all observations
  !-----------------------------------------------------------------------------
  WRITE(6,*) "Cycling through observations..."
  ohx=0.0d0
  oqc=0
  DO n=1,nobs
    !---------------------------------------------------------------------------
    ! Count bad obs errors associated with observations, and skip the ob
    !---------------------------------------------------------------------------
    if (oerr(n) <= 0) then
      !STEVE: this occurred for a few synthetic obs, perhaps due to Dave's code generating obs errors
      cnt_oerlt0 = cnt_oerlt0 + 1
      CYCLE
    endif

    !---------------------------------------------------------------------------
    ! Convert the physical coordinate to model grid coordinate (note: real, not integer)
    !---------------------------------------------------------------------------
    CALL phys2ijk(elem(n),rlon(n),rlat(n),rlev(n),ri,rj,rk) !(OCEAN)

    !---------------------------------------------------------------------------
    ! Filter in the tripolar region until localization is examined in the arctic !(ISSUE)
    !---------------------------------------------------------------------------
    if (DO_REMOVE_65N .and. rlat(n) > 65) then
      if (verbose) WRITE(6,'(A)') "Latitude above 65.0N, in tripolar region. Removing observation..."
      cnt_triout = cnt_triout + 1
      CYCLE
    endif

    !---------------------------------------------------------------------------
    ! Filter out observations in the black sea, which may cause problems
    !---------------------------------------------------------------------------
    if (DO_REMOVE_BLACKSEA) then
      if (40 < rlat(n) .and. rlat(n) < 50 .and. &
          25 < rlon(n) .and. rlon(n) < 45) then
        cnt_blacksea = cnt_blacksea + 1
        CYCLE
      endif
    endif

    !---------------------------------------------------------------------------
    ! Filter out observations that are out of range for the grid
    !---------------------------------------------------------------------------
    if (CEILING(ri) < 2 .OR. nlon+1 < CEILING(ri)) then
      if (verbose) WRITE(6,'(A)') '* X-coordinate out of range'
      if (verbose) WRITE(6,'(A,F6.2,A,F6.2)') '*   ri=',ri,', olon=', rlon(n)
      cnt_xout = cnt_xout + 1
      CYCLE
    endif
    if (CEILING(rj) < 2 .OR. nlat < CEILING(rj)) then
      if (verbose) WRITE(6,'(A)') '* Y-coordinate out of range'
      if (verbose) WRITE(6,'(A,F6.2,A,F6.2)') '*   rj=',rj,', olat=',rlat(n)
      cnt_yout = cnt_yout + 1
      CYCLE
    endif
    !STEVE: check against kmt, not nlev (OCEAN)
    if (CEILING(rk) > nlev) then
      CALL itpl_2d(kmt0,ri,rj,dk)
      WRITE(6,'(A)') '* Z-coordinate out of range'
      WRITE(6,'(A,F6.2,A,F10.2,A,F6.2,A,F6.2,A,F10.2)') &
           & '*   rk=',rk,', olev=',rlev(n),&
           & ', (lon,lat)=(',rlon(n),',',rlat(n),'), kmt0=',dk
      cnt_zout = cnt_zout + 1
      CYCLE
    endif
    if (CEILING(rk) < 2 .AND. rk < 1.00001d0) then   !(OCEAN)
      rk = 1.00001d0                                 !(OCEAN)
    endif                                            !(OCEAN)

    !---------------------------------------------------------------------------
    ! Check the observation against boundaries
    !---------------------------------------------------------------------------
    !STEVE: Check to make sure it's in the ocean, as determined       (OCEAN)
    !       by mom4's topography map.
    ! (note: must do it after coordinate checks, or the coordinate
    !        could be outside of the range of the kmt array)
    boundary_points : if (ri > nlon) then
      !STEVE: I have to check what it does for this case...
      !       but it causes an error in the next line if ri > nlon
      if (verbose) WRITE(6,'(A)') '* coordinate is not on mom4 model grid: ri > nlon'
      cnt_rigtnlon = cnt_rigtnlon + 1
      if (cnt_rigtnlon <= 1) then
        WRITE(6,*) "STEVE: ri > nlon (cnt_rigtnlon)"
        WRITE(6,*) "ri = ", ri
        WRITE(6,*) "nlon = ", nlon
        WRITE(6,*) "rj = ", rj
        WRITE(6,*) "elem(n) = ", elem(n)
        WRITE(6,*) "rlon(n) = ", rlon(n)
        WRITE(6,*) "rlat(n) = ", rlat(n)
        WRITE(6,*) "rlev(n) = ", rlev(n)
        WRITE(6,*) "rk = ", rk
      endif
      CYCLE
    else
      !STEVE: check this, case 1 allows more observations, case 2 is more restrictive
      select case (bdyobs)
      case(1)
        if (kmt(NINT(ri),NINT(rj)) .lt. 1) then
          if (debug_obsfilter) then
            WRITE(6,'(A)') '* coordinate is on or too close to land, according to kmt'
            WRITE(6,'(A,F6.2,A,F6.2)') '*   ri=',ri,', rj=',rj
            WRITE(6,*) "kmt cell = ", kmt(NINT(ri),NINT(rj))
          endif
          cnt_nearland = cnt_nearland + 1
          CYCLE
        elseif (kmt(NINT(ri),NINT(rj)) .lt. rk) then
          if (debug_obsfilter) then
            WRITE(6,'(A)') '* coordinate is on or too close to underwater topography, according to kmt'
            WRITE(6,'(A,F6.2,A,F6.2,A,F6.2)') '*   ri=',ri,', rj=',rj, ', rk=',rk
            WRITE(6,*) "kmt cell = ", kmt(NINT(ri),NINT(rj))
          endif
          cnt_nearland = cnt_nearland + 1
          CYCLE
        endif
      case(2)
        if(kmt(CEILING(ri),CEILING(rj)) .lt. 1 .or. &
             kmt(CEILING(ri),FLOOR(rj)) .lt. 1 .or. &
             kmt(FLOOR(ri),CEILING(rj)) .lt. 1 .or. &
             kmt(FLOOR(ri),FLOOR(rj)) .lt. 1) THEN

          if (debug_obsfilter) then
            WRITE(6,'(A)') '* coordinate is too close to land, according to kmt'
            WRITE(6,'(A,F6.2,A,F6.2)') '*   ri=',ri,', rj=',rj
            WRITE(6,*) "kmt cell = ", kmt(FLOOR(ri):CEILING(ri),FLOOR(rj):CEILING(rj))
          endif
          cnt_nearland = cnt_nearland + 1
          CYCLE
        elseif(kmt(CEILING(ri),CEILING(rj)) .lt. rk .or. &
                  kmt(CEILING(ri),FLOOR(rj)) .lt. rk .or. &
                  kmt(FLOOR(ri),CEILING(rj)) .lt. rk .or. &
                  kmt(FLOOR(ri),FLOOR(rj)) .lt. rk) THEN

          if (debug_obsfilter) then
            WRITE(6,'(A)') '* coordinate is too close to underwater topography, according to kmt'
            WRITE(6,'(A,F6.2,A,F6.2,A,F6.2)') '*   ri=',ri,', rj=',rj, ', rk=',rk
            WRITE(6,*) "kmt cell = ", kmt(FLOOR(ri):CEILING(ri),FLOOR(rj):CEILING(rj))
          endif
          cnt_nearland = cnt_nearland + 1
          CYCLE
        endif
      end select
    endif boundary_points

    !---------------------------------------------------------------------------
    ! (OPTIONAL) Scale the observation errors
    !---------------------------------------------------------------------------
    scale_obs : if (abs(obserr_scaling - 1.0d0) .gt. TINY(1.0d0) ) then
      oerr(n) = oerr(n) * obserr_scaling
    endif scale_obs

    !---------------------------------------------------------------------------
    ! (OPTIONAL) Thin the observations
    !---------------------------------------------------------------------------
    ! Select random subset of observations to speed up processing
    thin_obs : if (abs(obs_randselect - 1) > TINY(1.0d0)) then
      CALL com_rand(1,rand)
      if (rand(1) > obs_randselect) CYCLE
    endif thin_obs

    !---------------------------------------------------------------------------
    ! observation operator (computes H(x)) for specified member
    !---------------------------------------------------------------------------
    CALL Trans_XtoY(elem(n),ri,rj,rk,v3d,v2d,ohx(n))

    oqc(n) = 1
  enddo !1:nobs

  !-----------------------------------------------------------------------------
  ! Print out the counts of observations removed for various reasons
  !-----------------------------------------------------------------------------
  WRITE(6,*) "In obsop_tprof.f90:: observations removed for:"
  WRITE(6,*) "cnt_oerlt0 = ", cnt_oerlt0
  WRITE(6,*) "cnt_xout = ", cnt_xout
  WRITE(6,*) "cnt_yout = ", cnt_yout
  WRITE(6,*) "cnt_zout = ", cnt_zout
  WRITE(6,*) "cnt_triout = ", cnt_triout
  WRITE(6,*) "cnt_rigtnlon = ", cnt_rigtnlon
  WRITE(6,*) "cnt_nearland = ", cnt_nearland
  WRITE(6,*) "cnt_altlatrng = ", cnt_altlatrng
  if (DO_REMOVE_BLACKSEA) WRITE(6,*) "cnt_blacksea = ", cnt_blacksea

  !-----------------------------------------------------------------------------
  ! Write the observations and their associated innovations to file
  !-----------------------------------------------------------------------------
  CALL write_obs2(obsoutfile,nobs,elem,rlon,rlat,rlev,odat,oerr,ohx,oqc,obhr)

  DEALLOCATE( elem,rlon,rlat,rlev,odat,oerr,ohx,oqc,obhr,v3d,v2d )

CONTAINS

SUBROUTINE process_command_line
!===============================================================================
! Process command line arguments
!===============================================================================
IMPLICIT NONE
INTEGER, PARAMETER :: slen2=1024
CHARACTER(slen2) :: arg1,arg2
INTEGER :: i, ierr
INTEGER, DIMENSION(3) :: values

! STEVE: add input error handling!
! inputs are in the format "-x xxx"
do i=1,COMMAND_ARGUMENT_COUNT(),2
  CALL GET_COMMAND_ARGUMENT(i,arg1)
  PRINT *, "In obsop_tprof.f90::"
  PRINT *, "Argument ", i, " = ",TRIM(arg1)

  select case (arg1)
!   case('-nlon')
!     CALL GET_COMMAND_ARGUMENT(i+1,arg2)
!     PRINT *, "Argument ", i+1, " = ",TRIM(arg2)
!     read (arg2,*) nlon
!   case('-nlat')
!     CALL GET_COMMAND_ARGUMENT(i+1,arg2)
!     PRINT *, "Argument ", i+1, " = ",TRIM(arg2)
!     read (arg2,*) nlat
!   case('-nlev')
!     CALL GET_COMMAND_ARGUMENT(i+1,arg2)
!     PRINT *, "Argument ", i+1, " = ",TRIM(arg2)
!     read (arg2,*) nlev
    case('-obsin')
      CALL GET_COMMAND_ARGUMENT(i+1,arg2)
      PRINT *, "Argument ", i+1, " = ",TRIM(arg2)
      obsinfile = arg2
    case('-gues')
      CALL GET_COMMAND_ARGUMENT(i+1,arg2)
      PRINT *, "Argument ", i+1, " = ",TRIM(arg2)
      guesfile = arg2
    case('-obsout')
      CALL GET_COMMAND_ARGUMENT(i+1,arg2)
      PRINT *, "Argument ", i+1, " = ",TRIM(arg2)
      obsoutfile = arg2
    case('-rm65N')
      CALL GET_COMMAND_ARGUMENT(i+1,arg2)
      PRINT *, "Argument ", i+1, " = ",TRIM(arg2)
      read (arg2,*) DO_REMOVE_65N
    case('-rmBlackSea')
      CALL GET_COMMAND_ARGUMENT(i+1,arg2)
      PRINT *, "Argument ", i+1, " = ",TRIM(arg2)
      read (arg2,*) DO_REMOVE_BLACKSEA
    case('-debug')
      CALL GET_COMMAND_ARGUMENT(i+1,arg2)
      PRINT *, "Argument ", i+1, " = ",TRIM(arg2)
      read (arg2,*) dodebug1
    case default
      PRINT *, "ERROR: option is not supported: ", arg1
      PRINT *, "(with value : ", trim(arg2), " )"
      stop 1
  end select
enddo

END SUBROUTINE process_command_line

END PROGRAM obsop_tprof


! -*- mode: F90; mode: font-lock -*-
! ------------------------------------------------------------------------------
! $Id$
! ------------------------------------------------------------------------------
! Module matrix_data
! ------------------------------------------------------------------------------
! Code area 2: matrices
! ------------------------------------------------------------------------------

!!****h* Conquest/matrix_data *
!!  NAME
!!   matrix_data
!!  PURPOSE
!!   Gives access to ALL the indices (i.e. the matrix
!!   types) and data (i.e. the elements) for the matrices in the system.
!!  USES
!!   datatypes, matrix_module, maxima_module
!!  AUTHOR
!!   D.R.Bowler
!!  CREATION DATE
!!   12/04/00
!!  MODIFICATION HISTORY
!!   18/03/2002 dave
!!    Added ROBODoc header, RCS Id and Log tags and static for object file id
!!   29/07/2002 drb
!!    Changed temp_T so that is has dimension (NSF,NSF,....) instead of (NCF,NCF,....)
!!    to fix a problem when NCF/=NSF
!!   31/07/2002 dave
!!    Added data_M12 (for Pulay force in exact diagonalisation); removed misleading
!!    statement in purpose tag above
!!   14:36, 26/02/2003 drb
!!    Reordered and removed integ references during bug search
!!   15:01, 12/03/2003 drb
!!    Added data_KE and data_NL
!!   2006/01/25 16:57 dave
!!    Starting to add new variables and routines for encapsulated matrix data
!!   10:09, 13/02/2006 drb
!!    Removed all explicit references to data_ variables and rewrote in terms of new
!!    matrix routines: specifically declared matrix_pointer type, made dS and dH not allocatable and
!!    all data_ variables targets
!!   2006/08/30 08:12 dave
!!    Finalised conversion of matrix indexing to allocatable
!!   2008/03/12 06:12 dave
!!    Added max_range parameter to find longest range matrix
!!   2012/01/18 16:55 dave
!!    Added blip transfer type for analytic blip integration
!!   2014/01/17 13:20 lat
!!    Added new matrix X and SX for exchange
!!   2016/08/09 18:00 nakata
!!    Added parameters aSa_range,      aHa_range,        STr_range,  HTr_range,
!!                     aSs_range,      aHs_range,        sSa_range,  sHa_range,
!!                     SFcoeff_range,  SFcoeffTr_range,  LD_range,
!!                     aSa_matind,     aHa_matind,       STr_matind, HTr_matind,
!!                     aSs_matind,     aHs_matind,       sSa_matind, sHa_matind,
!!                     SFcoeff_matind, SFcoeffTr_matind, LD_matind
!!    for PAO-based calculations
!!    Changed from SPrange, PSrange, SPmatind, PSmatind
!!              to APrange, PArange, APmatind, PAmatind
!!    where A = atomic function (sf or paof) and P = projecter function for NL
!!   2017/03/08 15:00 nakata
!!    Removed dSrange, dHrange, PAOPrange, dSmatind, dHmatind and PAOPmatind
!!    which are no longer used
!!   2017/12/05 10:20 dave (with TM and NW (Mizuho))
!!    Adding new matrix indices (aNA and NAa) for atom function - NA projectors
!!  SOURCE
!!
module matrix_data

  use datatypes
  use matrix_module, only: matrix, matrix_halo, blip_transfer ! Think about this - how do we want to arrange ?

  implicit none
  save

  ! This will need to change if the above parameters are changed
  integer, parameter :: mx_matrices = 32

  ! Store ALL indices in a large array
  type(matrix),      allocatable, dimension(:,:), target :: mat
  type(matrix_halo), allocatable, dimension(:),   target :: halo
  real(double),      dimension(mx_matrices) :: rcut
  character(len=3),  dimension(mx_matrices) :: mat_name

  integer, dimension(:), pointer :: Smatind, Lmatind, LTrmatind, Hmatind, &
       APmatind, PAmatind, LSmatind, SLmatind, LHmatind, HLmatind, LSLmatind, &
       SLSmatind, Tmatind, TTrmatind, TSmatind, THmatind, TLmatind, Xmatind, SXmatind
  integer, dimension(:), pointer :: aSa_matind, aHa_matind, STr_matind, HTr_matind, &
                                    aSs_matind, aHs_matind, sSa_matind, sHa_matind, &
                                    SFcoeff_matind, SFcoeffTr_matind, LD_matind
  integer, dimension(:), pointer :: aNAmatind, NAamatind

  ! Parameters for the different matrix ranges
  integer, parameter :: Srange   = 1   ! STS,TST,TS.TS
  integer, parameter :: Lrange   = 2   ! SLS,HLSLS,SLSLS,THT,LSLSL
  integer, parameter :: Hrange   = 3   ! K,LSLSL
  integer, parameter :: APrange  = 4   ! PA,U   ! Maybe rename ?
  integer, parameter :: LSrange  = 5   ! SL
  integer, parameter :: LHrange  = 6   ! HL
  integer, parameter :: LSLrange = 7   ! HLS
  integer, parameter :: SLSrange = 8   ! LHL
  integer, parameter :: Trange   = 9   ! T is S^-1
  integer, parameter :: TSrange  = 10
  integer, parameter :: THrange  = 11
  integer, parameter :: TLrange  = 12
  integer, parameter :: PArange  = 13  ! AP,U   ! Maybe rename ?
  integer, parameter :: LTrrange = 14
  integer, parameter :: SLrange  = 15
  integer, parameter :: TTrrange = 16
  integer, parameter :: HLrange  = 17

  integer, parameter :: Xrange   = 18
  integer, parameter :: SXrange  = 19

  ! The indices for ATOMF-based-matrix ranges will be set later.
  integer :: aSa_range       ! 20 for S(atomf,atomf) = r_atomf + r_atomf
  integer :: aHa_range       ! 21 for H(atomf,atomf) = r_atomf + r_atomf
  integer :: STr_range       ! 22 for sMs -> aMa transformation (Srange)
  integer :: HTr_range       ! 23 for sMs -> aMa transformation (Hrange)
  integer :: aSs_range       ! 24 for S(atomf,sf) = r_atomf + r_sf
  integer :: aHs_range       ! 25 for H(atomf,sf) = r_atomf + r_sf
  integer :: sSa_range       ! 26 for S(sf,atomf) = r_atomf + r_sf
  integer :: sHa_range       ! 27 for H(sf,atomf) = r_atomf + r_sf
  integer :: SFcoeff_range   ! 28
  integer :: SFcoeffTr_range ! 29
  integer :: LD_range        ! 30
  ! Ranges for NA projectors set later also (dimens.module.f90)
  integer :: aNArange        ! 31
  integer :: NAarange        ! 32

  integer :: max_range ! Indexes matrix with largest range

  type(blip_transfer) :: blip_trans
!!***

!!****s* multiply_module/matrix_pointer *
!!  NAME
!!   matrix_pointer
!!  PURPOSE
!!   Contains pointer to matrix data and length of matrix
!!  AUTHOR
!!   D.R.Bowler
!!  SOURCE
!!
  type matrix_pointer
     integer :: length
     integer :: sf1_type, sf2_type
     real(double), pointer, dimension(:) :: matrix
  end type matrix_pointer
!!***

end module matrix_data


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

program wod_to_obs

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!     wod_to_obs - program that reads a list of World Ocean Datatbase obs
!                  profiles of ocean temperature and salinity in packed
!                  ascii format and writes a DART observation sequence file.
!
!     created 19-oct-2009, based on the GTSPP reader.   nsc.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

use        types_mod, only : r8
use time_manager_mod, only : time_type, set_calendar_type, GREGORIAN, set_time,&
                             increment_time, get_time, set_date, operator(-),  &
                             print_date, operator(+), leap_year, operator(>)
use    utilities_mod, only : initialize_utilities, find_namelist_in_file,    &
                             check_namelist_read, nmlfileunit, do_output,    &
                             get_next_filename, error_handler, E_ERR, E_MSG, &
                             find_textfile_dims, finalize_utilities,         &
                             open_file, close_file
use     location_mod, only : VERTISHEIGHT, set_location
use obs_sequence_mod, only : obs_sequence_type, obs_type, read_obs_seq,       &
                             static_init_obs_sequence, init_obs, destroy_obs, &
                             write_obs_seq, init_obs_sequence, get_num_obs,   &
                             insert_obs_in_seq, destroy_obs_sequence,         &
                             set_copy_meta_data, set_qc_meta_data, set_qc,    &
                             set_obs_values, set_obs_def, insert_obs_in_seq
use obs_def_mod,      only : obs_def_type, set_obs_def_time, set_obs_def_type_of_obs, &
                             set_obs_def_error_variance, set_obs_def_location, &
                             set_obs_def_key
use obs_kind_mod,     only : get_name_for_type_of_obs

! FIXME: i don't have all the actual kinds yet (bottle? underway? )
! but it's closer than before.  must have obs_def_ocean_mod.f90 in preprocess list.

use     obs_kind_mod, only : &
         SALINITY,                      QTY_SALINITY,              &
         TEMPERATURE,                   QTY_TEMPERATURE,           &
         U_CURRENT_COMPONENT,           QTY_U_CURRENT_COMPONENT,   &
         V_CURRENT_COMPONENT,           QTY_V_CURRENT_COMPONENT,   &
         SEA_SURFACE_HEIGHT,            QTY_SEA_SURFACE_HEIGHT,    &
         SEA_SURFACE_PRESSURE,          QTY_SEA_SURFACE_PRESSURE,  &
         ARGO_U_CURRENT_COMPONENT,      ARGO_V_CURRENT_COMPONENT,   &
         ARGO_SALINITY,                 ARGO_TEMPERATURE,           &
         ADCP_U_CURRENT_COMPONENT,      ADCP_V_CURRENT_COMPONENT,   &
         ADCP_SALINITY,                 ADCP_TEMPERATURE,           &
         FLOAT_SALINITY,                FLOAT_TEMPERATURE

use obs_kind_mod, only : &
         DRIFTER_U_CURRENT_COMPONENT,   DRIFTER_V_CURRENT_COMPONENT,   &
         DRIFTER_SALINITY,              DRIFTER_TEMPERATURE,           &
         GLIDER_U_CURRENT_COMPONENT,    GLIDER_V_CURRENT_COMPONENT,    &
         GLIDER_SALINITY,               GLIDER_TEMPERATURE,            &
         MOORING_U_CURRENT_COMPONENT,   MOORING_V_CURRENT_COMPONENT,   &
         MOORING_SALINITY,              MOORING_TEMPERATURE,           &
         MOORING_PRESSURE

use obs_kind_mod, only : &
         CTD_SALINITY,                  CTD_TEMPERATURE,               &
         TCTD_SALINITY,                 TCTD_TEMPERATURE,              &
         XCTD_SALINITY,                 XCTD_TEMPERATURE,              &
         STD_SALINITY,                  STD_TEMPERATURE,               &
         MBT_TEMPERATURE,               XBT_TEMPERATURE,               &
         DBT_TEMPERATURE,               APB_TEMPERATURE,               &
         MBT_SALINITY,                  XBT_SALINITY,                  &
         DBT_SALINITY,                  APB_SALINITY,                  &
         BOTTLE_TEMPERATURE,            BOTTLE_SALINITY,               &
         DOPPLER_U_CURRENT_COMPONENT,   DOPPLER_V_CURRENT_COMPONENT,   &
         DOPPLER_W_CURRENT_COMPONENT,   QTY_W_CURRENT_COMPONENT,      &
         SATELLITE_MICROWAVE_SST,       SATELLITE_INFRARED_SST,        &
         SATELLITE_SSH,                 SATELLITE_SSS,                 &
         HFRADAR_RADIAL_VELOCITY,       QTY_VELOCITY

! not clean interface; going for working code first.
use WOD_read_routines_mod, only : WODREADDART, depth, temp, ierror, iderror,  &
                      maxlevel, maxcalc, kdim, maxtcode, maxtax, maxpinf,     &
                      bmiss, isec, sechead

implicit none

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

integer, parameter ::   num_copies = 1,   &   ! number of copies in sequence
                        num_qc     = 1        ! number of QC entries

character (len=129) :: msgstring, next_infile, cdummy
integer :: j, k, nfiles, num_new_obs, castid, l
integer :: oday, osec
integer :: obsyear, obsmonth, obsday, obssec
integer :: obs_num, io, iunit, filenum, dummy
integer :: funit, levels, istdlev, nvar, nsecond, ieof
integer :: ip2(0:maxlevel), cast, itype
logical :: file_exist, did_obs, from_list = .false.
logical :: have_temp, have_salt
real(r8) :: terr, serr,         &
            phs, obs_val(1),  &
            d_qc(1)
real :: dtime, lato, lono
real(r8) :: obslat, obslon, obsdepth

! platform codes - reshape required by latest XLF compiler.
integer :: ptype(2, 16) = reshape( (/  &
   MBT_TEMPERATURE,     MBT_SALINITY,      &   ! ptype(1)  = MBT
   XBT_TEMPERATURE,     XBT_SALINITY,      &   ! ptype(2)  = XBT
   DBT_TEMPERATURE,     DBT_SALINITY,      &   ! ptype(3)  = DBT
   CTD_TEMPERATURE,     CTD_SALINITY,      &   ! ptype(4)  = CTD
   STD_TEMPERATURE,     STD_SALINITY,      &   ! ptype(5)  = STD
   XCTD_TEMPERATURE,    XCTD_SALINITY,     &   ! ptype(6)  = XCTD
   BOTTLE_TEMPERATURE,  BOTTLE_SALINITY,   &   ! ptype(7)  = bottle
   0,                   0,                 &   ! ptype(8)  = underway
   FLOAT_TEMPERATURE,   FLOAT_SALINITY,    &   ! ptype(9)  = profiling float
   MOORING_TEMPERATURE, MOORING_SALINITY,  &   ! ptype(10) = moored buoy
   DRIFTER_TEMPERATURE, DRIFTER_SALINITY,  &   ! ptype(11) = drifting buoy
   TCTD_TEMPERATURE,    TCTD_SALINITY,     &   ! ptype(12) = towed CTD
   APB_TEMPERATURE,     APB_SALINITY,      &   ! ptype(13) = animal
   0,                   0,                 &   ! ptype(14) = bucket
   GLIDER_TEMPERATURE,  GLIDER_SALINITY,   &   ! ptype(15) = glider
   MBT_TEMPERATURE,     MBT_SALINITY  /),  &   ! ptype(16) = microBT
   (/ 2, 16 /)  )  ! reshape 1d array into (2,16)

type(obs_sequence_type) :: obs_seq
type(obs_type)          :: obs, prev_obs
type(time_type)         :: obs_time, delta_time, prev_time

integer :: histbin(-1:26) = 0  ! for time debug
integer :: histcount = 0       ! for time debug
integer :: temp_type, salt_type, good_temp, good_salt, bad_temp, bad_salt
integer :: salt_qc(10), temp_qc(10)

!------------------------------------------------------------------------
!  Declare namelist parameters
!------------------------------------------------------------------------

character(len=128) :: wod_input_file     = 'XBTS2005'
character(len=128) :: wod_input_filelist = ''
character(len=128) :: wod_out_file       = 'obs_seq.wod'
integer            :: avg_obs_per_file   = 500000
logical            :: debug              = .false.
logical            :: timedebug          = .false.
logical            :: print_qc_summary   = .true.
integer            :: max_casts          = -1
logical            :: no_output_file     = .false.
integer            :: print_every_nth_cast = -1
real(r8)           :: temperature_error  = 0.5  ! degrees C
real(r8)           :: salinity_error     = 0.5  ! g/kg
integer            :: start_month        = 1
integer            :: end_month          = 12

namelist /wod_to_obs_nml/ &
   wod_input_file, wod_input_filelist, wod_out_file,   &
   avg_obs_per_file, debug, max_casts, no_output_file, &
   print_every_nth_cast, print_qc_summary,             &
   temperature_error, salinity_error, timedebug,       &
   start_month, end_month

! start of executable code

obs_num = 1
d_qc(1) = 0.0_r8

! time in files is year, month, day, fraction of day.
! day is sometimes = 0 (? not sure, am setting it to day 1).
! time often missing; am setting that to 0Z with less
! trepidation.
call set_calendar_type(GREGORIAN)
prev_time = set_date(4000, 1, 1)   ! must be something later than all obs

!  read the necessary parameters from input.nml
call initialize_utilities()
call find_namelist_in_file("input.nml", "wod_to_obs_nml", iunit)
read(iunit, nml = wod_to_obs_nml, iostat = io)

! Record the namelist values used for the run
if (do_output()) write(nmlfileunit, nml=wod_to_obs_nml)

! any needed namelist checks for sanity:

! cannot have both a single filename and a list; the namelist must
! shut one off.
if (wod_input_file /= '' .and. wod_input_filelist /= '') then
  call error_handler(E_ERR, 'wod_to_obs',                     &
                     'One of wod_input_file or filelist must be NULL', &
                     source, revision, revdate)
endif
if (wod_input_filelist /= '') from_list = .true.

! need to know a reasonable max number of obs that could be added here.
if (from_list) then
   call find_textfile_dims(wod_input_filelist, nfiles, dummy)
   num_new_obs = avg_obs_per_file * nfiles
else
   num_new_obs = avg_obs_per_file
endif

! FIXME: is this a good idea?  to append to an existing file?
!  either read existing obs_seq or create a new one
call static_init_obs_sequence()
call init_obs(obs, num_copies, num_qc)
call init_obs(prev_obs, num_copies, num_qc)
inquire(file=wod_out_file, exist=file_exist)
if (file_exist) then
   print *, "replacing existing obs_seq file ", trim(wod_out_file)
else
   print *, "creating obs_seq file ", trim(wod_out_file)
endif
print *, "max entries = ", num_new_obs
call init_obs_sequence(obs_seq, num_copies, num_qc, num_new_obs)
do k = 1, num_copies
   call set_copy_meta_data(obs_seq, k, 'WOD observation')
end do
do k = 1, num_qc
   call set_qc_meta_data(obs_seq, k, 'WOD QC')
end do

did_obs = .false.

! main loop that does either a single file or a list of files

filenum = 1
fileloop: do      ! until out of files

   ! get the single name, or the next name from a list
   if (from_list) then
      next_infile = get_next_filename(wod_input_filelist, filenum)
   else
      next_infile = wod_input_file
      if (filenum > 1) next_infile = ''
   endif
   if (next_infile == '') exit fileloop

   have_temp = .false.
   have_salt = .false.
   !FIXME: more types?  u, v, w  current, ?

   !  open the next profile file
   funit = open_file(next_infile, action='READ')

print *, ' '
print *, 'opening file ', trim(next_infile)

   ! reset anything that's per-file
   good_temp = 0
   bad_temp = 0
   good_salt = 0
   bad_salt = 0
   temp_qc(:) = 0
   salt_qc(:) = 0

   cast = 1
   castloop: do    ! until out of data
   call WODreadDART(funit,obsyear,obsmonth,obsday, &
              dtime,lato,lono,levels,istdlev,nvar,ip2,nsecond, &
              bmiss,castid,ieof)

!if (ieof /= 0) print *, 'ieof is ', ieof

   ! this comes back as 1 when the file has all been read.
   if (ieof == 1) exit castloop

   ! see what data we have
   if (nvar == 0) then
      goto 20 ! inc counter, cycle castloop
   endif

!print *, 'obsyear, obsmonth, obsday = ', obsyear, obsmonth, obsday
!print *, 'levels = ', levels
!print *, 'lato, lono = ', lato, lono

   ! need to gather:
   !   time (year, month, day, time), lat, lon, depth, obs type, ?.

   ! start out with converting the real time.
   ! do error check first.  if fail, cycle here
   ! this routine alters bad days and times to be valid, or
   ! returns a failure and we loop here.
   if (.not. date_ok(obsyear, obsmonth, obsday, &
                     dtime, bmiss, castid)) goto 20

   ! convert fractional hours (0-24) to integer days and seconds
   !  and add on to reference time.  dtime was set to 0 if it was
   !  missing in the date_ok() routine.
   obssec = int(dtime * 3600.0)
   delta_time = set_time(obssec)
   obs_time = set_date(obsyear, obsmonth, obsday) + delta_time
   call get_time(obs_time,  osec, oday)
!print *, 'oday, osec = ', oday, osec
!call print_date(obs_time)

   if (debug) then
      print *, ' --- '
      print *, 'cast number: ', castid
      print *, 'obsyear,month,day,time = ', obsyear, obsmonth, obsday, dtime
      print *, 'lato, lono = ', lato, lono
   endif

   have_temp = .false.
   have_salt = .false.
   do k=1, nvar
      if (ip2(k) == 1) have_temp = .true.
      if (ip2(k) == 2) have_salt = .true.
   enddo

   temp_type = 0
   salt_type = 0
   do k=1, nsecond
      if (isec(k) == 29) then
         itype = int(sechead(29))
         if (itype > 0 .and. itype <= 16) then
            temp_type = ptype(1, itype)
            salt_type = ptype(2, itype)
         endif
         if (itype > 0 .and. temp_type == 0) print *, 'temp=0, itype = ', itype
         if (itype > 0 .and. salt_type == 0) print *, 'salt=0, itype = ', itype
      endif
   enddo

! debug
   if (debug) then
      print *, 'num levels: ', levels
      print *, 'has temp, salinity: ', have_temp, have_salt
      if (have_temp) then
         cdummy = get_name_for_type_of_obs(temp_type)
         print *, 'temp type/name: ', temp_type, trim(cdummy)
      endif
      if (have_salt) then
         cdummy = get_name_for_type_of_obs(salt_type)
         print *, 'salt type/name: ', salt_type, trim(cdummy)
      endif
      call print_date(obs_time, 'obs time')
   endif

 ! FIXME: these are best-guess only.
   terr = temperature_error            ! degrees C
   serr = salinity_error / 1000.0_r8   ! g/kg, convert to kg/kg

   if (lono < 0.0_r8) lono = lono + 360.0_r8
   obslon = lono
   obslat = lato
   if((obslon < 0.0_r8 .or. obslon > 360.0_r8) .or. (obslat < -90.0_r8 .or. obslat > 90.0_r8)) then
      print *, 'FSC: longitude (',obslon,') or latitude (',obslat,') is not within range. cycle castloop'
      goto 20 ! inc counter, cycle castloop
   endif

   if (have_temp) then
      if (ierror(1) == 0) then
         good_temp = good_temp + 1
      else
         bad_temp = bad_temp + 1
         temp_qc(ierror(1)) = temp_qc(ierror(1)) + 1
      endif
   endif

   if (have_salt) then
      if (ierror(2) == 0) then
         good_salt = good_salt + 1
      else
         bad_salt = bad_salt + 1
         salt_qc(ierror(2)) = salt_qc(ierror(2)) + 1
      endif
   endif

   if (debug) then
      if (ierror(1) /= 0) print *, 'whole temp cast discarded, ierror == ', ierror(1)
      if (ierror(2) /= 0) print *, 'whole salt cast discarded, ierror == ', ierror(2)
   endif

   ! the incoming files are yearly collections.  allow this converter to create
   ! output files which are only partial years by only processing selected months.
   if (obsmonth < start_month .or. obsmonth > end_month) then
      goto 20 ! inc counter, cycle castloop
   endif

   obsloop: do k = 1, levels

     obsdepth = depth(k)

      if (debug) then
         write(*, "(A,F6.0,F8.3,F4.0,F8.3,F4.0)") "depth, temp/salt value,qc: ",&
                    depth(k), temp(k,1), iderror(k,1), temp(k, 2), iderror(k,2)
      endif

     ! ierror is whole cast error
     if (have_temp .and. ierror(1) == 0 .and. &
         temp_type > 0 .and. temp(k, 1) /= bmiss &
         .and. (.not. no_output_file)) then

         ! set location - incoming obs are -180 to 180 in longitude;
         ! dart wants 0 to 360.  (also, r8)
         call fill_obs(obs, obs_num, obslon, obslat, obsdepth, temp_type, &
                 obs_time, terr, real(temp(k, 1), r8), real(iderror(k, 1), r8))

         call add_obs(obs_seq, obs, obs_time, prev_obs, prev_time)

         if (.not. did_obs) did_obs = .true.
      endif

      ! ierror is whole cast
      if (have_salt .and. ierror(2) == 0 .and. &
          salt_type > 0 .and. temp(k, 2) /= bmiss &
         .and. (.not. no_output_file)) then

         call fill_obs(obs, obs_num, obslon, obslat, obsdepth, salt_type, &
               obs_time, serr, temp(k, 2) / 1000.0_r8, real(iderror(k, 2), r8))

         call add_obs(obs_seq, obs, obs_time, prev_obs, prev_time)

         if (.not. did_obs) did_obs = .true.
      endif

   end do obsloop

 20 continue
  if (print_every_nth_cast > 0) then
      if (mod(cast, print_every_nth_cast) == 0) then
         print *, 'processing cast ', cast
      endif
  endif

  cast = cast + 1
  if (max_casts > 0 .and. cast >= max_casts) exit castloop

  end do castloop

  call close_file(funit)
  filenum = filenum + 1

  if (print_qc_summary) then
     call error_handler(E_MSG, '', '')
     write(msgstring, *) 'input data filename: ', trim(next_infile)
     call error_handler(E_MSG, '', msgstring)
     call error_handler(E_MSG, '', '')
     write(msgstring, *) 'total casts, total profiles: ', cast, &
                          good_temp+bad_temp+good_salt+bad_salt
     call error_handler(E_MSG, '', msgstring)
     write(msgstring, *) 'total/good/bad temperature profiles: ', &
                          good_temp+bad_temp, good_temp, bad_temp
     call error_handler(E_MSG, '', msgstring)
     write(msgstring, *) 'total/good/bad salinity    profiles: ', &
                          good_salt+bad_salt, good_salt, bad_salt
     call error_handler(E_MSG, '', msgstring)
     call error_handler(E_MSG, '', '')
      do j=1, 10
         if (temp_qc(j) > 0) then
            write(msgstring, *) 'temp qc of ', j, ' found ', temp_qc(j), ' times'
            call error_handler(E_MSG, '', msgstring)
         endif
      enddo
      call error_handler(E_MSG, '', '')
      do j=1, 10
         if (salt_qc(j) > 0) then
            write(msgstring, *) 'salt qc of ', j, ' found ', salt_qc(j), ' times'
            call error_handler(E_MSG, '', msgstring)
         endif
      enddo
      call error_handler(E_MSG, '', '')
   endif

end do fileloop

! done with main loop.  if we added any obs to the sequence, write it out.
if (did_obs) then
print *, 'ready to write, nobs = ', get_num_obs(obs_seq)
   if (get_num_obs(obs_seq) > 0) &
      call write_obs_seq(obs_seq, wod_out_file)

   ! minor stab at cleanup, in the off chance this will someday get turned
   ! into a subroutine in a module.  probably not all that needs to be done,
   ! but a start.
   call destroy_obs(obs)
   !call destroy_obs(prev_obs)   ! is this identical to obs?
   ! get core dumps here, not sure why?
   if (get_num_obs(obs_seq) > 0) call destroy_obs_sequence(obs_seq)
endif

! histogram of times, debug only
if (timedebug) then
   print *, "total obs examined = ", histcount
   print *, "bin -1 is < 0"
   print *, "bin 0 is == 0"
   print *, "bin 25 is > 24 but != 99.9"
   print *, "bin 26 is == 99.9"
   print *, " "
   print *, 'bin    count'
   do l=lbound(histbin, 1), ubound(histbin, 1)
      print *, l, histbin(l)
   enddo
endif

call error_handler(E_MSG,'wod_to_obs','Finished successfully.',source,revision,revdate)
call finalize_utilities()

! END OF MAIN ROUTINE

contains

! local subroutines/functions follow

! subroutine to fill an obs.  assumes loc is 3d, and vert is in meters.
subroutine fill_obs(obs, onum, olon, olat, odepth, otype, otime, oerr, &
                    oval, oqc)
 type(obs_type),  intent(inout) :: obs
 integer,         intent(inout) :: onum
 real(r8),        intent(in)    :: olon, olat, odepth, oerr, oval, oqc
 integer,         intent(in)    :: otype
 type(time_type), intent(in)    :: otime

type(obs_def_type) :: obs_def
real(r8)           :: valarr(1), qcarr(1)

call set_obs_def_location(obs_def, &
                          set_location(olon, olat, odepth, VERTISHEIGHT))
call set_obs_def_type_of_obs(obs_def, otype)
call set_obs_def_time(obs_def, otime)

call set_obs_def_error_variance(obs_def, oerr * oerr)
call set_obs_def_key(obs_def, onum)
call set_obs_def(obs, obs_def)

valarr(1) = oval
call set_obs_values(obs, valarr)
qcarr(1)  = oqc
call set_qc(obs, qcarr)

onum = onum + 1

end subroutine fill_obs

! add an obs to the sequence.  if prev_time same or earlier
! than obs time, insert with search starting from prev obs.
subroutine add_obs(seq, obs, obs_time, prev_obs, prev_time)

! FIXME ... 'seq' in argument list never used ...
 type(obs_sequence_type),   intent(inout) :: seq
 type(obs_type),            intent(inout) :: obs, prev_obs
 type(time_type),           intent(in)    :: obs_time
 type(time_type),           intent(inout) :: prev_time

logical, save :: first_obs = .true.

if (first_obs .or. prev_time > obs_time) then
   call insert_obs_in_seq(obs_seq, obs)
   first_obs = .false.
else
   call insert_obs_in_seq(obs_seq, obs, prev_obs)
endif

prev_obs  = obs
prev_time = obs_time

end subroutine add_obs

! date check, since a lot of these obs seem to have bad times/dates.
! modify testmonth, testday, dtime if we know what the right answer is.
! return .TRUE. if date ok, .FALSE. if bad and not fixable.
function date_ok(testyear, testmonth, testday, dtime, bmiss, castid)
 integer,  intent(inout) :: testyear, testmonth, testday
 real,     intent(inout) :: dtime    ! note real, not real(r8), to match
 real,     intent(in)    :: bmiss    ! WOD-supplied code which uses reals
 integer,  intent(in)    :: castid

 logical :: date_ok

integer :: days_per_month(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/)
type(time_type) :: test_time

! at least 2 files have dates of 2/29 on non-leap years.  test for
! that and fix those dates.  also found a 9/31, apparently without
! a bad cast qc.   the 2/29s were examined and determined to be a bad
! conversion - should be mar 1  the 9/31s were recording errors and
! based on the other obs, should have been 9/30.

10 format (A,I9,A,I6,I4,I4,F6.2)

! bad month - return fail
if (testmonth <= 0 .or. testmonth > 12) then
   write(*, 10) 'cast number: ', castid, ' date, dtime: ', testyear, testmonth, testday, dtime
   write(*, *)  ' bad month number, discarding observation'
   date_ok = .FALSE.
   return
endif

! try to estimate the time shifting error impacts from old code.
if (timedebug) then
   histcount = histcount + 1
   if (dtime == bmiss) then
      ! no count.  it is ok since we discarded it before
   else if (dtime < 0.0) then
      histbin(-1) = histbin(-1) + 1
   else if (dtime == 0.0) then
      histbin(0) = histbin(0) + 1
   else if (dtime == 99.9) then
      histbin(26) = histbin(26) + 1
   else if (dtime > 24.0) then
      histbin(25) = histbin(25) + 1
   else
      histbin(int(dtime)) = histbin(int(dtime)) + 1
   endif
endif

! check time - if standard missing value, don't squawk.
! otherwise, note the cast number and original value, and
! then set to 0, or fail.
if (dtime == bmiss) then
   dtime = 0.0
else if (dtime == 99.90) then
   ! seems to be an alternative missing value in some few cases.
   ! got confirmation from WOD providers that this was an incorrect
   ! missing value and future versions of the WOD will use the standard
   ! 'missing_value' read out of the file (bmiss in this subroutine,
   ! appears to be something like -999.99)
   write(*, 10) 'cast number: ', castid, ' date, dtime: ', testyear, testmonth, testday, dtime
   write(*, *)  ' setting to 0 and continuing'
   dtime = 0.0
else if (dtime < 0) then
   write(*, 10) 'cast number: ', castid, ' date, dtime: ', testyear, testmonth, testday, dtime
   write(*, *)  ' setting to 0 and continuing'
   dtime = 0.0
else if (dtime > 24.0) then
   write(*, 10) 'cast number: ', castid, ' date, dtime: ', testyear, testmonth, testday, dtime
   ! some obs seem to have more than 24 hours in the time variable.
   ! got confirmation from WOD providers that some appear to be keypunch
   ! entry errors.  this field should never be > 24.  for now, set to 0
   ! because the date is believed to be good.
   !write(*, *)  ' discarding obs'
   !date_ok = .FALSE.
   !return
   write(*, *)  ' setting to 0 and continuing'
   dtime = 0.0
endif

! good day - return success
if (testday > 0 .and. testday <= days_per_month(testmonth)) then
   date_ok = .TRUE.
   return
endif

! don't do the year test unless this is leap day.
if ((testmonth == 2) .and. (testday == 29)) then
   ! jan 1st always exists.  set this so we can test for leap year.
   test_time = set_date(testyear, 1, 1)
   if (.not. leap_year(test_time)) then
      write(*, 10) 'cast number: ', castid, ' date, dtime: ', testyear, testmonth, testday, dtime
      write(*, *)  ' does not exist in this non-leap year; setting to mar 1'
      ! convert this to mar 1 (date conversion error)
      testmonth = 3
      testday = 1
   endif
   date_ok = .TRUE.
   return
endif

! day 0 is possibly a processing error, but actual day is currently unknown.
! i have been advised to discard these, which i am reluctantly going to do.
if (testday == 0) then
   write(*, 10) 'cast number: ', castid, ' date, dtime: ', testyear, testmonth, testday, dtime
   write(*, *)  ' does not exist; discarding obs'
   date_ok = .FALSE.
   return
   ! alternative code - keep obs and set day to 1 and time to 0.
   !write(*, *)  ' setting day to 1, dtime to 0'
   !testday = 1
   !dtime = 0.0
   !date_ok = .TRUE.
   return
endif

! if only 1 > end of month, set to end of month and succeed.
! if more than 1 > end of month, fail.
! found other files with 4/31 and 6/39 as dates.
if (testday > days_per_month(testmonth)+1) then
   write(*, 10) 'cast number: ', castid, ' date, dtime: ', testyear, testmonth, testday, dtime
   write(*, *)  ' does not exist; discarding obs'
   date_ok = .FALSE.
   return
endif

! not sure this is a good idea; maybe should discard these obs?
if (testday == days_per_month(testmonth)+1) then
   write(*, 10) 'cast number: ', castid, ' date, dtime: ', testyear, testmonth, testday, dtime
   write(*, *)  ' does not exist; assuming rollover to day 1, month+1, dtime to 0'
   dtime = 0.0
   testday = 1
   testmonth = testmonth + 1
   if (testmonth > 12) then
      testmonth = 1
      testyear = testyear + 1
   endif
   date_ok = .TRUE.
   return
endif

! shouldn't get here.  assume bad date.
write(*, 10) 'cast number: ', castid, ' date, dtime: ', testyear, testmonth, testday, dtime
write(*, *)  ' bad date; discarding obs'
date_ok = .FALSE.
return

end function date_ok

end program wod_to_obs

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


C*********************************************************************

      subroutine upyth(id1,iso31,id2,iso32,sqrts)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER id1,iso31,id2,iso32,iso3,kfa
      integer pdgid
      double precision sqrts,mm_to_fmc

      real*8 ranf
      external ranf

c      character*4 reffram

      include 'newpart.f'
      include 'options.f'

C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
      COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYINT1/MINT(400),VINT(400)
      COMMON/PYDATR/MRPY(6),RRPY(100)
      SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
     &     /PYINT1/,/PYDATR/
      integer pyk,pychge,pycomp
C...Local arrays.
c      DIMENSION PSUM(5),PINI(6),PFIN(6)

C...List of string ends besides those quarks or diquarks from nucleons
      DIMENSION NSTREND(20)
      DIMENSION NENTRY(4000),SUPPFACT(4000)
      character chaup_pro*20,chaup_tar*20

ccccccccccccccccccccccccc section 1: set up PYTHIA cccccccccccccccccccccc

c conversion from mm to fm/c
      mm_to_fmc=1d3/(1d-15/2.99792458d8)

c... redo pythia if scattering was soft
 437  continue

C...Reset process type, kinematics cuts, and the flags used.
      DO 190 ISUB=1,500
         MSUB(ISUB)=0
 190  CONTINUE

      msel=0
      msub(11)=1 !default processes
      msub(12)=1
      msub(13)=1
      msub(28)=1
      msub(53)=1
      msub(68)=1
      msub(95)=1
c      msub(81)=1 !extra
c      msub(82)=1
      msub(86)=1                ! turn on J/psi
      msub(87)=1
      msub(88)=1
      msub(89)=1
      msub(106)=1

c... use PYTHIA standard

      MSTP(2)=1  ! 1st order alpha_s

CC use default values
c      MSTP(33)=1 ! K-factor
c      PARP(31)=1.5
c      MSTP(81)=1 ! allow multiple interactions
c      MSTP(82)=1 ! gaussian matter distribution in nucleon
c      MSTP(111)=1 ! do fragmentation (LUND)
c      MSTP(131)=0 ! generate only one event at a time
c      MSTP(133)=0

c... no decays
      mstj(21)=0

c... suppress output
      mstp(122)=0

c... set the random number seed to urqmd random number
      mrpy(1)=int(900000000*ranf(0))

ccccccccccccccccccc section 2: convert urqmd input to PDGID ccccccccccccccc

c      write(6,*) 'id and iso ',id1,iso31,id2,iso32

      kfpro=pdgid(id1,iso31)
      kftar=pdgid(id2,iso32)

      call hepnam(kfpro,chaup_pro)
      call hepnam(kftar,chaup_tar)
ccccccccccccccccccc section 3: call PYTHIA cccccccccccccccccccccccccccccccc

c      write(6,*) 'calling pythia with ',chaup_pro,chaup_tar,sqrts

      CALL PYINIT('CMS',chaup_pro,chaup_tar,sqrts)

C...Generate nevent events of each required type.

      CALL PYEVNT

c ... hard scattering? Q>1.5 GeV
      if (vint(51).le.1.5) goto 437

c... define string ends for leading particle cross sections
C...Get the potential string end from the hard process
      istrend=0
      if(ABS(K(3,2)).le.3)then
         if(K(5,2).ne.K(3,2))then
            istrend = istrend + 1
            nstrend(istrend)=3
         else if(K(7,2).eq.K(3,2))then
            istrend = istrend + 1
            nstrend(istrend)=7
         endif
      endif
      if(ABS(K(4,2)).le.3)then
         if(K(6,2).ne.K(4,2))then
            istrend = istrend + 1
            nstrend(istrend)=4
         else if(K(8,2).eq.K(4,2))then
            istrend = istrend + 1
            nstrend(istrend)=8
         endif
      endif
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C...Some other cases:
C...1). gluon fusion or quark fusion? ~1%
C       or quark-antiquark annilation ~0.1%
c      if(K(5,2).ne.K(7,2).or.K(6,2).ne.K(8,2))then
c         write(*,*)i
c         call pylist(1)
c      endif
C...2). gluon shower to a quark. ~2%
c      nsig = 0
c      if(istrend.eq.0)then
c         do kk=3,8
c            if(K(kk,2).ne.21)nsig = 1
c         enddo
c      endif
c      if(K(5,2).ne.K(7,2).or.K(6,2).ne.K(8,2))nsig=0
c      if(nsig.eq.1)then
c         write(*,*)i
c         call pylist(1)
c      endif
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

C...Find the entries of the output hadrons (entries with K(I,1)=1) after
C   the call of pyedit(2).
      nhadron=0
      do j=1,N
         if(K(j,1).eq.1)then
            nhadron=nhadron+1
            NENTRY(j)=nhadron
         else
            NENTRY(j)=0
         endif
      enddo

C...Initialize of the array of leading factor.
      do j=1,nhadron
         SUPPFACT(j)=0
      enddo

C...Get the strings
      istrsig=0
      nenstrbegin=0
      nenstrend=0
      do j=msti(4)+1,N
         if(K(j,1).eq.12.and.istrsig.eq.0)then
            !begin of a string
            istrsig=1
            nenstrbegin=j

         else if(K(j,1).eq.11.and.istrsig.eq.1)then
            !end of a string
            istrsig=0
            nenstrend=j

            if(K(j,3).le.msti(4))then
            !consider only the original string
            !firtly, get the entry of the string
            ndt=K(j,4)
 1099       if(K(ndt,2).ne.92.and.K(ndt,2).ne.91)then
               ndt=K(ndt,4)
               goto 1099
            endif

            !find the leading parton
            ileadsigl=0
            if(K(nenstrbegin,3).le.2.and.K(nenstrbegin,3).gt.0)then
               ileadsigl=1
            else
               do jj=1,istrend
               if(K(nenstrbegin,3).eq.nstrend(jj)
     $            .and.K(nenstrbegin,2).eq.K(nstrend(jj),2))then
                  ileadsigl=1
               endif
               enddo
            endif
            ileadsigr=0
            if(K(nenstrend,3).le.2.and.K(nenstrend,3).gt.0)then
               ileadsigr=1
            else
               do jj=1,istrend
               if(K(nenstrend,3).eq.nstrend(jj)
     $            .and.K(nenstrend,2).eq.K(nstrend(jj),2))then
                  ileadsigr=1
               endif
               enddo
            endif

            if(K(ndt,2).eq.91)then
               !cluster
               !has 1 or 2 daughters
               !ASSUME:both quarks in a di-quark are from the incident hadrons

               if(abs(K(nenstrbegin,2)).lt.1000
     $            .and.abs(K(nenstrend,2)).lt.1000)then
                  !meson string (T)
                  if(K(ndt,4).eq.K(ndt,5))then
                     !single meson
                     if(ileadsigl.eq.1)then
                        SUPPFACT(NENTRY(K(ndt,4)))=
     $                    SUPPFACT(NENTRY(K(ndt,4)))+0.5d0
                     endif
                     if(ileadsigr.eq.1)then
                        SUPPFACT(NENTRY(K(ndt,4)))=
     $                    SUPPFACT(NENTRY(K(ndt,4)))+0.5d0
                     endif
                  else
                     !double meson
                     if(ileadsigl.eq.1)SUPPFACT(NENTRY(K(ndt,4)))=0.5d0
                     if(ileadsigr.eq.1)SUPPFACT(NENTRY(K(ndt,5)))=0.5d0
                  endif
               else
                  !baryon string (T)
                  if(abs(K(nenstrend,2)).gt.1000)then
                     nenstrtmp=nenstrbegin
                     nenstrbegin=nenstrend
                     nenstrend=nenstrtmp
                     ileadsigtmp=ileadsigl
                     ileadsigl=ileadsigr
                     ileadsigr=ileadsigtmp
                  endif

                  if(K(ndt,4).eq.K(ndt,5))then
                     !single baryon
                     if(ileadsigl.eq.1)then
                        SUPPFACT(NENTRY(K(ndt,4)))=
     $                    SUPPFACT(NENTRY(K(ndt,4)))+0.66667d0
                     endif
                     if(ileadsigr.eq.1)then
                        SUPPFACT(NENTRY(K(ndt,4)))=
     $                    SUPPFACT(NENTRY(K(ndt,4)))+0.33333d0
                     endif
                  else
                     !baryon+meson
                     if(ileadsigl.eq.1)then
                        if(abs(K(K(ndt,4),2)).gt.1000)then
                           SUPPFACT(NENTRY(K(ndt,4)))=0.66667d0
                        else
                           SUPPFACT(NENTRY(K(ndt,4)))=0.5d0
                           SUPPFACT(NENTRY(K(ndt,5)))=0.33333d0
                        endif
                     endif
                     if(ileadsigr.eq.1)then
                        if(abs(K(K(ndt,5),2)).gt.1000)then
                           SUPPFACT(NENTRY(K(ndt,5)))=
     $                       SUPPFACT(NENTRY(K(ndt,5)))+0.33333d0
                        else
                           SUPPFACT(NENTRY(K(ndt,5)))=0.5d0
                        endif
                     endif
                  endif
               endif
            else if(K(ndt,2).eq.92)then
               !string
               !has >= 2 daughters
               !ASSUME:both quarks in a di-quark are from the incident hadrons

               if(ileadsigl.eq.1)then
                  if(abs(K(nenstrbegin,2)).lt.10)then
                     !leading quark or anti-quark
                     if(abs(K(K(ndt,4),2)).lt.1000)then
                        SUPPFACT(NENTRY(K(ndt,4)))=0.5d0
                     else
                        SUPPFACT(NENTRY(K(ndt,4)))=0.33333d0
                     endif
                  else if(abs(K(nenstrbegin,2)).gt.1000)then
                     !leading di-quark
                     if(abs(K(K(ndt,4),2)).lt.1000)then
                        SUPPFACT(NENTRY(K(ndt,4)))=0.5d0
                        SUPPFACT(NENTRY(K(ndt,4)+1))=0.33333d0
                     else
                        SUPPFACT(NENTRY(K(ndt,4)))=0.66667d0
                     endif
                  endif
               endif

               if(ileadsigr.eq.1)then
                  if(abs(K(nenstrend,2)).lt.10)then
                     !leading quark or anti-quark
                     if(abs(K(K(ndt,5),2)).lt.1000)then
                        SUPPFACT(NENTRY(K(ndt,5)))=
     $                     SUPPFACT(NENTRY(K(ndt,5)))+0.5d0
                     else
                        SUPPFACT(NENTRY(K(ndt,5)))=
     $                     SUPPFACT(NENTRY(K(ndt,5)))+0.33333d0
                     endif
                  else if(abs(K(nenstrend,2)).gt.1000)then
                     !leading di-quark
                     if(abs(K(K(ndt,5),2)).lt.1000)then
                        SUPPFACT(NENTRY(K(ndt,5)))=
     $                     SUPPFACT(NENTRY(K(ndt,5)))+0.5d0
                        SUPPFACT(NENTRY(K(ndt,5)-1))=
     $                     SUPPFACT(NENTRY(K(ndt,5)-1))+0.33333d0
                     else
                        SUPPFACT(NENTRY(K(ndt,5)))=
     $                     SUPPFACT(NENTRY(K(ndt,5)))+0.66667d0
                     endif
                  endif
               endif

            else
               write(*,*)'ERROR in PYTHIA: ',i,j,ndt,K(ndt,2)
               call pylist(2)
            endif
            endif

         else if(K(j,1).eq.1.and.K(j,3).le.2)then
            !direct hadrons
            if(abs(K(j,2)).lt.1000)then
               !meson
               SUPPFACT(NENTRY(j))=0.5d0
            else
               !baryon
               !Need to check whether there are exceptions(only one l.q.)
               SUPPFACT(NENTRY(j))=0.66667d0
            endif

         else if(K(j,1).eq.11.and.K(j,2).eq.92.and.istrsig.eq.0)then
            !the string entry. the end of the treatment.
            goto 1101
         endif
      enddo

 1101 continue

c... check out the suppression factor before the removement
c      call pylist(2)
c      do j=1,N
c         if(K(j,1).eq.1.and.SUPPFACT(NENTRY(j)).ne.0)then
c         write(*,*)j,SUPPFACT(NENTRY(j))
c         endif
c      enddo

c... remove unwanted particles from event
      call pyedit(2)

C...List statistics for each process type.
c     CALL PYSTAT(1)

ccccccccccccccccccc section 4: convert PYTHIA arrays to UrQMD newpart array
c-
      nexit=n
      nstring1=nexit
      nstring2=0

c      write(6,*) 'exit pythia with ',nexit

      do 10 i=1,nexit

c         write(6,*) ' particle ',k(i,2)
         kfa=k(i,2)
         call pdg2id(ityp,iso3,kfa)
         itypnew(i)=ityp
         i3new(i)=iso3

c set leadfac
c.. suppress some part of the cross section to mimic coherence
         SUPPFACT(i)=SUPPFACT(i)*CTParam(59)
         leadfac(i)=SUPPFACT(i)

         do 20 j=1,4
            pnew(j,i)=p(i,j)
            xnew(j,i)=v(i,j)*mm_to_fmc !useless
 20      continue
         pnew(5,i)=p(i,5)
c set formation time
         if(pnew(5,i).gt.0d0) then
            xnew(4,i)=0.8d0*pnew(4,i)/pnew(5,i)
         endif

 10   continue

      do 63 i=1,nexit
         if (leadfac(i).gt.0d0) then
            sidnew(i)=strcount
         else
            sidnew(i)=0
         endif
 63   continue
      strcount=strcount + 1

      RETURN
      END

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine pdg2id (ityp,iso3,pdgid)
c
c     Author   : Steffen A. Bass
c     Date     : 06/08/98
c     Revision : 1.0
c
c based on ityp2pdg.f from Henning Weber
c
c     converts PDG-Id to  UrQMD-Id
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      implicit none

      integer pdgid,i
      integer ityp
      integer iso3

      integer tab_size
      parameter (TAB_SIZE = 172)

      integer idtab(3,TAB_SIZE)

      character chau*20

      data idtab/
c Neutron
     .       1, -1,  2112,
c Proton
     .       1,  1,  2212,
c N*
     .       2, -1, 12112,
     .       2,  1, 12212,
     .       3, -1,  1214,
     .       3,  1,  2124,
     .       4, -1, 22112,
     .       4,  1, 22212,
     .       5, -1, 32112,
     .       5,  1, 32212,
     .       6, -1,  2116,
     .       6,  1,  2216,
     .       7, -1, 12116,
     .       7,  1, 12216,
     .       8, -1, 21214,
     .       8,  1, 22124,
     .       9, -1, 42112,
     .       9,  1, 42212,
     .      10, -1, 31214,
     .      10,  1, 32124,
     .      14, -1,  1218,
     .      14,  1,  2128,
c Delta
     .      17, -3,  1114,
     .      17, -1,  2114,
     .      17,  1,  2214,
     .      17,  3,  2224,
     .      18, -3, 31114,
     .      18, -1, 32114,
     .      18,  1, 32214,
     .      18,  3, 32224,
     .      19, -3,  1112,
     .      19, -1,  1212,
     .      19,  1,  2122,
     .      19,  3,  2222,
     .      20, -3, 11114,
     .      20, -1, 12114,
     .      20,  1, 12214,
     .      20,  3, 12224,
     .      21, -3, 11112,
     .      21, -1, 11212,
     .      21,  1, 12122,
     .      21,  3, 12222,
     .      22, -3,  1116,
     .      22, -1,  1216,
     .      22,  1,  2126,
     .      22,  3,  2226,
     .      23, -3, 21112,
     .      23, -1, 21212,
     .      23,  1, 22122,
     .      23,  3, 22222,
     .      24, -3, 21114,
     .      24, -1, 22114,
     .      24,  1, 22214,
     .      24,  3, 22224,
     .      25, -3, 11116,
     .      25, -1, 11216,
     .      25,  1, 12126,
     .      25,  3, 12226,
     .      26, -3,  1118,
     .      26, -1,  2118,
     .      26,  1,  2218,
     .      26,  3,  2228,
c Lambda
     .      27,  0,  3122,
     .      28,  0, 13122,
     .      29,  0,  3124,
     .      30,  0, 23122,
     .      31,  0, 33122,
     .      32,  0, 13124,
     .      33,  0, 43122,
     .      34,  0, 53122,
     .      35,  0,  3126,
     .      36,  0, 13126,
     .      37,  0, 23124,
     .      38,  0,  3128,
     .      39,  0, 23126,
c Sigma
     .      40, -2,  3112,
     .      40,  0,  3212,
     .      40,  2,  3222,
     .      41, -2,  3114,
     .      41,  0,  3214,
     .      41,  2,  3224,
     .      42, -2, 13112,
     .      42,  0, 13212,
     .      42,  2, 13222,
     .      43, -2, 13114,
     .      43,  0, 13214,
     .      43,  2, 13224,
     .      44, -2, 23112,
     .      44,  0, 23212,
     .      44,  2, 23222,
     .      45, -2,  3116,
     .      45,  0,  3216,
     .      45,  2,  3226,
     .      46, -2, 13116,
     .      46,  0, 13216,
     .      46,  2, 13226,
     .      47, -2, 23114,
     .      47,  0, 23214,
     .      47,  2, 23224,
     .      48, -2,  3118,
     .      48,  0,  3218,
     .      48,  2,  3228,
c Xi
     .      49, -1,  3312,
     .      49,  1,  3322,
     .      50, -1,  3314,
     .      50,  1,  3324,
     .      52, -1, 13314,
     .      52,  1, 13324,
c Omega
     .      55,  0,  3334,
c gamma
     .     100,  0,    22,
c pion
     .     101, -2,  -211,
     .     101,  0,   111,
     .     101,  2,   211,
c eta
     .     102,  0,   221,
c omega
     .     103,  0,   223,
c rho
     .     104, -2,  -213,
     .     104,  0,   113,
     .     104,  2,   213,
c f0(980)
     .     105,  0, 10221,
c kaon
     .     106, -1,   311,
     .     106,  1,   321,
c eta'
     .     107,  0,   331,
c k*(892)
     .     108, -1,   313,
     .     108,  1,   323,
c phi
     .     109,  0,   333,
c k0*(1430)
     .     110, -1, 10313,
     .	   110,  1, 10323,
c a0(980)
     .	   111, -2,-10211,
     .     111,  0, 10111,
     .	   111,  2, 10211,
c f0(1370)
     .     112,  0, 20221,
c k1(1270)
     .     113, -1, 10313,
     .     113,  1, 10323,
c a1(1260)
     .     114, -2,-20213,
     .     114,	 0, 20113,
     .	   114,	 2, 20213,
c f1(1285)
     .     115,  0, 20223,
c f1'(1510)
     .     116,  0, 40223,
c k2*(1430)
     .     117, -1,   315,
     .	   117,  1,   325,
c a2(1329)
     .     118, -2,  -215,
     .     118,  0,   115,
     .	   118,  2,   215,
c f2(1270)
     .     119,  0,   225,
c f2'(1525)
     .     120,  0,   335,
c k1(1400)
     .     121, -1, 20313,
     .	   121,  1, 20323,
c b1
     .     122, -2,-10213,
     .     122,  0, 10113,
     .     122,  2, 10213,
c h1
     .     123,  0, 10223,
c K* (1410)
     .	   125, -1, 30313,
     .     125,  1, 30323,
c rho (1450)
     .     126, -2,-40213,
     .	   126,  0, 40113,
     .     126,  2, 40213,
c omega (1420)
     .	   127,  0, 50223,
c phi(1680)
     .	   128,  0, 10333,
c k*(1680)
     .	   129, -1, 40313,
     .     129,  1, 40323,
c rho(1700)
     .     130, -2,-30213,
     .	   130,  0, 30113,
     .     130,  2, 30213,
c omega(1600)
     .	   131,  0, 60223,
c phi(1850)
     .	   132,	 0,   337,
c D
     .     133,  1,   411,
     .     133, -1,   421,
c D*
     .     134,  1, 10411,
     .     134, -1, 10421,
c J/Psi
     .     135,  0, 443,
c Psi'
     .     136,  0, 100443,
c Chi_C
     .     137,  0, 10441/

c search for the ITYP in IDTAB

      do 99 i=1,TAB_SIZE
         if(idtab(3,i).eq.pdgid) then
            ityp=idtab(1,i)
            iso3=idtab(2,i)
            return
         elseif((pdgid.lt.0).and.(idtab(3,i).eq.abs(pdgid))) then
            ityp=(-1)*idtab(1,i)
            iso3=(-1)*idtab(2,i)
            return
         endif
 99   continue

c handle all unknown ityps from PYTHIA
      ityp=1000+abs(pdgid)
      if(pdgid.lt.0) ityp=(-1)*ityp
      iso3=0

c      call hepnam(pdgid,chau)
c      write(6,*) '(Info) pdg2ityp: ',chau,' PDG-Id: ',pdgid,'
c     &  -> ityp',ityp
c      stop

      return
      end


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     setsto4: STO-3G parameters in a four gaussian expansion for
!      EHT basis set
!
!     part of QMDFF
!
subroutine setsto4(nprim,n,l,zeta,expo,cont)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
dimension expo(*),cont(*)
dimension ALLC(4,5,3),ALLZ(4,5,3)
integer::iam,nprim
real(kind=8)::DEX(-1:96)

nprim=4

PI=4.D0*ATAN(1.D0)
DO I=-1,10
   DEX(I)=DEX2(I)
ENDDO
!     1s
ALLZ(1,1,1) =5.216844534
ALLZ(2,1,1) =9.546182760D-1
ALLZ(3,1,1) =2.652034102D-1
ALLZ(4,1,1) =8.801862774D-2
ALLC(1,1,1) =5.675242080D-2
ALLC(2,1,1) =2.601413550D-1
ALLC(3,1,1) =5.328461143D-1
ALLC(4,1,1) =2.916254405D-1
!     2s
ALLZ(1,2,1) =1.161525551D1
ALLZ(2,2,1) =2.000243111
ALLZ(3,2,1) =1.607280687D-1
ALLZ(4,2,1) =6.125744532D-2
ALLC(1,2,1) =-1.198411747D-2
ALLC(2,2,1) =-5.472052539D-2
ALLC(3,2,1) =5.805587176D-1
ALLC(4,2,1) =4.770079976D-1
!     2p
ALLZ(1,2,2) =1.798260992
ALLZ(2,2,2) =4.662622228D-1
ALLZ(3,2,2) =1.643718620D-1
ALLZ(4,2,2) =6.543927065D-2
ALLC(1,2,2) =5.713170255D-2
ALLC(2,2,2) =2.857455515D-1
ALLC(3,2,2) =5.517873105D-1
ALLC(4,2,2) =2.632314924D-1
!     3s
ALLZ(1,3,1) =1.513265591
ALLZ(2,3,1) =4.262497508D-1
ALLZ(3,3,1) =7.643320863D-2
ALLZ(4,3,1) =3.760545063D-2
ALLC(1,3,1) =-3.295496352D-2
ALLC(2,3,1) =-1.724516959D-1
ALLC(3,3,1) =7.518511194D-1
ALLC(4,3,1) =3.589627317D-1
!     3p
ALLZ(1,3,2) =1.853180239
ALLZ(2,3,2) =1.915075719D-1
ALLZ(3,3,2) =8.655487938D-2
ALLZ(4,3,2) =4.184253862D-2
ALLC(1,3,2) =-1.434249391D-2
ALLC(2,3,2) =2.755177580D-1
ALLC(3,3,2) =5.846750879D-1
ALLC(4,3,2) =2.144986514D-1
!     3p
ALLZ(1,4,1) =3.242212833D-1
ALLZ(2,4,1) =1.663217177D-1
ALLZ(3,4,1) =5.081097451D-2
ALLZ(4,4,1) =2.829066600D-2
ALLC(1,4,1) =-1.120682822D-1
ALLC(2,4,1) =-2.845426863D-1
ALLC(3,4,1) =8.909873788D-1
ALLC(4,4,1) =3.517811205D-1
!     4p
ALLZ(1,4,2) =1.492607880
ALLZ(2,4,2) =4.327619272D-1
ALLZ(3,4,2) =7.553156064D-2
ALLZ(4,4,2) =3.706272183D-2
ALLC(1,4,2) =-6.035216774D-3
ALLC(2,4,2) =-6.013310874D-2
ALLC(3,4,2) =6.451518200D-1
ALLC(4,4,2) =4.117923820D-1
!     5s
ALLZ(1,5,1) =8.602284252D-1
ALLZ(2,5,1) =1.189050200D-1
ALLZ(3,5,1) =3.446076176D-2
ALLZ(4,5,1) =1.974798796D-2
ALLC(1,5,1) =1.103657561D-2
ALLC(2,5,1) =-5.606519023D-1
ALLC(3,5,1) =1.179429987
ALLC(4,5,1) =1.734974376D-1
!     5p
ALLZ(1,5,2) =3.962838833D-1
ALLZ(2,5,2) =1.838858552D-1
ALLZ(3,5,2) =4.943555157D-2
ALLZ(4,5,2) =2.750222273D-2
ALLC(1,5,2) =-1.801459207D-2
ALLC(2,5,2) =-1.360777372D-1
ALLC(3,5,2) =7.533973719D-1
ALLC(4,5,2) =3.409304859D-1
!     3d
ALLZ(1,3,3) =9.185846715D-1
ALLZ(2,3,3) =2.920461109D-1
ALLZ(3,3,3) =1.187568890D-1
ALLZ(4,3,3) =5.286755896D-2
ALLC(1,3,3) =5.799057705D-2
ALLC(2,3,3) =3.045581349D-1
ALLC(3,3,3) =5.601358038D-1
ALLC(4,3,3) =2.432423313D-1
!     4d
ALLZ(1,4,3) =1.995825422
ALLZ(2,4,3) =1.823461280D-1
ALLZ(3,4,3) =8.197240896D-2
ALLZ(4,4,3) =4.000634951D-2
ALLC(1,4,3) =-2.816702620D-3
ALLC(2,4,3) =2.177095871D-1
ALLC(3,4,3) =6.058047348D-1
ALLC(4,4,3) =2.717811257D-1
!     5d
ALLZ(1,5,3) =4.230617826D-1
ALLZ(2,5,3) =8.293863702D-2
ALLZ(3,5,3) =4.590326388D-2
ALLZ(4,5,3) =2.628744797D-2
ALLC(1,5,3) =-2.421626009D-2
ALLC(2,5,3) =3.937644956D-1
ALLC(3,5,3) =5.489520286D-1
ALLC(4,5,3) =1.190436963D-1

iam=l-1
DO J=1,nprim
   cont(J)=ALLC(J,N,L)
   expo(J)=ALLZ(J,N,L)*zeta**2
   XNORM=(2.D0*EXPO(J)/PI)**0.75D0*(4.D0*EXPO(J))**(IAM/2.D0)/&
     &  SQRT(DEX(2*IAM-1))
   cont(j)=cont(j)*xnorm
END DO

end subroutine setsto4