text:
      module UTILS
      implicit none
      contains
      !****************************************************************
      !*** asserts that TEST is true. If not print MSG and exit program
      !*** If WARN is present and /= 0 print the message and WARN, do not exit
      !*** If the opional argument P is set to true, pause after the
      !*** printout and before the call to error if WARN==0
      subroutine assert(TEST,MSG,WARN,P)
      use MOD_ERROR
        logical,      intent(in) :: TEST
        integer,      intent(in),optional :: WARN
        logical,      intent(in),optional :: P
        character*(*),intent(in),optional :: MSG
        integer :: WARN__
        if(TEST) return
        WARN__ = 0
        if(present(WARN)) WARN__= WARN
        if(WARN__ >= 0) then
          print '("assert: Warning ",i0," : Reason: ",A)',WARN__,MSG
          if(present(P).and.P) pause
        else
          if(WARN__/=0)print '("assert: Error Level set to ",i0)',WARN__
          call ERROR('assert: failed: Reason: '//MSG,P)
        endif
      end subroutine assert

      pure function str2int(X)
        integer :: str2int
        character*(*),intent(in) :: X
        read (X,*), str2int
      end function str2int

      pure function str2real(X)
        real*8 :: str2real
        character*(*),intent(in) :: X
        read (X,*), str2real
      end function str2real

      pure function int2str(X)
        integer,intent(in):: X
        character*10 int2str
        write(int2str,'(i10)') X
      end function int2str
      !*** returns a free fileunit
      !*** not threadsafe
      function getFileUnit(start)
      use MOD_ERROR
      implicit none;
      integer,optional :: start
      integer :: getFileUnit
      integer :: i
      logical :: lOPENED
      integer :: start_
      start_=10
      if(present(start)) start_=start
      do i=start_,1000
        INQUIRE(unit=i,opened=lOPENED)
        if(.not.lOPENED) then
          getFileUnit=i
          return
        endif
      enddo
      call error('utils:getFileUnit: no open unit found')
      end function getFileUnit

      !*** Copy a file from FROMFILE to TOFILE using the opional OPTS
      !*** and set the returnstatus to the opional status
      subroutine cp(FROMFILE,TOFILE,OPTS,status)
      character*(*),intent(in) :: FROMFILE,TOFILE
      character*(*),intent(in),optional :: OPTS
      integer,optional,intent(inout) :: status
      integer :: istat
      integer,external :: system
      istat = system('cp '//OPTS//' '//FROMFILE//' '//TOFILE)
      if(present(status)) then
        status=istat
      else
        if(istat/=0)
     &     print '("UTILS:CP: Warning: system returned ",i0)',istat
      endif
      end subroutine
      end module UTILS

max_stars_repo_name: rtagirov/nessy

max_issues_repo_name: rtagirov/nessy

max_forks_repo_name: rtagirov/nessy-src


text:
      integer function std_spsign_msdis(msdis,occ,nblk)
*
*     set up standard sign for standard spin-string arising from
*     a distribution of MS values over nblk blocks:
*
*     e.g.  msdis=(+2,-1,+1)
*           occ  =(2,3,1)
*
*     --> standard spin-string:  aa abb a
*
*     standard sign: determined by number of permutations to arrange to
*     a sequence with first all alphas and then all betas, in our example
*
*       aaaabb  -> +1
*
*
      implicit none

      integer, intent(in) ::
     &     nblk, msdis(nblk), occ(nblk)

      integer ::
     &     nidx, iblk, idx, isp

      integer, pointer ::
     &     scr(:)

      integer, external ::
     &     std_spsign

      std_spsign_msdis = 1
      if (nblk.le.1) return

      nidx = 0
      do iblk = 1, nblk
        nidx = nidx+occ(iblk)
      end do
      allocate(scr(nidx)) ! FIXME: This allocate is probably expensive
                          !        as routine is called many times
                          !        see also annotation on sym_ab_blk
      idx = 0
      do iblk = 1, nblk
        do isp = 1, (occ(iblk)+msdis(iblk))/2
          idx = idx+1
          scr(idx) = +1
        end do
        do isp = 1, (occ(iblk)-msdis(iblk))/2
          idx = idx+1
          scr(idx) = -1
        end do
      end do

      std_spsign_msdis = std_spsign(scr,nidx)

      deallocate(scr)

      return
      end

ext: f

max_stars_repo_name: ak-ustutt/GeCCo-public

max_issues_repo_name: ak-ustutt/GeCCo-public

max_forks_repo_name: ak-ustutt/GeCCo-public


!*==drot.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief \b DROT
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S)
!
!       .. Scalar Arguments ..
!       DOUBLE PRECISION C,S
!       INTEGER INCX,INCY,N
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION DX(*),DY(*)
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!>    DROT applies a plane rotation.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>         number of elements in input vector(s)
!> \endverbatim
!>
!> \param[in,out] DX
!> \verbatim
!>          DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER
!>         storage spacing between elements of DX
!> \endverbatim
!>
!> \param[in,out] DY
!> \verbatim
!>          DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
!> \endverbatim
!>
!> \param[in] INCY
!> \verbatim
!>          INCY is INTEGER
!>         storage spacing between elements of DY
!> \endverbatim
!>
!> \param[in] C
!> \verbatim
!>          C is DOUBLE PRECISION
!> \endverbatim
!>
!> \param[in] S
!> \verbatim
!>          S is DOUBLE PRECISION
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2017
!
!> \ingroup double_blas_level1
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>     jack dongarra, linpack, 3/11/78.
!>     modified 12/3/93, array(1) declarations changed to array(*)
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE DROT(N,Dx,Incx,Dy,Incy,C,S)
      IMPLICIT NONE
!*--DROT96
!
!  -- Reference BLAS level1 routine (version 3.8.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2017
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION C , S
      INTEGER Incx , Incy , N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION Dx(*) , Dy(*)
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      DOUBLE PRECISION dtemp
      INTEGER i , ix , iy
!     ..
      IF ( N<=0 ) RETURN
      IF ( Incx==1 .AND. Incy==1 ) THEN
!
!       code for both increments equal to 1
!
         DO i = 1 , N
            dtemp = C*Dx(i) + S*Dy(i)
            Dy(i) = C*Dy(i) - S*Dx(i)
            Dx(i) = dtemp
         ENDDO
      ELSE
!
!       code for unequal increments or equal increments not equal
!         to 1
!
         ix = 1
         iy = 1
         IF ( Incx<0 ) ix = (-N+1)*Incx + 1
         IF ( Incy<0 ) iy = (-N+1)*Incy + 1
         DO i = 1 , N
            dtemp = C*Dx(ix) + S*Dy(iy)
            Dy(iy) = C*Dy(iy) - S*Dx(ix)
            Dx(ix) = dtemp
            ix = ix + Incx
            iy = iy + Incy
         ENDDO
      ENDIF
      END SUBROUTINE DROT


text:
Describe Users/justintrieu000 here.

20121204 16:39:06 nbsp justintrieu000  use a scannermake a scan. Then go to the House of Chang page, edit it (button down below) and click on Upload Files (down below) and follow the directions. Hope this helps. Users/PeteB

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
! 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 dwl_to_obs

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   dwl_to_obs - read in ascii lines with doppler wind lidar data.
!      see below for exact input format.  create 2 observations from
!      each input line - U and V components of the wind.
!
!   3 Sep 2013, nancy collins NCAR, Matic Savli FMF/Univ Ljubljana
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

use         types_mod, only : r8, PI, DEG2RAD
use      utilities_mod, only : initialize_utilities, find_namelist_in_file,    &
                               check_namelist_read, nmlfileunit, do_nml_file,  &
                               get_next_filename, error_handler, E_ERR, E_MSG, &
                               do_nml_term, finalize_utilities,                &
                               open_file, close_file
use  time_manager_mod, only : time_type, set_calendar_type, set_date, &
                              operator(>=), increment_time, get_time, &
                              operator(-), GREGORIAN, operator(+), print_date
use      location_mod, only : VERTISHEIGHT, VERTISPRESSURE
use  obs_sequence_mod, only : obs_sequence_type, obs_type, read_obs_seq, &
                              static_init_obs_sequence, init_obs, write_obs_seq, &
                              init_obs_sequence, get_num_obs, &
                              set_copy_meta_data, set_qc_meta_data
use      obs_kind_mod, only : DWL_U_WIND_COMPONENT, DWL_V_WIND_COMPONENT

implicit none

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

! the max possible number of obs needs to be specified but it will only
! write out the actual number created.

character(len=128)  :: text_input_file = 'dwldata.input'  ! default input name
character(len=128)  :: obs_out_file    = 'obs_seq.out'    ! default output name
integer             :: max_obs         = 100000   !  max number of obs in one file
logical             :: add_obs_data    = .true.   ! .false. makes empty observations
logical             :: debug           = .false.  ! .true. prints more info

namelist /dwl_to_obs_nml/ max_obs, text_input_file, obs_out_file, add_obs_data, debug

! local variables

character (len=129) :: input_line
character (len=20)  :: date_string

integer :: oday, osec, rcio, iunit, otype
integer :: year, month, day, hour, minute, second
integer :: num_copies, num_qc, lcount

logical  :: file_exist, first_obs

real(r8) :: temp, terr, qc, wdir, wspeed, werr
real(r8) :: lat, lon, vert, uwnd, uerr, vwnd, verr

type(obs_sequence_type) :: obs_seq
type(obs_type)          :: obs, prev_obs
type(time_type)         :: comp_day0, time_obs, prev_time

! start of executable code

call initialize_utilities('dwl_to_obs')

! namelist handling
call find_namelist_in_file("input.nml", "dwl_to_obs_nml", iunit)
read(iunit, nml = dwl_to_obs_nml, iostat = rcio)
call check_namelist_read(iunit, rcio, "dwl_to_obs_nml")

! Record the namelist values used for the run
if (do_nml_file()) write(nmlfileunit, nml=dwl_to_obs_nml)
if (do_nml_term()) write(     *     , nml=dwl_to_obs_nml)

! time setup
call set_calendar_type(GREGORIAN)

! open input text file

iunit = open_file(text_input_file, 'formatted', 'read')
if (debug) print *, 'opened input file ' // trim(text_input_file)

if (add_obs_data) then
   print *, 'adding observation values from text file to output'

   ! each observation in this series will have a single observation value
   ! and a quality control flag.
   num_copies = 1
   num_qc     = 1
else
   print *, 'creating no-data observations at the requested locations'

   num_copies = 0
   num_qc     = 0
endif

! call the initialization code, and initialize two empty observation types
call static_init_obs_sequence()
call init_obs(obs,      num_copies, num_qc)
call init_obs(prev_obs, num_copies, num_qc)
first_obs = .true.

! create a new, empty obs_seq file.  you must give a max limit
! on number of obs.  increase the size if too small.
call init_obs_sequence(obs_seq, num_copies, num_qc, max_obs)

if (add_obs_data) then
   ! the first one needs to contain the string 'observation' and the
   ! second needs the string 'QC'.
   call set_copy_meta_data(obs_seq, 1, 'observation')
   call set_qc_meta_data(obs_seq, 1, 'Data QC')
endif

! Set the DART data quality control.   0 is good data.
! increasingly larger QC values are more questionable quality data.
qc = 0.0_r8

! this is just for debugging or errors - count the number of input lines
lcount = 0

obsloop: do    ! no end limit - have the loop break when input ends

   lcount = lcount + 1

   ! read in a line from the text file.   What you need to create an obs:
   !  location: lat, lon, and height in pressure or meters
   !  time: when the observation was taken
   !  type: from the DART list of obs types
   !  error: very important - the instrument error plus representativeness error
   !        (see html file for more info)

   ! assume here a line is: a location, time, 2 obs values, obs error

   ! read in entire text line into a buffer.  exit when no more lines.
   read(iunit, "(A)", iostat=rcio) input_line
   if (rcio /= 0) then
      if (debug) print *, 'line number ', lcount
      if (debug) print *, 'got bad read code from input file, rcio = ', rcio
      if (debug) print *, '(bad read expected if end of file)'
      exit obsloop
   endif

   ! extract the different values from the input line
   read(input_line, *, iostat=rcio) lon, lat, vert, date_string, &
                                    uwnd, vwnd, werr
   if (rcio /= 0) then
      if (debug) print *, 'got bad read code getting next wind obs, rcio = ', rcio
      if (debug) print *, 'line number ', lcount, ' input line was:'
      if (debug) print *, trim(input_line)
      exit obsloop
   endif

   if (debug) print *, 'next observation located at lon, lat = ', lon, lat

   ! date format is: dd-mm-ccyy_hh:nn:ss
   read(date_string, "(2(I2,1X),I4,3(1X,I2))", iostat=rcio) day, month, year, hour, minute, second
   if (rcio /= 0) then
      if (debug) print *, 'got bad read code getting next time value, rcio = ', rcio
      if (debug) print *, 'line number ', lcount, ' input line was:'
      if (debug) print *, trim(input_line)
      exit obsloop
   endif

   if (debug) print *, 'next observation is at time ', year, month, day, hour, minute, second
   if (debug) print *, 'next observation values/err ', uwnd, vwnd, werr

   ! check the lat/lon values to see if they are ok
   if ( lat >  90.0_r8 .or. lat <  -90.0_r8 ) cycle obsloop
   if ( lon <   0.0_r8 .or. lon >  360.0_r8 ) cycle obsloop

   ! if lon comes in between -180 and 180, use these lines instead:
   !if ( lon > 180.0_r8 .or. lon < -180.0_r8 ) cycle obsloop
   !if ( lon < 0.0_r8 )  lon = lon + 360.0_r8 ! changes into 0-360

   ! put date into a dart time format
   time_obs = set_date(year, month, day, hour, minute, second)

   if (debug) call print_date(time_obs, 'next obs time is')

   ! extract time of observation into gregorian day, sec.
   call get_time(time_obs, osec, oday)

   ! vertical in height in meters

   ! if you want to create different obs types for clear air vs cloud,
   ! change the DWL_x_WIND_COMPONENT below to what you need.  it must be
   ! defined in obs_def/obs_def_dwl_mod.f90, and then quickbuild.csh must
   ! be run again.

   call create_3d_obs(add_obs_data, lat, lon, vert, VERTISHEIGHT, uwnd, &
                         DWL_U_WIND_COMPONENT, werr, oday, osec, qc, obs)
   call add_obs_to_seq(obs_seq, obs, time_obs, prev_obs, prev_time, first_obs)

   call create_3d_obs(add_obs_data, lat, lon, vert, VERTISHEIGHT, vwnd, &
                         DWL_V_WIND_COMPONENT, werr, oday, osec, qc, obs)
   call add_obs_to_seq(obs_seq, obs, time_obs, prev_obs, prev_time, first_obs)

   if (debug) print *, 'added 2 wind obs to output seq'

end do obsloop

! if we added any obs to the sequence, write it out to a file now.
if ( get_num_obs(obs_seq) > 0 ) then
   if (debug) print *, 'writing obs_seq, obs_count = ', get_num_obs(obs_seq)
   call write_obs_seq(obs_seq, obs_out_file)
endif

! end of main program
call finalize_utilities()

contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   create_3d_obs - subroutine that is used to create an observation
!                   type from observation data.
!
!       NOTE: assumes the code is using the threed_sphere locations module,
!             that the observation has a single data value and a single
!             qc value, and that this obs type has no additional required
!             data (e.g. gps and radar obs need additional data per obs)
!
!    add_data - if .false. create the location, time, err, kind only - no data
!    lat   - latitude of observation
!    lon   - longitude of observation
!    vval  - vertical coordinate
!    vkind - kind of vertical coordinate (pressure, level, etc)
!    obsv  - observation value
!    okind - observation kind
!    oerr  - observation error
!    day   - gregorian day
!    sec   - gregorian second
!    qc    - quality control value
!    obs   - observation type
!
!     created Oct. 2007 Ryan Torn, NCAR/MMM
!     adapted for more generic use 11 Mar 2010, nancy collins, ncar/image
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine create_3d_obs(add_data, lat, lon, vval, vkind, obsv, okind, oerr, day, sec, qc, obs)
use        types_mod, only : r8
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
use obs_sequence_mod, only : obs_type, set_obs_values, set_qc, set_obs_def
use time_manager_mod, only : time_type, set_time
use     location_mod, only : set_location

 logical,        intent(in)    :: add_data
 integer,        intent(in)    :: okind, vkind, day, sec
 real(r8),       intent(in)    :: lat, lon, vval, obsv, oerr, qc
 type(obs_type), intent(inout) :: obs

real(r8)           :: obs_val(1), qc_val(1)
type(obs_def_type) :: obs_def

call set_obs_def_location(obs_def, set_location(lon, lat, vval, vkind))
call set_obs_def_type_of_obs(obs_def, okind)
call set_obs_def_time(obs_def, set_time(sec, day))
call set_obs_def_error_variance(obs_def, oerr * oerr)
call set_obs_def(obs, obs_def)

if (add_data) then
   obs_val(1) = obsv
   call set_obs_values(obs, obs_val)
   qc_val(1)  = qc
   call set_qc(obs, qc_val)
endif

end subroutine create_3d_obs

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   add_obs_to_seq -- adds an observation to a sequence.  inserts if first
!           obs, inserts with a prev obs to save searching if that's possible.
!
!     seq - observation sequence to add obs to
!     obs - observation, already filled in, ready to add
!     obs_time - time of this observation, in dart time_type format
!     prev_obs - the previous observation that was added to this sequence
!                (will be updated by this routine)
!     prev_time - the time of the previously added observation (will also
!                be updated by this routine)
!     first_obs - should be initialized to be .true., and then will be
!                updated by this routine to be .false. after the first obs
!                has been added to this sequence.
!
!     created Mar 8, 2010   nancy collins, ncar/image
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine add_obs_to_seq(seq, obs, obs_time, prev_obs, prev_time, first_obs)
 use        types_mod, only : r8
 use obs_sequence_mod, only : obs_sequence_type, obs_type, insert_obs_in_seq
 use time_manager_mod, only : time_type, operator(>=)

  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,                 intent(inout) :: first_obs

! insert(seq,obs) always works (i.e. it inserts the obs in
! proper time format) but it can be slow with a long file.
! supplying a previous observation that is older (or the same
! time) as the new one speeds up the searching a lot.

if(first_obs) then    ! for the first observation, no prev_obs
   call insert_obs_in_seq(seq, obs)
   first_obs = .false.
else
   if(obs_time >= prev_time) then  ! same time or later than previous obs
      call insert_obs_in_seq(seq, obs, prev_obs)
   else                            ! earlier, search from start of seq
      call insert_obs_in_seq(seq, obs)
   endif
endif

! update for next time
prev_obs = obs
prev_time = obs_time

end subroutine add_obs_to_seq

end program dwl_to_obs

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

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: #redirect wiki:Sacramento:Century Theatres Stadium 14


text:
! This program reads the contents of a model file, calculates the
! various thermodynamic gradients (actual, adiabatic, & Ledoux) used
! in studying convective instability, and then dumps the output to a
! file.
!
! The format of the model file is the same as in MAESTRO.

program fconv_slopes

  use eos_module, only: eos_init, eos
  use eos_type_module, only: eos_input_rt, eos_t
  use network
  use bl_constants_module
  use bl_error_module
  use bl_types

  implicit none

  !f2kcli stuff
  integer :: narg, farg
  character(len=256) :: fname

  ! runtime variables
  character(len=256) :: inputfile, outputfile

  ! local variables
  integer :: u_in, u_out, ipos
  character(len=256) :: line

  integer :: idens, itemp, ipres, ispec, nvars, npoints
  integer :: nvars_file
  real(kind=dp_t), allocatable :: r(:), model_data(:,:)
  real(kind=dp_t), allocatable :: actual(:), adiabatic(:), ledoux(:)

  ! the chi_* variables are (\partial p / \partial *) at constant everything
  ! else
  real(kind=dp_t) :: chi_rho, chi_t, chi_X(nspec)
  real(kind=dp_t) :: dT, dP, dcomp(nspec), dXdP(nspec)

  type(eos_t) :: eos_state

  character(len=80), allocatable :: varnames_stored(:)
  real(kind=dp_t), allocatable :: vars_stored(:)

  logical :: found

  integer :: i, j, n

  real(kind=dp_t), parameter :: small = 1e-10

  ! set defaults
  inputfile = ''
  outputfile = ''

  ! variables needed are density, temperature, pressure and composition
  idens = 1
  itemp = idens + 1
  ipres = itemp + 1
  ispec = ipres + 1
  nvars = ispec + nspec - 1

  ! parse the runtime variables
  narg = command_argument_count()
  farg = 1
  do while (farg <= narg)
     call get_command_argument(farg, value=fname)

     select case(fname)
     case('-i','--input')
        farg = farg + 1
        call get_command_argument(farg, value = inputfile)

     case('-o','--output')
        farg = farg + 1
        call get_command_argument(farg, value = outputfile)

     case default
        print *, 'Unknown command line option.'
        exit

     end select

     farg = farg + 1
  enddo

  ! sanity check
  if (trim(inputfile) == '') then
     call print_usage()
     stop
  endif

  if (trim(outputfile) == '') outputfile = trim(inputfile) // '.out'

  ! initialize
  call network_init()
  call eos_init()

  ! open the data file
  u_in = 11
  open(u_in, file=inputfile)

  ! number of points in the model
  read(u_in, 100) line
  ipos = index(line, '=') + 1
  read(line(ipos:),*) npoints

  allocate(r(npoints), model_data(npoints,nvars))
  allocate(actual(npoints), adiabatic(npoints), ledoux(npoints))

  ! number of variables in the model file
  read(u_in, 100) line
  ipos = index(line, '=') + 1
  read(line(ipos:),*) nvars_file
  allocate(varnames_stored(nvars_file), vars_stored(nvars_file))

  ! read the variable names
  do i = 1, nvars_file
     read(u_in,100) line
     ipos = index(line, '#') + 1
     varnames_stored(i) = trim(adjustl(line(ipos:)))
  enddo

  ! read in the data
  do i = 1, npoints
     read(u_in,*) r(i), (vars_stored(j), j = 1, nvars_file)

     do j = 1, nvars_file
        found = .false.

        select case(trim(varnames_stored(j)))
        case("density")
           model_data(i,idens) = vars_stored(j)
           found = .true.
        case("temperature")
           model_data(i,itemp) = vars_stored(j)
           found = .true.
        case("pressure")
           model_data(i,ipres) = vars_stored(j)
           found = .true.
        case default
           do n = 1, nspec
              if (trim(varnames_stored(j)) == spec_names(n)) then
                 model_data(i,ispec+n-1) = vars_stored(j)
                 found = .true.
                 exit
              endif
           enddo
        end select

        if (.not. found) call bl_error("ERROR: variable not found: ", &
             trim(varnames_stored(j)))
     enddo
  enddo
  close(unit=u_in)

  ! build the gradients
  do i = 1, npoints

     eos_state % rho = model_data(i,idens)
     eos_state % T = model_data(i,itemp)
     eos_state % xn(:) = model_data(i,ispec:nvars)

     call eos(eos_input_rt, eos_state)

     chi_rho = eos_state % rho * eos_state % dPdr / eos_state % p
     chi_t = eos_state % T * eos_state % dPdT / eos_state % p
     chi_X(:) = eos_state % xn(:) * eos_state % dPdX(:) / (eos_state % p * chi_t)

     ! adiabatic gradient
     adiabatic(i) = (eos_state % gam1 - chi_rho) / (eos_state % gam1 * chi_t)

     ! forward difference
     if (i == 1) then
        dT = model_data(i+1,itemp) - model_data(i  ,itemp)
        dP = model_data(i+1,ipres) - model_data(i  ,ipres)
        dcomp(:) = model_data(i+1,ispec:nvars) - model_data(i  ,ispec:nvars)
     ! backward difference
     else if (i == npoints) then
        dT = model_data(i   ,itemp) - model_data(i-1,itemp)
        dP = model_data(i   ,ipres) - model_data(i-1,ipres)
        dcomp(:) = model_data(i  ,ispec:nvars) - model_data(i-1,ispec:nvars)
     ! centered difference
     else
        dT = model_data(i+1,itemp) - model_data(i-1,itemp)
        dP = model_data(i+1,ipres) - model_data(i-1,ipres)
        dcomp(:) = model_data(i+1,ispec:nvars) - model_data(i-1,ispec:nvars)
     endif

     ! actual gradient; if we are in a constant pressure region, set
     ! gradient to ZERO to prevent div by 0
     if (abs(dp) < small) then
        actual(i) = ZERO
        dXdP = ZERO
     else
        actual(i) = model_data(i,ipres) * dT / (dP * model_data(i,itemp))
        dXdP(:) = dcomp(:)/dP
     endif

     ! ledoux gradient
     ledoux(i) = adiabatic(i)
     do n = 1, nspec
        if (model_data(i,ispec+n-1) > ZERO) then
           ledoux(i) = ledoux(i) - &
                chi_X(n) * model_data(i,ipres)*dXdP(n) &
                / model_data(i,ispec+n-1)
        endif
     enddo

  enddo

  u_out = 22
  open(u_out, file=trim(outputfile))
  write(u_out,*) "# r, actual, adiabatic, ledoux"
  do i = 1, npoints
     write(u_out,*) r(i), actual(i), adiabatic(i), ledoux(i)
  enddo

  close(unit=u_out)

100 format(a256)

contains
  subroutine print_usage()
    implicit none

    print *, 'This program reads the contents of a model file, calculates the'
    print *, 'various thermodynamic gradients (actual, adiabatic, & Ledoux) used'
    print *, 'in studying convective instability, and then dumps the output to a'
    print *, 'file. The format of the model file is the same as in MAESTRO.'
    print *, ''
    print *, ' calling sequence: '
    print *, ' fconv_slopes -i <inputfile> [-o <outputfile>]'
    print *, ''
    print *, ' arguments:'
    print *, '-i | --input:'
    print *, '     specify the input plotfile used to calculate the'
    print *, '     thermodynamic gradients.  required.'
    print *, '-o | --output:'
    print *, '     specify the output filename for the thermodynamic gradients.'
    print *, '     defaults to "<inputfile>.out"'
    print *, ''

  end subroutine print_usage

end program fconv_slopes

max_stars_repo_name: sailoridy/MAESTRO

max_issues_repo_name: sailoridy/MAESTRO

max_forks_repo_name: sailoridy/MAESTRO


text:
	SUBROUTINE GQBND  ( sys, xl, yb, xr, yt, iret )
C************************************************************************
C* GQBND								*
C*									*
C* This subroutine returns the boundaries of the specified coordinate   *
C* system.  For the linear coordinate systems (D,N,V,P), the lower left *
C* and upper right corners are returned.  For M coordinates, the minimum*
C* and maximum range of latitude and longitude are estimated.  For G    *
C* coordinates, the minimum and maximum grid points displayed in the    *
C* plot area are given.		                                        *
C*									*
C* GQBND  ( SYS, XL, YB, XR, YT, IRET )					*
C*									*
C* Input parameters:							*
C*	SYS		CHAR*		Coordinate system		*
C*					  'S' = screen coordinates	*
C*					  'D' = device coordinates	*
C*					  'N' = normalized coordinates	*
C*					  'V' = view coordinates	*
C*					  'P' = plot coordinates	*
C*					  'M' = map coordinates		*
C*					  'G' = grid coordinates	*
C*									*
C* Output parameters:							*
C*	XL		REAL		Lower left x / latitude		*
C*	YB		REAL		Lower left y / longitude	*
C*	XR		REAL		Upper right x / latitude	*
C*	YT		REAL		Upper right y / longitude	*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* M. Goodman/RDS	 5/85	GEMPLT Version 3.1			*
C* M. desJardins/GSFC	 6/88	Cleaned up				*
C* L. Williams/EAi       3/94   Removed blank comments from header      *
C* S. Schotz/NCEP        7/97   Update documentation for S coordinate   *
C* M. Linda/GSC		 9/97	Changed a key word in the prologue	*
C* A. Hardy/GSC          6/98   Cleaned up prolog                       *
C************************************************************************
	INCLUDE		'FUNCCODE.PRM'
	INCLUDE		'ERROR.PRM'
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	sys
C*
	INTEGER		isend (3)
	REAL		rcv   (4)
C------------------------------------------------------------------------
C*	Determine which coordinate system to use.
C
	isys = INDEX  ( sysup, sys ) + INDEX  ( syslo, sys )
	IF  ( isys .eq. 0 )  THEN
	    iret = NOCORD
	    RETURN
	END IF
C
C*	Load input parameters into buffer and write them to the mailbox.
C
	isend (1) = 3
	isend (2) = FQBND
	isend (3) = isys
	CALL GPUT  ( isend, 3, iret )
	IF  ( iret .ne. NORMAL )  RETURN
C
C*	Get output parameters.
C
	CALL GGET  ( iret, 1, ier )
	IF  ( ier .ne. NORMAL )  THEN
	    iret = ier
	    RETURN
	END IF
C
	CALL GGETR  ( rcv, 4, ier )
	IF  ( ier .eq. NORMAL )  THEN
	    xl  = rcv (1)
	    yb  = rcv (2)
	    xr  = rcv (3)
	    yt  = rcv (4)
	END IF
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
module Ref {

  # ----------------------------------------------------------------------
  # Symbolic constants for port numbers
  # ----------------------------------------------------------------------

    enum Ports_RateGroups {
      rateGroup1
      rateGroup2
      rateGroup3
    }

    enum Ports_StaticMemory {
      downlink
      uplink
    }

  topology Ref {

    # ----------------------------------------------------------------------
    # Instances used in the topology
    # ----------------------------------------------------------------------

    instance $health
    instance SG1
    instance SG2
    instance SG3
    instance SG4
    instance SG5
    instance blockDrv
    instance chanTlm
    instance cmdDisp
    instance cmdSeq
    instance comm
    instance downlink
    instance eventLogger
    instance fatalAdapter
    instance fatalHandler
    instance fileDownlink
    instance fileManager
    instance fileUplink
    instance fileUplinkBufferManager
    instance linuxTime
    instance pingRcvr
    instance prmDb
    instance rateGroup1Comp
    instance rateGroup2Comp
    instance rateGroup3Comp
    instance rateGroupDriverComp
    instance recvBuffComp
    instance sendBuffComp
    instance staticMemory
    instance textLogger
    instance uplink
    instance systemResources

    # ----------------------------------------------------------------------
    # Pattern graph specifiers
    # ----------------------------------------------------------------------

    command connections instance cmdDisp

    event connections instance eventLogger

    param connections instance prmDb

    telemetry connections instance chanTlm

    text event connections instance textLogger

    time connections instance linuxTime

    health connections instance $health

    # ----------------------------------------------------------------------
    # Direct graph specifiers
    # ----------------------------------------------------------------------

    connections Downlink {

      chanTlm.PktSend -> downlink.comIn
      eventLogger.PktSend -> downlink.comIn
      fileDownlink.bufferSendOut -> downlink.bufferIn

      downlink.framedAllocate -> staticMemory.bufferAllocate[Ports_StaticMemory.downlink]
      downlink.framedOut -> comm.send
      downlink.bufferDeallocate -> fileDownlink.bufferReturn

      comm.deallocate -> staticMemory.bufferDeallocate[Ports_StaticMemory.downlink]

    }

    connections FaultProtection {
      eventLogger.FatalAnnounce -> fatalHandler.FatalReceive
    }

    connections RateGroups {

      # Block driver
      blockDrv.CycleOut -> rateGroupDriverComp.CycleIn

      # Rate group 1
      rateGroupDriverComp.CycleOut[Ports_RateGroups.rateGroup1] -> rateGroup1Comp.CycleIn
      rateGroup1Comp.RateGroupMemberOut[0] -> SG1.schedIn
      rateGroup1Comp.RateGroupMemberOut[1] -> SG2.schedIn
      rateGroup1Comp.RateGroupMemberOut[2] -> chanTlm.Run
      rateGroup1Comp.RateGroupMemberOut[3] -> fileDownlink.Run
      rateGroup1Comp.RateGroupMemberOut[4] -> systemResources.run

      # Rate group 2
      rateGroupDriverComp.CycleOut[Ports_RateGroups.rateGroup2] -> rateGroup2Comp.CycleIn
      rateGroup2Comp.RateGroupMemberOut[0] -> cmdSeq.schedIn
      rateGroup2Comp.RateGroupMemberOut[1] -> sendBuffComp.SchedIn
      rateGroup2Comp.RateGroupMemberOut[2] -> SG3.schedIn
      rateGroup2Comp.RateGroupMemberOut[3] -> SG4.schedIn

      # Rate group 3
      rateGroupDriverComp.CycleOut[Ports_RateGroups.rateGroup3] -> rateGroup3Comp.CycleIn
      rateGroup3Comp.RateGroupMemberOut[0] -> $health.Run
      rateGroup3Comp.RateGroupMemberOut[1] -> SG5.schedIn
      rateGroup3Comp.RateGroupMemberOut[2] -> blockDrv.Sched
      rateGroup3Comp.RateGroupMemberOut[3] -> fileUplinkBufferManager.schedIn

    }

    connections Ref {
      sendBuffComp.Data -> blockDrv.BufferIn
      blockDrv.BufferOut -> recvBuffComp.Data
    }

    connections Sequencer {
      cmdSeq.comCmdOut -> cmdDisp.seqCmdBuff
      cmdDisp.seqCmdStatus -> cmdSeq.cmdResponseIn
    }

    connections Uplink {

      comm.allocate -> staticMemory.bufferAllocate[Ports_StaticMemory.uplink]
      comm.$recv -> uplink.framedIn
      uplink.framedDeallocate -> staticMemory.bufferDeallocate[Ports_StaticMemory.uplink]

      uplink.comOut -> cmdDisp.seqCmdBuff
      cmdDisp.seqCmdStatus -> uplink.cmdResponseIn

      uplink.bufferAllocate -> fileUplinkBufferManager.bufferGetCallee
      uplink.bufferOut -> fileUplink.bufferSendIn
      uplink.bufferDeallocate -> fileUplinkBufferManager.bufferSendIn
      fileUplink.bufferSendOut -> fileUplinkBufferManager.bufferSendIn

    }

  }

}

ext: fpp


text:
c
c ------------------------------------------------------
c
       subroutine setir2(irreg2,mi2tot,mj2tot,mptr,lstgrd)
c
       implicit double precision (a-h,o-z)
       dimension  irreg2(mi2tot,mj2tot)
       integer srcptr, srclev, gptr
       logical outside

      common /userdt/ cfl,gamma,gamma1,xprob,yprob,alpha,Re,iprob,
     .                ismp,gradThreshold
      parameter  (maxgr = 192, maxlv=12)
      common /nodal/ rnode(12,maxgr),node(17,maxgr),lstart(maxlv),
     *  newstl(maxlv),
     *  listsp(maxlv),intrat(maxlv),tol,bzonex,bzoney,mstart,ndfree,
     *  lfine,iorder,mxnest,kcheck,lwidth,
     *  maxcl, graf, lhead
      include "calloc.i"
      include "cirr.i"
      dimension ialloc(2*allocsize)
      equivalence(alloc,ialloc)

       outside(x,y) = (x .lt. tolb) .or. (y .lt. tolb) .or.
     *                (x .gt. xprob-tolb) .or. (y .gt. yprob-tolb)
      iirrc(i,j)      = 2*(locirc-1)+1 + i - 1 + misrc*(j-1)
c
c make the irregular array for the (interior) coarsened grid using the
c irregular array for next coarser level grid.
c
       tolb  = 1.d-8
       hx   = rnode(9,mptr)
       hy   = rnode(10,mptr)
       hx2  = 2.d0*hx
       hy2  = 2.d0*hy
       xlow = rnode(1,mptr) - lwidth*hx2
       ylow = rnode(2,mptr) - lwidth*hy2
       gptr = 0
       level = node(4,mptr) - 1
       if (level .lt. 1) go to 99

       do 10 i = 1, mi2tot
       do 10 j = 1, mj2tot
          x = xlow + (i-.5)*hx2
          y = ylow + (j-.5)*hy2
	  if (outside(x,y)) then
	    irreg2(i,j) = lstgrd
	  else
             call getsrc(x,y,level,gptr, srcptr, srclev)
             if (srclev .lt. level) then
               irreg2(i,j) = -1
             else
               locirc = node(14, srcptr)
               misrc  = node(5,srcptr)-1+2*lwidth
               xsrc   = rnode(1,srcptr)-lwidth*hx2
               ysrc   = rnode(2,srcptr)-lwidth*hy2
	       isrc   = (x-xsrc)/hx2 + 1
	       jsrc   = (y-ysrc)/hy2 + 1
               ksrc = ialloc(iirrc(isrc,jsrc))
	       lstsrc = node(17,srcptr)
	       if (ksrc .ne. lstsrc) then
	         irreg2(i,j) = ksrc
	       else
	         irreg2(i,j) = lstgrd
	       endif
               gptr = srcptr
             endif
          endif
 10    continue
c
 99    return
       end


text:
! Filename: precision.f90
! Description: Module of precision parameters. Based on
!              http://fortranwiki.org/fortran/show/Real+precision
! Author: Tim Troxler
! Date: 7/17/2015
module precision

    integer, parameter :: sp = selected_real_kind(6, 37)
    integer, parameter :: dp = selected_real_kind(15, 307)
    integer, parameter :: qp = selected_real_kind(33, 4931)

end module precision

max_stars_repo_name: troxology/fortranUnitConversion

max_issues_repo_name: troxology/fortranUnitConversion

max_forks_repo_name: troxology/fortranUnitConversion


text:
C$$$  MAIN PROGRAM DOCUMENTATION BLOCK
C
C MAIN PROGRAM:  READ_PREPBUFR
C   PRGMMR: KEYSER           ORG: NP22        DATE: 2002-01-28
C
C ABSTRACT: READS SUBSETS (REPORTS) FROM A PREPBUFR FILE, MERGING
C   MASS AND WIND SUBSETS FROM THE SAME ORIGINAL REPORT.  MERGED
C   REPORTS ARE PARSED ACCORDING TO THEIR BUFR MESSAGE TYPE AND
C   ARE LISTED IN OUTPUT TEXT FILES.
C
C PROGRAM HISTORY LOG:
C ????-??-??  WOOLLEN/GSC ORIGINAL AUTHOR
C ????-??-??  ATOR        STREAMLINED AND DOCUMENTED
C 2001-10-26  KEYSER      FURTHER DOCUMENTATION FOR WEB, UPDATED
C                         TO REPLACE OBSOLETE MESSAGE TYPE "SATBOG"
C                         WITH "QKSWND"; ADDED MORE VARAIBLES AND
C                         MANY OTHER UPDATES
C 2002-01-28  KEYSER      NOW THAT "PCAT" (PRECISION OF TEMPERATURE
C                         OBS.) HAS BEEN ADDED TO PREPBUFR FILE FOR
C                         "AIRCFT" AND "AIRCAR" MESSAGE TYPES, ADDED
C                         THIS TO LISTING
C
C USAGE:
C   INPUT FILES:
C     UNIT 11  - PREPBUFR FILE
C
C   OUTPUT FILES:
C     UNIT 06  - UNIT 6 (STANDARD PRINTFILE)
C     UNIT 51  - LISTING OF REPORTS IN MESSAGE TYPE "ADPUPA"
C     UNIT 52  - LISTING OF REPORTS IN MESSAGE TYPE "AIRCAR"
C     UNIT 53  - LISTING OF REPORTS IN MESSAGE TYPE "AIRCFT"
C     UNIT 54  - LISTING OF REPORTS IN MESSAGE TYPE "SATWND"
C     UNIT 55  - LISTING OF REPORTS IN MESSAGE TYPE "PROFLR"
C     UNIT 56  - LISTING OF REPORTS IN MESSAGE TYPE "VADWND"
C     UNIT 57  - LISTING OF REPORTS IN MESSAGE TYPE "SATEMP"
C     UNIT 58  - LISTING OF REPORTS IN MESSAGE TYPE "ADPSFC"
C     UNIT 59  - LISTING OF REPORTS IN MESSAGE TYPE "SFCSHP"
C     UNIT 60  - LISTING OF REPORTS IN MESSAGE TYPE "SFCBOG"
C     UNIT 61  - LISTING OF REPORTS IN MESSAGE TYPE "SPSSMI"
C     UNIT 62  - LISTING OF REPORTS IN MESSAGE TYPE "SYNDAT"
C     UNIT 63  - LISTING OF REPORTS IN MESSAGE TYPE "ERS1DA"
C     UNIT 64  - LISTING OF REPORTS IN MESSAGE TYPE "GOESND"
C     UNIT 65  - LISTING OF REPORTS IN MESSAGE TYPE "QKSWND"
C
C   SUBPROGRAMS CALLED:
C     UNIQUE:    - READPB   INDEXF
C     LIBRARY:
C       W3LIB    - ERREXIT
C       BUFR     - OPENBF   DATELEN  READNS   UFBINT   UFBEVN
C                  UFBQCP
C
C   EXIT STATES:
C     COND =   0 - SUCCESSFUL RUN
C             22 - ABORT, NUMBER OF BALLOON DRIFT LEVELS RETURNED
C                  DOES NOT EQUAL NUMBER OF P/T/Z/Q/U/V LEVELS
C                  RETURNED (ADPUPA MESSAGE TYPE ONLY)
C             33 - ABORT, NUMBER OF VIRTUAL TEMP./DEWPOINT TEMP.
C                  LEVELS RETURNED DOES NOT EQUAL NUMBER OF
C                  P/T/Z/Q/U/V LEVELS RETURNED (ADPUPA MESSAGE
C                  TYPE ONLY)
C
C REMARKS: IN THIS PROGRAM, THE TERM "SUBSET" REFERS TO THE
C   COMPONENTS IN A BUFR MESSAGE.  THESE COULD BE CONSIDERED TO
C   BE "REPORTS" IN THE PREPBUFR FILE.  HERE, "REPORT" IS USED TO
C   REFER TO THE FINAL PRODUCT WHICH CONTAINS MERGED MASS AND WIND
C   SUBSETS FROM THE SAME ORIGINAL OBSERVATION.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM SP, SGI
C
C$$$

      PROGRAM   READ_PREPBUFR

      REAL*8    R8BFMS

      PARAMETER ( R8BFMS = 9.0E08 )! Missing value threshhold for BUFR
      PARAMETER ( NHR8PM = 14 )    ! Actual number of BUFR parameters
                                   !  in header
      PARAMETER ( MXR8PM =  8 )    ! Maximum number of BUFR parameters
                                   !  in level data (non-radiance) or
                                   !  in channel data (radiance)
      PARAMETER ( MXR8LV = 255 )   ! Maximum number of BUFR levels/
                                   !                        channels
      PARAMETER ( MXR8VN = 10 )    ! Max. number of BUFR event sequences
                                   !  (non-radiance reports)
      PARAMETER ( MXR8VT = 17)     ! Max. number of BUFR variable types
                                   !  (non-radiance reports)
      PARAMETER ( NFILO = 15 )

      REAL*8    hdr ( NHR8PM ), qkswnd_hdr(3), aircar_hdr(6),
     +          aircft_hdr(4),  adpupa_hdr(1), goesnd1_hdr(6),
     +          goesnd2_hdr(MXR8LV), adpsfc_hdr(5), sfcshp_hdr(2),
     +          satwnd_hdr(1), evns ( MXR8PM, MXR8LV, MXR8VN, MXR8VT ),
     +          drft ( 3, MXR8LV ), brts ( MXR8PM, MXR8LV ),
     +          toth ( 2, MXR8LV )

      INTEGER   ifirst ( NFILO ), iunso ( NFILO ), indxvr1 ( 100:299 ),
     +          indxvr2 ( 100:299 )

      CHARACTER    msgtyp*8, qc_step*8
      CHARACTER*18 var ( MXR8VT )
      CHARACTER*6  filo ( NFILO )

      LOGICAL   found

      COMMON  / PREPBC /      hdr, evns, drft, toth, brts, qkswnd_hdr,
     +  aircar_hdr, aircft_hdr, adpupa_hdr, goesnd1_hdr, goesnd2_hdr,
     +  adpsfc_hdr, sfcshp_hdr, satwnd_hdr, indxvr1, indxvr2, nlev, nchn

      DATA      iunso
     +        /   51,   52,   53,   54,   55,
     +            56,   57,   58,   59,   60,
     +            61,   62,   63,   64,   65  /
      DATA         var /
     +  'PRESSURE (MB)     ','SP HUMIDITY(MG/KG)','TEMPERATURE (C)   ',
     +  'HEIGHT (METERS)   ','U-COMP WIND (M/S) ','V-COMP WIND (M/S) ',
     +  'WIND DIR (DEG)    ','WIND SPEED (KNOTS)','TOTAL PWATER (MM) ',
     +  'RAIN RATE (MM/HR) ','1.-.9 sig PWAT(MM)','.9-.7 sig PWAT(MM)',
     +  '.7-.3 sig PWAT(MM)','.3-0. sig PWAT(MM)','CLOUD-TOP PRES(MB)',
     +  'CLOUD-TOP TEMP (K)','TOT. CLD. COVER(%)' /
      DATA         filo
     +        / 'ADPUPA', 'AIRCAR', 'AIRCFT', 'SATWND', 'PROFLR',
     +          'VADWND', 'SATEMP', 'ADPSFC', 'SFCSHP', 'SFCBOG',
     +          'SPSSMI', 'SYNDAT', 'ERS1DA', 'GOESND', 'QKSWND'/

C-----------------------------------------------------------------------

      IFIRST = 0

C       Open the output files.
C       ----------------------

      DO ifile = 1, NFILO
          OPEN  ( UNIT = iunso ( ifile ),
     +            FILE = 'readpb.out.' // filo ( ifile ) )
      END DO

C       Open the input PREPBUFR file.
C       -----------------------------
      OPEN  ( UNIT = 11, FILE = 'prepbufr.in', FORM = 'UNFORMATTED' )
      CALL OPENBF(11,'IN',11 )  ! BUFRLIB routine to open file
      CALL DATELEN(10)  ! BUFRLIB routine to use 10-digit date

C       Get the next subset from the input file.  Merge mass and
C        wind subsets for the same "true" report.
C       --------------------------------------------------------

  10  CALL READPB(11,msgtyp,idate,ierrpb )
      IF ( ierrpb .eq. -1 )  THEN
          print *, '1-All subsets read in and processed'
          STOP      ! All subsets read in and processed
      END IF

C       Set the appropriate output file unit number based on the
C        BUFR message type the subset is in.
C       --------------------------------------------------------

      ifile = 1
      found = .false.
      DO WHILE  ( ( .not. found ) .and. ( ifile .le. NFILO ) )
          IF  ( msgtyp (1:6) .eq. filo ( ifile ) )  THEN
              found = .true.
              iuno = iunso ( ifile )
          ELSE
              ifile = ifile + 1
          END IF
      END DO
      IF  ( ( .not. found ) .and. ( ierrpb .eq. 0 ) )  THEN
          GO TO 10
      END IF

      IF ( ifirst(ifile) .eq. 0 )  THEN
         WRITE  ( UNIT = iuno,
     +    FMT = '("LISTING FOR MESSAGE TYPE ",A6//' //
     +    '"Key for header:"/' //
     +    '"SID  -- Station identification"/' //
     +    '"YOB  -- Latitude (N+, S-)"/' //
     +    '"XOB  -- Longitude (E)"/' //
     +    '"ELV  -- Elevation (meters)"/' //
     +    '"DHR  -- Observation time minus cycle time (hours)"/' //
     +    '"RPT  -- Reported observation time (hours)"/' //
     +    '"TCOR -- Indicator whether observation time used to ",' //
     +     '"generate DHR was corrected (0- Observation time ",' //
     +     '"is reported time, no"/9X,"correction, 1- Observation ",' //
     +     '"time corrected based on reported launch time, 2- ",' //
     +     '"Observation time corrected even though"/9X,"launch ", ' //
     +     '"time is missing)"/' //
     +    '"TYP  -- PREPBUFR report type"/' //
     +    '"TSB  -- PREPBUFR report subtype"/' //
     +    '"T29  -- Input report type"/' //
     +    '"ITP  -- Instrument type (BUFR code table 0-02-001)"/' //
     +    '"SQN  -- Report sequence number"/' //
     +    '"PROCN - Process number for this MPI run (obtained from ",'//
     +     '"script)"/' //
     +    '"SAID -- Satellite identifier (BUFR code table 0-01-007)")')
     +    filo(ifile)
         IF (filo(ifile) .eq. 'ADPUPA' ) then
            WRITE  ( UNIT = iuno, FMT =
     +       '("SIRC -- Rawinsonde solar & infrared radiation ",' //
     +        '"correction indicator (BUFR code table 0-02-013)")')
         ELSE IF (filo(ifile) .eq. 'GOESND' .or.
     +            filo(ifile) .eq. 'SATEMP' ) then
            WRITE  ( UNIT = iuno, FMT =
     +       '("For reports with non-radiance data:"/' //
     +       '"  ACAV -- Total number with respect to accumulation ",'//
     +        '"or average"/' //
     +       '"  PRSS -- Surface pressure observation (mb)"/' //
     +       '"For reports with radiance data:"/' //
     +       '"  ELEV -- Satellite elevation (zenith angle - deg.)"/' //
     +       '"  SOEL -- Solar elevation (zenith angle - deg.)"/' //
     +       '"  OZON -- Total ozone (Dobson units)"/' //
     +       '"  TMSK -- Skin temperature (Kelvin)"/' //
     +       '"  CLAM -- Cloud Amount (BUFR code table 0-20-011)")')
         ELSE IF (filo(ifile) .eq. 'QKSWND' ) then
            WRITE  ( UNIT = iuno, FMT =
     +       '("ATRN -- Along track row number"/' //
     +       '"CTCN -- Cross track cell number"/' //
     +       '"SPRR -- Seawinds probability of rain (%)")')
         ELSE IF (filo(ifile) .eq. 'AIRCAR' ) then
            WRITE  ( UNIT = iuno, FMT =
     +       '("PCAT -- Precision of temperature obs. (Kelvin)"/' //
     +       '"POAF -- Phase of aircraft flight (BUFR code table ",' //
     +        '"0-08-004)"/' //
     +       '"TRBX10 -- Turbulence index for period TOB-1 min to ",' //
     +        '"TOB"/' //
     +       '"TRBX21 -- Turbulence index for period TOB-2 min to ",' //
     +        '"TOB-1 min"/' //
     +       '"TRBX32 -- Turbulence index for period TOB-3 min to ",' //
     +        '"TOB-2 min"/' //
     +       '"TRBX43 -- Turbulence index for period TOB-4 min to ",' //
     +        '"TOB-3 min")')
         ELSE IF (filo(ifile) .eq. 'AIRCFT' ) then
            WRITE  ( UNIT = iuno, FMT =
     +       '("RCT  -- Receipt time (hours)"/' //
     +       '"PCAT -- Precision of temperature obs. (Kelvin)"/' //
     +       '"POAF -- Phase of aircraft flight (BUFR code table ",' //
     +        '"0-08-004)"/' //
     +       '"DGOT -- Degree of turbulence (BUFR code table ",' //
     +        '"0-11-031)")')
         ELSE IF (filo(ifile) .eq. 'ADPSFC' ) then
            WRITE  ( UNIT = iuno, FMT =
     +       '("PMO  -- Mean sea-level pressure observation (mb)"/' //
     +       '"PMQ  -- Mean sea-level pressure quality marker"/' //
     +       '"ALSE -- Altimeter setting observation (mb)"/' //
     +       '"SOB  -- Wind speed observation (stored when ",' //
     +        '"direction is missing) (m/s)"/' //
     +       '"SQM  -- Wind speed quality marker (stored when ",' //
     +        '"direction is missing)")')
         ELSE IF (filo(ifile) .eq. 'SFCSHP' ) then
            WRITE  ( UNIT = iuno, FMT =
     +       '("PMO  -- Mean sea-level pressure observation (mb)"/' //
     +       '"PMQ  -- Mean sea-level pressure quality marker")')
         ELSE IF (filo(ifile) .eq. 'SATWND' ) then
            WRITE  ( UNIT = iuno, FMT =
     +       '("RFFL -- NESDIS recursive filter flag")')
         END IF
         WRITE  ( UNIT = iuno, FMT = '(//"PREPBUFR FILE DATE IS: ",
     +    I10)') idate
         WRITE  ( UNIT = iuno, FMT = '(/)')
         ifirst(ifile)=1
      END IF

      WRITE  ( UNIT = iuno,
     + FMT = '(/"SID=",A8,", YOB=",F6.2,", XOB=",F6.2,", ELV=",I5,' //
     + '", DHR=",F6.3,", RPT=",F8.3,", TCOR=",I1,", TYP=",I3,' //
     + '", TSB=",I1,", T29=",I3,", ITP=",I2,", SQN=",I6/,"PROCN=",I2,'//
     + '", SAID=",I3)')
     + (hdr(ii),ii=1,3),nint(hdr(4)),hdr(5),hdr(6),(nint(hdr(ii)),
     + ii=7,14)

      IF (filo(ifile) .eq. 'ADPUPA' ) then
         WRITE  ( UNIT = iuno, FMT = '("SIRC=",I2)') nint(adpupa_hdr)
      ELSE IF (filo(ifile) .eq. 'GOESND' .or.
     +         filo(ifile) .eq. 'SATEMP' ) then
         IF (nlev.gt.0)  THEN
            WRITE  ( UNIT = iuno, FMT = '("ACAV=",I3,", PRSS=",F6.1)')
     +       nint(goesnd1_hdr(1)),goesnd2_hdr(1)*0.01
         END IF
         IF (nchn.gt.0)  THEN
            WRITE  ( UNIT = iuno, FMT = '("ELEV=",F6.2,", SOEL=",' //
     +       'F6.2,", OZON=",I4,", TMSK=",F5.1,", CLAM=",I2)')
     +       goesnd1_hdr(2),goesnd1_hdr(3),nint(goesnd1_hdr(4)),
     +       goesnd1_hdr(5),nint(goesnd1_hdr(6))
         END IF
      ELSE IF (filo(ifile) .eq. 'QKSWND' ) then
         WRITE  ( UNIT = iuno, FMT = '("ATRN=",I3,", CTCN=",I3,' //
     +   '", SPRR=",I3)') (nint(qkswnd_hdr(ii)),ii=1,3)
      ELSE IF (filo(ifile) .eq. 'AIRCAR' ) then
         WRITE  ( UNIT = iuno, FMT = '("PCAT=",F5.2,", POAF=",I3,' //
     + '", TRBX10=",I3,", TRBX21=",I3,", TRBX32=",I3,", TRBX43=",I3)')
     +    aircar_hdr(1),(nint(aircar_hdr(ii)),ii=2,6)
      ELSE IF (filo(ifile) .eq. 'AIRCFT' ) then
         WRITE  ( UNIT = iuno, FMT = '("RCT=",F7.2,", PCAT=",F5.2,' //
     +    '", POAF=",I3,", DGOT=",I3)') aircft_hdr(1),aircft_hdr(2),
     +    (nint(aircft_hdr(ii)),ii=3,4)
      ELSE IF (filo(ifile) .eq. 'ADPSFC' ) then
         WRITE  ( UNIT = iuno, FMT = '("PMO=",F6.1,", PMQ=",I2,' //
     +    '", ALSE=",F6.1,", SOB=",F5.1,", SQM=",I2)')
     +   adpsfc_hdr(1),nint(adpsfc_hdr(2)),adpsfc_hdr(3)*0.01,
     +   adpsfc_hdr(4),nint(adpsfc_hdr(5))
      ELSE IF (filo(ifile) .eq. 'SFCSHP' ) then
         WRITE  ( UNIT = iuno, FMT = '("PMO=",F6.1,", PMQ=",I2)')
     +     sfcshp_hdr(1),nint(sfcshp_hdr(2))
      ELSE IF (filo(ifile) .eq. 'SATWND' ) then
         WRITE  ( UNIT = iuno, FMT = '("RFFL=",I3)') nint(satwnd_hdr(1))
      END IF

      IF (nlev .gt. 0 )  THEN

C       Print the level (non-radiance) data for report (if separate
C        mass & wind pieces in PREPBUFR file, these have been merged).
C       --------------------------------------------------------------

         DO lv = 1, nlev  ! loop through the levels
            WRITE  ( UNIT = iuno, FMT = '( 94("-") )' )
            WRITE  ( UNIT = iuno,
     +               FMT = '( 10X,"level ", I4, 2X, A9,A8,A10,5A9 )' )
     +       lv, 'obs      ', 'qmark   ', 'qc_step   ', 'rcode    ',
     +       'fcst     ', 'anal     ', 'oberr    ', 'category '
            WRITE  ( UNIT = iuno, FMT = '( 94("-") )' )
            DO kk = indxvr1(nint(hdr(8))),indxvr2(nint(hdr(8)))
                             ! loop through the variables
               IF( kk .eq. 10 )  ! convert rain rate from mm/s to mm/hr
     +                 evns( 1, lv, :,kk) = evns( 1, lv, :,kk)*3600.0_8
               IF( kk .eq. 15 ) ! convert cloud-top press. from Pa to mb
     +                 evns( 1, lv, :,kk) = evns( 1, lv, :,kk)*0.01
               DO jj = 1, MXR8VN  ! loop through the events
                  IF(min(evns(1,lv,jj,kk),evns(2,lv,jj,kk),
     +                   evns(3,lv,jj,kk),evns(4,lv,jj,kk),
     +                   evns(5,lv,jj,kk),evns(6,lv,jj,kk),
     +                   evns(7,lv,jj,kk))
     +                   .lt. R8BFMS) THEN
                     IF(evns(3,lv,jj,kk) .le. R8BFMS) THEN

C       Copy forecast value, analyzed value, observation error and
C        PREPBUFR category from latest event sequence to all earlier
C        valid event sequences
C       --------------------------------------------------------------

                        evns(5:8,lv,jj,kk) = evns(5:8,lv,1,kk)
                        pcode = evns(3,lv,jj,kk)
                        CALL UFBQCP(11,pcode,QC_STEP)
                     ELSE
                        QC_STEP = '        '
                     END IF
                     WRITE  ( UNIT = iuno,
     + FMT = '( A18,1X,F8.1,2X,F6.0,4X,A8,2X,F5.0,3(1X,F8.1),2X,F7.0)' )
     +               var (kk), ( evns ( ii, lv, jj, kk ), ii = 1, 2 ),
     +               qc_step,  ( evns ( ii, lv, jj, kk ), ii = 4, 8 )
                  END IF
               END DO
            END DO
            IF ( msgtyp .eq. 'ADPUPA' )  THEN
               WRITE  ( UNIT = iuno,
     +    FMT = '( 10X,"BALLOON DRIFT: D-TIME(HRS)=",F7.3,", LAT(N)=",
     +             F6.2,", LON(E)=",F6.2)' ) ( drft ( ii, lv), ii = 1,3)
               IF(min(toth(1,lv),toth(2,lv)) .lt. R8BFMS)
     +          WRITE  ( UNIT = iuno,
     + FMT = '( 10X,"Through PREPRO STEP only: VIRTUAL TEMP (C)=",F8.1,
     +       ", DEWPOINT TEMP (C)=",F8.1)' ) toth (1,lv), toth (2,lv)
            END IF
         END DO
      END IF

      IF (nchn .gt. 0 )  THEN

C       Print the channel (radiance) data for report
C       --------------------------------------------

         WRITE  ( UNIT = iuno, FMT = '( 42("-") )' )
         WRITE  ( UNIT = iuno,
     +            FMT = '("BRIGHTNESS TEMP  channel  observation (K)")')
         WRITE  ( UNIT = iuno, FMT = '( 42("-") )' )
         DO lv = 1, nchn  ! loop through the channels
            IF(min(brts(1,lv),brts(2,lv)) .lt. R8BFMS) THEN
               WRITE  ( UNIT = iuno, FMT = '(19X,I3,7X,F6.2)' )
     +          nint(brts(1,lv)), brts(2,lv)
            END IF
         END DO
      END IF

      IF  ( ierrpb .eq. 0 )  GO TO 10

      print *, '2-All subsets read in and processed'

      STOP      ! All subsets read in and processed

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    READPB
C   PRGMMR: KEYSER           ORG: NP12        DATE: 2002-01-28
C
C ABSTRACT: THIS SUBROUTINE READS IN SUBSETS FROM THE PREPBUFR
C   FILE.  SINCE ACTUAL OBSERVATIONS ARE SPLIT INTO MASS AND
C   WIND SUBSETS, THIS ROUTINE COMBINES THEM INTO A SINGLE
C   REPORT FOR OUTPUT.  IT IS STYLED AFTER BUFRLIB ENTRY POINT
C   READNS, AND IT ONLY REQUIRES THE PREPBUFR FILE TO BE OPENED
C   FOR READING WITH OPENBF.  THE COMBINED REPORT IS RETURNED TO
C   THE CALLER IN COMMON /PREPBC/.  THIS COMMON AREA CONTAINS
C   THE NUMBER OF LEVELS (NON-RADIANCES) IN THE REPORT, THE
C   NUMBER OF CHANNELS (RADIANCES) IN THE REPORT, A ONE
C   DIMENSIONAL ARRAY WITH THE HEADER INFORMATION, A FOUR
C   DIMENSIONAL ARRAY CONTAINING ALL EVENTS FROM ALL
C   NON-RADIANCE OBSERVATIONAL VARIABLE TYPES, AND A TWO
C   DIMENSIONAL ARRAY CONTAINING ALL CHANNELS OF BRIGHTNESS
C   TEMPERATURE FOR REPORTS CONTAINING RADIANCE DATA.
C
C PROGRAM HISTORY LOG:
C ????-??-??  WOOLLEN/GSC ORIGINAL AUTHOR
C ????-??-??  ATOR        STREAMLINED AND DOCUMENTED
C 2001-10-26  KEYSER      FURTHER DOCUMENTATION FOR WEB, UPDATED
C                         TO REPLACE OBSOLETE MESSAGE TYPE "SATBOG"
C                         WITH "QKSWND"; ADDED MORE VARAIBLES AND
C                         MANY OTHER UPDATES
C 2002-01-28  KEYSER      NOW THAT "PCAT" (PRECISION OF TEMPERATURE
C                         OBS.) HAS BEEN ADDED TO PREPBUFR FILE FOR
C                         "AIRCFT" AND "AIRCAR" MESSAGE TYPES, ADDED
C                         THIS TO LISTING
C
C USAGE:    CALL READPB  (LUNIT, MSGTYP, IDATE, IRET)
C   INPUT ARGUMENT LIST:
C     LUNIT    - UNIT NUMBER OF INPUT PREPBUFR FILE
C
C   OUTPUT ARGUMENT LIST:
C     MSGTYP   - BUFR MESSAGE TYPE (CHARACTER)
C     IDATE    - BUFR MESSAGE DATE IN FORM YYYYMMDDHH
C     IRET     - ERROR RETURN CODE (0 - normal return; 1 - the report
C                within COMMON /PREPBC/ contains the last available
C                report from within the prepbufr file; -1 - there are
C                no more reports available from within the PREPBUFR
C                file, all subsets have been processed)
C
C REMARKS:
C
C   The header array HDR contains the following list of mnemonics:
C         HDR(1)  Station identification (SID)
C         HDR(2)  Latitude  (YOB)
C         HDR(3)  Longitude (XOB)
C         HDR(4)  Elevation (ELV)
C         HDR(5)  Observation time minus cycle time (DHR)
C         HDR(6)  Reported observation time (RPT)
C         HDR(7)  Indicator whether observation time used to generate
C                  "DHR" was corrected (TCOR)
C         HDR(8)  PREPBUFR report type (TYP)
C         HDR(9) PREPBUFR report subtype (TSB)
C         HDR(10) Input report type (T29)
C         HDR(11) Instrument type (ITP)
C         HDR(12) Report sequence number (SQN)
C         HDR(13) Process number for this MPI run (obtained from
C                  script (PROCN)
C         HDR(14) Satellite identifier (SAID)
C
C   The 4-D array of non-radiance data, EVNS (ii, lv, jj, kk), is
C    indexed as follows:
C     "ii" indexes the event data types; these consist of:
C         1) Observation       (e.g., POB, ZOB, UOB, VOB, TOB, QOB, PWO)
C         2) Quality mark      (e.g., PQM, ZRM, WQM, TQM, QQM, PWQ)
C         3) Program code      (e.g., PPC, ZPC, WPC, TPC, QPC, PWP)
C         4) Reason code       (e.g., PRC, ZRC, WRC, TRC, QRC, PWR)
C         5) Forecast value    (e.g., PFC, ZFC, UFC, VFC, TFC, QFC, PWF)
C         6) Analyzed value    (e.g., PAN, ZAN, UAN, VAN, TAN, QAN, PWA)
C         7) Observation error (e.g., POE, ZOE, WOE, TOE, QOE, PWO)
C         8) PREPBUFR data level category (CAT)
C     "lv" indexes the levels of the report
C         1) Lowest level
C     "jj" indexes the event stacks
C         1) N'th event
C         2) (N-1)'th event (if present)
C         3) (N-2)'th event (if present)
C                ...
C        10) (N-9)'th event (if present)
C     "kk" indexes the variable types
C         1) Pressure
C         2) Specific humidity
C         3) Temperature
C         4) Height
C         5) U-component wind
C         6) V-component wind
C         7) Wind direction
C         8) Wind speed
C         9) Total precipitable water
C        10) Rain rate
C        11) 1.0 to 0.9 sigma layer precipitable water
C        12) 0.9 to 0.7 sigma layer precipitable water
C        13) 0.7 to 0.3 sigma layer precipitable water
C        14) 0.3 to 0.0 sigma layer precipitable water
C        15) Cloud-top pressure
C        16) Cloud-top temperature
C        17) Total cloud cover
C
C     Note that the structure of this array is identical to one
C      returned from BUFRLIB routine UFBEVN, with an additional (4'th)
C      dimension to include the 14 variable types into the same
C      array.
C
C   The 2-D array of radiance data, BRTS (ii, lv), is indexed
C    as follows:
C     "ii" indexes the event data types; these consist of:
C         1) Observation       (CHNM, TMBR)
C     "lv" indexes the channels (CHNM gives channel number)
C
C     Note that this array is directly returned from BUFRLIB
C      routine UFBINT.
C
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM SP
C
C$$$
      SUBROUTINE READPB  ( lunit, msgtyp, idate, iret )

      REAL*8    R8BFMS

      PARAMETER ( R8BFMS = 9.0E08 )! Missing value threshhold for BUFR
      PARAMETER ( NHR8PM = 14 )    ! Actual number of BUFR parameters
                                   !  in header
      PARAMETER ( MXR8PM =  8 )    ! Maximum number of BUFR parameters
                                   !  in level data (non-radiance) or
                                   !  in channel data (radiance)
      PARAMETER ( MXR8LV = 255 )   ! Maximum number of BUFR levels/
                                   !                        channels
      PARAMETER ( MXR8VN = 10 )    ! Max. number of BUFR event sequences
                                   !  (non-radiance reports)
      PARAMETER ( MXR8VT = 17)     ! Max. number of BUFR variable types
                                   !  (non-radiance reports)
      PARAMETER ( MXSTRL = 80 )    ! Maximum size of a string

      REAL*8    hdr ( NHR8PM ), qkswnd_hdr(3), aircar_hdr(6),
     +          aircft_hdr(4),  adpupa_hdr(1), goesnd1_hdr(6),
     +          goesnd2_hdr(MXR8LV), adpsfc_hdr(5), sfcshp_hdr(2),
     +          satwnd_hdr(1), evns ( MXR8PM, MXR8LV, MXR8VN, MXR8VT ),
     +          drft ( 3, MXR8LV ), brts ( MXR8PM, MXR8LV ),
     +          toth ( 2, MXR8LV )
      REAL*8    hdr2 ( NHR8PM ), qkswnd_hdr2(3), aircar_hdr2(6),
     +          aircft_hdr2(4),  adpupa_hdr2(1), goesnd1_hdr2(6),
     +          goesnd2_hdr2(MXR8LV), adpsfc_hdr2(5), sfcshp_hdr2(2),
     +          satwnd_hdr2(1), evns2 ( MXR8PM, MXR8LV, MXR8VN, MXR8VT),
     +          drft2 ( 3, MXR8LV ), toth2 ( 2, MXR8LV )
      REAL*8    hdr_save  ( NHR8PM ), adpsfc_hdr_save(5),
     +          sfcshp_hdr_save(2),
     +          evns_save ( MXR8PM, MXR8LV, MXR8VN, MXR8VT ),
     +          drft_save ( 3, MXR8LV ), toth_save ( 2, MXR8LV )
      REAL*8    r8sid, r8sid2, pob1, pob2

      REAL      p ( MXR8LV )

      INTEGER  indr ( MXR8LV ), indxvr1 ( 100:299 ), indxvr2 ( 100:299 )

      CHARACTER    msgtyp*8, msgtyp_process*8
      CHARACTER*8  csid, csid2, msgtp2
      CHARACTER*(MXSTRL)      head1, head2, ostr ( MXR8VT )

      LOGICAL         match, seq_match, single_msgtyp, radiance,
     +                not_radiance

      EQUIVALENCE     ( r8sid, csid ), ( r8sid2, csid2 )

      COMMON  / PREPBC /      hdr, evns, drft, toth, brts, qkswnd_hdr,
     +  aircar_hdr, aircft_hdr, adpupa_hdr, goesnd1_hdr, goesnd2_hdr,
     +  adpsfc_hdr, sfcshp_hdr, satwnd_hdr, indxvr1, indxvr2, nlev, nchn

      DATA   head1
     +        / 'SID YOB XOB ELV DHR RPT TCOR TYP TSB T29 ITP SQN' /
      DATA   head2
     +        / 'PROCN SAID' /
      DATA   ostr
     +        / 'POB PQM PPC PRC PFC PAN POE CAT',
     +          'QOB QQM QPC QRC QFC QAN QOE CAT',
     +          'TOB TQM TPC TRC TFC TAN TOE CAT',
     +          'ZOB ZQM ZPC ZRC ZFC ZAN ZOE CAT',
     +          'UOB WQM WPC WRC UFC UAN WOE CAT',
     +          'VOB WQM WPC WRC VFC VAN WOE CAT',
     +          'DDO DFQ DFP DFR NULL NULL NULL CAT',
     +          'FFO DFQ DFP DFR NULL NULL NULL CAT',
     +          'PWO PWQ PWP PWR PWF PWA PWE CAT',
     + 'REQ6 REQ6_QM REQ6_PC REQ6_RC REQ6_FC REQ6_AN REQ6_OE CAT',
     +          'PW1O PW1Q PW1P PW1R PW1F PW1A PW1E CAT',
     +          'PW2O PW2Q PW2P PW2R PW2F PW2A PW2E CAT',
     +          'PW3O PW3Q PW3P PW3R PW3F PW3A PW3E CAT',
     +          'PW4O PW4Q PW4P PW4R PW4F PW4A PW4E CAT',
     + 'CDTP CDTP_QM CDTP_PC CDTP_RC CDTP_TC CDTP_AN CDTP_OE CAT',
     +          'GCDTT NULL NULL NULL NULL NULL NULL CAT' ,
     +          'TOCC  NULL NULL NULL NULL NULL NULL CAT' /
      DATA            match / .true. /, seq_match / .false. /

      SAVE            match, msgtp2, idate2
