C Copyright(C) 2009-2017 National Technology & Engineering Solutions of
C Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are
C met:
C
C     * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C     * Redistributions in binary form must reproduce the above
C       copyright notice, this list of conditions and the following
C       disclaimer in the documentation and/or other materials provided
C       with the distribution.
C     * Neither the name of NTESS nor the names of its
C       contributors may be used to endorse or promote products derived
C       from this software without specific prior written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

c ======================================================================
c ======================================================================
c ======================================================================
c ======================================================================
c
c ROUTINE:              getins
c
c DESCRIPTION:          This routine is in charge of getting user
c                       input and keeping track of where
c                       it is coming from.
c
c AUTHOR:               John H. Glick
c                       Sandia National Laboratories
c                       Division 1511
c
c DATE:                 December 20, 1988
c
c TYPE OF SUBPROGRAM:   subroutine
c
c USAGE:               call getins (id, maxfld, nfield,
c                                    kvalue, cvalue, ivalue, rvalue,
c                                    line, iostat, prompt,
c                                    lprom, *)
c
c PARAMETERS:
c
c     character*(*) id  -- (input)
c                        = 'parse' if the input line should be read
c                        and parsed by the free field reader.  If so,
c                        input information is returned in the nfield,
c                        kvalue, cvalue, ivalue, and rvalue parameters.
c                        = 'line' if the input line is to be read as
c                        one line.  If so, the input line is returned
c                        in the parameter line.
c     integer maxfld  -- (input)
c                        Maximum number of fields returned by the
c                        free field reader (frefld).
c     integer nfield  -- (output)
c                        number of data fields returned by
c                        the free field reader (frefld).
c     integer kvalue( maxfld ) -- ( output )
c                        Translation states of the data fields
c                        returned by the free field reader.  The
c                        value of each element of this array is
c                        interpreted as follows:
c                           -1 = This is a null field.
c                            0 = This is a nonnumeric field; only
c                                cvalue contains a specified value.
c                            1 = This is a real numeric field;
c                                cvalue and rvalue contain specified
c                                values.
c                            2 = This is an integer numeric field;
c                                cvalue, rvalue, and ivalue contain
c                                specified values.
c     character*(*) cvalue( maxfld ) -- ( output )
c                         Character values of the data fields returned
c                         by the free field reader (frefld).  The data
c                         will be left justified and either
c                         blank-filled or truncated.  The value in
c                         this array is set by frefld to be blank
c                         for a null field.
c     integer ivalue( maxfld ) -- ( output )
c                         Integer values of the data fields.  The
c                         value in this array is set by frefld to
c                         be zero for a null or non-integer field.
c     real rvalue( maxfld ) -- ( output )
c                         Floating-point values of the data fields.
c                         The value in this array is set by frefld
c                         to be zero for a null or non-real fields.
c     character*(*) line -- ( output )
c                         If id = 'line', then the input line
c                         is returned in this parameter.
c     integer iostat -- (output)
c                         iostat value returned by the frefld reader
c                         (if id = 'parse') or by the read
c                         statement (if id = 'line').
c     character*(*) prompt -- (input)
c                         Prompt to be displayed to user.
c     integer lprom -- (input)
c                         Length of prompt string.
c     * -- Alternate return in case of fatal error.
c
c CALLS:                prterr (etclib), filhnd (BLOT),
c                       lenstr (strlib),
c                       frefld (SUPES), exname (SUPES)
c
c GLOBAL VARIABLES REFERENCED:
c
c     none
c
c CALLING ROUTINE(S):   comand (BLOT)
c
c SYSTEM DEPENDENCIES:  none
c
c ======================================================================
c ======================================================================
c
      subroutine getins (id, maxfld, nfield, kvalue, cvalue,
     &   ivalue, rvalue, line, iostat, prompt, lprom, *)
c
c ***********************************************************************
c
c        parameters

      character*(*) id
      integer maxfld
      character*(*) cvalue( maxfld )
      integer nfield, kvalue( maxfld ), ivalue( maxfld )
      real rvalue( maxfld )
      character*(*) line
      integer iostat
      character*(*) prompt
      integer lprom

c
c ***********************************************************************
c
c        local declarations

      integer maxstk
      parameter ( maxstk = 10 )
c         the maximum number of files allowed in the stack of files
c         containing instructions that are still to be read.
      character*2048 file, filelc
c         Name of file to be opened for reading instructions
      character*2048 name( maxstk )
c         the stack of file names containing instructions that are
c         still to be read
      integer recred( maxstk )
c         recred(i) = the number of records that have already been
c         processed in file i of the stack.  That is, when file i
c         is reopened as the source of instructions, the first
c         recred(i) records (instructions) have already been read
c         and so should be skipped.
      integer stkpnt
