Google
 

Trailing-Edge - PDP-10 Archives - BB-K818A-BM_1981 - sources/ratmig.for
There are 2 other files named ratmig.for in the archive. Click here to see a list.
C  Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C  ratmig -- I/O for RATFOR preprocessor including migration from RT-11
C  Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C  copyright notice
C 
C 
C   			C O P Y R I G H T
C 
C 
C   		Copyright (C) 1980 by
C   		Digital Equipment Corporation, Maynard, Mass.
C 
C 
C   	This software is furnished under a license and may be used and
C   	copied  only  in accordance with the terms of such license and
C   	with the  inclusion  of  the  above  copyright  notice.   This
C   	software  or  any  other copies thereof may not be provided or
C   	otherwise made available to any other person.  No title to and
C   	ownership of the software is hereby transferred.
C 
C   	The information in this software is subject to change  without
C   	notice  and should not be construed as a commitment by Digital
C   	Equipment Corporation.
C 
C   	DIGITAL assumes no responsibility for the use  or  reliability
C   	of its software on equipment that is not supplied by DIGITAL.
C 
C ========== Ratfor character definitions ==========
C 	 9-FEB-79
C 	12-MAY-80
C  ampersand
C  exclamation mark
C  ASCIZ strings as used by SYSLIB
C  max element count in packed char array
C  input record size
C  must be 2 more than MAXRECORD
C  alternative to YES, NO
C  a linefeed
C  for OPENF calls
C 	"
C 	"
C 	"
C  char i/o format:  "r1" for TOPS-20; "a1" otherwise
C  quoted string version of above
C  first char for single space with LIST carriagecontrol:
C 	' ' for RSTS, nothing for VMS
C  ascii numeric value corresponding to LISTSS, above
C  if "#", omit packed string code for this machine
C  5 for TOPS-20, 1 otherwise
C  if "#", omit TOPS20 code
C  scopy -- copy a character string to its full length
      integer function scopy ( in , out )
      integer in ( 1 ) , out ( 1 )
      continue
       i = 1
23000 if(.not.(in(i).ne.0))goto 23002
      out ( i ) = in ( i )
23001 i=i+1
      goto 23000
23002 continue
      out ( i ) = 0
C  terminate output string
      scopy = i - 1
      return
      end
C  of scopy
C  scopyl -- copy a character string given a maximum length
      integer function scopyl ( in , out , maxlen )
      integer in ( 1 ) , out ( 1 )
      integer maxlen
      continue
       i = 1
23003 if(.not.(i.le.maxlen.and.in(i).ne.0))goto 23005
      out ( i ) = in ( i )
23004 i=i+1
      goto 23003
23005 continue
      out ( i ) = 0
      scopyl = i - 1
      return
      end
C  of scopyl
C  makeuc -- translate alphabetics to upper case
      integer function makeuc ( str )
      integer str ( 1 ) , upper
      continue
       i = 1
23006 if(.not.(str(i).ne.0))goto 23008
      str ( i ) = upper ( str ( i ) )
23007 i=i+1
      goto 23006
23008 continue
      makeuc = i - 1
      return
      end
C  of makeuc
C  upper -- translate a character to upper case
      integer function upper ( c )
      integer c
      upper = c .and. " 177
      if(.not.( upper .lt. 97 ))goto 23009
      return
23009 continue
      if(.not.( upper .gt. 122 ))goto 23011
      return