C-----------------------------------------------------------------------

      single_msgtyp = .false.   ! set to true if you want to process
                                !  reports from only ONE message type

      msgtyp_process = 'ADPUPA' ! if single_msgtyp=T, then only
                                !  reports in this msgtyp will be
                                !  processed

 1000 continue

      iret = 0

C       If the previous call to this subroutine did not yield matching
C        mass and wind subsets, then BUFRLIB routine READNS is already
C        pointing at an unmatched subset.  Otherwise, call READNS to
C        advance the subset pointer to the next subset.
C       --------------------------------------------------------------
      IF  ( match )  THEN
          CALL READNS(lunit,msgtyp,idate,jret) ! BUFRLIB routine to
                                               !  read in next subset
          IF  ( jret .ne. 0 )  THEN
             iret = -1 ! there are no more subsets in the PREPBUFR file
                       !  and all subsets have been processed
             RETURN
          END IF
          if(single_msgtyp .and. msgtyp.ne.msgtyp_process) go to 1000
      ELSE
          msgtyp = msgtp2
          idate = idate2
      END IF

C       Read the report header based on mnemonic string "head" and
C        transfer 1 for 1 into array HDR for the subset that is
C        currently being pointed to.
C       -----------------------------------------------------------

                       !BUFRLIB routine to read specific info from
                       ! report (no event info though)
      CALL UFBINT(lunit,hdr,           12,1,jret,head1)
      CALL UFBINT(lunit,hdr(13),NHR8PM-12,1,jret,head2)