c         the number of files currently in the stack.  That is,
c         when the last instruction is read from a file,
c         the file from the top of the stack, file( numstk ),
c         is reopened.  This is the file that called the last file.
      save stkpnt, name, recred

      logical first
c         .TRUE. until after the first call to getins.
c         .FALSE. thereafter.
      save first
      integer ln
c          length of a file name or a command string
      integer ios
c          I/O status returned by and I/O statement or the free
c          field reader (frefld).
      logical gotins
c          .TRUE. if an instruction was successfully read from
c          the input stream.
c         .FALSE. otherwise. ( e.g., an EOF mark was read from
c          the input file.
      logical ecode
c          code returned by subroutine filhnd.
c          .TRUE. if file handling proceeded properly.
c          .FALSE. otherwise
      integer temp
c          temporary variable for saving integer variables.
      logical try
c          .TRUE. if an attempt to open an instruction file is to be made.
c          .FALSE. otherwise.
      logical quit
c          .TRUE. if control should go back to the top of the routine
c          to try to read another command line.
c          .FALSE. if a command line has successfully been read and
c          the program should exit.
      character*2048 cmdfile
c          Name of the command for directing command to a new file.
      save cmdfile

      logical parse
c          .TRUE. if the input is to be read and parsed by the free
c          field reader.
c          .FALSE. if the input is to be read as a line.

      logical instr

      integer nin
c          logical unit where instructions are currently being read from.
      save nin

      character*2048 cval2(80)
      logical batch

c ***********************************************************************
c
c     data statements
c
      data recred / maxstk*0 /
      data first / .TRUE. /
      data cmdfile(1:7) / 'CMDFILE' /
c
c ***********************************************************************
c ***********************************************************************
c
c
      iostat = 0
      if ( id .eq. 'parse' ) then
         parse = .TRUE.
      else if ( id .eq. 'line' ) then
         parse = .FALSE.
      else
         call prterr ('PROGRAM',
     &      'illegal value for id parameter passed to getins')
         return 1
      endif

      if ( first ) then
        stkpnt = 0
c         first call to getins

c           find out if an instruction file was specified in the P4
c           field of the command line

         if ( instr() ) then
c   an instruction file was specified
            call exname ( 7, name( 1 ), ln )
c   get name of file
c
c                 open file
c
            if ( batch() ) then
               call filhnd ( 7, name(1)(:ln), .TRUE., ecode,
     &            'o', 'f', 's', 0, *150)
               stkpnt = stkpnt + 1
c   increment stack pointer
               nin = 7
c    set logical unit where instructions are to be read from
            else
               call filhnd ( 7, name(1)(:ln), .FALSE., ecode,
     &            'o', 'f', 's', 0, *150)
               if ( ecode ) then
c  file opened properly
                  stkpnt = stkpnt + 1
c  increment stack pointer
                  nin = 7
c   set logical unit where instructions are to be read from
               else
c   instruction file wasn't there. prompt user for instructions.
                  nin = 0
               endif
            endif

         else
c   no instruction file was specified
            if ( batch() ) then
               call prterr ('FATAL',
     &        'No instruction file was specified on the command line.')
               return 1
            else
               nin = 0
            endif
         endif
         first = .FALSE.

      endif
c
c              get an instruction
c
  100 continue

      gotins = .FALSE.

  110 continue

      if ( nin .eq. 7 )
     &   recred( stkpnt ) = recred( stkpnt ) + 1
c
c              read instruction
c
      if ( parse ) then
         call frefld ( nin, 0, prompt(:lprom), maxfld, ios,
     &      nfield, kvalue, cval2, ivalue, rvalue )
      else
        if (nin .eq. 0) then
          read (*, fmt=10010, iostat=ios ) line
        else
          read ( unit=nin, fmt=10010, iostat=ios ) line
        end if
10010     format ( a )
      endif
c
c           check for an error in reading instruction
c
      if ( ios .gt. 0 ) then
c   error in reading instruction
         call prterr ('FATAL',
     &      'error reading an instruction in getins')
         return 1
      else if ( ios .lt. 0 ) then
c
c              end of file read from input stream.

         if ( nin .ne. 0 ) then
c            EOF mark read from a file.
c            Close the file and open the
c            previous one on the stack, if
c            one exists.  If not, switch to
c            interactive input.
            call filhnd ( -nin, ' ', .TRUE., ecode,
     &         ' ', ' ', ' ', 0, *150)
            stkpnt = stkpnt - 1
            if ( stkpnt .gt. 0 ) then

c                    open previous file

               call filhnd ( nin, name( stkpnt ), .TRUE., ecode,
     &            'o', 'f', 's', 0, *150)

c                    skip records that have already been read

               do 120 i = 1, recred( stkpnt )
                  read ( nin, * )
  120          continue

            else
c  no more files on the stack.  Switch
c  to interactive input if an interactive
c  job.  If a batch job, print error.
               if ( .not. batch() ) then
                  nin = 0
               else
                  call prterr ('PROGRAM',
     &          ' End of file mark read in lowest level command file.')
                  return 1
               endif

            endif

         endif


      else
         gotins = .TRUE.
      endif

      if ( .not. gotins ) go to 110

c
c              if id = 'line', just return the line of input
c
      if ( .not. parse ) then

         try = .FALSE.
         quit = .TRUE.

      else
c
c              check if command specifies that instructions
c              are to be read from a different source
c
         ln = lenstr ( cval2(1) )
         if ( cval2(1)(1:ln) .eq. cmdfile(1:ln) ) then

            if ( kvalue(2) .eq. 0 ) then
               file = cval2(2)
C ... Convert filename to all lowercase -- FREFLD converts to all uppercase
               call lowstr(filelc, file)
               try = .TRUE.
            else
               if ( nin .eq. 0 ) then
                  write ( *, 10020 )
10020              format ( // 5x, 'Please enter an instruction file',
     &               ' to read from or ''a'' to ' / 5x,
     &               'continue reading from the current unit. > ', $ )
                  read ( *, 10030 ) file
10030              format ( a )
               else
                  recred( stkpnt ) = recred( stkpnt ) + 1
                  read ( nin, 10030 ) file
               endif
               call pack ( file, ln )
               if ( file(1:1) .eq. 'A'  .or.
     &            file(1:1) .eq. 'a' ) then
                  try = .FALSE.
                  quit = .FALSE.
               else
                  try = .TRUE.
               endif
            endif
         else
            try = .FALSE.
            quit = .TRUE.
            do 130 i2 = 1, maxfld
               cvalue(i2) = cval2(i2)
  130       continue
         endif

      endif

      if ( try ) then

         quit = .FALSE.
c          will want to return to the
c          top of the routine to read
c          an instruction.

         temp = nin
c          remember where instructions are coming from.

         if ( nin .eq. 7 ) then
c           instructions are currently coming
c           from a file.  This current file
c           must be closed.  The information
c           on this file ( its name and the
c           pointer to its current instruction
c           has already been stored on the stack.
            call filhnd ( -nin, ' ', .TRUE., ecode, ' ', ' ', ' ',
     &         0, *150)
         else
c           instructions are currently coming
c           from the terminal.  Change unit
c           of instructions to 7
            nin = 7
         endif

         stkpnt = stkpnt + 1
c            increment stack pointer

         if ( stkpnt .gt. maxstk ) then
            call prterr ('FATAL',
     &'Nesting of instruction files is greater than maximum allowed')
            return 1
         endif
c
c              open instruction file
c
C ... We have a problem on systems with case-sensitive file names.
C     FREFLD converts all strings to uppercase.  Therefore, the filename
C     specified in 'file' will be all uppercase.  Since the file is
C     typically lowercase, we lowercase 'file' in variable 'filelc'.
C     First, try to open 'file' (uppercase), if this fails, try to
C     open 'filelc' (lowercase).  NOTE: There is no way (yet) to deal
C     with mixed-case filenames.  GDS 7/1/91.

         if ( batch() ) then
            call filhnd ( nin, file, .FALSE., ecode,
     &         'o', 'f', 's', 0, *150)
            if (.not. ecode) then
               call filhnd ( nin, filelc, .TRUE., ecode,
     &              'o', 'f', 's', 0, *150)
            end if
         else
            call filhnd ( nin, file, .FALSE., ecode,
     &         'o', 'f', 's', 0, *150)

            if (.not. ecode) then
               call filhnd ( nin, filelc, .FALSE., ecode,
     &              'o', 'f', 's', 0, *150)
            end if
         endif
         if ( ecode ) then
c   file was successfully opened
            name( stkpnt ) = file
            recred( stkpnt ) = 0
         else
c   file was not successfully opened
c   reopen last instruction file ( if
c   necessary ) and reset parameters.
            call prterr ('ERROR',
     &         ' Command file could not be opened.  Command ignored. ')

            nin = temp
            stkpnt = stkpnt - 1
            if ( nin .eq. 7 ) then

               call filhnd ( nin, name( stkpnt ), .TRUE., ecode,
     &            'o', 'f', 's', 0, *150)

c                       skip records that have already been read

               do 140 i = 1, recred( stkpnt )
                  call frefld ( nin, 0, ' ', maxfld, ios, nfield,
     &               kvalue, cval2, ivalue, rvalue )
                  if ( ios .ne. 0 ) then
                     call prterr ('PROGRAM',
     & 'Error skipping previously read records in getins')
                     return 1
                  endif
  140          continue
            endif
         endif

      endif

c
c              return to the top of the routine to read
c              another instruction, if necessary
c
      if ( .not. quit ) go to 100
      return

c              alternate return

  150 continue
      return 1
      end