23011 continue
      upper = upper .and. ( .not. " 40 )
      return
      end
C  makelc -- translate alphabetics to lower case
      integer function makelc ( str )
      integer str ( 1 ) , lower
      continue
       i = 1
23013 if(.not.(str(i).ne.0))goto 23015
      str ( i ) = lower ( str ( i ) )
23014 i=i+1
      goto 23013
23015 continue
      makelc = i - 1
      return
      end
C  of makelc
C  lower -- translate a character to lower case
      integer function lower ( c )
      integer c
      lower = c .and. " 177
      if(.not.( lower .lt. 65 ))goto 23016
      return
23016 continue
      if(.not.( lower .gt. 90 ))goto 23018
      return
23018 continue
      lower = lower .or. " 40
      return
      end
C  cvt -- remove blanks and control chars from string
      integer function cvt ( str )
      integer str ( 1 ) , chr
      integer in , out
      out = 1
      continue
       in = 1
23020 continue
      chr = str ( in )
      if(.not.( chr .eq. 0 ))goto 23023
      goto 23022
23023 continue
      if(.not.( chr .gt. 32 ))goto 23025
      str ( out ) = chr
      out = out + 1
23025 continue
23021 in=in+1
      goto 23020
23022 continue
      str ( out ) = 0
      cvt = out - 1
      return
      end
C  of cvt
C  trim -- remove trailing blanks and h.o. padding from string
      integer function trim ( buf )
C  returns length of string
      implicit integer ( a - z )
      integer buf ( 1 )
      continue
       i = 1
23027 continue
      buf ( i ) = buf ( i ) .and. " 177
C  remove h.o. bit(s)
      if(.not.( buf ( i ) .eq. 0 ))goto 23030
      goto 23029
23030 continue
23028 i=i+1
      goto 23027
23029 continue
      continue
       j = i - 1
23032 if(.not.(j.ge.1.and.buf(j).eq.32))goto 23034
C  locate last non-blank character
      continue
23033 j=j-1
      goto 23032
23034 continue
      buf ( j + 1 ) = 0
C  new terminator location
      trim = j
      return
      end
C  lpad -- pad out a string to a given length by adding padding on the left
      integer function lpad ( str , padc , len )
C  returns length of result
      implicit integer ( a - z )
      integer str ( 1 ) , padc
      integer len
      integer dif
      lpad = length ( str )
      dif = len - lpad
      if(.not.( dif .gt. 0 ))goto 23035
      do 23037 i = lpad + 1 , 1 , - 1
C  "lpad+1" includes EOS
      str ( i + dif ) = str ( i )
23037 continue
23038 continue
C  move stuff over by difference
      do 23039 i = 1 , dif
      str ( i ) = padc
23039 continue
23040 continue
C  add left padding
      lpad = len
C  returns "len" unless original
C  string longer than "len"
23035 continue
      return
      end
C  rpad -- pad out a string to a given length by adding padding on the right
      integer function rpad ( str , padc , len )
C  returns length of result
      implicit integer ( a - z )
      integer str ( 1 ) , padc
      integer len
      rpad = length ( str )
      if(.not.( rpad .ge. len ))goto 23041
      return
C already long enough, just return length
23041 continue
      do 23043 j = rpad + 1 , len
      str ( j ) = padc
C else add padding character as required
23043 continue
23044 continue
      rpad = len
      str ( len + 1 ) = 0
C terminate
      return
      end
C  length -- length of an ASCIZ string
      integer function length ( str )
      integer str ( 1 )
      continue
       i = 1
23045 if(.not.(str(i).ne.0))goto 23047
23046 i=i+1
      goto 23045
23047 continue
      length = i - 1
      return
      end
C  of length
C  iscomp -- compare two character strings
      integer function iscomp ( str1 , str2 )
      integer str1 ( 1 ) , str2 ( 1 )
      continue
       i = 1
23048 continue
      iscomp = str1 ( i ) - str2 ( i )
      if(.not.( iscomp .ne. 0 ))goto 23051
      goto 23050
23051 continue
      if(.not.( str1 ( i ) .eq. 0 ))goto 23053
      goto 23050
23053 continue
23049 i=i+1
      goto 23048
23050 continue
      return
      end
C  of iscomp
C  indexx -- find position of pattern in string
      integer function indexx ( str , pattrn , start )
      integer str ( 1 ) , pattrn ( 1 )
      integer start
      integer lpat
      lpat = length ( pattrn )
      continue
       i = start
23055 if(.not.(str(i).ne.0))goto 23057
      if(.not.( str ( i ) .eq. pattrn ( 1 ) ))goto 23058
      continue
       j = 2
23060 if(.not.(j.le.lpat.and.str(i+j-1).eq.pattrn(j)))goto 23062
23061 j=j+1
      goto 23060
23062 continue
      if(.not.( j .gt. lpat ))goto 23063
      indexx = i
      return
23063 continue
23058 continue
23056 i=i+1
      goto 23055
23057 continue
      indexx = 0
C  failure to find
      return
      end
C  of indexx
C  rindex -- find position of pattern in string, searching from end to start
      integer function rindex ( str , pattrn , strt )
      integer str ( 1 ) , pattrn ( 1 )
      integer strt , start
      integer lpat
      lpat = length ( pattrn )
      start = length ( str )
      if(.not.( strt .gt. 0 .and. strt .lt. start ))goto 23065
      start = strt
C  use supplied start if in range, else use end
23065 continue
      start = start - lpat + 1
      continue
       i = start
23067 if(.not.(i.gt.0))goto 23069
      if(.not.( str ( i ) .eq. pattrn ( 1 ) ))goto 23070
      continue
       j = 2
23072 if(.not.(j.le.lpat.and.str(i+j-1).eq.pattrn(j)))goto 23074
23073 j=j+1
      goto 23072
23074 continue
      if(.not.( j .gt. lpat ))goto 23075
      rindex = i
      return
23075 continue
23070 continue
23068 i=i-1
      goto 23067
23069 continue
      rindex = 0
C  failure to find
      return
      end
C  of rindex
C  getstr -- get a line of input
      integer function getstr ( lun , line , lim )
      implicit integer ( a - z )
      integer lun , lim , length
      integer line ( 1 )
      length = lim
C  in case "q" format not available
      if(.not.( lun .le. 0 ))goto 23077
      accept 100 , ( line ( i ) , i = 1 , min0 ( length , lim ) )
      goto 23078
23077 continue
      read ( lun , 100 , err = 200 , end = 300 ) ( line ( i ) , i = 1 , 
     *min0 ( length , lim ) )
23078 continue
100   format ( 255 r1 )
      getstr = min0 ( length , lim )
      line ( getstr + 1 ) = 0
      getstr = trim ( line )
      return
200   getstr = - 4
      return
300   getstr = - 3
C  end of file
      return
      end
C  of getstr
C  putstr -- put a (possibly packed character) string
      integer function putstr ( lun , line , cc )
      implicit integer ( a - z )
      integer lun , icc
      integer line ( 1 ) , cc , ccc
      logical ispack
      if(.not.( cc .eq. 0 ))goto 23079
      icc = 0
      goto 23080
23079 continue
      icc = 1
23080 continue
      if(.not.( lun .le. 0 .and. icc .eq. 0 ))goto 23081
      icc = 1
      ccc = 32
      goto 23082
23081 continue
      ccc = cc
23082 continue
      if(.not.( .not. ispack ( line ) ))goto 23083
C  the following code handles unpacked strings
      putstr = length ( line )
      if(.not.( lun .le. 0 ))goto 23085
      type 100 , ( ccc , i = 1 , icc ) , ( line ( i ) , i = 1 , putstr )
      goto 23086
23085 continue
      write ( lun , 100 ) ( cc , i = 1 , icc ) , ( line ( i ) , i = 1 , 
     *putstr )
23086 continue
100   format ( r1 , 255 r1 )
C  the following code handles packed strings
      goto 23084
23083 continue
C  here we assume a system-dependent packing rate handled by "a" format
C  "cc" must still be right-adjusted ascii
      putstr = lengp ( line )
      if(.not.( lun .le. 0 ))goto 23087
      type 200 , ( ccc , i = 1 , icc ) , ( line ( i ) , i = 1 , putstr )
      goto 23088
23087 continue
      write ( lun , 200 ) ( cc , i = 1 , icc ) , ( line ( i ) , i = 1 , 
     *putstr )
23088 continue
200   format ( r1 , 255 a )
23084 continue
      return
      end
C  of putstr
C  ptprmt -- put a (possibly packed character) string, with no CR at end
      integer function ptprmt ( lun , line , cc )
      implicit integer ( a - z )
      integer lun , icc
      integer line ( 1 ) , cc , ccc
      logical ispack
      if(.not.( cc .eq. 0 ))goto 23089
      icc = 0
      goto 23090
23089 continue
      icc = 1
23090 continue
      if(.not.( lun .le. 0 .and. icc .eq. 0 ))goto 23091
      icc = 1
      ccc = 32
      goto 23092
23091 continue
      ccc = cc
23092 continue
      if(.not.( .not. ispack ( line ) ))goto 23093
C  the following code handles unpacked strings
      ptprmt = length ( line )
      if(.not.( lun .le. 0 ))goto 23095
      type 100 , ( ccc , i = 1 , icc ) , ( line ( i ) , i = 1 , ptprmt )
      goto 23096
23095 continue
      write ( lun , 100 ) ( cc , i = 1 , icc ) , ( line ( i ) , i = 1 , 
     *ptprmt )
23096 continue
100   format ( r1 , $ , 255 ( r1 , $ ) )
C  the following code handles packed strings
      goto 23094
23093 continue
C  here we assume a system-dependent packing rate handled by "a" format
C  "cc" must still be right-adjusted ascii
      ptprmt = lengp ( line )
      if(.not.( lun .le. 0 ))goto 23097
      type 200 , ( ccc , i = 1 , icc ) , ( line ( i ) , i = 1 , ptprmt )
      goto 23098
23097 continue
      write ( lun , 200 ) ( cc , i = 1 , icc ) , ( line ( i ) , i = 1 , 
     *ptprmt )
23098 continue
200   format ( r1 , $ , 255 ( a , $ ) )
23094 continue
      return
      end
C  of ptprmt
C  ispack -- decide if string is packed characters
      logical function ispack ( str )
      integer str ( 1 )
C  test for content greater than one right-adjusted char
C  such a string is assumed to be an unpacked EOS-terminated character array
      ispack = ( ( str ( 1 ) .and. ( .not. " 377 ) ) .ne. 0 )
C  this will always return "false" on byte systems
      return
      end
C  of ispack
C  lengp -- length of a packed string (returns element count, not character count)
      integer function lengp ( str )
      integer str ( 1 )
C  we hope to find a terminating l.o. zero
      continue
       i = 1
23099 if(.not.(i.le.100))goto 23101
      if(.not.( ( str ( i ) .and. " 177 ) .eq. 0 ))goto 23102
      goto 23101
23102 continue
23100 i=i+1
      goto 23099
23101 continue
      if(.not.( str ( i ) .eq. 0 ))goto 23104
      lengp = i - 1
      goto 23105
23104 continue
      lengp = i
C  this only works on systems where packed chars are packed from h.o. to l.o.
23105 continue
      return
      end
C  of lengp
C  ctoi - convert string at in(i) to integer, increment i
      integer function ctoi ( in , i )
      integer in ( 1 )
      integer indexx
      integer c ( 2 )
      integer d , i
C 	string digits "0123456789"
      integer digits ( 11 )
      data digits / 48 , 49 , 50 , 51 , 52 , 53 , 54 , 55 , 56 , 57 , 0 
     */
      data c ( 2 ) / 0 /
      continue
23106 if(.not.( in ( i ) .eq. 32 .or. in ( i ) .eq. 9 ))goto 23107
      i = i + 1
      goto 23106
23107 continue
      continue
       ctoi = 0
23108 if(.not.(in(i).ne.0))goto 23110
      c ( 1 ) = in ( i )
C  ensure zero-termination
      d = indexx ( digits , c , 1 )
      if(.not.( d .eq. 0 ))goto 23111
C  non-digit
      goto 23110
23111 continue
      ctoi = 10 * ctoi + d - 1
23109 i=i+1
      goto 23108
23110 continue
      return
      end
C  equal - compare str1 to str2; return YES if equal, NO if not
      integer function equal ( str1 , str2 )
      integer str1 ( 1 ) , str2 ( 1 )
      integer i
      continue
       i = 1
23113 if(.not.(str1(i).eq.str2(i)))goto 23115
      if(.not.( str1 ( i ) .eq. 0 ))goto 23116
      equal = 1
      return
23116 continue
23114 i=i+1
      goto 23113
23115 continue
      equal = 0
      return
      end
C  matchs - compare str1 to str2; return YES if equal, NO if not
      integer function matchs ( str1 , str2 )
      integer str1 ( 1 ) , str2 ( 1 )
      integer i , upper
      continue
       i = 1
23118 if(.not.(upper(str1(i)).eq.upper(str2(i))))goto 23120
      if(.not.( str1 ( i ) .eq. 0 ))goto 23121
      matchs = 1
      return
23121 continue
23119 i=i+1
      goto 23118
23120 continue
      matchs = 0
      continue
       j = i
23123 if(.not.(str1(j).ne.0))goto 23125
C scan for all-blank trailer
      if(.not.( str1 ( j ) .ne. 9 .and. str1 ( j ) .ne. 32 ))goto 23126
      return
23126 continue
23124 j=j+1
      goto 23123
23125 continue
      continue
       j = i
23128 if(.not.(str2(j).ne.0))goto 23130
C scan for all-blank trailer
      if(.not.( str2 ( j ) .ne. 9 .and. str2 ( j ) .ne. 32 ))goto 23131
      return
23131 continue
23129 j=j+1
      goto 23128
23130 continue
      matchs = 1
      return
      end
C  stemeq - compare master to another string;
C 	return YES if equal up to length of master, NO if not
C 	return NO if "tested" string is null
C 	compare without regard to case of alphabetics
      integer function stemeq ( master , tested )
      integer master ( 1 ) , tested ( 1 )
      integer i , upper
      continue
       i = 1
23133 if(.not.(upper(master(i)).eq.upper(tested(i))))goto 23135
      if(.not.( master ( i ) .eq. 0 ))goto 23136
      goto 23135
23136 continue
23134 i=i+1
      goto 23133
23135 continue
      if(.not.( i .gt. 1 .and. tested ( i ) .eq. 0 ))goto 23138
      stemeq = 1
      goto 23139
23138 continue
      stemeq = 0
23139 continue
      return
      end
C  itoc - convert integer  int  to char string in  str
      integer function itoc ( int , str , size )
      integer abs , mod
      integer d , i , int , intval , j , k , size
      integer str ( size )
C 	string digits "0123456789"
      integer digits ( 11 )
      data digits / 48 , 49 , 50 , 51 , 52 , 53 , 54 , 55 , 56 , 57 , 0 
     */
      intval = abs ( int )
      str ( 1 ) = 0
      i = 1
      continue
23140 continue
C  generate digits
      i = i + 1
      d = mod ( intval , 10 )
      str ( i ) = digits ( d + 1 )
      intval = intval / 10
23141 if(.not.( intval .eq. 0 .or. i .ge. size ))goto 23140
23142 continue
      if(.not.( int .lt. 0 .and. i .lt. size ))goto 23143
C  then sign
      i = i + 1
      str ( i ) = 45
23143 continue
      itoc = i - 1
      continue
       j = 1
23145 if(.not.(j.lt.i))goto 23147
C  then reverse
      k = str ( i )
      str ( i ) = str ( j )
      str ( j ) = k
      i = i - 1
23146 j=j+1
      goto 23145
23147 continue
      return
      end
C  ftocg -- convert a real number to a character string, using "g" format
      integer function ftocg ( r , str , max0 )
C returns length of "str"
      real r
      integer str ( 1 )
C must be at least "max+1"
      integer max0
      integer scopy , type
      integer pstr ( 21 )
C "packed" internal character string
      encode ( 20 , 100 , pstr ) r
100   format ( g )
C default g size
      call unpack ( pstr , str , max0 )
      continue
       i = 1
23148 if(.not.(i.le.max0.and.str(i).ne.46))goto 23150
C  find decimal point
23149 i=i+1
      goto 23148
23150 continue
      continue
       i = i + 1
23151 if(.not.(i.le.max0.and.type(str(i)).eq.2))goto 23153
C  find first non-digit
23152 i=i+1
      goto 23151
23153 continue
      continue
       j = i - 1
23154 if(.not.(j.gt.0.and.str(j).eq.48))goto 23156
C  find least significant digit
23155 j=j-1
      goto 23154
23156 continue
      call scopy ( str ( i ) , str ( j + 1 ) )
C remove trailing zeros!
      continue
       i = 1
23157 if(.not.(i.le.max0.and.str(i).eq.32.and.str(i).ne.0))goto 23159
C  find first non-blank
23158 i=i+1
      goto 23157
23159 continue
      continue
       ftocg = scopy ( str ( i ) , str )
23160 if(.not.(str(ftocg).eq.32))goto 23162
      str ( ftocg ) = 0
C eliminate the blanks
C  the following is validation code that could be removed
23161 ftocg=ftocg-1
      goto 23160
23162 continue
      i = length ( str )
      if(.not.( i .ne. ftocg .or. i .gt. max0 ))goto 23163
      stop'RATLIB -- error in FTOCG'
23163 continue
      return
      end
C  strsub -- substitute an argument value for "%%" in a string
      integer function strsub ( instr , inouts , arg , type , maxl )
C  returns length of new string
      integer instr ( 1 ) , inouts ( 1 ) , type
C character/integer/real "arg" -- depending upon "type"
      integer maxl
      integer scopy , scopyl , length , indexx , itoc , ftocg , splice
      integer work ( 31 )
      integer pp , sl , l
      integer perper(3)
      integer errstr(8)
      data perper /37,37,0/
      data errstr /42,42,69,82,82,42,42,0/
C if "instr" is not a null string, first copy it to "inouts",
C -- else use "inouts" as-is
      if(.not.( instr ( 1 ) .ne. 0 ))goto 23165
      call scopyl ( instr , inouts , maxl )
23165 continue
      pp = indexx ( inouts , perper , 1 )
      if(.not.( pp .eq. 0 ))goto 23167
      l = length ( inouts )
      pp = l + 1
C if no "%%" found, put it at end
      goto 23168
23167 continue
      i = scopy ( inouts ( pp + 2 ) , inouts ( pp ) )
C remove the "%%"
      l = pp + i - 1
23168 continue
      if(.not.( type .eq. 0 .or. type .eq. 99 .or. type .eq. 115 ))goto 
     *23169
C "c"haracter "s"tring
      sl = length ( arg )
      if(.not.( sl + l .le. maxl ))goto 23171
C see if it fits
      strsub = splice ( inouts , arg , pp )
      goto 23172
23171 continue
C if it won't fit, copy what will fit up to "work" length
      call scopyl ( arg , work , min0 ( 30 , maxl - l ) )
      strsub = splice ( inouts , work , pp )
23172 continue
      goto 23170
23169 continue
      if(.not.( type .eq. 105 ))goto 23173
C "i"nteger
      call itoc ( arg , work , 30 )
      call scopyl ( work , work , maxl - l )
C truncate it if too big
      strsub = splice ( inouts , work , pp )
      goto 23174
23173 continue
      if(.not.( type .eq. 102 .or. type .eq. 114 ))goto 23175
C "f"loating point or "r"eal
      call ftocg ( arg , work , 30 )
      call scopyl ( work , work , maxl - l )
C truncate it if too big
      strsub = splice ( inouts , work , pp )
      goto 23176
23175 continue
C error, unrecognized type
      call scopyl ( errstr , work , maxl - l )
      strsub = splice ( inouts , work , pp )
C  the following is validation code that could be removed
23176 continue
23174 continue
23170 continue
      i = length ( inouts )
      if(.not.( i .ne. strsub .or. i .gt. maxl ))goto 23177
      stop'RATLIB -- error in STRSUB'
23177 continue
      return
      end
C  putdec - put decimal integer  n  in field width >= w
      subroutine putdec ( n , w , fd )
      integer chars ( 20 )
      integer itoc
      integer i , n , nd , w , fd
      nd = itoc ( n , chars , 20 )
      continue
       i = nd + 1
23179 if(.not.(i.le.w))goto 23181
      call putch ( 32 , fd )
23180 i=i+1
      goto 23179
23181 continue
      continue
       i = 1
23182 if(.not.(i.le.nd))goto 23184
      call putch ( chars ( i ) , fd )
23183 i=i+1
      goto 23182
23184 continue
      return
      end
C  splice - splice a string into the middle of another string
      integer function splice ( inout , in , pos )
      integer inout ( 1 ) , in ( 1 )
      integer pos
      integer c
      integer l1 , l2 , tpos , length
      l1 = length ( inout )
      l2 = length ( in )
      tpos = min0 ( l1 + 1 , max0 ( 1 , pos ) )
C  move tail end to make room
      continue
       i = l1 + l2 + 1
23185 if(.not.(i.ge.tpos+l2))goto 23187
      inout ( i ) = inout ( i - l2 )
23186 i=i-1
      goto 23185
23187 continue
      c = inout ( tpos + l2 )
C  save first, it will get clobbered
      call scopy ( in , inout ( tpos ) )
C  get insert
      inout ( tpos + l2 ) = c
C  restore it
      splice = l1 + l2
C  return length
      return
      end
C  strpqt -- strip quotes from a quoted string
      integer function strpqt ( str , qt )
      implicit integer ( a - z )
      integer str ( 1 ) , qt
      if(.not.( str ( 1 ) .ne. qt ))goto 23188
      strpqt = - 1
      return
23188 continue
      i = 2
      j = 1
      continue
23190 continue
      if(.not.( str ( i ) .eq. qt ))goto 23193
      i = i + 1
23193 continue
      str ( j ) = str ( i )
      if(.not.( str ( i ) .eq. 0 ))goto 23195
      goto 23192
23195 continue
      i = i + 1
      j = j + 1
23191 goto 23190
23192 continue
      strpqt = j - 1
      return
      end
C  of strpqt
C  puttyp -- add file type to end of file name if not specified
      integer function puttyp ( innam , outnam , type )
C return length of result
      integer innam ( 1 ) , outnam ( 1 ) , type ( 1 )
      logical indir , typfnd
      integer c
      integer scopy
      indir = . false .
      typfnd = . false .
      continue
       i = 1
23197 if(.not.(innam(i).ne.0))goto 23199
      c = innam ( i )
      outnam ( i ) = c
C  copy over while looking
      if(.not.( c .eq. 60 .or. c .eq. 91 ))goto 23200
      indir = . true .
      goto 23201
23200 continue
      if(.not.( c .eq. 62 .or. c .eq. 93 ))goto 23202
      indir = . false .
      goto 23203
23202 continue
      if(.not.( c .eq. 46 .and. .not. indir ))goto 23204
      typfnd = . true .
23204 continue
23203 continue
23201 continue
23198 i=i+1
      goto 23197
23199 continue
      outnam ( i ) = 0
      if(.not.( .not. typfnd .and. i .gt. 1 ))goto 23206
      l = scopy ( type , outnam ( i ) )
C  add type to end if none found
      goto 23207
23206 continue
      l = 0
23207 continue
      puttyp = i - 1 + l
C return the length
      return
      end
C  openio -- open input and output files after obtaining names from user
      logical function openio ( in , out )
      implicit integer ( a - z )
      integer in , out
C  lun's
      integer buf ( 101 )
      logical openf
      openio = . false .
      type 100
100   format (' file>' , $ )
      if(.not.( getstr ( 0 , buf , 100 ) .le. 0 ))goto 23208
      return
C  error
23208 continue
      i = indexx ( buf ,'=' , 2 )
      if(.not.( i .ne. 0 ))goto 23210
      buf ( i ) = 0
23210 continue
      if(.not.( .not. openf ( in , buf ( i + 1 ) , 2 ) ))goto 23212
      goto 999
23212 continue
      if(.not.( .not. openf ( out , buf , 1 ) ))goto 23214
      goto 888
23214 continue
      openio = . true .
C  good return, both open
      return
999   type 200
200   format (' error in opening file:' )
      call putstr ( 0 , buf ( i + 1 ) , 32 )
      return
888   type 200
      call putstr ( 0 , buf , 32 )
      return
      end
C  type - return LETTER, DIGIT or character
C  this one works with ascii alphabet
      integer function type ( c )
      integer c
      if(.not.( c .ge. 48 .and. c .le. 57 ))goto 23216
      type = 2
      goto 23217
23216 continue
      if(.not.( c .ge. 97 .and. c .le. 122 ))goto 23218
      type = 1
      goto 23219
23218 continue
      if(.not.( c .ge. 65 .and. c .le. 90 ))goto 23220
      type = 1
      goto 23221
23220 continue
      type = c
23221 continue
23219 continue
23217 continue
      return
      end
C  setup -- issue GIGI terminal setup commands
      subroutine setup ( str )
      implicit integer ( a - z )
      integer str ( 1 ) , esc , bs
      logical ispack
      data esc , bs / 155 , 92 /
      if(.not.( .not. ispack ( str ) ))goto 23222
      type 100 , esc , ( str ( i ) , i = 1 , length ( str ) ) , esc , bs
      goto 23223
23222 continue
      type 200 , esc , ( str ( i ) , i = 1 , lengp ( str ) )
      type 300 , esc , bs
23223 continue
100   format ('+' , r1 ,'Pr' , 255 ( r1 , $ ) )
200   format ('+' , r1 ,'Pr' , 255 ( a , $ ) )
300   format ('+' , 2 r1 , $ )
      return
      end
C  escseq -- send an escape sequence
      subroutine escseq ( str )
      implicit integer ( a - z )
      integer str ( 1 ) , esc
      logical ispack
      data esc / 155 /
      if(.not.( .not. ispack ( str ) ))goto 23224
      type 100 , esc , ( str ( i ) , i = 1 , length ( str ) )
      goto 23225
23224 continue
      type 200 , esc , ( str ( i ) , i = 1 , lengp ( str ) )
23225 continue
100   format ('+' , 255 ( r1 , $ ) )
200   format ('+' , 255 ( a , $ ) )
      return
      end
C  pack - convert an unpacked character string to most packed format
      integer function p a c k ( from , to )
      integer from ( 1 )
      integer to ( 32767 )
      l = length ( from )
C  "from" is in our right adjusted internal form
      encode ( l + 1 , 100 , to ) ( from ( i ) , i = 1 , l + 1 )
C  carry zero over
100   format ( 255 r1 )
      p a c k = l
      return
      end
C  of pack
C  unpack - convert a packed character string to internal format
      integer function u n p a c k ( from , to , l )
      implicit integer ( a - z )
      integer from ( 1 ) , to ( 1 )
      integer l
C  number of characters (or neg to let us determine it)
      integer length , lengp
      if(.not.( l .lt. 0 ))goto 23226
      len = lengp ( from ) * 5
      goto 23227
23226 continue
      len = l
23227 continue
      decode ( len , 100 , from ) ( to ( i ) , i = 1 , len )
100   format ( 255 r1 )
      to ( len + 1 ) = 0
C  "to" is in internal format
      u n p a c k = length ( to )
      return
      end