C       Read header information that is specific to the various
C        message types
C       -------------------------------------------------------

      qkswnd_hdr=10E10
      aircar_hdr=10E10
      aircft_hdr=10E10
      adpupa_hdr=10E10
      goesnd1_hdr=10E10
      goesnd2_hdr=10E10
      adpsfc_hdr=10E10
      sfcshp_hdr=10E10
      satwnd_hdr=10E10

      IF( msgtyp .eq. 'QKSWND')  THEN
         CALL UFBINT(lunit,qkswnd_hdr,3,1,jret,'CTCN ATRN SPRR ')
      ELSE IF( msgtyp .eq. 'AIRCAR')  THEN
         CALL UFBINT(lunit,aircar_hdr,6,1,jret,
     +    'PCAT POAF TRBX10 TRBX21 TRBX32 TRBX43 ')
      ELSE IF( msgtyp .eq. 'AIRCFT')  THEN
         CALL UFBINT(lunit,aircft_hdr,4,1,jret,'RCT PCAT POAF DGOT ')
      ELSE IF( msgtyp .eq. 'ADPUPA')  THEN
         CALL UFBINT(lunit,adpupa_hdr,1,1,jret,'SIRC ')
      ELSE IF( msgtyp .eq. 'GOESND' .or.  msgtyp .eq. 'SATEMP' )  THEN
         CALL UFBINT(lunit,goesnd1_hdr,6,1,jret,
     +               'ACAV ELEV SOEL OZON TMSK CLAM')
         IF( msgtyp .eq. 'GOESND' ) CALL UFBINT(lunit,goesnd2_hdr,1,
     +                                          MXR8LV,jret,'PRSS ')
      ELSE IF( msgtyp .eq. 'ADPSFC')  THEN
         CALL UFBINT(lunit,adpsfc_hdr,5,1,jret,'PMO PMQ ALSE SOB SQM ')
      ELSE IF( msgtyp .eq. 'SFCSHP')  THEN
         CALL UFBINT(lunit,sfcshp_hdr,2,1,jret,'PMO PMQ ')
      ELSE IF( msgtyp .eq. 'SATWND')  THEN
         CALL UFBINT(lunit,satwnd_hdr,1,1,jret,'RFFL ')
      END IF

