program main

!*****************************************************************************80
!
!! MAIN is the main program for NASADIG_FONTS.
!
!  Discuussion:
!
!    NASADIG_FONTS creates binary font files from text versions.
!
!    This program will process ASCII formatted sequential
!    files containing font move/draw information into a
!    direct access file for internal use by NASADIG.
!
!  Modified:
!
!    30 August 20080
!
  implicit none

  integer, parameter :: mxregf = 18
  integer, parameter :: mxshdf = 4
  integer, parameter :: maxtot = mxregf + mxshdf
  integer, parameter :: mxstrk = 12000

  integer bias(maxtot)
  integer bwidth(95)
  integer bx(150)
  integer bxy(mxstrk)
  integer by(150)
  logical file_exists
  integer i
  integer ibxy
  integer icmax
  integer icmin
  integer ie
  integer ierr
  integer ifill(512)
  integer ihight
  integer ileft
  integer indx(96)
  integer info
  character ( len = 40 ) inpfil
  integer iopflg
  integer ios
  integer ipxcon
  integer iright
  integer is
  integer j
  integer jchar
  integer jst
  character ( len = 80 ) kode
  integer load
  integer lrec
  integer luni
  integer luno
  integer nmchar
  integer nrec
  integer nst
  integer nstrok
  character ( len = 40 ) outfil
  character ( len = 3 ) status

  call timestamp ( )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'NASADIG_FONTS'
  write ( *, '(a)' ) '  FORTRAN90 version'
  write ( *, '(a)' ) '  Create the NASADIG font database file.'

  info = 0

  if ( info == 1 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  This version of the program incorporates all the'
    write ( *, '(a)' ) '  font information into one direct access file. '
    write ( *, '(a)' ) '  Whenever the file is written, all fonts must be' 
    write ( *, '(a)' ) '  redefined so that the first record of this file can'
    write ( *, '(a)' ) '  be updated to reflect where each font definition'
    write ( *, '(a)' ) '  begins.'
  end if
!
!  Load new font.
!
  do

    if ( info == 1 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Enter the direct access file name to be created:'
    end if

    read ( *, '(a)', iostat = ios ) outfil

    if ( ios /= 0 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'NASADIG_FONTS - Fatal error!'
      write ( *, '(a)' ) '  Failure to read user input.'
      stop
    end if

    inquire ( file = outfil, exist = file_exists )

    if ( .not. file_exists ) then
      status = 'new'
      exit
    end if

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  A file of this name already exists.'
    write ( *, '(a)' ) '  Do you want to overwrite it?'

    read ( *, '(a)', iostat = ios ) kode

    if ( ios /= 0 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'NASADIG_FONTS - Fatal error!'
      write ( *, '(a)' ) '  Failure to read user input.'
      stop
    end if

    if ( kode(1:1) == 'Y' .or. kode(1:1) == 'y' ) then
      exit
    end if

  end do
!
!  Set the record length of the font file.
!
  call syrecl ( 512, lrec )
!
!  Create the font file for direct access unformatted read/write.
!
  iopflg = ipxcon ( 'O_RDWR' ) &
         + ipxcon ( 'O_CREAT' ) &
         + ipxcon ( 'DIRECT' ) &
         + ipxcon ( 'UNFORM' ) &
         + lrec * 256

  call pxfopn ( outfil, iopflg, 0, luno, ios )

  if ( ios /= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'NASADIG_FONTS - Fatal error!'
    write ( *, '(a)' ) '  Could not open the font database file.'
    write ( *, '(a,i6)' ) '  Error code IOS = ', ios
    stop
  end if

  load = 2
  bias(1) = 0
  bias(2) = 1
  nrec = 0

  do

    if ( info == 1 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a,i6)' ) '  Enter the file name for font ID #', load
      write ( *, '(a)' ) '  or RETURN if done.'
    end if

    read ( *, '(a)', iostat = ios ) inpfil

    if ( ios /= 0 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'NASADIG_FONTS - Fatal error!'
      write ( *, '(a)' ) '  Failure to read user input.'
      stop
    end if

    if ( inpfil(1:1) == ' ') then
      exit
    end if
!
!  Open the raw font file for sequential access formatted read-only.
!
    iopflg = ipxcon ( 'O_RDONLY' )

    call pxfopn ( inpfil, iopflg, 0, luni, ios )

    if ( ios /= 0 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'NASADIG_FONTS - Fatal error!'
      write ( *, '(a)' ) '  Could not open the font file ' // trim ( inpfil )
      stop
    end if

    ibxy = 0
!
!  Read in a character from the sequential file and calculate the width.
!
    indx(1) = 1
    rewind ( unit = luni )

    do

      read ( luni, '(18i4)', iostat = ios ) &
        jchar, nstrok, ileft, iright, ( bx(i), by(i), i = 1, 7 )

      if ( ios /= 0 ) then
        exit
      end if

      if ( 32 < jchar .and. jchar < 128 ) then

        jchar = jchar - 32
        bwidth(jchar) = iright - ileft
        nst = nstrok / 2

        if ( nstrok > 16 ) then
          read ( luni, '(18i4)', iostat = ios ) ( bx(i), by(i), i = 8, nst-1 )
          if ( ios /= 0 ) then
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'NASADIG_FONTS - Fatal error!'
            write ( *, '(a)' ) '  Processing font file ' // trim ( inpfil )
            write ( *, '(a,i6)' ) '  The value of IOSTAT was ', ios
            stop
          end if
        end if

        nstrok = ( nstrok - 2 ) / 2

        if ( nstrok > 0 ) then
          do i = 1, nstrok
            if ( bx(i) == -999 ) then
              ibxy = ibxy + 1
              if ( by(i) == 0 .or. by(i) == -999 ) then
                bxy(ibxy) = -64
              else
                bxy(ibxy) = by(i)
              end if
            else
              ibxy = ibxy + 2
              bxy(ibxy-1) = bx(i) - ileft
              bxy(ibxy) = by(i)
            end if
          end do
        end if

        indx(jchar+1) = ibxy + 1

      end if

    end do

    close ( unit = luni )
!
!  Calculate height from capital A.
!
    is = indx(33)
    ie = indx(34) - 1
    icmax = bxy(is+1)
    icmin = bxy(is+1)

    if ( icmax == -64 ) then
      icmin = bxy(is+2)
      icmax = bxy(is+2)
    end if

    i = is

    do while ( i < ie )

      if ( bxy(i) > -64 ) then
        icmax = max ( icmax, bxy(i+1) )
        icmin = min ( icmin, bxy(i+1) )
      else
        i = i - 1
      end if

      i = i + 2

    end do

    ihight = icmax - icmin

    write ( *, '(a,i6,a,i6)' ) '  Font ', load, &
      ' from file ' // trim ( inpfil ) // ' Height = ', ihight
!
!  Subtract the Y bias from Y values in BXY to make zero the base
!  of all capital letters.
!
    nmchar = ibxy

    if ( load <= mxregf ) then

      i = 1

      do while ( i < nmchar )

        if ( bxy(i) > -64 ) then
          bxy(i+1) = bxy(i+1) - icmin
        else
          i = i - 1
        end if

        i = i + 2

      end do

    end if
!
!  Initialize the pad array.
!
    ifill(1:512) = 0
!
!  Write out the header record.
!
    nrec = 1 + ( nmchar + 511 ) / 512

    write ( luno, rec = 1, iostat = ios ) load, bias(2:load), ifill(load+1:512)

    if ( ios /= 0 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'NASADIG_FONTS - Fatal error!'
      write ( *, '(a)' ) '  An I/O error occurred while writing the first'
      write ( *, '(a)' ) '  header record to the direct access output file.'
      write ( *, '(a,i6)' ) '  The value of IOSTAT was ', ios
      stop
    end if

    write ( luno, rec = 1+bias(load), iostat = ios ) &
      nmchar, ihight, indx(1:96), bwidth(1:95), ifill(1:319)

    if ( ios /= 0 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'NASADIG_FONTS - Fatal error!'
      write ( *, '(a)' ) '  An I/O error occurred while writing the second'
      write ( *, '(a)' ) '  header record to the direct access output file.'
      write ( *, '(a,i6)' ) '  The value of IOSTAT was ', ios
      stop
    end if
!
!  Write out the strokes.
!
    jst = 1
    do i = 1, nrec-1

      write ( luno, rec = i+1+bias(load), iostat = ios ) bxy(jst:jst+511)

      if ( ios /= 0 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'NASADIG_FONTS'
        write ( *, '(a)' ) '  An I/O error occurred while writing the'
        write ( *, '(a)' ) '  stroke records to the direct access output file.'
        write ( *, '(a,i6)' ) '  The value of IOSTAT was ', ios
        stop
      end if

      jst = jst + 512
    end do

    if ( jst <= nmchar ) then
      write ( luno, rec = nrec+1+bias(load), iostat = ios ) bxy(jst:nmchar)
      if ( ios /= 0 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'NASADIG_FONTS'
        write ( *, '(a)' ) '  An I/O error occurred while writing the last'
        write ( *, '(a)' ) '  stroke record to the direct access output file.'
        write ( *, '(a,i6)' ) '  The value of IOSTAT was ', ios
        stop
      end if
    end if

    load = load + 1

    if ( load > maxtot ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'NASADIG_FONTS'
      write ( *, '(a)' ) '  No room for more fonts!'
      exit
    end if

    bias(load) = bias(load-1) + nrec + 1

  end do

  load = load - 1
  close ( unit = luno )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'NASADIG_FONTS:'
  write ( *, '(a)' ) '  Created the direct access font file ' // trim ( outfil )
  write ( *, '(a,i6)' ) '  It contains fonts 2 through ', load

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'NASADIG_FONTS:'
  write ( *, '(a)' ) '  Normal end of execution.'

  write ( *, '(a)' ) ' '
  call timestamp ( )

  stop
end
function bytes_per_word ( )

!*****************************************************************************80
!
!! BYTES_PER_WORD returns the number of bytes per word.
!
!  Modified:
!
!    18 October 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, integer BYTES_PER_WORD, the number of bytes per word.
!
  implicit none

  integer bytes_per_word
!
!ALIANT
!  continue
!AMDUTS
!  bytes_per_word = 4
!APOLLO
!  bytes_per_word = 4
!CDCOS
!  bytes_per_word = 4
!CONVEX
!  bytes_per_word = 4
!DECOSF
! bytes_per_word = 4
!DECVMS
!  bytes_per_word = 4
!HPF77
!  bytes_per_word = 4
!RISC6K
!  bytes_per_word = 4
!MSDOS
!  bytes_per_word = 4
!SGIRIX
   bytes_per_word = 4
!SUNOS
!  bytes_per_word = 4
!UNICOS
!  bytes_per_word = 8
!UNIVAC
!  bytes_per_word = 4
!UNKNOW
!  bytes_per_word = 4
!X8FTN
!  bytes_per_word = 4
!
  return
end
function ipxcon ( CONNAM )

!*****************************************************************************80
!
!! IPXCON gets an integer associated with a POSIX constant string.
!
!  Author:
!
!    Rick Lutowski
!
!  ARGUMENT LIST INPUT:
!  CONNAM = character representation of the name of any POSIX-
!  defined constant; trailing blanks are ignored
!
!  ARGUMENT LIST OUTPUT:
!  IPXCON = positive integer value associated with the constant
!  -1 = argument is not a defined POSIX constant
!
!  Notes:
!  This subroutine is an approximation of the POSIX FORTRAN binding
!  subroutine IPXFCONST described on pp 83-84 of IEEE Std 1003.9-1992
!  It has a type-compatible argument list but differs from IPXFCONST
!  in the following ways:
!
!  1. The name has been shortened to conform to the FORTRAN-77
!  6 character naming restriction
!
!  2. The full set of POSIX constants is not implemented; only
!  the subset of POSIX constants required by POSIX routines
!  implemented for SYSLIB is recognized
!
  implicit none

  integer, parameter :: nfcon = 7
  integer, parameter :: necon = 7

  character ( len = *  ) connam
  character ( len = 12 ) errcon(necon)
  character ( len = 8  ) filcon(nfcon)
  integer                i
  integer                iflcon(nfcon)
  integer                ipxcon
  integer                lcon

  data filcon /'O_RDONLY','O_WRONLY','O_RDWR  ','O_APPEND' &
              ,'O_CREAT ','DIRECT  ','UNFORM  '/
  data iflcon / 1        , 2        , 4        , 8 &
              , 16       , 32       , 64       /
  data errcon /'ENAMETOOLONG','EACCES      ','ENFILE      ' &
              ,'ENOENT      ','EBADF       ','EINTR       ' &
              ,'ENONAME     '/

  lcon = len_trim (CONNAM)

  if ( lcon <= 0 ) then
    ipxcon = -1
    return
  end if

  do i = 1, nfcon
    if ( connam(1:lcon) == trim ( filcon(i) ) ) then
      ipxcon = iflcon(i)
      return
    end if
  end do

  do i = 1, necon
    if ( connam(1:lcon) == trim ( errcon(i) ) ) then
      ipxcon = i
      return
    end if
  end do

  ipxcon = -1

  return
end
function ksyand ( item, jtem )

!*****************************************************************************80
!
!! KSYAND performs the logical AND of two integer values.
!
!  Parameters:
!
!    Input, integer ITEM, JTEM, the integers to be used.
!
!    Output, integer KSYAND, the AND of the two integers.
!
  implicit none

  integer item
  integer jtem
  integer ksyand

!ALIANT
!  ksyand = iand ( item, jtem )
!AMDUTS
!  ksyand = iand ( item, jtem )
!APOLLO
!  ksyand = and ( item, jtem )
!CDCOS
!  ksyand = iand ( item, jtem )
!CONVEX
!  ksyand = iand ( item, jtem )
!DECOSF
!  ksyand = iand ( item, jtem )
!DECVMS
!  ksyand = iand ( item, jtem )
!HPF77
!  ksyand = iand ( item, jtem )
!RISC6K
!  ksyand = iand ( item, jtem )
!MSDOS
!  ksyand = iand ( item, jtem )
!SGIRIX
   ksyand = iand ( item, jtem )
!SUNOS
!  ksyand = iand ( item, jtem )
!UNICOS
!  ksyand = item .and. jtem
!UNIVAC
!  ksyand = and ( item, jtem )
!UNKNOW
!  ksyand = kzzand ( item, jtem )
!X8FTN
!  ksyand = and ( item, jtem )
!
  return
end
subroutine pxfopn ( file_name, iopflg, imode, ifilds, ierror )

!*****************************************************************************80
!
!! PXFOPN opens a file.
!
!  Discussion:
!
!    This subroutine is an approximation of the POSIX FORTRAN binding
!    subroutine PXFopen, described on pp 51 of IEEE Std 1003.9-1992
!    and pages 88-90 of IEEE Std 1003.1.  It has a type-compatible
!    argument list, but differs from PXFopen in the following ways:
!
!    * The name has been shortened to conform to the FORTRAN-77
!      6 character naming restriction
!
!    * The following status flag bits of the iopflg argument are not
!      implemented  -
!      * exclusive use bit
!      * controlling terminal assignment bit
!      * no delay (non-block) bit
!      * file truncation bit
!
!    * ierror error codes for functionality associated with the above
!      bits are not implemented
!
!    * The following status flag bits of the iopflg argument have
!      been added as extensions for compatibility with FORTRAN file
!      opening convention -
!      * sequential/direct ascces bit
!      * formatted/unformatted i/o bit
!
!    * The IMODE argument, which is supposed to specify file
!      permission flags for a file to be created, is not used.
!      File permission flags for a new file are set to the default
!      permissions defined by the host operating system.
!
!    * The IFILDS argument returns a FORTRAN logical unit number
!      instead of a POSIX file descriptor number.
!
!  Author:
!
!    Rick Lutowski
!
!  Parameters:
!
!    Input, character ( len = * ) FILE_NAME, the name of the file.
!
!    Input, integer IOPFLG, file access mode and status flag bits.
!    Obtain bit values using ipxcon, and add individual bit values to
!    get composite iopflg value)
!                File Access Mode bits (set only one) -
!                O_RDONLY = open for read only
!                O_WRONLY = open for write only
!                O_RDWR   = open for read and write
!                File Status Flags (set any combination) -
!                O_APPend = set append mode, set file pointer at eof;
!                           valid only for SEQUENTIAL read/write access
!                O_CREAT  = create file if it does not exist
!                DIRECT   = open for DIRECT access if set,
!                           open for SEQUENTIAL access if clear
!                UNFORM   = open for UNformatTED i/o if set,
!                           open for formatTED i/o if clear
!                bytes 2-4 = record length for files to be opened for
!                         DIRECT access, length units are
!                         in number of characters for formatTED files,
!                         in host-defined units for UNformatTED files;
!                         not used for SEQUENTIAL files
!
!    Input, integer IMODE  = not used
!
!    Output, integer IFILDS, the logical unit number of the opened file.
!    A value of -1 indicates that there was an error while opening the
!    file.
!
!    Output, integer IERROR, the error code.
!    (obtain integer values using ipxcon)
!    0 = no errors
!    ENAMETOOLONG = ILEN exceeds declared length of PATH
!    EACCES = access error,
!                    more than one file access mode bit is set, or
!                    no file access mode bit is set, or
!                    cannot check file for existence (e.g., user has
!                      no access permission to file path)
!           ENFILE = cannot assign a logical unit number (e.g.,
!                      too many files open), or
!           EINTR  = error when attempting file operation (e.g., access
!                      or i/o bits or record length not consistent with
!                      existing file)
!           ENOENT = file existence error,
!                    file does not exist and create bit is not set
!                      in iopflg, or
!                    the file name is empty.
!
  implicit none

  character ( len = 12 ) aacc
  character adummy
  character ( len = 12 ) aio
  character ( len = 12 ) astat
  character ( len = * ) file_name
  integer i
  integer iacc
  integer iappnd
  integer icreat
  integer ierror
  integer ifam
  integer ifam3
  integer ifilds
  integer iio
  integer imode
  integer iopflg
  integer ipxcon
  integer ksyand
  logical lexist
  logical lopen
  integer lpath
  integer lrec
  integer lun
!
!  Determine which File Access Mode bits are set.
!
  ifam3 = 1

  if ( ksyand ( iopflg, ipxcon ( 'O_RDONLY' ) ) /= 0 ) then
    ifam3 = ifam3 + 1
  end if

  if ( ksyand ( iopflg, ipxcon ( 'O_WRONLY' ) ) /= 0 ) then
    ifam3 = ifam3 + 2
  end if

  if ( ksyand ( iopflg, ipxcon ( 'O_RDWR' ) ) /= 0 ) then
    ifam3 = ifam3 + 4
  end if

  if ( ifam3 == 2 ) then
    ifam = 1
  else if ( ifam3 == 3 ) then
    ifam = 2
  else if ( ifam3 == 5 ) then
    ifam = 3
  else
    write ( *, * ) ' '
    write ( *, * ) 'PXFOPN - Fatal error!'
    write ( *, * ) '  An illegal combination of access modes was set.'
    write ( *, * ) '  IOPFLG = ', iopflg
    ierror = ipxcon ( 'EACCES' )
    ifilds = -1
    return
  end if
!
!  Determine Length of Path Name
!
  lpath = len_trim ( file_name )

  if ( lpath == 0 ) then
    write ( *, * ) ' '
    write ( *, * ) 'PXFOPN - Fatal error!'
    write ( *, * ) '  The file name is an empty string.'
    ierror = ipxcon ( 'ENOENT' )
    ifilds = -1
    return
  end if
!
!  Determine File Status Flag Values
!
  iappnd = ksyand ( iopflg, ipxcon ( 'O_APPEND' ) )
  icreat = ksyand ( iopflg, ipxcon ( 'O_CREAT' ) )
  iacc = ksyand ( iopflg, ipxcon ( 'DIRECT' ) )

  if ( iacc == 0 ) then

    aacc = 'SEQUENTIAL'

  else

    if ( iappnd /= 0 ) then
      ierror = ipxcon ( 'EACCES' )
      ifilds = -1
      return
    end if

    aacc = 'DIRECT'
    lrec = iopflg / 256
    ifam = ifam + 3

  end if

  iio = ksyand ( iopflg, ipxcon ( 'UNFORM' ) )

  if ( iio == 0 ) then
    aio = 'FORMATTED'
  else
    aio = 'UNFORMATTED'
  end if
!
!  Check if file exists
!
  inquire ( file = file_name(1:lpath), err = 921, exist = lexist, &
    opened = lopen, number = lun )
!
!  Check if file is already opened
!
  if ( lopen ) then
    ierror = 0
    ifilds = lun
    return
  end if
!
!  Set file existence status value
!
  if ( lexist ) then
    astat = 'OLD'
  else
!
!  Return with error code if file does not exist
!  and if create bit is not set
!
    if ( icreat == 0 ) then
      go to 940
    else
      astat = 'NEW'
    end if
  end if
!
!  Find Available Logical Unit Number
!
!  Loop for candidate logical unit numbers.
!
  do i = 1, 90
    lun = i + 9
    inquire ( unit = lun, err = 930, opened = lopen )
    if ( .not. lopen ) then
      go to 159
    end if
  end do
!
!  No available logical unit number found
!
  go to 930

  159 continue
!
!ALIANT
!  if ( ifam == 1 .or. ifam == 2 .or. ifam == 3 ) then
!    open ( unit = lun, file = file_name(1:lpath), err = 931, &
!      status = astat, access = aacc, form = aio )
!  else if ( ifam == 4 .or. ifam == 5 .or. ifam == 6 ) then
!    open ( unit = lun, file = file_name(1:lpath), err = 931,
!    status = astat, access = aacc, form = aio, recl = lrec )
!  end if
!AMDUTSC
!AMDUTS      go to (2021,2022,2023,2024,2025,2026), ifam
!  if ( ifam == 1 ) then
!    open ( unit = lun, file = trim ( file_name ), err = 931, action = 'read',
!      status = astat, access = aacc, form = aio )
!  else if ( ifam == 2 ) then
!    open ( unit = lun, file = trim ( file_name ), err = 931, action = 'write',
!      status = astat, access = aacc, form = aio )
!  else if ( ifam == 3 ) then
!    open ( unit = lun, file = trim ( file_name ), err = 931,
!      status = astat, access = aacc, form = aio )
!  else if ( ifam == 4 ) then
!    open ( unit = lun, file = trim ( file_name ), err = 931, action = 'read',
!      status = astat, access = aacc, form = aio, recl = lrec )
!  else if ( ifam == 5 ) then
!    open ( unit = lun, file = trim ( file_name ), err = 931, action = 'write',
!      status = astat, access = aacc, form = aio, recl = lrec )
!  else if ( ifam == 6 ) then
!    open ( unit = lun, file = trim ( file_name ), err = 931,
!      status = astat, access = aacc, form = aio, recl = lrec )
!  end if
!APOLLO
!  if ( ifam == 1 .or. ifam == 2 .or. ifam == 3 ) then
!    open ( unit = lun, file = trim ( file_name ), err = 931, &
!      status = astat, access = aacc, form = aio )
!  else if ( ifam == 4 .or. ifam == 5 .or. ifam == 6 ) then
!    open ( unit = lun, file = trim ( file_name ), err = 931, &
!      status = astat, access = aacc, form = aio, recl = lrec )
!  end if
!CDCOS
!  if ( ifam == 1 .or. ifam == 2 .or. ifam == 3 ) then
!    open ( unit = lun, file = trim ( file_name ), err = 931, &
!      status = astat, access = aacc, form = aio )
!  else if ( ifam == 4 .or. ifam == 5 .or. ifam == 6 ) then
!    open ( unit = lun, file = trim ( file_name ), err = 931, &
!      status = astat, access = aacc, form = aio, recl = lrec )
!  end if
!CONVEX
!  if ( ifam == 1 ) then
!    open ( unit = lun, file = trim ( file_name ), err = 931, readonly, &
!      status = astat, access = aacc, form = aio )
!  else if ( ifam == 2 .or. ifam == 3 ) then
!    open ( unit = lun, file = file_name(1:lpath), err = 931, &
!      status = astat, access = aacc, form = aio )
!  else if ( ifam == 4 ) then
!    open ( unit = lun, file = file_name(1:lpath), err = 931, readonly, &
!      status = astat, access = aacc, form = aio, recl = lrec )
!  else if ( ifam == 5 .or. ifam == 6 ) then
!    open ( unit = lun, file = file_name(1:lpath), err = 931, &
!      status = astat, access = aacc, form = aio, recl = lrec )
!  end if
!DECOSF
! if ( ifam == 1 ) then
!   open ( unit = lun, file = file_name(1:lpath), err = 931, readonly, &
!     status = astat, access = aacc, form = aio )
! else if ( ifam == 2 .or. ifam == 3 ) then
!   open ( unit = lun, file = file_name(1:lpath), err = 931, &
!     status = astat, access = aacc, form = aio )
! else if ( ifam == 4 ) then
!   open ( unit = lun, file = file_name(1:lpath), err = 931, readonly, &
!     status = astat, access = aacc, form = aio, recl = lrec )
! else if ( ifam == 5 .or. ifam == 6 ) then
!   open ( unit = lun, file = file_name(1:lpath), err = 931, &
!     status = astat, access = aacc, form = aio, recl = lrec )
! end if
!
!     ******************************************************************
!
!                       0 - DEC VMS
!
!DECVMSC       Seq r/o  w/o  r/w | r/o  w/o  r/w Direct
!DECVMS      go to (2001,2002,2003,2004,2005,2006), ifam
!DECVMSC                       Sequential access - read only
!DECVMS 2001 open ( unit = lun, file = file_name(1:lpath), err = 931, readonly,
!DECVMS     *      status = astat, access = aacc, form = aio)
!DECVMS      go to 2009
!DECVMSC                       Sequential access - write, read/write
!DECVMS 2002 continue
!DECVMS 2003 open ( unit = lun, file = file_name(1:lpath), err = 931,
!DECVMS     *      status = astat, access = aacc, form = aio)
!DECVMS      go to 2009
!DECVMSC                       Direct access - read only
!DECVMS 2004 open ( unit = lun, file = file_name(1:lpath), err = 931, readonly,
!DECVMS     *      status = astat, access = aacc, form = aio, recl = lrec )
!DECVMS      go to 2009
!DECVMSC                       Direct access - write only, read/write
!DECVMS 2005 continue
!DECVMS 2006 open ( unit = lun, file = file_name(1:lpath), err = 931,
!DECVMS     *      status = astat, access = aacc, form = aio, recl = lrec )
!DECVMSC     go to 2009
!DECVMS 2009 continue
!
!     ******************************************************************
!
!                       7 - Hewlitt-Packard 9000 UNIX
!
!HPF77C       Seq r/o  w/o  r/w | r/o  w/o  r/w Direct
!HPF77      go to (2071,2072,2073,2074,2075,2076), ifam
!HPF77C                       Sequential access - read, write, r/w
!HPF77 2071 continue
!HPF77 2072 continue
!HPF77 2073 open ( unit = lun, file = file_name(1:lpath), err = 931,
!HPF77     *      status = astat, access = aacc, form = aio)
!HPF77      go to 2079
!HPF77C                       Direct access - read, write, r/w
!HPF77 2074 continue
!HPF77 2075 continue
!HPF77 2076 open ( unit = lun, file = file_name(1:lpath), err = 931,
!HPF77     *      status = astat, access = aacc, form = aio, recl = lrec )
!HPF77C     go to 2079
!HPF77 2079 continue
!
!     ******************************************************************
!
!                       2 - IBM RISC 6000 AIX
!
!RISC6KC       Seq r/o  w/o  r/w | r/o  w/o  r/w Direct
!RISC6K      go to (2151,2152,2153,2154,2155,2156), ifam
!RISC6KC                       Sequential access - read, write, r/w
!RISC6K 2151 continue
!RISC6K 2152 continue
!RISC6K 2153 open ( unit = lun, file = file_name(1:lpath), err = 931,
!RISC6K     *      status = astat, access = aacc, form = aio)
!RISC6K      go to 2159
!RISC6KC                      Direct access - read, write, r/w
!RISC6K 2154 continue
!RISC6K 2155 continue
!RISC6K 2156 open ( unit = lun, file = file_name(1:lpath), err = 931,
!RISC6K     *      status = astat, access = aacc, form = aio, recl = lrec )
!RISC6KC     go to 2159
!RISC6K 2159 continue
!
!     ******************************************************************
!
!                       Unsupported - MS-DOS PC
!
!MSDOS C       Seq r/o  w/o  r/w | r/o  w/o  r/w Direct
!MSDOS      go to (2531,2532,2533,2534,2535,2536), ifam
!MSDOS C                       Sequential access - read, write, r/w
!MSDOS 2531 continue
!MSDOS 2532 continue
!MSDOS 2533 open ( unit = lun, file = file_name(1:lpath), err = 931,
!MSDOS     *      status = astat, access = aacc, form = aio)
!MSDOS      go to 2539
!MSDOS C                       Direct access - read, write, r/w
!MSDOS 2534 continue
!MSDOS 2535 continue
!MSDOS 2536 open ( unit = lun, file = file_name(1:lpath), err = 931,
!MSDOS     *      status = astat, access = aacc, form = aio, recl = lrec )
!MSDOS C    go to 2539
!MSDOS 2539 continue
!
!     ******************************************************************
!
!SGIRIX
!                       4 - Silicon Graphics UNIX
!
!       Seq r/o  w/o  r/w | r/o  w/o  r/w Direct
!
!  Sequential access - read, write, r/w
!
  if ( ifam == 1 .or. ifam == 2 .or. ifam == 3 ) then

    open ( unit = lun, file = file_name(1:lpath), err = 931, &
      status = astat, access = aacc, form = aio)
!
!  Direct access - read, write, r/w
!
  else if ( ifam == 4 .or. ifam == 5 .or. ifam == 6 ) then

    open ( unit = lun, file = file_name(1:lpath), err = 931, &
      status = astat, access = aacc, form = aio, recl = lrec )

  end if
!
!     ******************************************************************
!
!                       5 - Sun UNIX
!
!SUNOSC       Seq r/o  w/o  r/w | r/o  w/o  r/w Direct
!SUNOS      go to (2051,2052,2053,2054,2055,2056), ifam
!SUNOSC                       Sequential access - read, write, r/w
!SUNOS 2051 continue
!SUNOS 2052 continue
!SUNOS 2053 open ( unit = lun, file = file_name(1:lpath), err = 931,
!SUNOS     *      status = astat, access = aacc, form = aio)
!SUNOS      go to 2059
!SUNOSC                       Direct access - read, write, r/w
!SUNOS 2054 continue
!SUNOS 2055 continue
!SUNOS 2056 open ( unit = lun, file = file_name(1:lpath), err = 931,
!SUNOS     *      status = astat, access = aacc, form = aio, recl = lrec )
!SUNOSC     go to 2059
!SUNOS 2059 continue
!
!     ******************************************************************
!
!                       6 - Cray UNICOS UNIX
!
!UNICOSC       Seq r/o  w/o  r/w | r/o  w/o  r/w Direct
!UNICOS      go to (2061,2062,2063,2064,2065,2066), ifam
!UNICOSC                       Sequential access - read, write, r/w
!UNICOS 2061 continue
!UNICOS 2062 continue
!UNICOS 2063 open ( unit = lun, file = file_name(1:lpath), err = 931,
!UNICOS     *      status = astat, access = aacc, form = aio)
!UNICOS      go to 2069
!UNICOSC                       Direct access - read, write, r/w
!UNICOS 2064 continue
!UNICOS 2065 continue
!UNICOS 2066 open ( unit = lun, file = file_name(1:lpath), err = 931,
!UNICOS     *      status = astat, access = aacc, form = aio, recl = lrec )
!UNICOSC     go to 2069
!UNICOS 2069 continue
!
!     ******************************************************************
!
!                       Unsupported - UNIVAC EXEC 8 o/s
!                       with UFTN (Universal  FORTRAN)
!
!UNIVACC       Seq r/o  w/o  r/w | r/o  w/o  r/w Direct
!UNIVAC      go to (2541,2542,2543,2544,2545,2546), ifam
!UNIVACC                       Sequential access - read, write, r/w
!UNIVAC 2541 continue
!UNIVAC 2542 continue
!UNIVAC 2543 open ( unit = lun, file = file_name(1:lpath), err = 931,
!UNIVAC     *      status = astat, access = aacc, form = aio)
!UNIVAC      go to 2549
!UNIVACC                       Direct access - read, write, r/w
!UNIVAC 2544 continue
!UNIVAC 2545 continue
!UNIVAC 2546 open ( unit = lun, file = file_name(1:lpath), err = 931,
!UNIVAC     *      status = astat, access = aacc, form = aio, recl = lrec )
!UNIVACC     go to 2549
!UNIVAC 2549 continue
!
!     ******************************************************************
!
!                       (CR)  - Unspecified UNIX
!
!UNKNOWC       Seq r/o  w/o  r/w | r/o  w/o  r/w Direct
!UNKNOW      go to (2081,2082,2083,2084,2085,2086), ifam
!UNKNOWC                       Sequential access - read, write, r/w
!UNKNOW 2081 continue
!UNKNOW 2082 continue
!UNKNOW 2083 open ( unit = lun, file = file_name(1:lpath), err = 931,
!UNKNOW     *      status = astat, access = aacc, form = aio)
!UNKNOW      go to 2089
!UNKNOWC                       Direct access - read, write, r/w
!UNKNOW 2084 continue
!UNKNOW 2085 continue
!UNKNOW 2086 open ( unit = lun, file = file_name(1:lpath), err = 931,
!UNKNOW     *      status = astat, access = aacc, form = aio, recl = lrec )
!UNKNOWC     go to 2089
!UNKNOW 2089 continue
!
!     ******************************************************************
!
!                       Unsupported - UNIVAC EXEC 8 o/s
!                       with older ASCII FORTRAN
!
!X8FTNC       Seq r/o  w/o  r/w | r/o  w/o  r/w Direct
!X8FTN      go to (2551,2552,2553,2554,2555,2556), ifam
!X8FTNC                       Sequential access - read, write, r/w
!X8FTN 2551 continue
!X8FTN 2552 continue
!X8FTN 2553 open ( unit = lun, file = file_name(1:lpath), err = 931,
!X8FTN     *      status = astat, access = aacc, form = aio)
!X8FTN      go to 2559
!X8FTN                        Direct access - read, write, r/w
!X8FTN 2554 continue
!X8FTN 2555 continue
!X8FTN 2556 open ( unit = lun, file = file_name(1:lpath), err = 931,
!X8FTN     *      status = astat, access = aacc, form = aio, recl = lrec )
!X8FTNC     go to 2559
!X8FTN 2559 continue
!
  if ( iacc == 0 ) then

    if ( iappnd /= 0 ) then

      do
        read ( lun, '(a)', err = 813 , end = 850 ) adummy
      end do

    else

      rewind ( lun, err = 813 )
      go to 850

    end if
!
!  Close file and return with error code if problem positioning file pointer
!
  813   close ( lun, err = 931)
        go to 931
      end if

  850 continue
!
!  Set Error Code
!
!  0 = no errors
!
  ierror = 0
  ifilds = lun
  return
!
!  Cannot check file for existence (e.g., user has no access permission
!  to file path)
!
  921 ierror = ipxcon ( 'EACCES' )
      go to 990
!
!  ENFILE = cannot assign a logical unit number
!  (e.g., too many files open)
!
  930 ierror = ipxcon ( 'ENFILE' )
      go to 990
!
!  EINTR = error when attempting file operation (e.g., access or i/o bits
!  or record length not consistent with existing file)
!
  931 ierror = ipxcon ( 'EINTR' )
      go to 990
!
!  ENOENT = file existence error, file does not exist and create bit is
!  not set in iopflg
!
  940 ierror = ipxcon ( 'ENOENT' )
      go to 990

  990 continue

  ifilds = -1

 1000 continue

  return
end
subroutine syrecl ( nwds, lrec )

!*****************************************************************************80
!
!! SYRECL determines the record length for a random access file.
!
!  Author:
!
!    Rick Lutowski
!
!  Parameters:
!
!    Input, integer NWDS, the number of machine words per record.
!
!    Output, integer LREC, the appropriate value of "RECL" in an
!    open statement for a binary file.
!
  implicit none

  integer bytes_per_word
  integer kzbyte
  integer lrec
  character nmchwd
  integer nwds

  kzbyte = bytes_per_word ( )
!
!ALIANT
!  lrec = nwds
!AMDUTS
!  lrec = nwds * kzbyte
!APOLLO
!  lrec = nwds * kzbyte
!CDCOS
!  lrec = nwds
!CONVEX
!  lrec = nwds * kzbyte
!DECOSF
! lrec = nwds
!DECVMS
!  lrec = nwds
!HPF77
!  lrec = nwds * kzbyte
!RISC6K
!  lrec = nwds * kzbyte
!MSDOS
!  lrec = nwds
!SGIRIX
   lrec = nwds * kzbyte
!SUNOS
!  lrec = nwds * kzbyte
!UNICOS
!  lrec = nwds * kzbyte
!UNIVAC
!  lrec = nwds
!UNKNOW
!  lrec = nwds
!X8FTN
!  lrec = nwds
!
  return
end
subroutine timestamp ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    May 31 2001   9:45:54.872 AM
!
!  Modified:
!
!    31 May 2001
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer d
  character ( len = 8 ) date
  integer h
  integer m
  integer mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer n
  integer s
  character ( len = 10 )  time
  integer values(8)
  integer y
  character ( len = 5 ) zone

  call date_and_time ( date, time, zone, values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end