text:
! ###################################################################
! Copyright (c) 2013-2022, Marc De Graef Research Group/Carnegie Mellon University
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are
! permitted provided that the following conditions are met:
!
!     - Redistributions of source code must retain the above copyright notice, this list
!        of conditions and the following disclaimer.
!     - Redistributions in binary form must reproduce the above copyright notice, this
!        list of conditions and the following disclaimer in the documentation and/or
!        other materials provided with the distribution.
!     - Neither the names of Marc De Graef, Carnegie Mellon University nor the names
!        of its contributors may be used to endorse or promote products derived from
!        this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
! USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ###################################################################

module mod_DREAM3D
  !! author: MDG
  !! version: 1.0
  !! date: 05/28/21
  !!
  !! module with DREAM3D support functions (mostly reading .dream3d files)

use mod_kinds
use mod_global
use iso_fortran_env, only: int64
use mod_quaternions

IMPLICIT NONE

type microstructure

  type(Quaternion3DArray_T)         :: Quaternions
  integer(kind=irg),allocatable     :: FeatureIDs(:,:,:)
  integer(kind=int64),allocatable   :: dimensions(:)
  real(kind=sgl),allocatable        :: origin(:)
  real(kind=sgl),allocatable        :: gridspacing(:)
  real(kind=sgl)                    :: samplescalefactor
  integer(kind=irg)                 :: numvoxels
end type microstructure

contains

!--------------------------------------------------------------------------
subroutine ReadDREAM3Dfile(EMsoft, dname, microstr, EApath, FIDpath)
!DEC$ ATTRIBUTES DLLEXPORT :: ReadDream3Dfile
!! author: MDG
!! version: 1.0
!! date: 05/28/21
!!
!! load a microstructure from an HDF5 file
!! this assumes that the HDF5 interface has been initialized by the calling program

use mod_EMsoft
use mod_IO
use HDF5
use mod_HDFsupport
use mod_rotations

IMPLICIT NONE

type(EMsoft_T),INTENT(INOUT)          :: EMsoft
character(fnlen),INTENT(IN)           :: dname
type(microstructure),INTENT(INOUT)    :: microstr
character(fnlen),INTENT(IN)           :: EApath(10)
character(fnlen),INTENT(IN)           :: FIDpath(10)

type(HDF_T)                           :: HDF
type(IO_T)                            :: Message
type(e_T)                             :: eu
type(q_T)                             :: qq
type(Quaternion_T)                    :: quat

character(fnlen)                      :: fname, groupname, dataset
logical                               :: f_exists, readonly
integer(kind=irg)                     :: hdferr, iq, ix, iy, iz, d3(3)
integer(HSIZE_T)                      :: dims(1), dims3(3), dims4(4)
integer(kind=int64),allocatable       :: dimensions(:)
real(kind=sgl),allocatable            :: origin(:)
real(kind=sgl),allocatable            :: gridspacing(:)
integer(kind=irg),allocatable         :: FeatureIDs(:,:,:,:)
real(kind=sgl),allocatable            :: EulerAngles(:,:,:,:)

HDF = HDF_T()
fname = trim(EMsoft%generateFilePath('EMdatapathname',dname))