C       From PREPBUFR report type, determine if this report contains
C        only non-radiance data, only radiance data, or both
C       ------------------------------------------------------------

      radiance = (  nint(hdr(8)) .eq. 102 .or.
     +            ( nint(hdr(8)) .ge. 160 .and. nint(hdr(8)) .le. 179 ))
      not_radiance = ( .not.radiance .or.
     +          ( nint(hdr(8)) .ge. 160 .and. nint(hdr(8)) .le. 163 )
     +     .or. ( nint(hdr(8)) .ge. 170 .and. nint(hdr(8)) .le. 173 ))

      EVNS = 10E10
      BRTS = 10E10
      nlev = 0
      nchn = 0

      IF ( not_radiance )  THEN

C       For reports with non-radiance data, read the report level data
C        for the variable types based on the variable-specific mnemonic
C        string "ostr(kk)" and transfer all levels, all events 1 for 1
C        into array EVNS for the subset that is currently being pointed
C        to.
C       ---------------------------------------------------------------

         DO kk = indxvr1(nint(hdr(8))),indxvr2(nint(hdr(8)))
                                 ! loop through the variables
             CALL UFBEVN(lunit,evns(1,1,1,kk),MXR8PM,MXR8LV,MXR8VN,nlev,
     +        ostr(kk)) ! BUFRLIB routine to read specific info from
                        ! report, accounting for all possible events
         END DO

         drft=10E10
         toth=10E10
         IF( msgtyp .eq. 'ADPUPA')  THEN

