c @(#)README_ask	1.1 04/08/96
c***** begin text file README_ask *****************************************
c
c
c              Installation of the ASK susbsystem of
c              ODDF  (Object_Description_Data_File)
c
c              ODDF 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 3)   The 'include'  statement which reads a file and inserts it into the
c      code before compilation.  The syntax is:    include   'filename'
c
c
c
c  Known operating system dependencies: none.
c  Software dependencies:  Gen_Char subsystem of ODDF.
c
c
c                       Pre-compilation step
c
c  If you have a concatentated source file, it will be necessary to split out
c  the include files into separate files for the compiler.  The include files
c  are delimited much the same as this text file.
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 @(#)ask.cmn	1.6 04/05/96
c***** begin include file ask.cmn *****

	parameter       ( iakpad=-1 )

c IKBUNT  Keyboard file unit (readonly), typically 5.
c IDSUNT  Display file unit (writeonly), typically 6.
c IDSACT  Display inactive or active ( 0 or 1 ).
c IJOUNT  Journal file unit (writeonly), range 0 or 1-4 or 7-99.
c IJOACT  Journal file inactive or active ( 0 or 1 ).

c  The write formats are used in subroutine askprl.
c WRTDSP  ASCII writing format to display.
c WRTFIL  ASCII writing format to file.

	common /ioak1/  kpad1,
     1                  ikbunt, idsunt, idsact, ijount, ijoact

	character       wrtdsp*80, wrtfil*80
	common /ioak2/  wrtdsp,    wrtfil

	common /ioak3/  kpad2

c***** end include file *****
c @(#)askc.f	1.4 04/05/96
c*****************************************************************************
	subroutine askc( prompt, c, kboard )

c  ASK_Character.
c
c  Print PROMPT on the user's terminal with the current string C in
c  square brackets.  Accept a new character string and return in C.
c
c  User response is any of:
c  1) a new string.
c  2) carriage_return to leave string unchanged.
c  3) a CTL_EOT (control_end_of_text) or the strings mu or MU to leave
c     string unchanged but return the improper_question response in KBOARD.
c
c  To change character string C to blank enter ' ' or " " (a quoted
c  blank string).  This ploy is necessary because this system uses
c  a blank response to indicate take_the_current_value_of_C.
c
c  KBOARD =  0  no information
c         = -1  took the default via a carriage_return.
c         = -2  improper question (the calling routine decides what to do).
c
c  Calls subroutines:  askrd, gclast, gcleft.
c  Uses include file:  none.

	character*160  txtrec, blank, tmp1, tmp2
	character*160  tmpc
	character*1    squot,  dquot, firsch, lastch
	character      prompt*(*), c*(*)

	kboard  = 0

	lenc   = len( c )
	lentmp = len( tmpc )

	squot  = char( 39 )
	dquot  = char( 34 )

	blank  = ' '
	txtrec = ' '


c  Find printable lengths for the prompt and value.

	call gclast( prompt, np )
	call gclast( c, nc )


c  Print prompt.

        if ( np .le. 0 ) np = 1
        if ( nc .le. 0 ) nc = 1

	if ( np + nc + 5 .gt. lentmp ) then
	  if ( np .gt. 78 ) np = 78
	  if ( np + nc + 5 .gt. lentmp ) nc = lentmp - 5 - np
          print *, ' askc warning: limiting display to ', lentmp      
	endif

	tmpc = prompt(1:np) // ' [ ' // c(1:nc) // ' ]'
	call askpr( tmpc )


c  Read from standard input.

	call askrd( txtrec, kboard )
	if ( kboard .ne. 0 ) go to 999


c  Check for quoted blank string:  either ' '  or "  "  will cause C
c  to be set to BLANK.

	isetb  = 0
	tmp1   = txtrec
	call gcleft( tmp1, nc1 )
	if ( nc1 .le. 0 ) go to 999

	firsch = tmp1(1:1)
	lastch = tmp1(nc1:nc1)


c  If matching quotes, then check interior for blank.

	if ( firsch .eq. squot  .or.  firsch .eq. dquot ) then
	  if ( ( firsch .eq. squot  .and.  lastch .eq. squot  )  .or.
     1         ( firsch .eq. dquot  .and.  lastch .eq. dquot  ) ) then

	    tmp2          = tmp1
	    tmp2(1:1)     = ' '
	    tmp2(nc1:nc1) = ' '
	    if ( tmp2 .eq. blank ) isetb = 1

	  endif
	endif


c  Transfer to output string.

	if ( isetb .eq. 1 ) then
	  c = ' '
	else
	  lenout = lenc
	  if ( lentmp .lt. lenc ) lenout = lentmp
	  c = ' '
	  c = txtrec(1:lenout)
	endif


999	return
	end
