c %W% %G%
c***** begin text file README_genchar ****************************************
c
c
c              Installation of the Gen_Char susbsystem of
c              ODDF  (Object_Description_Data_File)
c
c               version  1.5.1       April, 1996
c
c
c
c In general your Fortran-77 compiler must support the non-ANSI constructs:
c
c 1)   lowercase alphabet.
c
c 2)   Statements consisting of:   <horiz_tab>    statement body
c
c
c  Known operating system dependencies:  none.
c  Software dependencies:  none.
c
c
c
c                     Author and Technical contact
c
c  This system is written in Fortran-77 with selected mil-spec upgrades and
c  designed for easy transport.  If you have any questions, comments, or 
c  transport problems please contact:
c
c    Mike Webring
c    U S Geological Survey,  mail stop 964
c    Denver Federal Center
c    Denver CO 80225
c
c
c  Internet address:  mwebring@musette.cr.usgs.gov
c
c  phone:  (303) 236-1392
c
c
c***** end text file *********************************************************
c @(#)gcaptx.f	1.3 03/22/96
c***************************************************************************** 
	subroutine gcaptx( old, new, nchold )

c  General_Character_APpend_TeXt.

	character old*(*), new*(*)

	len1 = len( old )
	len2 = len( new )

	do 10 ie1 = len1, 1, -1
	  ic = ichar( old(ie1:ie1) )
	  if ( ic .ne. 32  .and.  ic .ne. 0 ) go to 20
10	continue
	ie1 = 0

20	do 30 ie2 = len2, 1, -1
	  ic = ichar( new(ie2:ie2) )
	  if ( ic .ne. 32  .and.  ic .ne. 0 ) go to 40
30	continue
	nchold = ie1
	go to 999

40	is     = ie1 + 1
	ie     = ie1 + ie2
	if ( ie .gt. len1 ) ie = len1
	if ( is .gt. ie   ) go to 999

	old(is:ie) = new(1:ie2)
	nchold     = ie

999	return
	end
c @(#)gccvc.f	1.3 03/22/96
c*****************************************************************************
	subroutine gccvc( a, i2 )

c  General_Character_ConVert_Case.
c
c  a to z are modified to all upper or lower case.
c
c  i2 = 1 for uppercase output.
c  i2 = 2 for lowercase output.


	dimension  ilb(2), iub(2), icv(2)
	character  a*(*)

	data      ilb/97,65/, iub/122,90/, icv/-32,+32/

	n = len( a )

	if ( i2 .eq. 1   .or.   i2 .eq. 2 ) then

	  do 10 i = 1, n
	    j      = ichar( a(i:i) )
	    if ( j .lt. ilb(i2)   .or.   j .gt. iub(i2) ) go to 10
	    j      = j + icv(i2)
	    a(i:i) = char(j)
10	  continue

	else

	  print *, ' %%gccvc: invalid convert parameter'

	endif

999	return
	end
c @(#)gclast.f	1.3 03/22/96
c*****************************************************************************
	subroutine gclast( a, lastch )

c  General_Character_LAST.
c  Return the position of the last non-blank character.

	character  a*(*)
	character  blk*1

	blk    = ' '
	na     = len( a )
	lastch = 0

	do 10 i = na, 1, -1
	  if ( a(i:i) .ne. blk ) then
	    lastch = i
	    go to 999
	  endif
10	continue

999	return
	end
c @(#)gcleft.f	1.3 03/22/96
c*****************************************************************************
	subroutine gcleft( a, nchar )

c  (General_Character)_LEFT_justify.
c
c  Left justifies a string and returns the position
c  of the last nonblank character.  This routine considers
c  nulls (char zero) to be a blank.

	character a*(*)

	n     = len( a )
	nchar = 0

	if ( n .lt. 1  .or.  n .gt. 65535 ) go to 999


c  Position of first character.

	is  = 1
	ich = ichar( a(is:is) )

	if ( ich .eq. 0  .or.  ich .eq. 32 ) then
	  do 1 is = 2, n
	    ich = ichar( a(is:is) )
	    if ( ich .ne. 0  .and.  ich .ne. 32 ) go to 5
1	  continue
	  nchar = 0
	  go to 999
	endif


c  Position of last character.

5	continue
	do 10 ie = n, is, -1
	    ich = ichar( a(ie:ie) )
	    if ( ich .ne. 0  .and.  ich .ne. 32 ) go to 15
10	continue


c  Left justify.

15	nchar = ie - is + 1

	j = is - 1
	do 20 i = 1, nchar
	  j      = j + 1
	  a(i:i) = a(j:j)
20	continue

	do 30 i = nchar + 1, ie
	  a(i:i) = ' '
30	continue


999	return
	end
c @(#)gcnthw.f	1.3 03/22/96
c*****************************************************************************
	subroutine gcnthw( txtrec, nthwrd, isch, wrd, nchwrd )

c  General_Character_NTH_Word.
c
c  Return nth word in the string.  Routine cannot handle a very long
c  txtrec where the desired word is more than 256 characters from the
c  beginning.
c
c  calls subroutines :  gcnxtw.

	character   work*256, txtrec*(*), wrd*(*)

	nwork  = len( work )
	ntxt   = len( txtrec )

	ibegtx = 1
	iendtx = ntxt
	if ( nwork .lt. ntxt ) iendtx = nwork

	call gclast( txtrec, lasttx )
	
	do 10 i = nthwrd

	  work = ' '
	  work = txtrec(ibegtx:iendtx)

	  call gcnxtw( work, isch, wrd, nchwrd )

	  if ( nchwrd .eq. 0 ) then
	    isch  = 0
	    wrd   = ' '
	    go to 999
	  endif

	  ibegtx = isch + nchwrd
10	continue

999	return
	end
c @(#)gcnxtw.f	1.3 03/22/96
c*****************************************************************************
	subroutine gcnxtw( txtrec, isch, wrd, nchwrd )

c  General_Character_NeXT_Word.
c
c  Return the next word, its length, and the starting character
c  location in txtrec.
c
c    For this subroutine "word" is defined as the first contiguous
c  set of characters which is bounded by spaces, control_characters,
c  or the limits of the input string.

	character  txtrec*(*), wrd*(*)

	ntxt   = len( txtrec )
	nwrd   = len( wrd )
	isch   = 0
	nchwrd = 0
	wrd    = ' '

c  Find the first printing character.

	do 10 i = 1, ntxt
	  itest = ichar( txtrec(i:i) )
	  if ( itest .gt. 32  .and.  itest .lt. 127 ) then
	    isch = i
	    go to 20
	  endif
10	continue

c  No printing characters so exit.

	go to 999


c  Find the end printing character.

20	do 50 i = isch, ntxt
	  itest = ichar( txtrec(i:i) )
	  if ( itest .le. 32  .or.  itest .ge. 127 ) then
	    iech = i - 1
	    go to 100
	  endif
50	continue
	iech = ntxt

c  If the word is longer than WRD, then return specs but do not
c  transfer characters.

100	nchwrd = iech - isch + 1
	if ( nchwrd .gt. nwrd ) go to 999

	wrd = txtrec(isch:iech)

999	return
	end
c @(#)gcpalf.f	1.3 03/22/96
c*****************************************************************************
	subroutine gcpalf( txtrec, ipos )

c  General_Character_Position_ALFa_character.
c
c  Return the position of the first alphabetic character.
c  Includes: A to Z, a to z, and '_' (underscore).

	character txtrec*(*)

	ntxt   = len( txtrec )
	ipos  = 0

	do 50 i = 1, ntxt

	  itest = ichar( txtrec(i:i) )

c  Upper case.

	  if ( itest .ge. 65  .and.  itest .le. 90 ) then
	    ipos = i
	    go to 999
	  endif

c  Lower case.

	  if ( itest .ge. 97  .and.  itest .le. 122 ) then
	    ipos = i
	    go to 999
	  endif

c  Under_score.

	  if ( itest .eq. 95 ) then
	    ipos = i
	    go to 999
	  endif

50	continue

999	return
	end
c @(#)gcpaln.f	1.3 03/22/96
c*****************************************************************************
	subroutine gcpaln( txtrec, ipos )

c  General_Character_Position_ALpha_Numeric.
c
c  Return the position of the first alphanumeric character.
c  Alphanumeric includes:  0 to 9,  A to Z,  the underscore,  and  a to z.
c
c  call subroutines : none.

	character txtrec*(*)

	ntxt   = len( txtrec )
	ipos  = 0

	do 50 i = 1, ntxt

c  Get the character number from the ASCII encoding sequence.

	  itest = ichar( txtrec(i:i) )

c  Numeral.

	  if ( itest .ge. 48  .and.  itest .le. 57 ) then
	    ipos = i
	    go to 999
	  endif

c  Upper case.

	  if ( itest .ge. 65  .and.  itest .le. 90 ) then
	    ipos = i
	    go to 999
	  endif

c  Under_score.

	  if ( itest .eq. 95 ) then
	    ipos = i
	    go to 999
	  endif

c  Lower case.

	  if ( itest .ge. 97  .and.  itest .le. 122 ) then
	    ipos = i
	    go to 999
	  endif

50	continue

999	return
	end
c @(#)gcpct.f	1.3 03/22/96
c*****************************************************************************
	subroutine gcpct( txtrec, ipos )

c  General_Character_Position_ConTrol.
c
c  Position of the first control character.

	character txtrec*(*)

	ipos = 0
	ntxt = len( txtrec )

	do 10 i = 1, ntxt
 	  if ( ichar( txtrec(i:i) ) .lt. 32 ) then
	    ipos = i
	    go to 999
	  endif
10	continue

999	return
	end
c @(#)gcpnal.f	1.3 03/22/96
c*****************************************************************************
	subroutine gcpnal( txtrec, ipos )

c  General_Character_Position_Non_ALf_numeric.
c
c  Return the position of the first non-alphanumeric character.
c  Alphanumeric includes (in the order they appear in the ASCII sequence):
c  0 to 9,  A to Z,  the underscore,  and  a to z.
c
c  calls subroutines: none.

	character txtrec*(*)

	ntxt   = len( txtrec )
	ipos  = 0

	do 50 i = 1, ntxt

c  Get character number from the ASCII encoding sequence.

	  itest = ichar( txtrec(i:i) )

c  Before numeral or after lowercase (completly outside the range).

	  if ( itest .lt. 48  .or.  itest .gt. 122 ) then
	    ipos = i
	    go to 999
	  endif

c  Between numerals and upper case.

	  if ( itest .gt. 57  .and.  itest .lt. 65 ) then
	    ipos = i
	    go to 999
	  endif

c  Beween upper case and under_score.

	  if ( itest .gt. 90  .and.  itest .lt. 95 ) then
	    ipos = i
	    go to 999
	  endif

c  Beween under_score and lower case.

	  if ( itest .gt. 95  .and.  itest .lt. 97 ) then
	    ipos = i
	    go to 999
	  endif

50	continue

999	return
	end
c @(#)gcrf4.f	1.5 03/22/96
c*****************************************************************************
	subroutine gcrf4( val, fval, ierror )

c  General_Character_Read_Float_4.
c
c  Read the next word into float_4 variable, avoiding the
c  construct:    read( val, * ) fval.
c
c  In case of error, FVAL is set a very large, but ordinary
c  number and IERROR not-zero.
c
c  Calls subroutine:  gcnxtw.

	real*4            amnmx
	double precision  dptmp

	character         fmt*16, valwrd*24
	character*1       expf(4)
	character         val*(*)

c  Approximate_Min_Max, for generality this number should be fairly
c  close to the min max for a particular hardware implementation.
c  IEEE encoding has a limit on the order of +- 3.402823e38.

	amnmx  = 3.4e38

	ierror = 1
	fval   = amnmx

	fltbig = 1.0 * amnmx


c  Find the next word.

	call gcnxtw( val, isch, valwrd, nchval )

	if ( nchval .le. 0  .or.  nchval .gt. 24 ) then
	  go to 999
	endif


c Test for exponential form   1.0e+38 or 1.0d+38.

	expf(1) = char( 68 )
        expf(2) = char( 69 )
	expf(3) = char( 100 )
        expf(4) = char( 101 )

	iexpf  = 0
	idpexp = 0

	do 10 i = 1, 4
	  k = index( valwrd, expf(i) )
	  if ( k .ge. 1  .and.  k .lt. nchval ) then
	    iexpf = 1
	    if ( i .eq. 1  .or.  i .eq. 3 ) idpexp = 1
	  endif
10	continue


c  Compilers have many combinations of 'err=', 'iostat=', and returned
c  'ftmp'.  Catching the spurious ones is a losing battle...
 
c  Read via wwww.fff.

	if ( iexpf .eq. 0 ) then

	  if ( nchval .lt. 10 ) then
	    write( fmt, 61 ) nchval
61	    format( '( f', i1, '.0 )'  )
	  else
	    write( fmt, 62 ) nchval
62	    format( '( f', i2, '.0 )'  )
	  endif

	  read( valwrd(1:nchval), fmt, err=999, iostat=ios ) ftmp
	  if ( ios .ne. 0 ) go to 999

          if ( nchval .gt. 10 ) then
            print *, ' gcrf4 warning: too many digits'
            print *, ' >>', valwrd(1:nchval), '<<'
          endif

	endif


c  Exponential form.

	if ( iexpf .eq. 1 ) then
	
	  if ( idpexp .eq. 0 ) then

	    if ( nchval .lt. 10 ) then
	      write( fmt, 121 ) nchval
121	      format( '( e', i1, '.0 )'  )
	    else
	      write( fmt, 122 ) nchval
122	      format( '( e', i2, '.0 )'  )
	    endif

            read( valwrd(1:nchval), fmt, err=999, iostat=ios ) ftmp
            if ( ios .ne. 0 ) go to 999

	  else

            if ( nchval .lt. 10 ) then
              write( fmt, 131 ) nchval
131           format( '( d', i1, '.0 )'  )
            else
              write( fmt, 132 ) nchval
132           format( '( d', i2, '.0 )'  )
            endif

	    read( valwrd(1:nchval), fmt, err=999, iostat=ios ) dptmp
	    if ( ios .ne. 0 ) go to 999

	    ftmp = sngl( dptmp )

          endif

          if ( nchval .gt. 16 ) then
            print *, ' gcrf4 warning: too many digits'
            print *, ' >>', valwrd(1:nchval), '<<'
          endif

	endif


c  Check that FTMP is inside a reasonable range before assignment. 
c  Specifically; NaN, +INF, and, -INF are disallowed.

        if ( ftmp .gt. -fltbig  .and.  ftmp .lt. fltbig ) then
	  fval   = ftmp
	  ierror = 0
        endif


999	return
	end
c @(#)gcrf8.f	1.5 03/22/96
c*****************************************************************************
	subroutine gcrf8( val, fval, ierror )

c  General_Character_Read_Float_8.
c
c  Read the next word into float_8 variable, avoiding the
c  construct:    read( val, * ) fval.
c
c  In case of error, FVAL is set to a very large, but ordinary
c  number and IERROR not-zero.
c
c  This routine is a derivative of gcrf4.
c
c  Calls subroutine:  gcnxtw.

	real*8            amnmx
	double precision  fval, fltbig, ftmp, dptmp
	real*4            sptmp
	character         fmt*16, valwrd*24
	character*1       expf(4)
	character         val*(*)


c  Approximate_Min_Max, for generality this number should be fairly 
c  close to the min max for a particular hardware implementation.
c  IEEE encoding has a limit on the order of +- 3.402823e38.

	amnmx = 3.4d38

	ierror = 1
	fval   = amnmx

	fltbig = 1.0d0 * amnmx


c  Find the next word.

	call gcnxtw( val, isch, valwrd, nchval )

	if ( nchval .le. 0  .or.  nchval .gt. 24 ) then
	  go to 999
	endif


c Test for exponential form   1.0e+38 or 1.0d+38.

	expf(1) = char( 68 )
        expf(2) = char( 69 )
	expf(3) = char( 100 )
        expf(4) = char( 101 )

	iexpf  = 0
	idpexp = 0

	do 10 i = 1, 4
	  k = index( valwrd, expf(i) )
	  if ( k .ge. 1  .and.  k .lt. nchval ) then
	    iexpf = 1
	    if ( i .eq. 1  .or.  i .eq. 3 ) idpexp = 1
	  endif
10	continue


c  Compilers have many combinations of 'err=', 'iostat=', and returned
c  'ftmp'.  Catching the spurious ones is a losing battle...
 
c  Read via wwww.fff.

	if ( iexpf .eq. 0 ) then

	  if ( nchval .lt. 10 ) then
	    write( fmt, 61 ) nchval
61	    format( '( f', i1, '.0 )'  )
	  else
	    write( fmt, 62 ) nchval
62	    format( '( f', i2, '.0 )'  )
	  endif

	  read( valwrd(1:nchval), fmt, err=999, iostat=ios ) ftmp
	  if ( ios .ne. 0 ) go to 999

	endif


c  Exponential form.

	if ( iexpf .eq. 1 ) then
	
	  if ( idpexp .eq. 0 ) then

	    if ( nchval .lt. 10 ) then
	      write( fmt, 121 ) nchval
121	      format( '( e', i1, '.0 )'  )
	    else
	      write( fmt, 122 ) nchval
122	      format( '( e', i2, '.0 )'  )
	    endif

            read( valwrd(1:nchval), fmt, err=999, iostat=ios ) sptmp
            if ( ios .ne. 0 ) go to 999

	    ftmp = dble( sptmp )

            if ( nchval .gt. 16 ) then
              print *, ' gcrf8 warning: too many digits for E form'
              print *, ' >>', valwrd(1:nchval), '<<'
            endif

	  else

            if ( nchval .lt. 10 ) then
              write( fmt, 131 ) nchval
131           format( '( d', i1, '.0 )'  )
            else
              write( fmt, 132 ) nchval
132           format( '( d', i2, '.0 )'  )
            endif

	    read( valwrd(1:nchval), fmt, err=999, iostat=ios ) dptmp
	    if ( ios .ne. 0 ) go to 999

	    ftmp = dptmp

          endif

	endif


c  Check that FTMP is inside a reasonable range before assignment. 
c  Specifically; NaN, +INF, and, -INF are disallowed.  Note that exponents
c  beyond d+38 are disallowed for transportability.

        if ( ftmp .gt. -fltbig  .and.  ftmp .lt. fltbig ) then
	  fval   = ftmp
	  ierror = 0
        endif


999	return
	end
c @(#)gcri4.f	1.4 04/05/96
c*****************************************************************************
	subroutine gcri4( val, ival, ierror )

c  General_Character_Read_Integer_4.
c
c  Read the next word into integer_4 variable, avoiding the
c  construct:    read( val, * ) ival.
c
c  In case of error, ival is set to very large number and ierror .ne. 0
c
c  Calls subroutines : gcnxtw.

	character  fmt*16, valwrd*16, val*(*)

c  Default ival is very close to the maximum int_4.

	ival   = 2147483647
	ierror = 1

c  Get next word.

	call gcnxtw( val, isch, valwrd, nchval )

	if ( nchval .le. 0  .or.  nchval .gt. 11 ) then
	  go to 999
	endif

c  Prepare format.

	if ( nchval .lt. 10 ) then
	  write( fmt, 20 ) nchval
20	  format( '( i', i1, ' )'  )
	else
	  write( fmt, 21 ) nchval
21	  format( '( i', i2, ' )'  )
	endif

c  Internal read.

	read( valwrd(1:nchval), fmt, err=999, iostat=ios ) itmp
	if ( ios .ne. 0 ) go to 999

	ival   = itmp
	ierror = 0


999	return
	end
c @(#)gcrite.f	1.3 03/22/96
c*****************************************************************************
	subroutine gcrite( a, istart )

c  (General_Character)_RITE(right)_justify.
c
c  Right justify a string and return the starting index.

	character a*(*)

	na     = len( a )
	istart = 0


c  Find the first nonblank character.

	do 10 is = 1, na
	  if ( a(is:is) .ne. ' ' ) go to 20
10	continue
	go to 999


c  Input is a nonblank string, now find the last character.

20	continue
	do 30 ie = na, 1, -1
	  if ( a(ie:ie) .ne. ' ' ) go to 40
30	continue


c  Right justify the string.

40	i2 = na + 1

	do 50 i = ie, is, -1
	  i2       = i2 - 1
	  a(i2:i2) = a(i:i)
50	continue

	istart = i2

c  Remove the characters from the old start up to the new start.

	nblank = istart - 1
	do 60 i = is, nblank
	  a(i:i) = ' '
60	continue

999	return
	end
c @(#)gcrpcc.f	1.1 03/22/96
c*****************************************************************************
	subroutine gcrpcc( txtrec )

c  General_Character_RePlace_C_style_Comments.
c
c  Replace comments including delimiters with blanks.  The delimitors
c  /* and */ are operated on regardless of the presence of quoted test.
c
c  For example:
c  description = "This variable /* which one? */ is ambiguous."
c  would be returned as:
c  description = "This variable                  is ambiguous."
c
c  Three forms are recognized:
c
c  1)   [any_characters]  /*  [comment_text]  */  [any_characters]
c
c  1)   BOT [comment_text]  */ [any_characters]
c
c  3)   [any_characters]  /*  [comment_text]  EOT
c
c  where 2 and 3 are for when truncated or continued text exists in TXTREC.
c
c  calls subroutines : none.
c  uses include file : none.

	character   txtrec*(*)
	character   coms*2,  come*2

	ntxt = len( txtrec )

	coms = '/*'
	come = '*/'

	npair  = 0
	mxpair = ntxt / 4


c  Do while there is text.

	istart = 1
10	if ( istart .lt. ntxt ) then


c  Find relative adresses of comment delimiters.

	  icoms = index( txtrec(istart:ntxt), coms )
          icome = index( txtrec(istart:ntxt), come )

c  If neither exist, then exit.

	  if ( icoms .le. 0  .and.  icome .le. 0 ) go to 999

c  If both exist, but */ is before /*, then ignore /* for now.

	  if ( ( icoms .gt. 0  .and.  icome .gt. 0 )  .and.
     1    ( icome .lt. icoms  )  )  icoms = 0


c  Set delete range with absolute adresses.
c  Note IDELE points to the '/' character.

	  if ( icoms .le. 0 ) then
	    idels = istart
	  else
	    idels = icoms + ( istart - 1 )
	  endif

	  if ( icome .le. 0 ) then
            idele = ntxt
	  else
	    idele = icome + ( istart - 1 ) + 1
	  endif


c  Replace with blanks.

	  do 30 i = idels, idele
	    txtrec(i:i) = ' '
30	  continue


c  Prepare to cycle back.

	  istart = idele + 1

	  npair  = npair + 1
	  if ( npair .le. mxpair ) go to 10
	endif


999	return
	end
c @(#)gcrpcm.f	1.3 03/22/96
c*****************************************************************************
	subroutine gcrpcm( txtrec )

c  General_Character_RePlace_CoMma.
c  Replace all commas with blank.

	character   txtrec*(*)

	ntxt = len( txtrec )

	do 20 i = 1, ntxt
	  if ( txtrec(i:i) .eq. ',' ) txtrec(i:i) = ' '
20 	continue

	return
	end
c @(#)gcrpct.f	1.3 03/22/96
c*****************************************************************************
	subroutine gcrpct( txtrec )

c  General_Character_RePlace_ConTrol.
c
c  Replace all characters less than ASCII 32 (base10) with ASCII 32.

	character   txtrec*(*)

	ntxt = len( txtrec )

	do 20 i = 1, ntxt
	  ichr = ichar( txtrec(i:i) )
	  if ( ichr .lt. 32 ) txtrec(i:i) = ' '
20 	continue

	return
	end
c @(#)gcrplt.f	1.3 03/22/96
c*****************************************************************************
	subroutine gcrplt( txtrec, nopair )

c  General_Character_RePlace_LiTerals.
c
c  Remove all literal contents by changing every character between
c  paired ", ', and ` (inclusive) to blank.
c  The order should be such that the string delimiter is removed first
c  then second and third passes are made just in case on the other
c  possibilies.
c  Unpaired primary delimiters are a problem.  It is best to ensure
c  txtrec has paired delimiters.

	character quote*1, txtrec*(*)

	nopair = 0
	ntxt   = len( txtrec )

	do 100 icycle = 1, 3

c  Primary:34=char( '"' ), secondaries:39=char( ''' ),  96=char( '`' )

	  if ( icycle .eq. 1 ) quote = char( 34 )
	  if ( icycle .eq. 2 ) quote = char( 39 )
	  if ( icycle .eq. 3 ) quote = char( 96 )
	  is    = 1
	  idone = 0

c  Begin idone block (do while).

10	  if ( idone .eq. 0 ) then

	    iq1 = index( txtrec(is:ntxt), quote )

c  Begin quote_exist block

	    if ( iq1 .eq. 0 ) then
	      idone = 1
	    else
	      iq1p = iq1 + 1
	      iq2 = index( txtrec(iq1p:ntxt), quote )

c  If primary delimiter is unpaired assume it is continued on another
c  text record,  blank out to the end of txtrec, and return.

	      if ( icycle .eq. 1 ) then
	        if ( iq1 .ne. 0  .and.  iq2 .eq. 0 ) then
	          iq2    = ntxt
	          nopair = 1
	          idone  = 1
	        endif
	      endif

	      do 20 i = iq1, iq2
	        txtrec(i:i) = ' '
20	      continue
	      is = max( iq1, iq2 )

	    endif
c  End quote_exist block.

	    go to 10
	  endif
c  End idone block.

100	continue

999	return
	end
c @(#)gcrpnp.f	1.4 03/22/96
c*****************************************************************************
	subroutine gcrpnp( txtrec )

c  General_Character_RePlace_Non-Printing.
c
c  Replace all characters less than ASCII 32 (base10) exclusive of the 
c  print control characters or greater than ASCII 126 with spaces.

	character   txtrec*(*)

	ntxt = len( txtrec )

	do 20 i = 1, ntxt

	  ich = ichar( txtrec(i:i) )

	  if ( ich .ge. 32  .and.  ich .le. 126 ) go to 20

	  if ( ich .ge. 8   .and.  ich .le. 13  ) go to 20

	  txtrec(i:i) = ' '

20 	continue

	return
	end
c @(#)gcrpnv.f	1.2 03/22/96
c*****************************************************************************
	subroutine gcrpnv( txtrec )

c  General_Character_RePlace_Not_Visible.
c
c  Replace all characters less than ASCII 32 (base10) or
c  greater than ASCII 126  (ie. ! to ~ inclusive) with ASCII 32.
c  The space is deemed a visible character.
c
c  The routine GCRPNP accepts chars 8 to 13 (print controls) in addition
c  to 32 to 126.

	character   txtrec*(*)

	ntxt = len( txtrec )

	do 20 i = 1, ntxt
	  ich = ichar( txtrec(i:i) )
	  if ( ich .lt. 32  .or.  ich .gt. 126 ) txtrec(i:i) = ' '
20 	continue

	return
	end
c @(#)gcsbac.f	1.3 03/22/96
c*****************************************************************************
	subroutine gcsbac( txtbuf, repch )

c  General_Character_SuBstitute_All_CHaracter.
c
c  Substitute REPCH for each character of TXTBUF.
c

	character  txtbuf*(*), repch*(*)

	lenb = len( txtbuf )
	lenr = len( repch )

	if ( lenr .gt. 1 ) then
	  print *, ' %%gcrpch: repch longer than 1'
	  go to 999
	endif

	do 10 i = 1, lenb
	  txtbuf(i:i) = repch
10	continue

999	return
	end
c %W% %G%
c*****************************************************************************
	subroutine gcwf4( valinp, chval, ierror )

c  General_Character_Write_Float_4.
c
c  Encode float_4 VAL into left-justified character CHVAL.
c  Format for best readability, numbers inside the range .001 to 999999.9
c    use decimal formatting and outside the range exponential formatting.
c  Maintain 7 significant figures. which should also suppress spurious
c    trailing 001's and 999's (IEEE encoding for 32 bit real numbers has just
c    over 7 sigfig depending on the mantissa).
c  Return -1.0e-38 <= VAL <= 1.0-38, as CHVAL = '0'.
c  CHVAL is initially set to blanks, and must be at least length 16.
c  In case of encode error CHVAL is returned as blank.
c
c  calls subroutines : gcleft, gcwx4.
c  uses include file : none.

	character         chval*(*)
	character         chdec*2, chexp*4,  fmt*16


c  Use test_gcwf4.f and idblvl = 1 to confirm operation.

	idblvl = 0


c  Check.

	chval  = ' '
	ierror = 1

	lenchv = len( chval )
	if ( lenchv .lt. 16 ) then
	  print *, '%%gcwf4: receiving string must be at least 16 char'       
	endif


c  Initialize.

        val = valinp
        call gcwx4( val, iexpn )

        chexp = ' '
        fmt   = ' '


c  Very large number or NaN or +-INF, do not attempt formatting.

	if ( iexpn .ge. +39 ) go to 50


c  Zero test.

	if ( iexpn .le. -38 ) then
	  chval  = '0'
	  ierror = 0
	  go to 999
	endif


c  Get fraction in range .1 to .9999999 for exponential format.

	if ( iexpn .lt. -2  .or.  iexpn .gt. 6 ) then
	  val     = valinp * 10.0**(-iexpn)
	  jexpn   = 0
	  iexfmt  = 1
	else
	  val     = valinp
	  jexpn   = iexpn
	  iexfmt  = 0
	endif

	if ( idblvl .ge. 1 ) then
	  print *, ' gcwf4: valinp, val, iexpn =', valinp, val, iexpn
	endif


c  Format number or fraction.
c  Remove trailing zeroes from CHVAL, for whole numbers remove the decimal.

	ndec = 7 - jexpn
	if ( ndec .lt. 1 ) ndec = 1

	write( chdec, '(i2)', err=50, iostat=ierror ) ndec

	call gcleft( chdec, nchdec )
	fmt = '( f16.' // chdec // ' )'

	write( chval, fmt, err=50, iostat=ierror ) val
	call gcleft( chval, nchval )
	if ( nchval .le. 0 ) go to 50

	do 20 i = nchval, 2, -1
	  if ( chval(i:i)   .ne. '0'  ) go to 21
	  if ( chval(i-1:i) .eq. '.0' ) then
	    chval(i-1:i) = '  '
	    go to 21
	  else
	    chval(i:i)   = ' '
	  endif
20	continue
21	continue


c  No exponent.

	if ( iexfmt .eq. 0 ) then
	  if ( idblvl .ge. 1 ) then
	    print *, ' formatted val =', chval
	  endif
	  ierror = 0
	  go to 999
	endif


c  Add the exponent.

	if ( iexfmt .eq. 1 ) then

	  if ( iexpn .ge. 10 ) then
	    write( chdec(1:2), '(i2)', err=50, iostat=ierror ) iexpn
	    chexp = 'e+' // chdec(1:2)

	  else if ( iexpn .ge. 0  .and.  iexpn .lt. 10 ) then
	    write( chdec(1:1), '(i1)', err=50, iostat=ierror ) iexpn
	    chexp = 'e+0' // chdec(1:1)

	  else if ( iexpn .ge. -9 .and. iexpn .lt. 0 ) then
	    write( chdec(1:2), '(i2)', err=50, iostat=ierror ) iexpn
	    chexp = 'e-0' // chdec(2:2)

	  else
	    write( chdec(1:3), '(i3)', err=50, iostat=ierror ) iexpn
            chexp = 'e' // chdec(1:3)
	  endif

	  call gcleft( chval, nchval )
	  if ( nchval .le. 0 ) go to 50

	  chval(1:nchval+4) = chval(1:nchval) // chexp(1:4)

	  if ( idblvl .ge. 1 ) then
	    print *, ' assembled exponential =', chval
	  endif

	  ierror = 0
	  go to 999

	endif


c  Last chance recovery.

50	continue
	write( chval, '( e16.8 )', err=51, iostat=ierror ) val

	if ( idblvl .ge. 1 ) then
	  print *, ' gcwf4: exp fmt, chval = ', chval
	endif

51	continue

	call gcleft( chval, nchval )


999	return
	end
c %W% %G%
c*****************************************************************************
	subroutine gcwf8( valinp, chval, ierror )

c  General_Character_Write_Float_8.
c
c  Encode float_8 VAL into left-justified character CHVAL.
c  Format for best readability, numbers inside the range .001 to 999999.9
c    use decimal formatting and outside the range exponential formatting.
c  Maintain 14 significant figures. which should also suppress spurious
c    trailing 001's and 999's (IEEE encoding for 32 bit real numbers has just
c    over 14 sigfig depending on the mantissa).
c  Return -1.0e-38 <= VAL <= 1.0-38, as CHVAL = '0'.
c  CHVAL is initially set to blanks, and must be at least length 24.
c  In case of encode error CHVAL is returned as blank.
c
c  calls subroutines : gcleft, gcwxp.
c  uses include file : none.

	character         chval*(*)
	character         chdec*2, chexp*4,  fmt*16
	double precision  valinp, val


c  Use test_gcwf8.f and idblvl = 1 to confirm operation.

	idblvl = 0


c  Check.

	chval  = ' '
	ierror = 1

	lenchv = len( chval )
	if ( lenchv .lt. 24 ) then
	  print *, '%%gcwf8: receiving string must be at least 24 char'       
	endif


c  Initialize.

        val = valinp
        call gcwx8( val, iexpn )

        chexp = ' '
        fmt   = ' '


c  Very large number or NaN or +-INF, do not attempt formatting.

	if ( iexpn .ge. +39 ) go to 50


c  Zero test.

	if ( iexpn .le. -38 ) then
	  chval  = '0'
	  ierror = 0
	  go to 999
	endif


c  Get fraction in range .1 to .9999999 for exponential format.

	if ( iexpn .lt. -2  .or.  iexpn .gt. 6 ) then
	  val     = valinp * 10.0d0**(-iexpn)
	  jexpn   = 0
	  iexfmt  = 1
	else
	  val     = valinp
	  jexpn   = iexpn
	  iexfmt  = 0
	endif

	if ( idblvl .ge. 1 ) then
	  print *, ' gcwf8: valinp, val, iexpn =', valinp, val, iexpn
	endif


c  Format number or fraction.
c  Remove trailing zeroes from CHVAL, for whole numbers remove the decimal.

	ndec = 14 - jexpn
	if ( ndec .lt. 1 ) ndec = 1

	write( chdec, '(i2)', err=50, iostat=ierror ) ndec

	call gcleft( chdec, nchdec )
	fmt = '( f24.' // chdec // ' )'

	write( chval, fmt, err=50, iostat=ierror ) val
	call gcleft( chval, nchval )
	if ( nchval .le. 0 ) go to 50

	do 20 i = nchval, 2, -1
	  if ( chval(i:i)   .ne. '0'  ) go to 21
	  if ( chval(i-1:i) .eq. '.0' ) then
	    chval(i-1:i) = '  '
	    go to 21
	  else
	    chval(i:i)   = ' '
	  endif
20	continue
21	continue


c  No exponent.

	if ( iexfmt .eq. 0 ) then
	  if ( idblvl .ge. 1 ) then
	    print *, ' formatted val =', chval
	  endif
	  ierror = 0
	  go to 999
	endif


c  Add the exponent.

	if ( iexfmt .eq. 1 ) then

	  if ( iexpn .ge. 10 ) then
	    write( chdec(1:2), '(i2)', err=50, iostat=ierror ) iexpn
	    chexp = 'e+' // chdec(1:2)

	  else if ( iexpn .ge. 0  .and.  iexpn .lt. 10 ) then
	    write( chdec(1:1), '(i1)', err=50, iostat=ierror ) iexpn
	    chexp = 'e+0' // chdec(1:1)

	  else if ( iexpn .ge. -9 .and. iexpn .lt. 0 ) then
	    write( chdec(1:2), '(i2)', err=50, iostat=ierror ) iexpn
	    chexp = 'e-0' // chdec(2:2)

	  else
	    write( chdec(1:3), '(i3)', err=50, iostat=ierror ) iexpn
            chexp = 'e' // chdec(1:3)
	  endif

	  call gcleft( chval, nchval )
	  if ( nchval .le. 0 ) go to 50

	  chval(1:nchval+4) = chval(1:nchval) // chexp(1:4)

	  if ( idblvl .ge. 1 ) then
	    print *, ' assembled exponential =', chval
	  endif

	  ierror = 0
	  go to 999

	endif


c  Last chance recovery.

50	continue
	write( chval, '( d24.15 )', err=51, iostat=ierror ) val

	if ( idblvl .ge. 1 ) then
	  print *, ' gcwf8: exp fmt, chval = ', chval
	endif

51	continue

	call gcleft( chval, nchval )


999	return
	end
c @(#)gcwi4.f	1.4 04/09/96
c*****************************************************************************
	subroutine gcwi4( ival, chval, ierror )

c  General_Character_Write_Integer_4.
c
c  Encode integer_4 IVAL into left-justified character CHVAL.
c  CHVAL is initially set to blanks, and should be at least length 11.

	character       chtmp*12,  chval*(*)

	ierror = 1
	chval  = ' '

c  Encode.

	write( chtmp, '( i11 )', err=999, iostat=ios ) ival
	if ( ios .ne. 0 ) go to 999

c  Left justify.

	call gcleft( chtmp, nchtmp )
	if ( nchtmp .le. 0 ) go to 999

c  Check length.

	lenval = len( chval )

	if ( lenval .lt. nchtmp ) then
	  print *, '%%gcwi4: char string too short'
	  go to 999
	endif

c  Transfer.

	chval(1:nchtmp) = chtmp(1:nchtmp)
	ierror = 0

999	return
	end
c %W% %G%
c*****************************************************************************
	subroutine gcwx4( x, ixp )

c  (General_Character)_Writing_eXponent_float4.
c
c  The exponent IXP is determined so the fraction is in the range .1 to
c  .9999999 inclusive.  This is similar to the log10 function
c  X_input = 10^IXP * mantissa_of_X  except both .1 and .9999999 are
c  returned as IXP = 0   ( ie. 0.1e0 <= x < 0.1e1 ). 
c
c  This routine assumes a maximum on the order of .3402823e39 (IEEE)
c    and does not explicitly test outside the range -.1e39 to +.1e39.
c  Plus and minus INFinity and Not_a_Number are returned as IXP=39.
c  Numbers less than 0.10e-38 are returned are IXP=-38.

	parameter   ( maxm=40, maxn=39 )

	dimension xm(maxm), xn(maxn)

	data  xm/  0.1e0,
     1             0.1e1,   0.1e2,   0.1e3,   0.1e4,   0.1e5,
     1             0.1e6,   0.1e7,   0.1e8,   0.1e9,   0.1e10,
     1             0.1e11,  0.1e12,  0.1e13,  0.1e14,  0.1e15,
     1             0.1e16,  0.1e17,  0.1e18,  0.1e19,  0.1e20,
     1             0.1e21,  0.1e22,  0.1e23,  0.1e24,  0.1e25,
     1             0.1e26,  0.1e27,  0.1e28,  0.1e29,  0.1e30,
     1             0.1e31,  0.1e32,  0.1e33,  0.1e34,  0.1e35,
     1             0.1e36,  0.1e37,  0.1e38,  0.1e39  /

	data  xn/  0.1e0,
     1             0.1e-1,   0.1e-2,   0.1e-3,   0.1e-4,   0.1e-5,
     1             0.1e-6,   0.1e-7,   0.1e-8,   0.1e-9,   0.1e-10,
     1             0.1e-11,  0.1e-12,  0.1e-13,  0.1e-14,  0.1e-15,
     1             0.1e-16,  0.1e-17,  0.1e-18,  0.1e-19,  0.1e-20,
     1             0.1e-21,  0.1e-22,  0.1e-23,  0.1e-24,  0.1e-25,
     1             0.1e-26,  0.1e-27,  0.1e-28,  0.1e-29,  0.1e-30,
     1             0.1e-31,  0.1e-32,  0.1e-33,  0.1e-34,  0.1e-35,
     1             0.1e-36,  0.1e-37,  0.1e-38  /


c  Very large.

	if ( x .gt. -xm(maxm)  .and.  x .lt. xm(maxm) ) then
	  continue
	else
	  ixp = 39
	  go to 999
	endif

c  Very small.

	ax = abs( x )
	if ( ax .lt. xn(maxn) ) then
	  ixp = -38
	  go to 999
	endif

c  Step through either positive or negative exponents.

	if ( ax .ge. 0.1 ) then

	  do 10 i = 1, maxm - 1
	    if ( ax .ge. xm(i) ) then
	      if ( ax .lt. xm(i+1)  ) then
	        ixp = i - 1
	        go to 999
	      endif
	    endif
10	  continue

	else

	  do 20 i = 1, maxn - 1
	    if ( ax .lt. xn(i) ) then
	      if ( ax .ge. xn(i+1)  ) then
	        ixp = -i
	        go to 999
	      endif
	    endif
20	  continue

	endif

999	return
	end
c %W% %G%
c*****************************************************************************
	subroutine gcwx8( x, ixp )

c  (General_Character)_Writing_eXponent_float8.
c
c  The exponent IXP is determined so the fraction is in the range .1 to
c  .9999999 inclusive.  This is similar to the log10 function
c  X_input = 10^IXP * mantissa_of_X  except both .1 and .9999999 are
c  returned as IXP = 0   ( ie. 0.1e0 <= x < 0.1e1 ). 
c
c  This routine assumes a maximum on the order of .3402823e39 (IEEE)
c    and does not explicitly test outside the range -.1e39 to +.1e39.
c  Plus and minus INFinity and Not_a_Number are returned as IXP=39.
c  Numbers less than 0.10e-38 are returned are IXP=-38.

	parameter   ( maxm=40, maxn=39 )

	double precision  x, ax
	double precision  xm(maxm), xn(maxn)

	data  xm/  0.1e0,
     1             0.1e1,   0.1e2,   0.1e3,   0.1e4,   0.1e5,
     1             0.1e6,   0.1e7,   0.1e8,   0.1e9,   0.1e10,
     1             0.1e11,  0.1e12,  0.1e13,  0.1e14,  0.1e15,
     1             0.1e16,  0.1e17,  0.1e18,  0.1e19,  0.1e20,
     1             0.1e21,  0.1e22,  0.1e23,  0.1e24,  0.1e25,
     1             0.1e26,  0.1e27,  0.1e28,  0.1e29,  0.1e30,
     1             0.1e31,  0.1e32,  0.1e33,  0.1e34,  0.1e35,
     1             0.1e36,  0.1e37,  0.1e38,  0.1e39  /

	data  xn/  0.1e0,
     1             0.1e-1,   0.1e-2,   0.1e-3,   0.1e-4,   0.1e-5,
     1             0.1e-6,   0.1e-7,   0.1e-8,   0.1e-9,   0.1e-10,
     1             0.1e-11,  0.1e-12,  0.1e-13,  0.1e-14,  0.1e-15,
     1             0.1e-16,  0.1e-17,  0.1e-18,  0.1e-19,  0.1e-20,
     1             0.1e-21,  0.1e-22,  0.1e-23,  0.1e-24,  0.1e-25,
     1             0.1e-26,  0.1e-27,  0.1e-28,  0.1e-29,  0.1e-30,
     1             0.1e-31,  0.1e-32,  0.1e-33,  0.1e-34,  0.1e-35,
     1             0.1e-36,  0.1e-37,  0.1e-38  /


c  Very large.

	if ( x .gt. -xm(maxm)  .and.  x .lt. xm(maxm) ) then
	  continue
	else
	  ixp = 39
	  go to 999
	endif

c  Very small.

	ax = dabs( x )
	if ( ax .lt. xn(maxn) ) then
	  ixp = -38
	  go to 999
	endif

c  Step through either positive or negative exponents.

	if ( ax .ge. 0.1 ) then

	  do 10 i = 1, maxm - 1
	    if ( ax .ge. xm(i) ) then
	      if ( ax .lt. xm(i+1)  ) then
	        ixp = i - 1
	        go to 999
	      endif
	    endif
10	  continue

	else

	  do 20 i = 1, maxn - 1
	    if ( ax .lt. xn(i) ) then
	      if ( ax .ge. xn(i+1)  ) then
	        ixp = -i
	        go to 999
	      endif
	    endif
20	  continue

	endif

999	return
	end