C       Read balloon drift level data for message type ADPUPA
C       -----------------------------------------------------

            CALL UFBINT(lunit,drft,3,MXR8LV,nlevd,'HRDR YDR XDR ')
            if(nlevd .ne. nlev)  CALL ERREXIT(22)

C       Read virtual temperature and dewpoint temperature (through
C        "PREPRO" step only) data for message type ADPUPA
C       ----------------------------------------------------------

            CALL UFBINT(lunit,toth,2,MXR8LV,nlevt,'TVO TDO ')
            if(nlevt .ne. nlev)  CALL ERREXIT(33)

         END IF

      END IF

      IF ( radiance)  THEN

C       For reports with radiance data, read the report channel data
C        for the variable types based on the mnemonic string
C        "CHNM TMBR" and transfer all channels 1 for 1 into array BRTS
C        for the subset that is currently being pointed to.
C       --------------------------------------------------------------

          CALL UFBINT(lunit,brts,MXR8PM,MXR8LV,nchn,'CHNM TMBR')

      END IF

 2000 CONTINUE

C      Now, advance the subset pointer to the next subset and read
C       its report header.
C      -----------------------------------------------------------

      CALL READNS(lunit,msgtp2,idate2,jret)
      IF  ( jret .ne. 0 )  THEN
         iret = 1 ! there are no more subsets in the PREPBUFR file
                  !  but we must still return and process the
                  !  previous report in common /PREPBC/
         RETURN
      END IF
      if(single_msgtyp .and. msgtp2.ne.msgtyp_process) go to 2000
      CALL UFBINT(lunit,hdr2,           12,1,jret,head1)
      CALL UFBINT(lunit,hdr2(13),NHR8PM-12,1,jret,head2)