! make sure the file actually exists
inquire(file=trim(fname), exist=f_exists)
if (.not.f_exists) then
  call Message%printError('ReadDREAM3Dfile','DREAM3D file '//trim(fname)//' does not exist')
end if

! open the file in read-only mode
readonly = .TRUE.
hdferr =  HDF%openFile(fname, readonly)

! open the DataContainers group
groupname = 'DataContainers'
  hdferr = HDF%openGroup(groupname)

groupname = EApath(2)
  hdferr = HDF%openGroup(groupname)

!--------------------------------------------------------------------------
! in that group we have the _SIMPL_GEOMETRY group with the array dimensions
groupname = '_SIMPL_GEOMETRY'
  hdferr = HDF%openGroup(groupname)

dataset = 'DIMENSIONS'
  call HDF%readDatasetInteger64Array(dataset, dims, hdferr, dimensions)
  allocate(microstr%dimensions(dims(1)))
  microstr%dimensions = dimensions
  d3(1:3) = dimensions(1:3)

dataset = 'ORIGIN'
  call HDF%readDatasetFloatArray(dataset, dims, hdferr, origin)
  allocate(microstr%origin(dims(1)))
  microstr%origin = origin

dataset = 'SPACING'
  call HDF%readDatasetFloatArray(dataset, dims, hdferr, gridspacing)
  allocate(microstr%gridspacing(dims(1)))
  microstr%gridspacing = gridspacing

call HDF%pop()
!--------------------------------------------------------------------------

! next we get the EulerAngles and the FeatureIDs arrays from where ever they are located ...
groupname = EApath(3)
  hdferr = HDF%openGroup(groupname)

dataset = trim(EApath(4))
  call HDF%readDatasetFloatArray(dataset, dims4, hdferr, EulerAngles)

! convert them to a QuaternionArray_T
  microstr%numvoxels = product(dimensions)
  microstr%Quaternions = Quaternion3DArray_T( d3, s = 'd' )
  do iz=1,dimensions(3)
    do iy=1,dimensions(2)
      do ix=1,dimensions(1)
        eu = e_T( edinp = dble(EulerAngles(1:3,ix,iy,iz)) )
        qq = eu%eq()
        quat = Quaternion_T( qd = qq%q_copyd() )
        call microstr%Quaternions%insertQuatin3DArray( (/ ix, iy, iz /), quat)
      end do
    end do
  end do

dataset = trim(FIDpath(4))
  call HDF%readDatasetIntegerArray(dataset, dims4, hdferr, FeatureIDs)
  allocate(microstr%FeatureIDs(dims4(2),dims4(3),dims4(4)))
  microstr%FeatureIDs = FeatureIDs(1,:,:,:)

! clean up some large arrays
  deallocate(EulerAngles, FeatureIDs, dimensions, origin, gridspacing)

! that's it, so we close the file
call HDF%pop(.TRUE.)

call Message%printMessage(' Microstructure data read from DREAM.3D file '//trim(fname))

end subroutine ReadDREAM3Dfile

!--------------------------------------------------------------------------
recursive subroutine getRayOrientations(microstr, rslist, nsp, orlist)
!DEC$ ATTRIBUTES DLLEXPORT :: getRayOrientations
!! author: MDG
!! version: 1.0
!! date: 07/15/21
!!
!! extract orientations from the microstructure along a ray

type(microstructure),INTENT(INOUT)    :: microstr
integer(kind=irg),INTENT(IN)          :: nsp
real(kind=dbl),INTENT(IN)             :: rslist(3, nsp)
type(QuaternionArray_T),INTENT(INOUT) :: orlist

integer(kind=irg)                     :: i

! declare a standard QuaternionArray structure
orlist = QuaternionArray_T( n = nsp, s = 'd' )

! get the orientation at each ray position from the 3D quaternion array
do i=1,nsp
  call orlist%insertQuatinArray( i, microstr%Quaternions%getQuatfrom3DArray( nint(rslist(:,i)) ) )
end do

! expansion for multi-phase microstructures:  get Feature and Phase IDs as well
end subroutine getRayOrientations

end module mod_DREAM3D

max_stars_repo_name: EMsoft-org/EMsoftOO

max_issues_repo_name: EMsoft-org/EMsoftOO

max_forks_repo_name: EMsoft-org/EMsoftOO


text:
!   ADDED BY KSM 7.4.3

module dm_mod
   type dmtab
      integer(kind=4) :: statei, statej
      integer(kind=4) :: jt
      real(kind=4), pointer :: tab(:,:,:)  ! tab(orba, orbb, species)
      type(dmtab), pointer :: next
   end type dmtab

   type(dmtab), pointer :: dmhead => NULL()
contains

! clean up linked list
subroutine dm_reset()
   implicit none
   type(dmtab), pointer :: dp

   do while(associated(dmhead))
      dp => dmhead
      dmhead => dp%next
      deallocate(dp%tab)
      deallocate(dp)
   end do
end subroutine dm_reset

! push new record onto linked list
subroutine dm_add_tab(statei, statej, jt, numorb)
   implicit none
   ! args
   integer :: species, statei, statej, jt,numorb
   ! locals
   real(kind=4), pointer :: tab(:,:,:)
   type(dmtab),  pointer :: dnp

   allocate(dnp)
   allocate(dnp%tab(1:numorb, 1:numorb, 0:1))
   dnp%tab = 0.0
   dnp%statei = statei
   dnp%statej = statej
   dnp%jt = jt
   dnp%next => dmhead
   dmhead => dnp
end subroutine dm_add_tab

!======================================================
! Write out density matrix elements to Mathematica format
! KSM
subroutine density1b_write_math_me(mfn, nkeep, numorbmax, dp)
   implicit none
   ! arguments
   integer :: mfn  ! file
   integer :: species, nkeep, numorbmax
   real(kind=4) :: tab(1:numorbmax,1:numorbmax,0:1)
   type(dmtab), pointer :: dp

   ! locals
   integer :: m, n
   real(kind=4) :: me0, me1
   logical :: wcomma

   write(mfn, '(A)')  "(* densMatElem[statei, statej, jt, tt, {table}]        *)"
   write(mfn, '(A)')  "(* Table entries   {orba, orbb, me0, me1}              *)"
   write(mfn, '(A,I4,A,I4,A,I4,A)') "densMatElem[", &
      dp%statei, ",", dp%statej, ", ", dp%jt,  ", {"
   wcomma = .false.
   do m=1,numorbmax
      do n=1,numorbmax
         me0 = dp%tab(m,n,0)
         me1 = dp%tab(m,n,1)
         if(me0 /= 0.0 .or. me1 /= 0.0) then
            if(wcomma) write(mfn, '(A)') ","
            wcomma = .true.
            write(mfn, '(A,I3,A,I3,A,F12.8,A,F12.8,A)', advance='NO') "   {", m, ", ", n, ", ", me0,", ", me1, "}"
         end if
      end do
   end do
   write(mfn, '(A)') " " ! newline
   write(mfn, '(A)') "}];"
end subroutine density1b_write_math_me

subroutine density1b_write_math(nkeep, stateE, stateJ, stateT)
   use nodeinfo
   use sporbit
   use io
   use menu_choices
   use pocc_mod
   use system_parameters
   use interaction
   implicit none
   ! arguments
   integer :: nkeep
   real(kind=4) :: dm(0:1, 1:nkeep, 1:nkeep, 1:numorbmax, 1:numorbmax)
   real(kind=4) :: stateE(1:nkeep), stateJ(1:nkeep), stateT(1:nkeep)
   ! locals
   integer :: i, j, m, n
   logical :: wcomma
   integer :: mfn ! file
   character(len=1024) :: mdenspath
   type(dmtab), pointer :: dp

  ! open mathematica format output file if requested
  mfn = -1  ! test  mfn > 0 for writing below
  if(iproc == 0 .and. menu_dx_omathematica) then
     i = index(outfile, ' ') - 1
     mdenspath = outfile(1:i) // '_dres.m'
     open(unit=mdensfile, file=mdenspath,  action='WRITE', status='REPLACE', err=101)
     mfn = mdensfile
101  continue
  end if
  if(mfn > 0) then
     write(mfn, "(A)")  "(* Bigstick density matrix file *)"
     if(isoflag) then
        write(mfn, '(A)') "densSetIso[True];"
     else
        write(mfn, '(A)') "densSetIso[False];"
     endif
     call pocc_write_orbits_m(mfn)
     write(mfn, '(A,I4,A,I4,A)') "densSetNumParticles[", np(1), ",", np(2), "];"
     write(mfn, '(A)')  "densSetStates[{ (* {#, E, J*2, T*2} *)"
     wcomma = .false.
     do i=1,nkeep
        if(wcomma) write(mfn, '(A)') ","
        wcomma = .true.
        write(mfn, '(A,I3,A,F14.8,A,F12.5,A,F12.5,A)', advance='NO') &
          "   {", i, ",", stateE(i), ",", stateJ(i), ",", stateT(i), "}"
     end do
     write(mfn, '(A)')  " "  ! final newline
     write(mfn, '(A)')  "}];"
     dp => dmhead
     do while(associated(dp))
        call density1b_write_math_me(mfn, nkeep, numorbmax, dp)
        dp => dp%next
     end do
  end if
  if(mfn > 0) close(mfn)

end subroutine density1b_write_math

end module dm_mod

max_stars_repo_name: noctildon/pyBigstick

max_issues_repo_name: noctildon/pyBigstick

max_forks_repo_name: noctildon/pyBigstick


text:
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!
!!!!   MIT License
!!!!
!!!!   ParaMonte: plain powerful parallel Monte Carlo library.
!!!!
!!!!   Copyright (C) 2012-present, The Computational Data Science Lab
!!!!
!!!!   This file is part of the ParaMonte library.
!!!!
!!!!   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.
!!!!
!!!!   ACKNOWLEDGMENT
!!!!
!!!!   ParaMonte is an honor-ware and its currency is acknowledgment and citations.
!!!!   As per the ParaMonte library license agreement terms, if you use any parts of
!!!!   this library for any purposes, kindly acknowledge the use of ParaMonte in your
!!!!   work (education/research/industry/development/...) by citing the ParaMonte
!!!!   library as described on this page:
!!!!
!!!!       https://github.com/cdslaborg/paramonte/blob/main/ACKNOWLEDGMENT.md
!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!> \brief
!> This module contains the classes and procedures for setting up the `tolerance` attribute of samplers of class [ParaNest_type](@ref paranest_mod::paranest_type).
!> For more information, see the description of this attribute in the body of the module.
!> \author Amir Shahmoradi

module SpecNest_Tolerance_mod

    use Constants_mod, only: RK
    implicit none

    character(*), parameter         :: MODULE_NAME = "@SpecNest_Tolerance_mod"

    real(RK)                        :: tolerance ! namelist input

    type                            :: Tolerance_type
        real(RK)                    :: val
        real(RK)                    :: def
        real(RK)                    :: null
        character(:), allocatable   :: desc
    contains
        procedure, pass             :: set, checkForSanity, nullifyNameListVar
    end type Tolerance_type

    interface Tolerance_type
        module procedure            :: construct
    end interface Tolerance_type

    private :: construct, set, nullifyNameListVar

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

contains

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    pure function construct(methodName) result(self)
#if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
        !DEC$ ATTRIBUTES DLLEXPORT :: construct
#endif
        use Constants_mod, only: NULL_RK
        use String_mod, only: num2str
        implicit none
        character(*), intent(in)    :: methodName
        type(Tolerance_type)        :: self
        self%def = 0.5_RK
        self%null = NULL_RK
        self%desc = &
        "tolerance is a 64-bit positive real number representing the threshold below which the integration of the objective function &
        &by the " //methodName// " sampler is assumed to have converged. Typical values are around 0.1-1. Avoid setting this number to &
        &extremely tiny values on the order of 1e-6 or smaller, otherwise neither the integration result is guaranteed to converge nor &
        &nor the sampler will ever stop the simulation. &
        &The default value for tolerance is "//num2str(self%def)//"."
    end function construct

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    subroutine nullifyNameListVar(self)
#if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
        !DEC$ ATTRIBUTES DLLEXPORT :: nullifyNameListVar
#endif
        implicit none
        class(Tolerance_type), intent(in)   :: self
        tolerance = self%null
    end subroutine nullifyNameListVar

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    pure subroutine set(self,tolerance)
#if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
        !DEC$ ATTRIBUTES DLLEXPORT :: set
#endif
        use Constants_mod, only: RK
        implicit none
        class(Tolerance_type), intent(inout)    :: self
        real(RK), intent(in)                    :: tolerance
        self%val = tolerance
        if (self%val==self%null) self%val = self%def
    end subroutine set

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    pure subroutine checkForSanity(self,Err,methodName)
#if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
        !DEC$ ATTRIBUTES DLLEXPORT :: checkForSanity
#endif
        use Constants_mod, only: RK
        use Err_mod, only: Err_type
        use String_mod, only: num2str
        implicit none
        class(Tolerance_type), intent(in)   :: self
        type(Err_type), intent(inout)       :: Err
        character(*), intent(in)            :: methodName
        character(*), parameter             :: PROCEDURE_NAME = "@checkForSanity()"
        if ( self%val <= 0._RK ) then
            Err%occurred = .true.
            Err%msg =   Err%msg // &
                        MODULE_NAME // PROCEDURE_NAME // ": Error occurred. &
                        &The input variable tolerance (" // num2str(self%val) // &
                        ") cannot be less than 0. If you are not sure of the appropriate value for tolerance, drop it &
                        &from the input list. " // methodName // " will automatically assign an appropriate value to it.\n\n"
        end if
    end subroutine checkForSanity

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

end module SpecNest_Tolerance_mod ! LCOV_EXCL_LINE

max_stars_repo_name: cdslaborg/paramonte

max_issues_repo_name: cdslaborg/paramonte

max_forks_repo_name: cdslaborg/paramonte


text:
cdis
cdis    Open Source License/Disclaimer, Forecast Systems Laboratory
cdis    NOAA/OAR/FSL, 325 Broadway Boulder, CO 80305
cdis
cdis    This software is distributed under the Open Source Definition,
cdis    which may be found at http://www.opensource.org/osd.html.
cdis
cdis    In particular, redistribution and use in source and binary forms,
cdis    with or without modification, are permitted provided that the
cdis    following conditions are met:
cdis
cdis    - Redistributions of source code must retain this notice, this
cdis    list of conditions and the following disclaimer.
cdis
cdis    - Redistributions in binary form must provide access to this
cdis    notice, this list of conditions and the following disclaimer, and
cdis    the underlying source code.
cdis
cdis    - All modifications to this software must be clearly documented,
cdis    and are solely the responsibility of the agent making the
cdis    modifications.
cdis
cdis    - If significant modifications or enhancements are made to this
cdis    software, the FSL Software Policy Manager
cdis    (softwaremgr@fsl.noaa.gov) should be notified.
cdis
cdis    THIS SOFTWARE AND ITS DOCUMENTATION ARE IN THE PUBLIC DOMAIN
cdis    AND ARE FURNISHED "AS IS."  THE AUTHORS, THE UNITED STATES
cdis    GOVERNMENT, ITS INSTRUMENTALITIES, OFFICERS, EMPLOYEES, AND
cdis    AGENTS MAKE NO WARRANTY, EXPRESS OR IMPLIED, AS TO THE USEFULNESS
cdis    OF THE SOFTWARE AND DOCUMENTATION FOR ANY PURPOSE.  THEY ASSUME
cdis    NO RESPONSIBILITY (1) FOR THE USE OF THE SOFTWARE AND
cdis    DOCUMENTATION; OR (2) TO PROVIDE TECHNICAL SUPPORT TO USERS.
cdis
cdis
cdis
cdis
cdis
c
c
      subroutine read_metar(nf_fid , maxSkyCover, recNum, altimeter,
     &     autoStationType, dewpoint, dpFromTenths, elevation,
     &     latitude, longitude, maxTemp24Hour, minTemp24Hour,
     &     precip1Hour, precip24Hour, precip3Hour, precip6Hour,
     &     presWeather, pressChange3Hour, pressChangeChar,
     &     reportType, seaLevelPress, skyCover, skyLayerBase,
     &     snowCover, stationName, tempFromTenths, temperature,
     &     timeObs, visibility, windDir, windGust, windSpeed, wmoId,
     &     badflag, istatus)
c
c======================================================================
c
c     Routine to read the METAR NetCDF files at FSL.
c     Code created with 'xgennet.pl' by J. Edwards, NOAA/FSL.
c
c     Original:  P. Stamus, NOAA/FSL  12 Mar 1998
c     Changes:
c        P. Stamus, NOAA/FSL  01 Sep 1998  Fix for differences in
c           /public vs WFO cdls (no snowCover in WFO at this time.)
c
c======================================================================
c
      include 'netcdf.inc'
c
      integer maxSkyCover, recNum, nf_fid, nf_vid, nf_status
      integer ifilval
c
      character*6 autoStationType(recNum)
      character*25 presWeather(recNum)
      character*6 reportType(recNum)
      character*8 skyCover( maxSkyCover, recNum)
      character*5 stationName(recNum)
      integer   pressChangeChar(recNum), wmoId(recNum)

      double precision timeObs(recNum), dfilval

      real altimeter(recNum), dewpoint(recNum), dpFromTenths(recNum)
      real elevation(recNum), latitude(recNum), longitude(recNum)
      real maxTemp24Hour(recNum), minTemp24Hour(recNum)
      real precip1Hour(recNum), precip24Hour(recNum)
      real precip3Hour(recNum), precip6Hour(recNum)
      real pressChange3Hour(recNum), seaLevelPress(recNum)
      real skyLayerBase( maxSkyCover, recNum), snowCover(recNum)
      real tempFromTenths(recNum), temperature(recNum)
      real visibility(recNum), windDir(recNum), windGust(recNum)
      real windSpeed(recNum)

      real filval
c
c
c..... Start.
c
      istatus = 0
C
C     Variable        NETCDF Long Name
C      autoStationType"automated station type"
C
        nf_status = NF_INQ_VARID(nf_fid,'autoStationType',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var autoStationType'
      endif
        nf_status = NF_GET_VAR_TEXT(nf_fid,nf_vid,autoStationType)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ autoStationType '
      endif
C
C     Variable        NETCDF Long Name
C      presWeather  "present weather"
C
        nf_status = NF_INQ_VARID(nf_fid,'presWeather',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var presWeather'
      endif
        nf_status = NF_GET_VAR_TEXT(nf_fid,nf_vid,presWeather)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ presWeather '
      endif
C
C     Variable        NETCDF Long Name
C      reportType   "report type"
C
        nf_status = NF_INQ_VARID(nf_fid,'reportType',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var reportType'
      endif
        nf_status = NF_GET_VAR_TEXT(nf_fid,nf_vid,reportType)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ reportType '
      endif
C
C     Variable        NETCDF Long Name
C      skyCover     "sky cover"
C
        nf_status = NF_INQ_VARID(nf_fid,'skyCover',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var skyCover'
      endif
        nf_status = NF_GET_VAR_TEXT(nf_fid,nf_vid,skyCover)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ skyCover '
      endif
C
C     Variable        NETCDF Long Name
C      stationName  "alphanumeric station identification"
C
        nf_status = NF_INQ_VARID(nf_fid,'stationName',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var stationName'
      endif
        nf_status = NF_GET_VAR_TEXT(nf_fid,nf_vid,stationName)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ stationName '
      endif
C
C     Variable        NETCDF Long Name
C      pressChangeChar"character of pressure change"
C
        nf_status = NF_INQ_VARID(nf_fid,'pressChangeChar',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var pressChangeChar'
      endif
        nf_status = NF_GET_VAR_INT(nf_fid,nf_vid,pressChangeChar)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ pressChangeChar '
      endif
        nf_status = NF_GET_ATT_INT(nf_fid,nf_vid,'_FillValue',ifilval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *, ' in var pressChangeChar'
      endif
      do i=1,recNum
         if(pressChangeChar(i) .eq. ifilval)
     &                         pressChangeChar(i) = int(badflag)
      enddo !i
C
C     Variable        NETCDF Long Name
C      wmoId        "numeric WMO identification"
C
        nf_status = NF_INQ_VARID(nf_fid,'wmoId',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var wmoId'
      endif
        nf_status = NF_GET_VAR_INT(nf_fid,nf_vid,wmoId)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ wmoId '
      endif
        nf_status = NF_GET_ATT_INT(nf_fid,nf_vid,'_FillValue',ifilval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *, ' in var wmoId'
      endif
      do i=1,recNum
         if(wmoId(i) .eq. ifilval) wmoId(i) = int(badflag)
      enddo !i
C
C     Variable        NETCDF Long Name
C      altimeter    "altimeter setting"
C
        nf_status = NF_INQ_VARID(nf_fid,'altimeter',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var altimeter'
      endif
        nf_status = NF_GET_VAR_REAL(nf_fid,nf_vid,altimeter)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ altimeter '
      endif
        nf_status = NF_GET_ATT_REAL(nf_fid,nf_vid,'_FillValue',filval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *, ' in var altimeter'
      endif
      call ck_array_real(altimeter, recNum, filval, badflag)
C
C     Variable        NETCDF Long Name
C      dewpoint     "dewpoint"
C
        nf_status = NF_INQ_VARID(nf_fid,'dewpoint',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var dewpoint'
      endif
        nf_status = NF_GET_VAR_REAL(nf_fid,nf_vid,dewpoint)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ dewpoint '
      endif
        nf_status = NF_GET_ATT_REAL(nf_fid,nf_vid,'_FillValue',filval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *, ' in var dewpoint'
      endif
      call ck_array_real(dewpoint, recNum, filval, badflag)
C
C     Variable        NETCDF Long Name
C      dpFromTenths "dewpoint from tenths of a degree Celsius"
C
        nf_status = NF_INQ_VARID(nf_fid,'dpFromTenths',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var dpFromTenths'
      endif
        nf_status = NF_GET_VAR_REAL(nf_fid,nf_vid,dpFromTenths)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ dpFromTenths '
      endif
        nf_status = NF_GET_ATT_REAL(nf_fid,nf_vid,'_FillValue',filval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
        print *,'in var dpFromTenths'
      endif
      call ck_array_real(dpFromTenths, recNum, filval, badflag)
C
C     Variable        NETCDF Long Name
C      elevation    "elevation"
C
        nf_status = NF_INQ_VARID(nf_fid,'elevation',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var elevation'
      endif
        nf_status = NF_GET_VAR_REAL(nf_fid,nf_vid,elevation)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ elevation '
      endif
        nf_status = NF_GET_ATT_REAL(nf_fid,nf_vid,'_FillValue',filval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *,'in var elevation'
      endif
      call ck_array_real(elevation, recNum, filval, badflag)
C
C     Variable        NETCDF Long Name
C      latitude     "latitude"
C
        nf_status = NF_INQ_VARID(nf_fid,'latitude',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var latitude'
      endif
        nf_status = NF_GET_VAR_REAL(nf_fid,nf_vid,latitude)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ latitude '
      endif
        nf_status = NF_GET_ATT_REAL(nf_fid,nf_vid,'_FillValue',filval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *, ' in var latitude'
      endif
      call ck_array_real(latitude, recNum, filval, badflag)
C
C     Variable        NETCDF Long Name
C      longitude    "longitude"
C
        nf_status = NF_INQ_VARID(nf_fid,'longitude',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var longitude'
      endif
        nf_status = NF_GET_VAR_REAL(nf_fid,nf_vid,longitude)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ longitude '
      endif
        nf_status = NF_GET_ATT_REAL(nf_fid,nf_vid,'_FillValue',filval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *, ' in var longitude'
      endif
      call ck_array_real(longitude, recNum, filval, badflag)
C
C     Variable        NETCDF Long Name
C      maxTemp24Hour"24 hour max temperature"
C
        nf_status = NF_INQ_VARID(nf_fid,'maxTemp24Hour',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var maxTemp24Hour'
      endif
        nf_status = NF_GET_VAR_REAL(nf_fid,nf_vid,maxTemp24Hour)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ maxTemp24Hour '
      endif
        nf_status = NF_GET_ATT_REAL(nf_fid,nf_vid,'_FillValue',filval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *,'in var maxTemp24Hour'
      endif
      call ck_array_real(maxTemp24Hour, recNum, filval, badflag)
C
C     Variable        NETCDF Long Name
C      minTemp24Hour"24 hour min temperature"
C
        nf_status = NF_INQ_VARID(nf_fid,'minTemp24Hour',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var minTemp24Hour'
      endif
        nf_status = NF_GET_VAR_REAL(nf_fid,nf_vid,minTemp24Hour)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ minTemp24Hour '
      endif
        nf_status = NF_GET_ATT_REAL(nf_fid,nf_vid,'_FillValue',filval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *,'in var minTemp24Hour'
      endif
      call ck_array_real(minTemp24Hour, recNum, filval, badflag)
C
C     Variable        NETCDF Long Name
C      precip1Hour  "1 hour precipitation"
C
        nf_status = NF_INQ_VARID(nf_fid,'precip1Hour',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var precip1Hour'
      endif
        nf_status = NF_GET_VAR_REAL(nf_fid,nf_vid,precip1Hour)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ precip1Hour '
      endif
        nf_status = NF_GET_ATT_REAL(nf_fid,nf_vid,'_FillValue',filval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *, ' in var precip1Hour'
      endif
      call ck_array_real(precip1Hour, recNum, filval, badflag)
C
C     Variable        NETCDF Long Name
C      precip24Hour "24 hour precipitation"
C
        nf_status = NF_INQ_VARID(nf_fid,'precip24Hour',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var precip24Hour'
      endif
        nf_status = NF_GET_VAR_REAL(nf_fid,nf_vid,precip24Hour)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ precip24Hour '
      endif
        nf_status = NF_GET_ATT_REAL(nf_fid,nf_vid,'_FillValue',filval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *, ' in var precip24Hour'
      endif
      call ck_array_real(precip24Hour, recNum, filval, badflag)
C
C     Variable        NETCDF Long Name
C      precip3Hour  "3 hour precipitation"
C
        nf_status = NF_INQ_VARID(nf_fid,'precip3Hour',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var precip3Hour'
      endif
        nf_status = NF_GET_VAR_REAL(nf_fid,nf_vid,precip3Hour)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ precip3Hour '
      endif
        nf_status = NF_GET_ATT_REAL(nf_fid,nf_vid,'_FillValue',filval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *, ' in var precip3Hour'
      endif
      call ck_array_real(precip3Hour, recNum, filval, badflag)
C
C     Variable        NETCDF Long Name
C      precip6Hour  "6 hour precipitation"
C
        nf_status = NF_INQ_VARID(nf_fid,'precip6Hour',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var precip6Hour'
      endif
        nf_status = NF_GET_VAR_REAL(nf_fid,nf_vid,precip6Hour)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ precip6Hour '
      endif
        nf_status = NF_GET_ATT_REAL(nf_fid,nf_vid,'_FillValue',filval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *, ' in var precip6Hour'
      endif
      call ck_array_real(precip6hour, recNum, filval, badflag)
C
C     Variable        NETCDF Long Name
C      pressChange3Hour"3 hour pressure change"
C
        nf_status = NF_INQ_VARID(nf_fid,'pressChange3Hour',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var pressChange3Hour'
      endif
        nf_status = NF_GET_VAR_REAL(nf_fid,nf_vid,pressChange3Hour)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ pressChange3Hour '
      endif
        nf_status = NF_GET_ATT_REAL(nf_fid,nf_vid,'_FillValue',filval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *, ' in var pressChange3Hour'
      endif
      call ck_array_real(pressChange3Hour, recNum, filval, badflag)
C
C     Variable        NETCDF Long Name
C      seaLevelPress"sea level pressure"
C
        nf_status = NF_INQ_VARID(nf_fid,'seaLevelPress',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var seaLevelPress'
      endif
        nf_status = NF_GET_VAR_REAL(nf_fid,nf_vid,seaLevelPress)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ seaLevelPress '
      endif
        nf_status = NF_GET_ATT_REAL(nf_fid,nf_vid,'_FillValue',filval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *, ' in var seaLevelPress'
      endif
      call ck_array_real(seaLevelPress, recNum, filval, badflag)
C
C     Variable        NETCDF Long Name
C      skyLayerBase "sky cover layer base"
C
        nf_status = NF_INQ_VARID(nf_fid,'skyLayerBase',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var skyLayerBase'
      endif
        nf_status = NF_GET_VAR_REAL(nf_fid,nf_vid,skyLayerBase)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ skyLayerBase '
      endif
        nf_status = NF_GET_ATT_REAL(nf_fid,nf_vid,'_FillValue',filval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *, ' in var skyLayerBase'
      endif
      call ck_array_real(skyLayerBase, recNum, filval, badflag)
C
C     Variable        NETCDF Long Name
C      snowCover    "snow cover"
C
        nf_status = NF_INQ_VARID(nf_fid,'snowCover',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var snowCover'
        do i=1,recNum
           snowCover(i) = badflag
        enddo !i
        go to 500
      endif
        nf_status = NF_GET_VAR_REAL(nf_fid,nf_vid,snowCover)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ snowCover '
      endif
        nf_status = NF_GET_ATT_REAL(nf_fid,nf_vid,'_FillValue',filval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *, ' in var snowCover'
      endif
      call ck_array_real(snowCover, recNum, filval, badflag)
C
C     Variable        NETCDF Long Name
C      tempFromTenths"temperature from tenths of a degree Celsius"
C
 500  nf_status = NF_INQ_VARID(nf_fid,'tempFromTenths',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var tempFromTenths'
      endif
        nf_status = NF_GET_VAR_REAL(nf_fid,nf_vid,tempFromTenths)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ tempFromTenths '
      endif
        nf_status = NF_GET_ATT_REAL(nf_fid,nf_vid,'_FillValue',filval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *, ' in var tempFromTenths'
      endif
      call ck_array_real(tempFromTenths, recNum, filval, badflag)
C
C     Variable        NETCDF Long Name
C      temperature  "temperature"
C
        nf_status = NF_INQ_VARID(nf_fid,'temperature',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var temperature'
      endif
        nf_status = NF_GET_VAR_REAL(nf_fid,nf_vid,temperature)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ temperature '
      endif
        nf_status = NF_GET_ATT_REAL(nf_fid,nf_vid,'_FillValue',filval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *, ' in var temperature'
      endif
      call ck_array_real(temperature, recNum, filval, badflag)
C
C     Variable        NETCDF Long Name
C      visibility   "visibility"
C
        nf_status = NF_INQ_VARID(nf_fid,'visibility',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var visibility'
      endif
        nf_status = NF_GET_VAR_REAL(nf_fid,nf_vid,visibility)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ visibility '
      endif
        nf_status = NF_GET_ATT_REAL(nf_fid,nf_vid,'_FillValue',filval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *, ' in var visibility'
      endif
      call ck_array_real(visibility, recNum, filval, badflag)
C
C     Variable        NETCDF Long Name
C      windDir      "wind direction"
C
        nf_status = NF_INQ_VARID(nf_fid,'windDir',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var windDir'
      endif
        nf_status = NF_GET_VAR_REAL(nf_fid,nf_vid,windDir)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ windDir '
      endif
        nf_status = NF_GET_ATT_REAL(nf_fid,nf_vid,'_FillValue',filval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *, ' in var windDir'
      endif
      call ck_array_real(windDir, recNum, filval, badflag)
C
C     Variable        NETCDF Long Name
C      windGust     "wind gust"
C
        nf_status = NF_INQ_VARID(nf_fid,'windGust',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var windGust'
      endif
        nf_status = NF_GET_VAR_REAL(nf_fid,nf_vid,windGust)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ windGust '
      endif
        nf_status = NF_GET_ATT_REAL(nf_fid,nf_vid,'_FillValue',filval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *, ' in var windGust'
      endif
      call ck_array_real(windGust, recNum, filval, badflag)
C
C     Variable        NETCDF Long Name
C      windSpeed    "wind speed"
C
        nf_status = NF_INQ_VARID(nf_fid,'windSpeed',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var windSpeed'
      endif
        nf_status = NF_GET_VAR_REAL(nf_fid,nf_vid,windSpeed)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ windSpeed '
      endif
        nf_status = NF_GET_ATT_REAL(nf_fid,nf_vid,'_FillValue',filval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *, ' in var windSpeed'
      endif
      call ck_array_real(windSpeed, recNum, filval, badflag)
C
C     Variable        NETCDF Long Name
C      timeObs      "time of observation"
C
        nf_status = NF_INQ_VARID(nf_fid,'timeObs',nf_vid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in var timeObs'
      endif
        nf_status = NF_GET_VAR_DOUBLE(nf_fid,nf_vid,timeObs)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'in NF_GET_VAR_ timeObs '
      endif
       nf_status = NF_GET_ATT_DOUBLE(nf_fid,nf_vid,'_FillValue',dfilval)
      if(nf_status .ne. NF_NOERR) then
         print *, NF_STRERROR(nf_status)
         print *, ' in var timeObs'
      endif
      do i=1,recNum
         if(timeObs(i) .eq. dfilval) timeObs(i) = badflag
      enddo !i
c
c
      nf_status = nf_close(nf_fid)
      if(nf_status.ne.NF_NOERR) then
        print *, NF_STRERROR(nf_status)
        print *,'nf_close'
      endif
c
c..... That's it.
c
      istatus = 1
c
      return
      end

ext: f

max_stars_repo_name: maxinye/laps-mirror

max_stars_repo_licenses: Intel Unlicense OLDAP-2.2.1 NetCDF

max_issues_repo_name: longwosion/laps-mirror

max_issues_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense

max_forks_repo_name: longwosion/laps-mirror

max_forks_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense


text:
Captain Tuttle is no longer with us : May 12, 2006
 We can all be comforted by the thought that hes not really gone, theres a little Tuttle left in all of us, in fact you might say that all of us together made up Tuttle.  Our grief will pass, its already hard to remember how Johnny talked, how he looked. His little laugh. Thankfully hes left behind a memorial. We salute you Captain Tuttle. Humanitarian and healer. Good luck doctor in that great big waiting room in the sky.

Personnel File

Captain Tuttle is named after a fictional character from an wiki:WikiPedia:Tuttle_(MASH_episode) episode of wiki:WikiPedia:M%2AA%2AS%2AH_%28TV_series%29 MASH (his owners  favorite show).  He was rescued by Users/AllisonEriksen at the Lyons cat colony in August 2005, missing most of his tail and obviously quite frightened and tired, judging from the ease of catching him.  Since being rescued from the cats, Tuttle has been living the good life.  He eats crickets from Pet Cetera and gets to go Central California home with his owner during holidays.  He once also got to attend a Monday Night Rehearsal rehearsal of the California Aggie Marching Banduh, a privilege bestowed on a select few Town Wildlife reptiles.  He cant wait until summer when his house can go Parkside Apartments outside instead of sitting under a big lamp all day.

Users/AynReyes is convinced that Tuttle carries Salmonella, but he claims innocence in the matter.  Especially since she does not intend to eat him, its ok.

This is a Photoshop representation of what Tuttle could look like:

But he doesnt look like this, so dont get too excited.  Damn that would be awesome though...

20060105 05:27:50 nbsp Damn cool... when I saw the page title I instantly thought of MASH, but figured it couldnt be a reference.  So, what are you going to do with his backpay?  ;) Users/JabberWokky

Captain Tuttle was found dead in his tank this morning.  He had acted a little bit sick earlier this afternoon, and I thought it had something to do with the heat.  I sprayed him with his squirt bottle and gave him a dish of fresh water (with a rock in the dish to keep it shallow).  A few hours later, I returned to find him upsidedown in the dish.  He will be dearly missed.  Users/AllisonEriksen

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
      include 'VICMAIN_FOR'
      SUBROUTINE MAIN44
      COMMON/C1/HIST(-32768:32767),IBUF(32768)
      INTEGER*4 HIST
      INTEGER*2 IBUF

      COMMON/C2/OBUF(10),OHIST(0:255)	!Histogram record data structure
      INTEGER*4 OHIST
      INTEGER*4 BUF(10)
      EQUIVALENCE (BUF,OBUF)

      LOGICAL XVPTST
      INTEGER*4 SL,SS,EL
      REAL*4 MEAN,SIGMA
      CHARACTER*8 FORMAT
      CHARACTER*80 MSG

  803 FORMAT(' Mean=',F14.8,'   Sigma=',F14.8,
     &   '   Total number of pixels=',I10)

C     ....Get unit number and open input image
      CALL XVUNIT(iunit,'INP',1,IND,' ')
      CALL XVOPEN(IUNIT,IND,'OPEN_ACT','SA','IO_ACT','SA',' ')
      CALL XVSIZE(sl,ss,nl,ns,nli,nsi)
      IF (SL+NL-1 .GT. NLI) GOTO 902
      IF (SS+NS-1 .GT. NSI) GOTO 903
      IF (NS.GT.32768) GOTO 904
      NPTS = NL*NS
C     ....Compute histogram of input image.  If the image is byte
C     ....the histogram is stored directly in OHIST.  If halfword,
C     ....the histogram is first stored in HIST, and then
C     ....compressed into OHIST.

      EL = SL+NL-1
      CALL XVGET(IUNIT,IND,'FORMAT',FORMAT,' ')
      IF (FORMAT.EQ.'BYTE') THEN
         ITYPE = 1
C     ....Generate histogram
         DO LINE=SL,EL
            CALL XVREAD(IUNIT,ibuf,ind,'LINE',LINE,'SAMP',SS,
     &                 'NSAMPS',NS,' ')
            CALL HSUB(1,NS,IBUF,OHIST)
         ENDDO
      ELSE IF (FORMAT.EQ.'HALF'.OR.FORMAT.EQ.'WORD') THEN
         ITYPE = 2
         DO LINE=SL,EL
            CALL XVREAD(IUNIT,ibuf,ind,'LINE',LINE,'SAMP',SS,
     &                 'NSAMPS',NS,' ')
            DO J=1,NS
              IDN = IBUF(J)
              HIST(IDN) = HIST(IDN) + 1
            ENDDO
         ENDDO
      ELSE
         GOTO 990
      ENDIF

      IF (ITYPE.EQ.1) THEN
         CALL histat(OHIST,NPTS,mean,sigma,maxfreq)
C     ....Print mean, standard deviation, and total number of pixels
c         CALL QPRINT(' ***Test from Fortran')
          CALL XVMESSAGE(' ***Test from Fortran',' ')
         WRITE (MSG,803) MEAN,SIGMA,NPTS
c        CALL QPRINT(MSG,80)
         Call Xvmessage(msg, ' ')
         mean=0.0
         sigma=0.0
         maxfreq=0
         CALL tzhistat(OHIST,NPTS,mean,sigma,maxfreq)
c         CALL QPRINT(' ***Test from C')
         CALL Xvmessage(' ***Test from C', ' ')
         WRITE (MSG,803) MEAN,SIGMA,NPTS
c         CALL QPRINT(MSG,80)
         Call Xvmessage(msg, ' ')
      ELSE
	 IF (.NOT.XVPTST('INCLUDE')) THEN
	    NPTS = NPTS - HIST(-32768)
	    HIST(-32768) = 0
         ENDIF
         CALL histat2(HIST,NPTS,mean,sigma,mindn,maxdn,maxfreq)
C     ....Print mean, standard deviation, and total number of pixels
c         CALL QPRINT(' ***Test from Fortran')
         CALL Xvmessage(' ***Test from Fortran', ' ')
         WRITE (MSG,803) MEAN,SIGMA,NPTS
c         CALL QPRINT(MSG,80)
         Call Xvmessage(msg, ' ')
         mean=0.0
         sigma=0.0
         mindn=0
         maxdn=0
         maxfreq=0
         CALL tzhistat2(HIST,NPTS,mean,sigma,mindn,maxdn,maxfreq)
c         CALL QPRINT(' ***Test from C')
         CALL Xvmessage(' ***Test from C', ' ')
         WRITE (MSG,803) MEAN,SIGMA,NPTS
c         CALL QPRINT(MSG,80)
         Call Xvmessage(msg, ' ')
      ENDIF

      RETURN

c  902 CALL QPRINT(' ***Number of lines requested exceeds input size')
  902 CALL Xvmessage(' *** # lines requested exceeds input size',' ')
      GOTO 999
c  903 CALL QPRINT(' ***Number of samples requested exceeds input size')
  903 CALL Xvmessage(' *** # samples requested exceeds input size', ' ')
      GOTO 999
c  904 CALL QPRINT(' ***Input image number of samples exceeds limit')
  904 CALL Xvmessage(' ***Input image #samples exceeds limit', ' ')
      GOTO 999
c  990 CALL QPRINT(' ***Invalid input data format')
  990 CALL Xvmessage(' ***Invalid input data format',' ')
c      CALL QPRINT(' ***Inputs must be byte or halfword')
      CALL Xvmessage(' ***Inputs must be byte or halfword',' ')
      GOTO 999
c  999 CALL QPRINT(' thistat task cancelled')
  999 CALL Xvmessage(' thistat task cancelled', ' ')
      CALL ABEND
      END

max_stars_repo_name: NASA-AMMOS/VICAR

max_issues_repo_name: NASA-AMMOS/VICAR

max_forks_repo_name: NASA-AMMOS/VICAR


text:
module mpisetup

! Adapted from .../src/enkf/mpisetup.f90

!$$$  module documentation block
!
! module: mpisetup                     initialize MPI.
!
! prgmmr: whitaker         org: esrl/psd               date: 2009-02-23
!
! abstract: Initialize and finalize MPI, create variables numproc (total # of MPI tasks,
!  same for each task) and nproc (MPI task #, different for each task). MPI
!  subroutine names and constants are imported via the 'mpif.h' include file.
!
! Public Subroutines
!   mpi_initialize: Initialize MPI.
!   mpi_cleanup: Wait for all tasks, then finalize MPI.
!   all the MPI routines (included via the mpif.h include file).
!
! Public Variables:
!   nproc:  MPI task # (root = 0).
!   numproc:  total number of MPI tasks.
!   mpi_status:  MPI status
!   mpi_realkind: double/single precision. not explicitly used
!
! program history log:
!   2009-02-23  Initial version.
!
! attributes:
!   language: f95
!
!$$$

use kinds, only: r_kind, r_single, r_double
implicit none
! mpi definitions.
include 'mpif.h'
integer, public :: numproc, nproc
integer, public :: mpi_status(mpi_status_size)
integer, public :: mpi_realkind

contains

subroutine mpi_initialize()
integer :: ierr
call mpi_init(ierr)
! nproc is process number, numproc is total number of processes.
call mpi_comm_rank(mpi_comm_world,nproc,ierr)
call mpi_comm_size(mpi_comm_world,numproc,ierr)

if (nproc == 0) print *,'running on ',numproc,' processors ...'
if (r_kind == r_single) then
   mpi_realkind = mpi_real4
   if (nproc == 0) print *,'mpi_realkind set to mpi_real4',mpi_real4
else if (r_kind == r_double) then
   mpi_realkind = mpi_real8
   if (nproc == 0) print *,'mpi_realkind set to mpi_real8',mpi_real8
else
   print *,'ERROR: illegal r_kind (must be single or double)'
   call mpi_cleanup()
endif

end subroutine mpi_initialize

subroutine mpi_cleanup()
integer :: ierr
flush(6,err=10)
flush(0,err=10)
10 continue
call mpi_barrier(mpi_comm_world,ierr)
if (nproc == 0) write(6,*) 'all done!'
call mpi_finalize(ierr)
if (ierr /= 0) then
 print *, 'MPI_Finalize error status = ',ierr
end if
end subroutine mpi_cleanup

end module mpisetup

max_stars_repo_name: hkershaw-brown/feature-preprocess

max_issues_repo_name: hkershaw-brown/feature-preprocess

max_forks_repo_name: hkershaw-brown/feature-preprocess


text:
Bay Laurel (Laurus nobilis Lauraceae) is a town flora locally found tree that grows up to 40 tall (easily kept lower by pruning) with aromatic leaves that are culinary plants used in cooking.  Native to the Mediterranean region, it has small flowers that are light yellowgreen and small black fruits. There is a staminate cultivar called Saratoga that produces no fruit. There is a related species wiki:WikiPedia:Umbellularia California bay laurel (Umbellularia californica) of tree native to the Northern Coast Range.

Bay leaves are most commonly used today in cooking, but they are also the leaves that were twisted into a U shape and placed as a crown atop the head of winners in ancient Greece (i.e., Laurels).  People going for the collegian toga look could possibly use them today for a spicy smelling accessory.  Alternatively, people who succeeded in the past and are now just relaxing could make a bed from them and Sleeping On Campus rest on their laurels.  A pair of green laurels over a yellow shield is the emblem of the Society for Creative Anachronism, as appears on bumperstickers around town.

Bay has antioxidant, analgesic, antiinflammatory and anticonvulsant properties.


!
! Distributed under the OSI-approved Apache License, Version 2.0.  See
!  accompanying file Copyright.txt for details.
!
!  adios2_engine_put_deferred.f90 : implementation of adios2_put_deferred
!  subroutines
!
!   Created on: Feb 21, 2018
!       Author: William F Godoy godoywf@ornl.gov
!

! Single data
subroutine adios2_put_deferred_real(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    real, intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_real, &
                                    'put real', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_dp(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    real(kind=8), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_dp, &
                                    'put dp', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_complex(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    complex, intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_complex, &
                                    'put complex', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_complex_dp(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    complex(kind=8), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_complex_dp, &
                                    'put complex_dp', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer1(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=1), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer1, &
                                    'put integer1', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer2(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=2), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer2, &
                                    'put integer2', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer4(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=4), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer4, &
                                    'put integer4', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer8(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=8), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer8, &
                                    'put integer8', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

! 1D arrays
subroutine adios2_put_deferred_real_1d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    real, dimension(:), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_real, &
                                    'put real', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_dp_1d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    real(kind=8), dimension(:), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_dp, &
                                    'put dp', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_complex_1d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    complex, dimension(:), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_complex, &
                                    'put complex', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_complex_dp_1d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    complex(kind=8), dimension(:), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_complex_dp, &
                                    'put complex_dp', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer1_1d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=1), dimension(:), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer1, &
                                    'put integer1', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer2_1d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=2), dimension(:), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer2, &
                                    'put integer2', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer4_1d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=4), dimension(:), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer4, &
                                    'put integer4', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer8_1d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=8), dimension(:), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer8, &
                                    'put integer8', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

! 2D arrays
subroutine adios2_put_deferred_real_2d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    real, dimension(:, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_real, &
                                    'put real', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_dp_2d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    real(kind=8), dimension(:, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_dp, &
                                    'put dp', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_complex_2d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    complex, dimension(:, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_complex, &
                                    'put complex', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_complex_dp_2d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    complex(kind=8), dimension(:, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_complex_dp, &
                                    'put complex_dp', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer1_2d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=1), dimension(:, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer1, &
                                    'put integer1', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer2_2d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=2), dimension(:, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer2, &
                                    'put integer2', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer4_2d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=4), dimension(:, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer4, &
                                    'put integer4', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer8_2d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=8), dimension(:, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer8, &
                                    'put integer8', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

! 3D arrays
subroutine adios2_put_deferred_real_3d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    real, dimension(:, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_real, &
                                    'put real', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_dp_3d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    real(kind=8), dimension(:, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_dp, &
                                    'put dp', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_complex_3d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    complex, dimension(:, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_complex, &
                                    'put complex', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_complex_dp_3d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    complex(kind=8), dimension(:, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_complex_dp, &
                                    'put complex_dp', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer1_3d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=1), dimension(:, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer1, &
                                    'put integer1', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer2_3d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=2), dimension(:, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer2, &
                                    'put integer2', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer4_3d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=4), dimension(:, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer4, &
                                    'put integer4', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer8_3d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=8), dimension(:, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer8, &
                                    'put integer8', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

! 4D arrays
subroutine adios2_put_deferred_real_4d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    real, dimension(:, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_real, &
                                    'put real', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_dp_4d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    real(kind=8), dimension(:, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_dp, &
                                    'put dp', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_complex_4d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    complex, dimension(:, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_complex, &
                                    'put complex', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_complex_dp_4d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    complex(kind=8), dimension(:, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_complex_dp, &
                                    'put complex_dp', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer1_4d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=1), dimension(:, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer1, &
                                    'put integer1', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer2_4d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=2), dimension(:, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer2, &
                                    'put integer2', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer4_4d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=4), dimension(:, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer4, &
                                    'put integer4', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer8_4d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=8), dimension(:, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer8, &
                                    'put integer8', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

! 5D arrays
subroutine adios2_put_deferred_real_5d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    real, dimension(:, :, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_real, &
                                    'put real', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_dp_5d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    real(kind=8), dimension(:, :, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_dp, &
                                    'put dp', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_complex_5d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    complex, dimension(:, :, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_complex, &
                                    'put complex', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_complex_dp_5d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    complex(kind=8), dimension(:, :, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_complex_dp, &
                                    'put complex_dp', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer1_5d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=1), dimension(:, :, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer1, &
                                    'put integer1', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer2_5d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=2), dimension(:, :, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer2, &
                                    'put integer2', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer4_5d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=4), dimension(:, :, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer4, &
                                    'put integer4', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer8_5d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=8), dimension(:, :, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer8, &
                                    'put integer8', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

! 6D arrays
subroutine adios2_put_deferred_real_6d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    real, dimension(:, :, :, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_real, &
                                    'put real', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_dp_6d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    real(kind=8), dimension(:, :, :, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_dp, &
                                    'put dp', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_complex_6d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    complex, dimension(:, :, :, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_complex, &
                                    'put complex', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_complex_dp_6d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    complex(kind=8), dimension(:, :, :, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_complex_dp, &
                                    'put complex_dp', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer1_6d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=1), dimension(:, :, :, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer1, &
                                    'put integer1', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer2_6d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=2), dimension(:, :, :, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer2, &
                                    'put integer2', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer4_6d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=4), dimension(:, :, :, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer4, &
                                    'put integer4', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine

subroutine adios2_put_deferred_integer8_6d(engine, variable, data, ierr)
    type(adios2_engine), intent(in):: engine
    type(adios2_variable), intent(in):: variable
    integer(kind=8), dimension(:, :, :, :, :, :), intent(in):: data
    integer, intent(out):: ierr

    call adios2_variable_check_type(variable, adios2_type_integer8, &
                                    'put integer8', ierr)
    if (ierr == 0) then
        call adios2_put_f2c(engine%f2c, variable%f2c, data, &
                            adios2_mode_deferred, ierr)
    end if

end subroutine


text:
      program applu

      common/cgcon/ nx, ny, nz
      common/cvar/ u(5,33,33,33)
      read (5,*) nx, ny, nz

      if ( ( nx .lt. 5 ) .or.
     $     ( ny .lt. 5 ) .or.
     $     ( nz .lt. 5 ) ) then
c
         write (6,2001)
 2001    format (5x,'PROBLEM SIZE IS TOO SMALL - ',
     $        /5x,'SET EACH OF NX, NY AND NZ AT LEAST EQUAL TO 5')
         stop
      end if
      if ( ( nx .gt. 33 ) .or.
     $     ( ny .gt. 33 ) .or.
     $     ( nz .gt. 33 ) ) then

         write (6,2002)
 2002    format (5x,'PROBLEM SIZE IS TOO LARGE - ',
     $        /5x,'NX, NY AND NZ SHOULD BE LESS THAN OR EQUAL TO ',
     $        /5x,'ISIZ1, ISIZ2 AND ISIZ3 RESPECTIVELY')
         stop
      end if
c
      call setbv
      call error
      stop
      end

      subroutine setbv
      common/cgcon/ nx, ny, nz
      common/cvar/ u(5,33,33,33)

      do j = 1, ny
         do i = 1, nx
            call exact ( i, j, 1, u( 1, i, j, 1 ) )
            call exact ( i, j, nz, u( 1, i, j, nz ) )
         end do
      end do
      do k = 1, nz
         do i = 1, nx
            call exact ( i, 1, k, u( 1, i, 1, k ) )
            call exact ( i, ny, k, u( 1, i, ny, k ) )
         end do
      end do
      do k = 1, nz
         do j = 1, ny
            call exact ( 1, j, k, u( 1, 1, j, k ) )
            call exact ( nx, j, k, u( 1, nx, j, k ) )
         end do
      end do
      return
      end

      subroutine exact ( i, j, k, u000ijk )
      common/cgcon/ nx, ny, nz
      dimension u000ijk(*)

      do m = 1, 5
         u000ijk(m) =  m
      end do
      return
      end
c
      subroutine error
      common/cgcon/ nx, ny, nz
      common/cvar/ u(5,33,33,33)
      dimension u000ijk(5)
      do k = 2, nz-1
         do j = 2, ny-1
            do i = 2, nx-1
c
               call exact ( i, j, k, u000ijk )

            end do
         end do
      end do
      return
      end


      subroutine dr_read_pest

      use hydrograph_module
      use dr_module
      use input_file_module
      use organic_mineral_mass_module
      use constituent_mass_module
      use maximum_data_module

      character (len=80) :: titldum, header
      integer :: eof, imax, ob1, ob2
      logical :: i_exist              !none       |check to determine if file exists

      eof = 0
      imax = 0

      !read all delivery ratio data
      inquire (file=in_delr%pest, exist=i_exist)
      if (i_exist .or. in_delr%pest /= "null") then
        do
          open (107,file=in_delr%pest)
          read (107,*,iostat=eof) titldum
          if (eof < 0) exit
          read (107,*,iostat=eof) header
          if (eof < 0) exit
          imax = 0
          do while (eof == 0)
            read (107,*,iostat=eof) titldum
            if (eof < 0) exit
            imax = imax + 1
          end do

          db_mx%dr_pest = imax

          allocate (dr_pest(imax))
          do idr_pest = 1, imax
            allocate (dr_pest(idr_pest)%pest(cs_db%num_pests))
          end do
          allocate (dr_pest_num(imax))
          allocate (dr_pest_name(imax))
          rewind (107)
          read (107,*,iostat=eof) titldum
          if (eof < 0) exit
          read (107,*,iostat=eof) header
          if (eof < 0) exit

          !read all delivery ratio data
          do ii = 1, db_mx%dr_pest
            read (107,*,iostat=eof) titldum
            if (eof < 0) exit
            backspace (107)
            read (107,*,iostat=eof) dr_pest_name(ii), (dr_pest(ii)%pest(ipest), ipest = 1, cs_db%num_pests)
            if (eof < 0) exit
          end do
          close (107)
          exit
        end do
      end if

      ! xwalk with dr file to get sequential number
      do idr = 1, db_mx%dr
        do idr_pest = 1, db_mx%dr_pest
          if (dr_db(idr)%pest_file == dr_pest_name(idr_pest)) then
            dr_pest_num(idr) = idr_pest
            exit
          end if
        end do
      end do

      !set dr_pest object hydrograph
      ob1 = sp_ob1%dr
      ob2 = sp_ob1%dr + sp_ob%dr - 1
      do iob = ob1, ob2
        idr = ob(iob)%props
        idr_pest = dr_pest_num(idr)
        obcs(iob)%hd(1)%pest = dr_pest(idr_pest)%pest
      end do

      return
      end subroutine dr_read_pest