c @(#)askde.f	1.3 04/05/96
c*****************************************************************************
	subroutine askde( txtrec )

c  ASK_Dummy_Element.
c
c  Insert between two commas a character string which will cause the
c  GCRead routines to return an error and therefore the ASK routines to skip
c  that element.  For instance TXTREC='1,2,,,5' will be modified to '1,2,*,*,5'
c  and ',,,' to '*,*,*,*' and '  1,  2,  ,  4' to '1,  2,*,  4'.
c
c  Possible system dependency:  The DE character string must be something that
c  causes an error during internal reads of i4, f4, and f8 variable types.
c  Use driver test_ask_a for verification.
c
c  Calls subroutines : gcast, gcleft.
c  Uses include file : none.


	character   de*1, wk1*160
	character   txtrec*(*)

c  Assign dummy element.

	de = '*'

c  Get string lengths and make initial test.

	lende  = len( de )
	lenwk  = len( wk1 )
	lentxt = len( txtrec )

	call gcleft( txtrec, nch )

	if ( nch .gt. ( lenwk - 2 * lende )  ) then
	  print *, ' %%askde: input string too long'
	  go to 999
	endif


c  Leading comma.

	if ( txtrec(1:1) .eq. ',' ) then
	  wk1    = txtrec(1:nch) // ' '
	  txtrec = de // wk1(1:nch) // ' '
	endif


c  Trailing comma.

	call gclast( txtrec, nch )

	if ( txtrec(nch:nch) .eq. ',' ) then
	  wk1    = txtrec(1:nch) // ' '
	  txtrec = wk1(1:nch) // de // ' '
	endif


c  Internal commas.

	call gclast( txtrec, nsch )

	is    = 1
	ntest = nsch


c  Cycle no more than NSCH times.

	do 100 itest = 1, ntest

	  call gclast( txtrec, nch )

	  iexist = index( txtrec(is:lentxt), ',' )
	  if ( iexist .eq. 0 ) go to 999
	  icmm1 = ( is - 1 ) + iexist

c  Found a comma.  Is it immediately followed by another?

	  do 20 it = icmm1 + 1, nch

c  If blank keep going.
c  If comma, then insert DE between the two commas and reset search.

	    if ( txtrec(it:it) .eq. ' ' ) go to 20

	    if ( txtrec(it:it) .eq. ',' ) then

	      if ( nch .gt. ( lentxt - lende ) .or.
     1        nch .gt. ( lenwk - lende ) ) then
	        print *, ' %%askde: too many dummy entries for work str'
	        print *, ' current expanded length =', nch
	        go to 999
	      endif
	
	      wk1    = ' '
	      wk1    = txtrec(1:icmm1) // de // txtrec(it:nch)	
	      call gclast( wk1, nch )
	      txtrec = ' '
	      txtrec = wk1(1:nch)
	      is     = icmm1 + 1
	      go to 100
	    endif

c  Found a non-blank,comma; reset search.

	    is = it
	    go to 100

20	  continue

c  This point should not be reached so exit.
	  go to 999

100	continue


999	return
	end
c @(#)askdsp.f	1.3 04/05/96
c*****************************************************************************
	subroutine askdsp( opr, iact, ierror )

c  ASK_DiSPlay.
c
c  I/O the logical state of the display output variable.

c
c  OPR     is supplied 'read' or 'write', where 'read' is get display status
c          from the ask system and write is put display status to system.
c  IACT    is supplied/returned state of the display.  IACT is a switch
c          either 0 or 1 for no_display or display.
c  IERROR  returned error parameter either zero or not_zero for ok or not_ok.
c
c  Calls subroutines : none.
c  Uses include file : ask.cmn.
c  Modifies include variable : idsunt, idsact.

	include     'ask.cmn'

	character   opr*(*)


c  Check common area for initialization.

        if ( kpad1 .ne. iakpad  .or.  kpad2 .ne. iakpad ) then
          print *, ' %%askdsp: common area corrupt detect.'
          print *, ' Make sure ASK has been initialized.'
          ierror = 1
          go to 999
        endif


c  Check data object, turn on display if incorrect.

        if ( idsunt .ne. 0  .and.  idsunt .ne. 6 ) then
          print *, ' askdsp warning: resetting idsunt to 6'
          idsunt = 6
        endif

	if ( idsact .ne. 0  .and.  idsact .ne. 1 ) then
          print *, ' askdsp warning: resetting idsact to 1'
          idsact = 1
        endif

	ierror = 0


c  Read.

	if ( opr(1:1) .eq. 'r'  .or.  opr(1:1) .eq. 'R' ) then
	  iact   = idsact
	  ierror = 0
	  go to 999
	endif


c  Write.

	if ( opr(1:1) .eq. 'w'  .or.  opr(1:1) .eq. 'W' ) then

	  if ( iact .lt. 0  .or.  iact .gt. 1 ) then
	    print *, ' %%askdsp: display variable must be 0 or 1'
	    ierror = 1
	    go to 999
	  endif

	  idsact = iact

	  if ( idsact .eq. 1 ) idsunt = 6

	  ierror = 0
	  go to 999
	endif


	print *, ' %%askdsp: operator not recognized'
	ierror = 1


999	return
	end
c @(#)askf4.f	1.4 04/05/96
c*****************************************************************************
	subroutine askf4( prompt, f4, kboard )

c  ASK_Floating_4 (single precision).
c
c  Calls subroutine : askpr, askrd, gclast, gcleft, gcrf4, gcwf4.
c  Uses include file: none.

	character  txtrec*80, tmpc*160
	character  prompt*(*)

	kboard = 0


	txtrec = ' '
	icnt   = 0

	call gclast( prompt, np )


c  Print to ASKPR.

20	continue

	call gcwf4( f4, txtrec, ierror )
	call gcleft( txtrec, nchtxt )

	if ( np     .le. 0 ) np = 1
	if ( nchtxt .le. 0 ) nchtxt = 1

	tmpc = prompt(1:np) // ' [ ' // txtrec(1:nchtxt) // ' ]'
	call askpr( tmpc )


c  Read from standard input.

	call askrd( txtrec, kboard )
	if ( kboard .ne. 0 ) go to 999	


c  Read first word of TXTREC into FTMP.
c  Give 3 chances then exit.

	call gcrf4( txtrec, ftmp, ierror )

	if ( ierror .ne. 0 ) then
	  icnt = icnt + 1
	  if ( icnt .ge. 3 ) then
	    kboard = -1
            call askpr( ' askf4 count exceeded, taking default.' )
	    go to 999
	  endif
          call askpr( 'Could not interpret a real number.' )
	  go to 20
	endif

	f4     = ftmp
	kboard = 0


999	return
	end
c @(#)askf4a.f	1.4 04/05/96
c*****************************************************************************
	subroutine askf4a( prompt, farr, narr, kboard )

c  ASK_Floating_4_Array.
c
c  Read in multiple 4 byte floating point numbers from standard input.
c
c  See routine ASKI4A for usage and characteristics.
c
c  Calls subroutines: askpr, askrd, gclast, gcnxtw, gcrf4, gcwf4.
c  Uses include file: none.

	dimension         farr(*)
        character         wrd*80, txtrec*160, tmpc*160, tmp1*160
	character         prompt*(*)


	kboard = -1

        if ( narr .le. 0 ) then
          print *, ' %%askf4a: NARR must be greater than zero'
          print *, ' continuing...'
          go to 999
        endif

        if ( narr .gt. 10 ) then
          print *, ' %%askf4a: NARR must be less than 11 so the'
          print *, ' prompt can print, continuing...'
          go to 999
        endif


c  Initialize.

	lentmp = len( tmp1 )
	txtrec = ' '
	tmpc   = ' '

	call gclast( prompt, np )


c  Print to ASKPR.

        if ( np .le. 0 ) np = 1

	tmpc = prompt(1:np) // ' ['
        call gclast( tmpc, nchtmp )

        do 30 i = 1, narr

          call gcwf4( farr(i), wrd, ierror )
          call gclast( wrd, nchwrd )
	  if ( nchwrd .le. 0 ) nchwrd = 1

          n1     = nchtmp + 1

	  if ( n1 + nchwrd + 2  .gt.  lentmp ) then
	    print *, ' askf4a warning: prompt too long, truncating'
	    print *, ' after element = ', i
	    go to 31 
	  endif

	  tmp1   = ' '
          tmp1   = tmpc(1:n1) // wrd(1:nchwrd)
	  tmpc   = tmp1
          nchtmp = n1 + nchwrd

30      continue

31	continue
	call gclast( tmpc, nchtmp )
	if ( nchtmp .le. 0 ) nchtmp = 1

        tmp1 = ' '
        tmp1 = tmpc(1:nchtmp) // ' ]'
        tmpc = tmp1

	call askpr( tmpc )


c  Read from standard input.
	
	call askrd( txtrec, kboard )
	if ( kboard .ne. 0 ) go to 999


c  Replace comma delimited missing elements with dummies.

	call askde( txtrec )

c  Replace commas with blanks.

	call gcrpcm( txtrec )


c  Interprete words.

	istxt = 1

	do 100 icycle = 1, narr

	  tmp1 = txtrec(istxt:lentmp)
	  call gcnxtw( tmp1, iswrd, wrd, nchwrd )
	  if ( nchwrd .eq. 0 ) go to 999

	  call gcrf4( wrd, ftmp, ierror )
	  if ( ierror .eq. 0 ) farr(icycle) = ftmp

	  istxt = ( istxt - 1 ) + iswrd + nchwrd
	  if ( istxt .gt. lentmp ) go to 999

100	continue


999	return
	end
c @(#)askf8.f	1.5 04/05/96
c*****************************************************************************
	subroutine askf8( prompt, f8, kboard )

c  ASK_Floating_8 (double precision).
c
c  Calls subroutine : askpr, askrd, gclast, gcleft, gcrf8, gcwf8.
c  Uses include file: none.

	double precision  f8, ftmp
	character         txtrec*80, tmpc*160
	character         prompt*(*)

	kboard = 0


	txtrec = ' '
	icnt   = 0

	call gclast( prompt, np )


c  Print to ASKPR.

20	continue

	call gcwf8( f8, txtrec, ierror )
	call gcleft( txtrec, nchtxt )

	if ( np     .le. 0 ) np = 1
        if ( nchtxt .le. 0 ) nchtxt = 1

	tmpc = prompt(1:np) // ' [ ' // txtrec(1:nchtxt) // ' ]'

	call askpr( tmpc )


c  Read from standard input.

	call askrd( txtrec, kboard )
	if ( kboard .ne. 0 ) go to 999	


c  Read first word of TXTREC into FTMP.
c  Give 3 chances then exit.

	call gcrf8( txtrec, ftmp, ierror )

	if ( ierror .ne. 0 ) then
	  icnt = icnt + 1
	  if ( icnt .ge. 3 ) then
	    kboard = -1
            call askpr( ' askf8 count exceeded, taking default.' )
	    go to 999
	  endif
          call askpr( 'Could not interpret a double precison real' )
	  go to 20
	endif

	f8     = ftmp
	kboard = 0


999	return
	end
c @(#)askf8a.f	1.4 04/05/96
c*****************************************************************************
	subroutine askf8a( prompt, farr, narr, kboard )

c  ASK_Floating_8_Array.
c
c  Read in multiple 8 byte floating point numbers from standard input.
c
c  See routine ASKI4A for usage and characteristics.
c
c  Calls subroutines: askpr, askrd, gclast, gcnxtw, gcrf8, gcwf8.
c  Uses include file: none.

	double precision  ftmp, farr(*)
        character         wrd*80, txtrec*160, tmpc*160, tmp1*160
	character         prompt*(*)


	kboard = -1

        if ( narr .le. 0 ) then
          print *, ' %%askf8a: NARR must be greater than zero'
          print *, ' continuing...'
          go to 999
        endif

        if ( narr .gt. 5) then
          print *, ' %%askf8a: NARR must be less than 6 so the'
          print *, ' prompt can print, continuing...'
          go to 999
        endif


c  Initialize.

        lentmp = len( tmp1 )
	txtrec = ' '
	tmpc   = ' '

	call gclast( prompt, np )


c  Print to ASKPR.

        if ( np .le. 0 ) np = 1

        tmpc = prompt(1:np) // ' ['
        call gclast( tmpc, nchtmp )

        do 30 i = 1, narr

          call gcwf8( farr(i), wrd, ierror )
          call gclast( wrd, nchwrd )
          if ( nchwrd .le. 0 ) nchwrd = 1

          n1     = nchtmp + 1

          if ( n1 + nchwrd + 2  .gt.  lentmp ) then
            print *, ' askf8a warning: prompt too long, truncating'
            print *, ' after element = ', i
            go to 31 
          endif

	  tmp1   = ' '
          tmp1   = tmpc(1:n1) // wrd(1:nchwrd)
	  tmpc   = tmp1
          nchtmp = n1 + nchwrd

30      continue

31      continue
        call gclast( tmpc, nchtmp )
        if ( nchtmp .le. 0 ) nchtmp = 1

	tmp1 = ' '
        tmp1 = tmpc(1:nchtmp) // ' ]'
	tmpc = tmp1

        call askpr( tmpc )


c  Read from standard input.

	call askrd( txtrec, kboard )
	if ( kboard .ne. 0 ) go to 999


c  Replace comma delimited missing elements with dummies.

	call askde( txtrec )

c  Replace commas with blanks.

	call gcrpcm( txtrec )


c  Interprete words.

	istxt = 1

	do 100 icycle = 1, narr

	  tmp1 = txtrec(istxt:lentmp)
	  call gcnxtw( tmp1, iswrd, wrd, nchwrd )
	  if ( nchwrd .eq. 0 ) go to 999

	  call gcrf8( wrd, ftmp, ierror )
	  if ( ierror .eq. 0 ) farr(icycle) = ftmp

	  istxt = ( istxt - 1 ) + iswrd + nchwrd
	  if ( istxt .gt. lentmp ) go to 999

100	continue


999	return
	end
c @(#)aski4.f	1.4 04/05/96
c*****************************************************************************
	subroutine aski4( prompt, i4, kboard )

c  ASK_Integer_4 (long word integer).
c
c  Calls subroutines : askpr, askrd, gclast, gcri4.
c  Uses include files: none.

	character  txtrec*80, tmpc*160
	character  prompt*(*)

	txtrec = ' '
	icnt   = 0

	call gclast( prompt, np )


c  Print to ASKPR.

20	continue

	call gcwi4( i4, txtrec, ierror )
	call gcleft( txtrec, nchtxt )

        if ( np     .le. 0 ) np = 1
        if ( nchtxt .le. 0 ) nchtxt = 1

	tmpc = prompt(1:np) // ' [ ' // txtrec(1:nchtxt) // ' ]'
	call askpr( tmpc )


c  Read from standard input.

	call askrd( txtrec, kboard )
	if ( kboard .ne. 0 ) go to 999


c  Read first word of TXTREC into ITMP.
c  Give 3 chances then exit.

	call gcri4( txtrec, itmp, ierror )

	if ( ierror .ne. 0 ) then
	  icnt = icnt + 1
	  if ( icnt .ge. 3 ) then
	    kboard = -1
	    call askpr( ' aski4 count exceeded, taking default.' )
	    go to 999
	  endif
	  call askpr( 'Could not interpret an integer' )
	  go to 20
	endif

	i4     = itmp
	kboard = 0


999	return
	end
c @(#)aski4a.f	1.4 04/05/96
c*****************************************************************************
	subroutine aski4a( prompt, iarr, narr, kboard )

c  ASK_Integer_4_Array.
c
c  Read in multiple 4 byte integers from standard input.
c
c  Usage:
c  PROMPT  may be either a character string in the argument list or a
c          character variable passed to the argument list.
c  IARR    should be initialized with reasonable values before calling
c          this routine.
c  NARR    (number of array elements) must be greater than zero.
c  KBOARD  is the returned user response in the range -2 to 0.
c
c  Characteristics:
c  Display of the form:  Enter starting values [ 34 -20 9 ],  where
c    prompt = 'Enter starting values' and iarr(1:3) = 34,-20,9.
c  The user may enter spaces or commas to delimit numbers.
c  Does not modify an element of IARR unless a valid number has been
c    parsed so the user can leave some elements unchanged.  Two successive
c    commas, for instance, cause an element to be skipped.
c  Two display lines (160 chars) are available for the prompt plus current
c    values, the routine truncates the display at 160 chars but the routine
c    should accept as many values as input.
c  Depending on the runtime library (ie. machine dependent) the CTL-EOT
c    form of the mu response can soft abort anywhere.  The character
c    string 'mu', as usual, works only in the first two characters. 
c
c  Call subroutines : askde,  askrd,  askpr,
c                     gclast, gcnxtw, gcri4, gcrpcm, gcwi4.
c  Uses include file: none.

	character     txtrec*80, tmp80*80, wrd*80
	character     tmpc*160,  tmpc2*160

	character     prompt*(*)
	dimension     iarr(*)


c  Set user response to 'take default' and check number of array elements.
c  The maximum is not really practical and is only to ensure some
c  initialized value.

	kboard = -1

	if ( narr .le. 0 ) then
	  print *, ' %%aski4a: NARR must be greater than zero'
	  print *, ' continuing...'
	  go to 999
	endif

	if ( narr .gt. 79 ) then
          print *, ' %%aski4a: NARR must be less than 80 so the'
	  print *, ' prompt can print, continuing...'
          go to 999
        endif


c  Initialize.

	kboard = 0
	txtrec = ' '
	tmpc   = ' '


c  Assemble display message.

	call gclast( prompt, np )
        if ( np .le. 0 ) np = 1
	tmpc = prompt(1:np) // ' ['
	call gclast( tmpc, nchtmp )

	do 30 i = 1, narr

	  call gcwi4( iarr(i), wrd, ierror )
	  call gclast( wrd, nchwrd )
          if ( nchwrd .le. 0 ) nchwrd = 1

	  n1     = nchtmp + 1

          if ( n1 + nchwrd + 2  .gt.  160 ) then
            print *, ' aski4a warning: prompt too long, truncating'
            print *, ' after element = ', i
            go to 31 
          endif

	  tmpc2  = tmpc(1:n1) // wrd(1:nchwrd)
	  tmpc   = tmpc2
	  nchtmp = n1 + nchwrd

30	continue

31      if ( nchtmp .le. 0 ) nchtmp = 1
	tmpc2 = tmpc(1:nchtmp) // ' ]'
	tmpc  = tmpc2


c  Print display message.

	call askpr( tmpc )


c  Read from standard input.

	call askrd( txtrec, kboard )
	if ( kboard .ne. 0 ) go to 999


c  Condition text.

	call askde( txtrec )

c  Replace commas with blanks.

	call gcrpcm( txtrec )


c  Interprete words.

	istxt = 1

	do 100 icycle = 1, narr

	  tmp80 = txtrec(istxt:80)
	  call gcnxtw( tmp80, iswrd, wrd, nchwrd )
	  if ( nchwrd .eq. 0 ) go to 999

	  call gcri4( wrd, itmp, ierror )
	  if ( ierror .eq. 0 ) iarr(icycle) = itmp

	  istxt = ( istxt - 1 ) + iswrd + nchwrd
	  if ( istxt .gt. 80 ) go to 999

100	continue


999	return
	end
c @(#)aski4l.f	1.4 04/05/96
c*****************************************************************************
	subroutine aski4l( prompt, logswt, kboard )

c  ASK_Integer_4_Logical.
c
c  LOGSWT is a logical switch where 0 is false or no  and
c         1 is true or yes.
c  KBOARD is the returned value of the user's response range -2 to 1.
c
c  Calls subroutines: askpr, askyn, gclast.
c  Uses include file: none.

	character  tmpc*160
	character  prompt*(*)


c  Check LOGSWT state.

	if ( logswt .lt. 0  .or.  logswt .gt. 1 )  logswt = 0

	call gclast( prompt, np )


c  Print to ASKPR.

20	continue

        if ( np .le. 0 ) np = 1

	if ( logswt .eq. 0 ) then
	  tmpc = prompt(1:np) // ' [ n ]'
	else
	  tmpc = prompt(1:np) // ' [ y ]'
	endif

	call askpr( tmpc )


c  Get response from user.

	call askyn( kboard )
	if ( kboard .ge. 0 ) logswt = kboard


999	return
	end
c @(#)askin.f	1.4 04/05/96
c*****************************************************************************
	subroutine askin

c  ASK_INitialize.
c
c  Destroy the ASK data object.
c
c  Calls subroutines: none.
c  Uses include file: ask.cmn.
c  Modifies include variables: ikbunt, idsunt, idsact, ijoact, ijount,
c                              wrtdsp, wrtfil.

	include   'ask.cmn'


c  Data object pads.

	kpad1  = iakpad
	kpad2  = iakpad


c  Keyboard and display.

	ikbunt = 5
	idsunt = 6
	idsact = 1

c  Journal.

	ijount = 0
	ijoact = 0

c  ASCII writing formats.

	wrtdsp = '( a )'
	wrtfil = '( a )'


999	return
	end
c @(#)askjnl.f	1.1 04/05/96
c*****************************************************************************
	subroutine askjnl( opr,  jnlunt, jnlact,  ierror )

c  ASK_JourNaLing.
c
c  I/O the journal file unit number and whether journaling is
c  currently active.
c
c  OPR     is supplied 'read' or 'write', where 'read' is get journal status
c            from the ask system and write is put journal status to system.
c  JNLUNT  is the file unit number for the journaling file.  The file is
c            opened and clossed external to the ASK system and only the unit
c            number passed to ASK.  File unit numbers are typically
c            1 to 4 or 7 to 99 to not conflict with display I/O.
c            JNLUNT = 0 is null, no_information, or no_change.
c            JNLUNT > points to a file.  Multiple journals ok.
c  JNLACT  is an integer switch to signal whether prompts, answers and
c            printed text and are directed to the journal file.  The two
c            states are off=0 and on=1, where either JNLUNT or IJOUNT must
c            be set before journaling is turned on.
c  IERROR  returned error parameter either zero or not_zero for ok or not_ok.
c
c  Characterics:
c
c  Errors or warnings cause a printed message.
c  The initialization via routine ASKIN sets the journal unit to null 
c    and inactive state.  This routine exits with a common area corrupt
c    detect if the area has not been initialized.
c  If the stored journal information is incorrect, then immediate error return.
c
c  The 'read' operation has no error or warning paths. 
c
c  The 'write' operation must pass several tests before updating:
c    JNLACT must be either 0 or 1,
c    JNLUNT must always be in the range 0-99 and not equal to IKBUNT,
c    and then:
c    if JNLUNT > 0, then that file unit is stored,
c    if JNLUNT = 0, then the stored file unit is unchanged,
c    JNLACT = 1 is ignored if the stored IJOUNT = 0.  A warning is printed.
c    JNLACT = 0 is always stored.
c
c  Calls subroutines : none.
c  Uses include file : ask.cmn.
c  Modifies include variable :  ijount, ijoact.


	include     'ask.cmn'

	character   opr*(*)


c  Check common area for initialization.

        if ( kpad1 .ne. iakpad  .or.  kpad2 .ne. iakpad ) then
          print *, ' %%askjnl: common area corrupt detect.'
          print *, ' Make sure ASK has been initialized.'
	  ierror = 1
          go to 999
        endif


c  Data object check.

	ierror = 0
	if ( ijoact .lt. 0  .or.  ijoact .gt. 1  ) ierror = 1
	if ( ijount .lt. 0  .or.  ijount .gt. 99 ) ierror = 1
	if ( ijount .eq. ikbunt ) ierror = 1

	if ( ierror .eq. 1 ) then
	  ijount = 0
	  ijoact = 0
	  print *, ' %%askjnl: data object error, reset, exitting...'
	  go to 999
	endif


c  Read.

	if ( opr(1:1) .eq. 'r'  .or.  opr(1:1) .eq. 'R' ) then
	  jnlunt = ijount
	  jnlact = ijoact
	  ierror = 0
	  go to 999
	endif


c  Write.

	if ( opr(1:1) .eq. 'w'  .or.  opr(1:1) .eq. 'W' ) then

	  if ( jnlact .lt. 0  .or.  jnlact .gt. 1 ) then
	    print *, ' %%askjnl: JNLACT must = 0 or 1'
	    ierror = 1
	    go to 999
	  endif

	  if ( jnlunt .lt. 0  .or.  jnlunt .gt. 99  .or.  
     1    jnlunt .eq. ikbunt ) then
	    print *, ' %%askjnl: JNLUNT must be 0-99 and not keyboard'
	    ierror = 1
	    go to 999
	  endif

	  if ( jnlunt .gt. 0 ) ijount = jnlunt

	  if ( jnlact .eq. 1  .and.  ijount .gt. 0 ) ijoact = 1

	  if ( jnlact .eq. 1  .and.  ijoact .eq. 0 ) then
	    print *, ' askjnl warning: journaling cannot be activated'
	    print *, ' without a valid file unit number.'
	  endif

	  if ( jnlact .eq. 0 ) ijoact = 0

	  ierror = 0
	  go to 999
	endif

	print *, ' %%askjnl: operator not recognized'
	ierror = 1


999	return
	end
c @(#)askpr.f	1.6 04/05/96
c*****************************************************************************
	subroutine askpr( prompt )

c  ASK_PRint.
c
c  Print the PROMPT on the user's display terminal and/or journal file unit.
c
c  Operating characteristics in order of priority:
c    PROMPT is any length and is not modified.
c    Written text lines are always less than 80 characters in length.
c    PROMPT may be formatted into text lines terminated with CR/LF or LF
c      an isolated CR character is replaced with a blank.  Succesive line
c      terminators then generate one blank line for each occurance.
c    Text lines may be formed automatically by breaking at the last word
c      delimiter less than 80 characters.  Word delimiters are either a
c      space or comma.  If there are no word delimiters available a long
c      line will be broken at the 79th character.
c    Lines have non_printing characters replaced with spaces.  Horizontal
c      tabs, vertical tabs, backspace and bell are ignored.
c
c  Calls subroutines : askprl, askprz, gclast.
c  Uses include file : ask.cmn.

	include     'ask.cmn'

	character   txtrec*80, crlf*2, lf*1
	character   prompt*(*)


c  Check common area for initialization.

	if ( kpad1 .ne. iakpad  .or.  kpad2 .ne. iakpad ) then
	  print *, ' %%askpr: common area corrupt detect.'
	  print *, ' Make sure ASK has been initialized.'
	  go to 999
	endif


c  Initialize.

	crlf = char( 13 ) // char( 10 )
	lf   = char( 10 )

	lenpr = len( prompt )
	if ( lenpr .le. 0 ) then
	  print *, ' %%askpr: zero length prompt.'
	  go to 999
	endif

	call gclast( prompt, nchnb )


c  No-character case.

	if ( nchnb .eq. 0 ) then
	  call askprz
	  go to 999
	endif


c  Assemble lines and print.

	ncycle = 0
	lmtcyc = nchnb / 2

	is = 1
	ie = 0


c  If there are characters remaining.

100	if ( is .le. nchnb  .and.  ncycle .le. lmtcyc ) then
	  ncycle = ncycle + 1


c  Check for supplied line breaks.  Either CRLF or LF is recognized.

	  ilf = 0
	  icf = 0

	  ilf = index( prompt(is:nchnb), lf )

	  if ( is .lt. nchnb ) then
	    icf = index( prompt(is:nchnb), crlf )
	  endif


c  Find the closer of CRLF or LF.

	  if ( icf .gt. 0  .and.  ilf .gt. 0 ) then
	    if ( icf .lt. ilf ) then
	      ilf = 0
	    else
	      icf = 0
	    endif
	  endif


c  Position in the original string.

          iprlf  = 0
          iprcf  = 0
	  if ( ilf .gt. 0 ) iprlf = ( is - 1 ) + ilf
	  if ( icf .gt. 0 ) iprcf = ( is - 1 ) + icf


c  If either CRLF or LF is the current first character, 
c  then print zero length.

	  if ( icf .eq. 1 ) then
	    call askprz
	    is = is + 2
	    go to 100
	  endif

          if ( ilf .eq. 1 ) then
            call askprz
            is = is + 1
            go to 100
          endif


c  If either CRLF or LF are within 80 chars then print the line and
c  step over the delimiters.

	  if ( icf .gt. 1  .and.  icf .le. 79 ) then
	    ie     = iprcf - 1
	    txtrec = prompt(is:ie)
	    call askprl( txtrec )
	    is     = iprcf + 2
	    go to 100
	  endif

	  if ( ilf .gt. 1  .and.  ilf .le. 80 ) then
            ie     = iprlf - 1
            txtrec = prompt(is:ie)
            call askprl( txtrec )
            is     = iprlf + 1
            go to 100
          endif


c  At this point there are no line delimiters within 80 characters.
c  Can we print the last text record?

          ie = is + 78

          if ( ie .ge. nchnb ) then
	    ie     = nchnb
	    txtrec = prompt(is:ie)
            call askprl( txtrec )
            is     = ie + 1
            go to 100
          endif


c  The string continues for more lines.
c  Look for a possible line break at a word boundary delimited with
c  either space or a comma.  The last character of the line is a visible
c  nonblank glyph, whitespace if any then preceeds the next line.

	  ietmp = is + 78
	  if ( ietmp .gt. nchnb ) ietmp = nchnb

	  it = ietmp
120	  if ( it .ge. is ) then

	    if ( prompt(it:it) .eq. ' ' ) then 
	      ie     = it - 1
	      if ( ie .ge. is ) then
                txtrec = prompt(is:ie)
                call askprl( txtrec )
                is     = ie + 1
                go to 100
	      endif
	    endif

	    if ( prompt(it:it) .eq. ',' ) then
              ie     = it 
              txtrec = prompt(is:ie)
              call askprl( txtrec )
              is     = ie + 1
              go to 100
            endif

	    it = it - 1
	    go to 120
	  endif


c  There was no word break, print 79 characters and continue.

	  ie = is + 78
	  if ( ie .gt. nchnb ) ie = nchnb

	  txtrec = prompt(is:ie)
          call askprl( txtrec )
          is     = ie + 1

	  go to 100
	endif


999	return
	end
c @(#)askprl.f	1.1 04/05/96
c*****************************************************************************
	subroutine askprl( txtinp )

c  ASK_PRint_Line.
c
c  Use Fortran WRITE to display and/or journal a line of text.
c  TXTREC may be modified.
c
c  The writing format is set in ASKIN.
c
c  Calls subroutines: askprz, gclast, gcrpnp.
c  Uses include file: ask.cmn.
c  Modifies include variables: none.

	include      'ask.cmn'

	character    cr*1, lf*1, txtrec*80
	character    txtinp*(*)


c  Check common area for initialization.

        if ( kpad1 .ne. iakpad  .or.  kpad2 .ne. iakpad ) then
          print *, ' %%askpr: common area corrupt detect.'
          print *, ' Make sure ASK has been initialized.'
          go to 999
        endif

	leninp = len( txtinp )
	if ( leninp .le. 0 ) go to 999

	lencpy = len( txtrec )


c  Copy string.

	lenmin = leninp
	if ( lencpy .lt. lenmin ) lenmin = lencpy

	lentxt = lenmin
	txtrec = txtinp(1:lentxt)


c  Replace non-printing characters with space.

        call gcrpnp( txtrec )


c  Replace any remaining CR or LF with space.

	cr = char( 13 )
	lf = char( 11 )

	do 10 i = 1, lentxt
	  if ( txtrec(i:i) .eq. cr ) txtrec(i:i) = ' '
	  if ( txtrec(i:i) .eq. lf ) txtrec(i:i) = ' '
10	continue


c  Check number of characters.

	call gclast( txtrec, nchtxt )

	if ( nchtxt .eq. 0 ) then
	  call askprz
	  go to 999
	endif


c  Write a text line.

        if ( idsact .eq. 1 ) then
          write( idsunt, wrtdsp, err=999 ) txtrec(1:nchtxt)
        endif

        if ( ijoact .eq. 1 ) then
          write( ijount, wrtfil, err=999 ) txtrec(1:nchtxt)
        endif


999	return
	end
c @(#)askprz.f	1.1 04/05/96
c*****************************************************************************
        subroutine askprz

c  ASK_PRint_Zero_length.
c
c  Write a zero length string.  This routine handles the exceptional case
c  of a zero length write in fortran (ie. txtrec(i:i-1) substring is invalid).

	include    'ask.cmn'


c  Check common area for initialization.

        if ( kpad1 .ne. iakpad  .or.  kpad2 .ne. iakpad ) then
          print *, ' %%askprz: common area corrupt detect.'
          print *, ' Make sure ASK has been initialized.'
          go to 999
        endif


c  Write a zero length string.

        if ( idsact .eq. 1 ) then
          write( idsunt, '(a)', err=999 )
        endif

        if ( ijoact .eq. 1 ) then
          write( ijount, '(a)', err=999 )
        endif


999	return
	end
c @(#)askrd.f	1.3 04/05/96
c*****************************************************************************
	subroutine askrd( txtrec, kboard )

c  ASK_ReaD.
c
c  Generic read from the the user's display for ASK library.  User input,
c  including the 'mu' response, may be directed to a journal file.
c
c  TXTREC  Returned user response with nonvisible characters, if any,
c          replaced with blanks.
c  KBOARD  Returned user keyboard response any of: 0, -1, -2.
c
c  Calls subroutines:  askdsp, askpr, gclast, gcleft, gcrpnv.
c  Uses include file:  ask.cmn.
c  Modifies include variables: none.

	include       'ask.cmn'

	character     inprec*160, warn*80, tmp16*16
	character     txtrec*(*)


c  Set response to 'take default' and check string length.

	kboard = -1

	nchtxt = len( txtrec )
	if ( nchtxt .le. 0 ) then
	  print *, ' %%askrd: zero length text string.'
          go to 999
	endif


c  Initialize.

	kboard = 0
	txtrec = ' '


c  Read from keyboard.

	read( ikbunt, '(a)', end=50, iostat=ios ) inprec 


c  Condition the input.
c  Any error condition triggers the mu response.
c  Any nonvisible characters are replaced with blanks (ie 0-31 and 127-255).

50	continue
	if ( ios .ne. 0 ) inprec = 'mu'

	call gcrpnv( inprec )
	call gclast( inprec, nchinp )


c  If journaling active; then disable display output, write the response
c  to the journal and restore display to its former state.

	if ( ijoact .eq. 1 ) then
	  call askdsp( 'read',  idsp, ierror )
	  call askdsp( 'write',    0, ierror )
	  call askpr( inprec )
	  call askdsp( 'write', idsp, ierror )
	endif


c  Copy input to return string.

	if ( nchinp .gt. nchtxt ) then
	  nchinp = nchtxt
	  call gcwi4( nchinp, tmp16, ierror )
	  warn   = ' %%askrd: cannot return more than chars =' // 
     1             tmp16
          call askpr( warn )
	endif

	if ( nchinp .gt. 0 ) then
	  txtrec(1:nchinp) = inprec(1:nchinp)
	endif


c  Soft abort.

	call gcleft( inprec, nchinp )

	if ( nchinp .eq. 2  .and. 
     1  ( inprec(1:2) .eq. 'mu'  .or.  inprec(1:2) .eq. 'MU'  ) ) then

	  kboard = -2

	  go to 999
	endif


c  No answer.

	if ( nchinp .eq. 0 ) then

	  kboard = -1

	  go to 999
	endif


c  Some answer.

	kboard = 0


999	return
	end
c @(#)askyn.f	1.4 04/05/96
c*****************************************************************************
	subroutine askyn( kboard )

c  ASK_Yes_No.
c
c  Does not print a prompt.
c  User input any of: 'y'es, 'n'o, <cr> (carriage_return only), or 'mu'.
c
c  KBOARD  Returned 4 byte integer:
c       1 for 'yes' keyboard input,
c       0 for 'no' keyboard input,
c      -1 for carriage_return only,
c      -2 for 'mu' or 'MU'.  This is the character equivalent of a 
c           limited abort generated by a CTL-EOT (eg. ^d).
c
c  An interpretation of KBOARD values:
c       1 is true,
c       0 is false,
c      -1 is don't care, take the default answer,
c      -2 is don't ask this question.
c
c   M Webring, USGS, 4 level response circa 1985 as function NOYES.

	character txtrec*80

	icnt  =  0


10	continue
	call askrd( txtrec, kboard )


c  Partially interpreted KBOARD values.

	if ( kboard .eq. -2 ) go to 999
	if ( kboard .eq. -1 ) go to 999


c  TXTREC interpretation (for completeness).

	kboard = 999999999
	call gcleft ( txtrec, nchtxt )

        if ( txtrec(1:1) .eq. 'y' .or.
     1  txtrec(1:1) .eq. 'Y' )   kboard =  1

        if ( txtrec(1:1) .eq. 'n' .or.
     1  txtrec(1:1) .eq. 'N' )   kboard =  0

	if ( nchtxt .eq. 0 )     kboard = -1

	if ( txtrec(1:2) .eq. 'mu' .or.
     1  txtrec(1:2) .eq. 'MU' )  kboard = -2


c  Answer not recognized.

        if ( kboard .gt. 99 ) then
          if ( icnt .lt. 3 ) then
            icnt = icnt + 1
            print *, ' Yes, No, <CR>, MU (ie.unask)'
            go to 10
          else
            print *, ' askyn: Count exceeded taking default'
	    kboard = -1
            go to 999
          endif
        endif


999	return
	end