C       Next, check whether this subset and the previous one are
C        matching mass and wind components for a single "true" report.
C       --------------------------------------------------------------

      match = .true.
      seq_match = .false.

      IF ( max( hdr (12), hdr2 (12) ) .le. R8BFMS )  THEN
         IF ( hdr (13)  .gt. R8BFMS )  hdr (13) = 0.
         IF ( hdr2(13)  .gt. R8BFMS )  hdr2(13) = 0.
         seq  = (hdr (13) * 1000000.) + hdr (12) ! combine seq. nunmber
         seq2 = (hdr2(13) * 1000000.) + hdr2(12) !  and MPI proc. number
         IF  ( seq .ne. seq2 )  THEN
            match = .false.
            RETURN  ! the two process/sequence numbers do not match,
                    !  return and process information in common /PREPBC/
         ELSE
            seq_match = .true.  ! the two process/sequence numbers match
         END IF
      END IF

      IF  ( msgtyp .ne. msgtp2 )  THEN
          match = .false.
          RETURN   ! the two message types do not match, return and
                   !  process information in common /PREPBC/
      END IF

      IF ( .not. seq_match )  THEN

C       The two process/sequence numbers are missing, so as a last
C        resort must check whether this subset and the previous one
C        have identical values for SID, YOB, XOB, ELV, and DHR in
C        which case they match.
C       -----------------------------------------------------------

         r8sid  = hdr (1)
         r8sid2 = hdr2(1)
         IF  ( csid .ne. csid2 )  THEN
             match = .false.
             RETURN   ! the two report id's do not match, return and
                      !  process information in common /PREPBC/
         END IF

         DO ii = 5, 2, -1
            IF  ( hdr (ii) .ne. hdr2 (ii) )  THEN
               match = .false.
               RETURN   ! the two headers do not match, return and
                        !  process information in common /PREPBC/
            END IF
         END DO
      END IF

C       The two headers match, read level data for the second subset.
C        (Note: This can only happen for non-radiance reports)
C       -------------------------------------------------------------

      DO kk = indxvr1(nint(hdr(8))),indxvr2(nint(hdr(8)))
                                 ! loop through the variables
          CALL UFBEVN(lunit,evns2 (1,1,1,kk),MXR8PM,MXR8LV,MXR8VN,
     +     nlev2,ostr(kk))
      ENDDO

      drft2=10E10
      toth2=10E10
      IF( msgtp2 .eq. 'ADPUPA')  THEN

C       Read balloon drift level data for message type ADPUPA
C        for the second subset
C       -----------------------------------------------------

         CALL UFBINT(lunit,drft2,3,MXR8LV,nlev2d,'HRDR YDR XDR ')
         if(nlev2d .ne. nlev2)  CALL ERREXIT(22)

C       Read virtual temperature and dewpoint temperature (through
C        "PREPRO" step only) data for message type ADPUPA for the
C        second subset
C       ----------------------------------------------------------

         CALL UFBINT(lunit,toth2,2,MXR8LV,nlev2t,'TVO TDO ')
         if(nlev2t .ne. nlev2)  CALL ERREXIT(33)

      END IF

C       Read header information that is specific to the various
C        message types for the second supset
C       -------------------------------------------------------

      qkswnd_hdr2=10E10
      aircar_hdr2=10E10
      aircft_hdr2=10E10
      adpupa_hdr2=10E10
      goesnd1_hdr2=10E10
      goesnd2_hdr2=10E10
      adpsfc_hdr2=10E10
      sfcshp_hdr2=10E10
      satwnd_hdr2=10E10
      IF( msgtp2 .eq. 'QKSWND')  THEN
         CALL UFBINT(lunit,qkswnd_hdr2,3,1,jret,'CTCN ATRN SPRR ')
      ELSE IF( msgtp2 .eq. 'AIRCAR')  THEN
         CALL UFBINT(lunit,aircar_hdr2,6,1,jret,
     +    'PCAT POAF TRBX10 TRBX21 TRBX32 TRBX43 ')
      ELSE IF( msgtp2 .eq. 'AIRCFT')  THEN
         CALL UFBINT(lunit,aircft_hdr2,4,1,jret,'RCT PCAT POAF DGOT ')
      ELSE IF( msgtp2 .eq. 'ADPUPA')  THEN
         CALL UFBINT(lunit,adpupa_hdr2,1,1,jret,'SIRC ')
      ELSE IF( msgtp2 .eq. 'GOESND' .or.  msgtp2 .eq. 'SATEMP' )  THEN
         CALL UFBINT(lunit,goesnd1_hdr2,6,1,jret,
     +               'ACAV ELEV SOEL OZON TMSK CLAM')
         IF( msgtp2 .eq. 'GOESND' ) CALL UFBINT(lunit,goesnd2_hdr2,1,
     +                                          MXR8LV,jret,'PRSS ')
      ELSE IF( msgtp2 .eq. 'ADPSFC')  THEN
         CALL UFBINT(lunit,adpsfc_hdr2,5,1,jret,'PMO PMQ ALSE SOB SQM ')
      ELSE IF( msgtp2 .eq. 'SFCSHP')  THEN
         CALL UFBINT(lunit,sfcshp_hdr2,2,1,jret,'PMO PMQ ')
      ELSE IF( msgtp2 .eq. 'SATWND')  THEN
         CALL UFBINT(lunit,satwnd_hdr2,1,1,jret,'RFFL ')
      END IF

      IF (nint(hdr(8)) .ge. 280)  THEN

C       If this is a surface report, the wind subset precedes the
C        mass subset - switch the subsets around in order to combine
C        the surface pressure properly
C       ------------------------------------------------------------

         evns_save = evns2
         evns2 = evns
         evns = evns_save
         hdr_save = hdr2
         hdr2 = hdr
         hdr = hdr_save
         adpsfc_hdr_save = adpsfc_hdr2
         adpsfc_hdr2 = adpsfc_hdr
         adpsfc_hdr = adpsfc_hdr_save
         sfcshp_hdr_save = sfcshp_hdr2
         sfcshp_hdr2 = sfcshp_hdr
         sfcshp_hdr = sfcshp_hdr_save
      END IF

C       Combine the message type-specific header data for the two
C        matching subsets into a single array.
C       ---------------------------------------------------------

      qkswnd_hdr(:) = min(qkswnd_hdr(:),qkswnd_hdr2(:))
      aircar_hdr(:) = min(aircar_hdr(:),aircar_hdr2(:))
      aircft_hdr(:) = min(aircft_hdr(:),aircft_hdr2(:))
      adpupa_hdr(:) = min(adpupa_hdr(:),adpupa_hdr2(:))
      goesnd1_hdr(:) = min(goesnd1_hdr(:),goesnd1_hdr2(:))
      goesnd2_hdr(:) = min(goesnd2_hdr(:),goesnd2_hdr2(:))
      adpsfc_hdr(:) = min(adpsfc_hdr(:),adpsfc_hdr2(:))
      sfcshp_hdr(:) = min(sfcshp_hdr(:),sfcshp_hdr2(:))
      satwnd_hdr(:) = min(satwnd_hdr(:),satwnd_hdr2(:))

C       Combine the data for the two matching subsets into a single 4-D
C        array.  Do this by merging the EVNS2 array into the EVNS array.
C       ----------------------------------------------------------------

      LOOP1: DO lv2 = 1, nlev2  ! loop through the levels of subset 2
         DO lv1 = 1, nlev  ! loop through the levels of subset 1
            pob1 = evns  ( 1, lv1, 1, 1 )
            pob2 = evns2 ( 1, lv2, 1, 1 )
            IF  ( pob1 .eq. pob2 )  THEN

C       This pressure level from the second subset also exists in the
C        first subset, so overwrite any "missing" piece of data for
C        this pressure level in the first subset with the corresponding
C        piece of data from the second subset (since this results in no
C        net loss of data!).
C       ---------------------------------------------------------------

               DO kk = indxvr1(nint(hdr(8))),indxvr2(nint(hdr(8)))
                                 ! loop through the variables
                  DO jj = 1,MXR8VN  ! loop through the events
                     DO ii = 1,MXR8PM-1 ! loop through BUFR parameters
                                        ! skip the CAT parameter
                        IF ( evns (ii,lv1,jj,kk ) .gt. R8BFMS ) THEN
                           evns  ( ii, lv1, jj, kk ) =
     +                     evns2 ( ii, lv2, jj, kk )
                           IF ( evns2 (ii,lv2,jj,kk).le.R8BFMS) THEN

C       If any piece of data in the first subset is missing and the
C        corresponding piece of data is NOT missing in the second
C        subset, also overwrite the PREPBUFR category parameter in the
C        first subset with that from the second subset regardless of
C        its value in either subset
C       --------------------------------------------------------------

                              evns  (  8, lv1, jj, kk ) =
     +                        evns2 (  8, lv2, jj, kk )
                           END IF
                        END IF
                     END DO
                  END DO
               END DO
               CYCLE LOOP1
            ELSE IF  (  ( pob2 .gt. pob1 )  .or.
     +                  ( lv1  .eq. nlev )  )  THEN

C       Either all remaining pressure levels within the first subset
C        are less than this pressure level from the second subset
C        (since levels within each subset are guaranteed to be in
C        descending order wrt pressure!) *OR* there are more total
C        levels within the second subset than in the first subset.
C        In either case, we should now add this second subset level
C        to the end of the EVNS array.
C       ------------------------------------------------------------

               nlev = nlev + 1
               evns  ( :, nlev, :, : ) = evns2 ( :, lv2,  :, : )
               drft  ( :, nlev ) = drft2 ( :, lv2 )
               toth  ( :, nlev ) = toth2 ( :, lv2 )
               CYCLE LOOP 1
            END IF
         END DO
      END DO  LOOP1

C       Sort combined report according to decreasing pressure.
C       ------------------------------------------------------

      p(:) = evns  ( 1, :, 1, 1)
      if(nlev .gt. 0)  call indexf(nlev,p,indr)
      evns_save = evns
      drft_save = drft
      toth_save = toth
      do i = 1,nlev
         j = indr(nlev-i+1)
         evns ( :, i, :, :) = evns_save ( :, j, :, :)
         drft ( :, i) = drft_save ( :, j)
         toth ( :, i) = toth_save ( :, j)
      end do

C       Return to calling program with a complete report in common
C        /PREPBC/.
C       ----------------------------------------------------------

      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    INDEXF      GENERAL SORT ROUTINE FOR REAL ARRAY
C   PRGMMR: D. A. KEYSER     ORG: NP22       DATE: 1995-05-30
C
C ABSTRACT: USES EFFICIENT SORT ALGORITHM TO PRODUCE INDEX SORT LIST
C   FOR AN REAL ARRAY.  DOES NOT REARRANGE THE FILE.
C
C PROGRAM HISTORY LOG:
C 1993-06-05  R  KISTLER -- FORTRAN VERSION OF C-PROGRAM
C 1995-05-30  D. A. KEYSER - TESTS FOR < 2 ELEMENTS IN SORT LIST,
C             IF SO RETURNS WITHOUT SORTING (BUT FILLS INDX ARRAY)
C
C USAGE:    CALL INDEXF(N,ARRIN,INDX)
C   INPUT ARGUMENT LIST:
C     N        - SIZE OF ARRAY TO BE SORTED
C     ARRIN    - REAL ARRAY TO BE SORTED
C
C   OUTPUT ARGUMENT LIST:
C     INDX     - ARRAY OF POINTERS GIVING SORT ORDER OF ARRIN IN
C              - ASCENDING ORDER {E.G., ARRIN(INDX(I)) IS SORTED IN
C              - ASCENDING ORDER FOR ORIGINAL I = 1, ... ,N}
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM-SP
C
C$$$
      SUBROUTINE INDEXF(N,ARRIN,INDX)
      INTEGER  INDX(N)
      REAL  ARRIN(N)
      DO J = 1,N
         INDX(J) = J
      ENDDO
C MUST BE > 1 ELEMENT IN SORT LIST, ELSE RETURN
      IF(N.LE.1)  RETURN
      L = N/2 + 1
      IR = N
   33 CONTINUE
      IF(L.GT.1)  THEN
         L = L - 1
         INDXT = INDX(L)
         AA = ARRIN(INDXT)
      ELSE
         INDXT = INDX(IR)
         AA = ARRIN(INDXT)
         INDX(IR) = INDX(1)
         IR = IR - 1
         IF(IR.EQ.1)  THEN
            INDX(1) = INDXT
            RETURN
         END IF
      END IF
      I = L
      J = L * 2
   30 CONTINUE
      IF(J.LE.IR)  THEN
         IF(J.LT.IR)  THEN
            IF(ARRIN(INDX(J)).LT.ARRIN(INDX(J+1)))  J = J + 1
         END IF
         IF(AA.LT.ARRIN(INDX(J)))  THEN
            INDX(I) = INDX(J)
            I = J
            J = J + I
         ELSE
            J = IR + 1
         END IF
      END IF
      IF(J.LE.IR)  GO TO 30
      INDX(I) = INDXT
      GO TO 33
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      BLOCK DATA

      PARAMETER ( NHR8PM = 14 )    ! Actual number of BUFR parameters
                                   !  in header
      PARAMETER ( MXR8PM =  8 )    ! Maximum number of BUFR parameters
                                   !  in level data (non-radiance) or
                                   !  in channel data (radiance)
      PARAMETER ( MXR8LV = 255 )   ! Maximum number of BUFR levels/
                                   !                        channels
      PARAMETER ( MXR8VN = 10 )    ! Max. number of BUFR event sequences
                                   !  (non-radiance reports)
      PARAMETER ( MXR8VT = 17)     ! Max. number of BUFR variable types
                                   !  (non-radiance reports)

      REAL*8    hdr ( NHR8PM ), qkswnd_hdr(3), aircar_hdr(6),
     +          aircft_hdr(4),  adpupa_hdr(1), goesnd1_hdr(6),
     +          goesnd2_hdr(MXR8LV), adpsfc_hdr(5), sfcshp_hdr(2),
     +          satwnd_hdr(1), evns ( MXR8PM, MXR8LV, MXR8VN, MXR8VT ),
     +          drft ( 3, MXR8LV ), brts ( MXR8PM, MXR8LV ),
     +          toth ( 2, MXR8LV )

      INTEGER   indxvr1 ( 100:299 ), indxvr2 ( 100:299 )

      COMMON  / PREPBC /      hdr, evns, drft, toth, brts, qkswnd_hdr,
     +  aircar_hdr, aircft_hdr, adpupa_hdr, goesnd1_hdr, goesnd2_hdr,
     +  adpsfc_hdr, sfcshp_hdr, satwnd_hdr, indxvr1, indxvr2, nlev, nchn

      DATA      nlev /0/, nchn /0/

      DATA      indxvr1
     + /   20*1,    30*1,   10,  15,   9,    3*1,    4*11,    40*1 ,
C         100-119  120-149  150  151  152  153-155  156-159  160-199
     +     20*1,    40*1,    25*1,    1,   1,   13*1    /
C         200-219  220-259  260-284  285  286  287-299

      DATA      indxvr2
     + /   20*4,    30*8,   10,  17,   9,    3*6,    4*14,    40*6 ,
C         100-119  120-149  150  151  152  153-155  156-159  160-299
     +     20*6,    40*8,    25*6,    8,   8,   13*6    /
C         200-219  220-259  260-284  285  286  287-299

      END

max_stars_repo_name: GEOS-ESM/GEOSadas

max_issues_repo_name: GEOS-ESM/GEOSadas

max_forks_repo_name: GEOS-ESM/GEOSadas


text:
*----------------------------------------------------------------------*
      subroutine test_memman()
*----------------------------------------------------------------------*
*     a few dummy allocations and deallocations to test the memman
*     routines
*     we assume that the memory manager was initialized outside
*----------------------------------------------------------------------*

      implicit none

      include 'stdunit.h'
      include 'def_filinf.h'
      include 'ifc_memman.h'

      integer ::
     &     ifree, idx
      real(8), pointer ::
     &     xbuf1(:), xbuf2(:), xbuf3(:), xbuf4(:), xbuf5(:), xbuf6(:)
      integer, pointer ::
     &     ibuf1(:), ibuf2(:), ibuf3(:)

      type(filinf) ::
     &     ffbuf

      write(lulog,*) ' test_memman: '
      write(lulog,*) ' memory map on entry'
      call mem_map(.true.)

      ifree = mem_setmark('section_1')
      ifree = mem_alloc_real(xbuf1,10000,'xbuf1')
      ifree = mem_alloc_real(xbuf2,30000,'xbuf2')
      ifree = mem_setmark('section_2')
      ifree = mem_setmark('section_3')
      ifree = mem_alloc_real(xbuf3,30000,'xbuf3')
      ifree = mem_setmark('section_4')
      ifree = mem_alloc_real(xbuf4,30000,'xbuf4')

      write(lulog,*) 'memory map after first round'
      call mem_map(.true.)

      call mem_pushmark()
      ifree = mem_gotomark('section_2')
      ifree = mem_alloc_int(ibuf1,2000,'ibuf1')
      call mem_popmark()
      ifree = mem_alloc_int(ibuf2,2000,'ibuf2')

      write(lulog,*) 'memory map after second round'
      call mem_map(.true.)

      ifree = mem_flushmark('section_3')
      ifree = mem_alloc_int(ibuf3,2000,'ibuf3')

      write(lulog,*) 'memory map after second round'
      call mem_map(.true.)

      ifree = mem_flushmark()
      ifree = mem_flushmark()
      ifree = mem_flushmark()

      write(lulog,*) ' memory map on exit'
      call mem_map(.true.)

      write(lulog,*) ' now testing virtual arrays'

      ifree = mem_alloc_int(ibuf1,1000,'ibuf1')
      ifree = mem_alloc_int(ibuf2,1000,'ibuf2')
      do idx = 1, 1000
        ibuf1(idx) = idx
      end do

      call file_init(ffbuf,'testbuffer',ftyp_da_unf,10)
      call file_open(ffbuf)
      call mem_init_vbuffer(ffbuf,'vbuffer1',50,10)

      write(lulog,*) 'put 1..35'
      call mem_iput(ffbuf,ibuf1,1,35)

      call mem_print_vbuffer(lulog,ffbuf)

      write(lulog,*) 'put 36..70'
      call mem_iput(ffbuf,ibuf1(36),36,70)

      call mem_print_vbuffer(lulog,ffbuf)

      write(lulog,*) 'and reading again ...'
      call mem_iget(ffbuf,ibuf2,1,70)
      write(lulog,*) 'read in:'
      write(lulog,'(10i6)') ibuf2(1:70)

      write(lulog,*) 'put 71..200'
      call mem_iput(ffbuf,ibuf1(71),71,200)

      write(lulog,*) ' memory map after that'
      call mem_map(.true.)

      call mem_print_vbuffer(lulog,ffbuf)

      write(lulog,*) 'and reading 101 ... 200'
      call mem_iget(ffbuf,ibuf2,101,200)
      write(lulog,*) 'read in:'
      write(lulog,'(10i6)') ibuf2(1:100)
      write(lulog,*) 'and reading 1 ... 150'
      call mem_iget(ffbuf,ibuf2,1,150)
      write(lulog,*) 'read in:'
      write(lulog,'(10i6)') ibuf2(1:150)
      write(lulog,*) 'and reading 76 ... 123'
      call mem_iget(ffbuf,ibuf2,76,123)
      write(lulog,*) 'read in:'
      write(lulog,'(10i6)') ibuf2(1:48)
      write(lulog,*) 'and reading 180 ... 200'
      call mem_iget(ffbuf,ibuf2,180,200)
      write(lulog,*) 'read in:'
      write(lulog,'(10i6)') ibuf2(1:21)

      call mem_clean_vbuffer('vbuffer1')
      call file_close_delete(ffbuf)

      call quit(1,'test_memman','test exit')

      return
      end


text:
program TEST
	integer ans
		do
			read (*,*) ans
			if (ans.eq.42) stop
			write (*,*) ans
		enddo
	stop
end


text:
program arrays_09
implicit none
character(10) :: a(1)
a(1) = 'Substring'
if(a(1)(4:9) /= 'string') error stop
end program

max_stars_repo_name: Thirumalai-Shaktivel/lfortran

max_issues_repo_name: Thirumalai-Shaktivel/lfortran

max_forks_repo_name: Thirumalai-Shaktivel/lfortran


text:
This guide outlines all of the classes available at UC Davis for a given quarter. Information regarding classes includes: meeting times, class locations, enrollment capacities, and final examination times.

Since classes, its locations, and its times will change every quarter, this guide is printed every quarter, compared to the General Catalog which is printed every two years.

See http://registrar.ucdavis.edu/csrg/ to view the guide online.  The site also lists updates to the CSRG that happened after press time.  If youre registered in the class, youll see these changes on http://sisweb.ucdavis.edu/ SISWeb, anyway.

Organizing your class schedule can be hard and overwhelming considering the number of classes available, which is why a site like http://siscast.com can be very useful.


text:
Roots Fair Trade specializes in fairly traded handcrafts from around the world.

20110510 23:19:50 nbsp Open already.. nice stuff. Users/Aaron.Curtin

20120202 18:09:43 nbsp Hi catherine, You should consider making your user page, your user page and your business page, the business page. Cuts down on confusion. Im happy to help if you need t :) Users/jsbmeb

20120815 19:39:54 nbsp Im glad I found this place! The owner carries some of the same items as Baksheesh (Sonoma, Healdsburg) plus pieces from artisans in Mexico. I hope the business will be here for quite some time...we need more sources for fair trade clothing, housewares, etc. Users/EmilyHughes


text:
* $Id$
      program numder
      implicit real*8 (a-h,o-z)
c23456789.123456789.123456789.123456789.123456789.123456789.123456789.12
c
      parameter (n=10000)
cccc  character*16 name_p(n),name_m(n)
      character*16 name_p   ,name_m  , name_2
      character*2 direction
cccc  dimension del_plus(n,3), del_m(n,3)
c
      open(unit=7,file='delta_p',status='old',form='formatted')
      open(unit=8,file='delta_m',status='old',form='formatted')
cccc  open(unit=33,file='anali_2',status='old',form='unformatted')
c
      open(unit=34,file='compare',status='new',form='formatted')
c
      write(*,*)' enter number of points:'
      read(*,*) npoints
      write(*,*)' second differentiation over :'
      read(*,*) direction
c
      do ipoint=1,npoints
         read(7,69) name_p, icf_p,jcf_p,kcf_p,lcf_p,
     *                        der1_p_x,der1_p_y,der1_p_z
         read(8,69) name_m, icf_m,jcf_m,kcf_m,lcf_m,
     *                        der1_m_x,der1_m_y,der1_m_z
   69    format(a16,4i2,1x,3(f12.7,2x))
c
         if(name_p.eq.name_m) then
            der2_x=100.d0*(der1_p_x-der1_m_x)
            der2_y=100.d0*(der1_p_y-der1_m_y)
            der2_z=100.d0*(der1_p_z-der1_m_z)
c
            icf=icf_p
            jcf=jcf_p
            kcf=kcf_p
            lcf=lcf_p
c
            if(name_p.eq.'d /dAi   : ijkl=') then
               if(direction.eq.'Ax') name_2='d2/dAidAj: ijkl='
               if(direction.eq.'Ay') name_2='d2/dAidAj: ijkl='
               if(direction.eq.'Az') name_2='d2/dAidAj: ijkl='
c
               if(direction.eq.'Bx') name_2='d2/dAidBj: ijkl='
               if(direction.eq.'By') name_2='d2/dAidBj: ijkl='
               if(direction.eq.'Bz') name_2='d2/dAidBj: ijkl='
c
               if(direction.eq.'Cx') name_2='d2/dAidCj: ijkl='
               if(direction.eq.'Cy') name_2='d2/dAidCj: ijkl='
               if(direction.eq.'Cz') name_2='d2/dAidCj: ijkl='
c
               if(direction.eq.'Dx') name_2='d2/dAidDj: ijkl='
               if(direction.eq.'Dy') name_2='d2/dAidDj: ijkl='
               if(direction.eq.'Dz') name_2='d2/dAidDj: ijkl='
            endif
            if(name_p.eq.'d /dBi   : ijkl=') then
               if(direction.eq.'Ax') name_2='d2/dAidBj: ijkl='
               if(direction.eq.'Ay') name_2='d2/dAidBj: ijkl='
               if(direction.eq.'Az') name_2='d2/dAidBj: ijkl='
c
               if(direction.eq.'Bx') name_2='d2/dBidBj: ijkl='
               if(direction.eq.'By') name_2='d2/dBidBj: ijkl='
               if(direction.eq.'Bz') name_2='d2/dBidBj: ijkl='
c
               if(direction.eq.'Cx') name_2='d2/dBidCj: ijkl='
               if(direction.eq.'Cy') name_2='d2/dBidCj: ijkl='
               if(direction.eq.'Cz') name_2='d2/dBidCj: ijkl='
c
               if(direction.eq.'Dx') name_2='d2/dBidDj: ijkl='
               if(direction.eq.'Dy') name_2='d2/dBidDj: ijkl='
               if(direction.eq.'Dz') name_2='d2/dBidDj: ijkl='
            endif
            if(name_p.eq.'d /dCi   : ijkl=') then
               if(direction.eq.'Ax') name_2='d2/dAidCj: ijkl='
               if(direction.eq.'Ay') name_2='d2/dAidCj: ijkl='
               if(direction.eq.'Az') name_2='d2/dAidCj: ijkl='
c
               if(direction.eq.'Bx') name_2='d2/dBidCj: ijkl='
               if(direction.eq.'By') name_2='d2/dBidCj: ijkl='
               if(direction.eq.'Bz') name_2='d2/dBidCj: ijkl='
c
               if(direction.eq.'Cx') name_2='d2/dCidCj: ijkl='
               if(direction.eq.'Cy') name_2='d2/dCidCj: ijkl='
               if(direction.eq.'Cz') name_2='d2/dCidCj: ijkl='
c
               if(direction.eq.'Dx') name_2='d2/dCidDj: ijkl='
               if(direction.eq.'Dy') name_2='d2/dCidDj: ijkl='
               if(direction.eq.'Dz') name_2='d2/dCidDj: ijkl='
            endif
            if(name_p.eq.'d /dDi   : ijkl=') then
               if(direction.eq.'Ax') name_2='d2/dAidDj: ijkl='
               if(direction.eq.'Ay') name_2='d2/dAidDj: ijkl='
               if(direction.eq.'Az') name_2='d2/dAidDj: ijkl='
c
               if(direction.eq.'Bx') name_2='d2/dBidDj: ijkl='
               if(direction.eq.'By') name_2='d2/dBidDj: ijkl='
               if(direction.eq.'Bz') name_2='d2/dBidDj: ijkl='
c
               if(direction.eq.'Cx') name_2='d2/dCidDj: ijkl='
               if(direction.eq.'Cy') name_2='d2/dCidDj: ijkl='
               if(direction.eq.'Cz') name_2='d2/dCidDj: ijkl='
c
               if(direction.eq.'Dx') name_2='d2/dDidDj: ijkl='
               if(direction.eq.'Dy') name_2='d2/dDidDj: ijkl='
               if(direction.eq.'Dz') name_2='d2/dDidDj: ijkl='
            endif
c
cc             write(34,69) name_2,icf,jcf,kcf,lcf,
cc   *                      der2_x,der2_y,der2_z
               write(34,70) name_2,icf,jcf,kcf,lcf,
     *                      der2_x,der2_y,der2_z
   70    format(a16,4i2,1x,3(f12.4,2x))
c
         endif
      enddo
c
      stop
      end

max_stars_repo_name: dinisAbranches/nwchem

max_issues_repo_name: dinisAbranches/nwchem

max_forks_repo_name: dinisAbranches/nwchem