c
c     Copyright (c) 1999,2000, Compaq Computer Corporation
c
c     See the file "license.terms" for information on usage and redistribution
c     of this file, and for a DISCLAIMER OF ALL WARRANTIES.
c
c  Menu formatting subroutines
c
      subroutine display_string(x, y, string, width, highlight)
      implicit none
c
      integer x, y, width, highlight
      character*(*) string
c
      include 'menu.cmn'
c
c     Display string at row x and column y. String limited to 132 characters
c
      character*132 buffer
c
      integer i, string_len
c
      call move_cursor(x,y)
c     Copy string into buffer, to ensure trailing spaces out to "width"
      buffer = string
      i = string_len(buffer)
      if( highlight .eq. 1 ) then
         if(i .ne. 0) then
         write(luout,100)
     1      BOLD_CHAR,buffer(1:MIN(132,i,width)),NORMAL_CHAR
100      format('+',a,a,a,$)
         endif
c        Write out any trailing blanks into field width
         if( width .gt. i ) then
            write(luout,101) buffer(i+1:MIN(132,width))
101         format('+',a,$)
         endif
      else
         write(luout,102) buffer(1:MIN(132,i,width))
102      format('+',a,$)
c        Write out any trailing blanks into field width
         if( width .gt. i ) then
            write(luout,101) buffer(i+1:MIN(132,width))
         endif
      endif
      return
      end
c
      subroutine display_real(x, y, value, highlight)
      implicit none
c
      integer x,y, highlight
      real    value
c
      include 'menu.cmn'
c
c     Display real number "value" at row x and column y
c     Format assumes field width is at least 9 characters wide
c
      real avalue
c
      avalue = ABS(value)
c
      call move_cursor(x,y)
      if( (avalue .LT. 1.0E4 .AND. avalue .GE. 1.0E-2) .OR.
     1     value .EQ. 0.0 ) then
         if( highlight .eq. 1 ) then
            write(luout,100,err=1000) BOLD_CHAR, value, NORMAL_CHAR
100         format('+',a,f9.3,a,$)
         else
            write(luout,101,err=1000) value
101         format('+',f9.3,$)
         endif
      else if( avalue .LT. 1.0E-2 .AND. avalue .GE. 1.0E-3 ) then
         if( highlight .eq. 1 ) then
            write(luout,200,err=1000) BOLD_CHAR, value, NORMAL_CHAR
200         format('+',a,f9.4,a,$)
         else
            write(luout,201,err=1000) value
201         format('+',f9.4,$)
         endif
      else
         if( highlight .eq. 1 ) then
            write(luout,300,err=1000) BOLD_CHAR, value, NORMAL_CHAR
300         format('+',a,1pe9.2,a,$)
         else
            write(luout,301,err=1000) value
301         format('+',1pe9.2,$)
         endif
      endif
1000  return
      end
c
      subroutine display_int(x, y, value, width)
      implicit none
c
      integer x,y
      integer value, width
c
      include 'menu.cmn'
c
c     Display integer number "value" at row x and column y
c
      call move_cursor(x,y)
      write(luout,100) BOLD_CHAR
100   format('+',a,$)
      write(luout,101,err=1000) value
101   format('+',i<width>,$)
1000  continue
      write(luout,100) NORMAL_CHAR
      return
      end
c
      subroutine display_intp(x, y, value, width)
      implicit none
c
      integer x,y
      integer value, width
c
      include 'menu.cmn'
c
c     Display integer number "value" at row x and column y
c     enclosed by parenthesis
c
      call move_cursor(x,y)
      write(luout,100) BOLD_CHAR
100   format('+',a,$)
      write(luout,101,err=1000) value
101   format('+','(',i<width>,')',$)
1000  continue
      write(luout,100) NORMAL_CHAR
      return
      end
c
      subroutine display_intf(x, y, value, format)
      implicit none
c
      integer x,y
      integer value
      character*(*) format
c
      include 'menu.cmn'
c
c     Display integer number "value" at row x and column y using format
c
      call move_cursor(x,y)
      write(luout,100) BOLD_CHAR
100   format('+',a,$)
      write(luout,format,err=1000) value
1000  continue
      write(luout,100) NORMAL_CHAR
      return
      end
c
      subroutine display_prompt(string)
      implicit none
c
c     Clear user input area (line 22) and
c     print a string to the prompt area (line 21)
c
      character*(*) string
c
      call clear_eol(22, 1)
      call display_string(21, 1, string, 80, 1)
      return
      end
c
      subroutine display_message(string)
      implicit none
c
c     Displays a string to the message area (line 24)
c
      character*(*) string
c
      call beep_terminal
      call display_string(24, 1, string, 80, 1)
      return
      end
c
      subroutine display_message_quietly(string)
      implicit none
c
c     Displays a string to the message area (line 24) without beeping
c     the terminal.
c
      character*(*) string
c
      call display_string(24, 1, string, 80, 1)
      return
      end
c
c
      subroutine clear_message_area
      implicit none
c
c     Clears the message area
      call clear_eol(24, 1)
c
      return
      end
c
      subroutine read_from_input_area(string, eof)
      implicit none
c
c     Read a string from the user input area
c     Side effect: message area is cleared after read is complete
c
      include 'menu.cmn'
c
      character*(*) string
      logical eof
c
      call move_cursor(22, 1)
      eof = .FALSE.
      read(luin, 100, end=1000) string
100   format(a)
      goto 2000
1000  eof = .TRUE.
c
c     Clear message area
2000  call clear_eol(24, 1)
c
      return
      end
c
      subroutine get_string_with_prompt(string, prompt)
      implicit none
c
c     Write prompt to prompt area, read string from user input area.
c     If user types in an EOF, return original string.
c
      character*(*) string, prompt
c
c     locals
c
      character*80 buffer
      logical eof
c
      call display_prompt(prompt)
      call read_from_input_area(buffer,eof)
      if( .NOT. eof ) then
         string = buffer
      endif
c
      return
      end
c
      subroutine get_reals_with_prompt(real_vec, nreals, prompt)
      implicit none
c
c     Write prompt to prompt area, read "nreals" real values 
c     from user input area.
c     If user types in a return or an EOF, return original real_values.
c
      integer nreals
      real real_vec(nreals)
      character*(*) prompt
c
c     locals
c
      integer i
      character*132 buffer
      logical eof, empty
c
2000  call display_prompt(prompt)
      call read_from_input_area(buffer,eof)
      if( .NOT. eof ) then
c         Test for empty buffer, if empty, return input values
          empty = .TRUE.
          do i=1,132
             if( buffer(i:i) .ne. ' ' ) empty = .FALSE.
          end do
          if( .NOT. empty ) then
             read(buffer,*,err=1000) (real_vec(i), i=1,nreals)
          endif
      endif
      goto 3000
c
1000  call display_message(
     1    'Illegal input, or insuffient number of input values')
      goto 2000
c
3000  continue
      return
      end
c
      subroutine get_ints_with_prompt(int_vec, nints, prompt)
      implicit none
c
c     Write prompt to prompt area, read "nints" integer values 
c     from user input area.
c     If user types in a return or an EOF, return original int_values.
c
      integer nints, int_vec(nints)
      character*(*) prompt
c
c     locals
c
      integer i
      character*80 buffer
      logical eof, empty
c
2000  call display_prompt(prompt)
      call read_from_input_area(buffer,eof)
      if( .NOT. eof ) then
c         Test for empty buffer, if empty, return input values
          empty = .TRUE.
          do i=1,80
             if( buffer(i:i) .ne. ' ' ) empty = .FALSE.
          end do
          if( .NOT. empty ) then
             read(buffer,*,err=1000) (int_vec(i), i=1,nints)
          endif
      endif
      goto 3000
c
1000  call display_message(
     1    'Illegal input, or insuffient number of input values')
      goto 2000
c
3000  continue
      return
      end
c
      subroutine display_ints(intval,nints,irow,icol,iwidth)
      implicit none
c
      integer nints, irow, icol, iwidth, intval(nints)
c
      integer i, jcol
c
      jcol = icol
c
      do i=1,nints
c        Assumes 80 columns wide screen
         if( jcol .gt. (80-iwidth+1) ) then
            call display_string(irow,78,'...',3,1)
            goto 100
         else
            call display_int(irow,jcol,intval(i),iwidth)
         end if
         jcol = jcol + iwidth
      end do
100   continue
      return
c
      end
c
      subroutine menu_set_logical_units(in, out)
      implicit none
c
      include 'menu.cmn'
c
      integer in, out
c
      luin  = in
      luout = out
c
      return
      end
c
      subroutine clear_screen
      implicit none
c
c     ANSI clear screen, home cursor.
c     Note: This subroutine does not enter ReGIS mode and clear
c     graphics plane (only needed for VT125). This should avoid screen
c     flashes when running Postmini from DECterms.
c
      include 'menu.cmn'
c
      character*1 ESC
      ESC = CHAR(27)
      write(luout,100) ESC, ESC
100   format('+', a1,'[H',a1,'[J',$)
      return
      end
c
      subroutine reset_vt_colormap
      implicit none
c
c     Resets VTxxx color map, so we get back normal intensity text.
c     Clear screen is placed last, so any control sequences that are
c     not recognized by the terminal will not appear on screen
c     (useful when called on Vaxstation terminal window).
c
      include 'menu.cmn'
c
      character*1 ESC, BACKSLASH
      parameter ( ESC = CHAR(27) )
      parameter ( BACKSLASH = CHAR(92) )
c
      write(luout,100) ESC, ESC, BACKSLASH, ESC
100   format('+', a1,
     1 'PpS(I0)S(M0(L0)1(L25)2(L50)3(L75))S(M0(AD)1(AB)2(AR)3(AG)',
     2 '4(AM)5(AC)6(AY)7(AH0L99S0))'
     2  a1, a1, a1, '[J', $)
      return
      end
c
      subroutine move_cursor(i,j)
      implicit none
c
c     moves cursor to position (i,j) for VTxxx terminals
c
      include 'menu.cmn'
c
      character*1 ESC
      integer i,j
      ESC = CHAR(27)
c
      if( i .lt. 10 ) then
         if( j .lt. 10) then
         write(luout,100)  ESC, i,j
         else
         write(luout,101)  ESC, i,j
         endif
      else
         if( j .lt. 10) then
         write(luout,102)  ESC, i,j
         else
         write(luout,103)  ESC, i,j
         endif
      endif
c
100   format('+',a1,'[',i1,';',i1,'H',$)
101   format('+',a1,'[',i1,';',i2,'H',$)
102   format('+',a1,'[',i2,';',i1,'H',$)
103   format('+',a1,'[',i2,';',i2,'H',$)
      return
      end
c
      subroutine move_cursor_bottom_of_screen
      implicit none
c
c     Move cursor to next to last row of screen
c
      integer rows, cols
c
      call get_term_display_size(rows,cols)
      call move_cursor(rows-1,1)
c
      return
      end
c
      subroutine clear_eol(i, j)
      implicit none
c
c     Moves cursor to position (i,j) and clears to end of line
c     for VTxxx terminals
c
      include 'menu.cmn'
c
      character*1 ESC
      integer i,j
      ESC = CHAR(27)
c
      if( i .lt. 10 ) then
         if( j .lt. 10) then
         write(luout,100)  ESC, i,j, ESC
         else
         write(luout,101)  ESC, i,j, ESC
         endif
      else
         if( j .lt. 10) then
         write(luout,102)  ESC, i,j, ESC
         else
         write(luout,103)  ESC, i,j, ESC
         endif
      endif
c
100   format('+',a1,'[',i1,';',i1,'H',a1,'[K'$)
101   format('+',a1,'[',i1,';',i2,'H',a1,'[K'$)
102   format('+',a1,'[',i2,';',i1,'H',a1,'[K'$)
103   format('+',a1,'[',i2,';',i2,'H',a1,'[K'$)
      return
      end
c
      subroutine get_reals(real_vec,num_real_vals,prompt,prompt_style)
      implicit none
c
      integer num_real_vals, prompt_style
      real real_vec(num_real_vals)
      character*(*) prompt
c
      include 'menu.cmn'
c
c     Write prompt, read in reals. Check for error on input,
c     cycle until you get what you want.
c     'prompt_style' is 0 if there is no linefeed after prompt;
c                       1 if there is a  linefeed after prompt.
c
c     locals
      integer i
c
100   if( prompt_style .eq. 0 ) then
         write(luout,1000) prompt
1000     format(' ',a,$)
      else
         write(luout,1001) prompt
1001     format(' ',a)
      endif
c
      read(luin,*,err=200) ( real_vec(i), i=1,num_real_vals )
      goto 300
c
200   write(luout,1010)
1010  format(' ','Illegal input of real values...re-enter')
      goto 100
c
300   continue
      return
      end
c
      subroutine get_ints(int_vec,num_int_vals,prompt,prompt_style)
      implicit none
c
      integer num_int_vals, prompt_style
      integer int_vec(num_int_vals)
      character*(*) prompt
c
      include 'menu.cmn'
c
c     Write prompt, read in ints. Check for error on input,
c     cycle until you get what you want.
c     'prompt_style' is 0 if there is no linefeed after prompt;
c                       1 if there is a  linefeed after prompt.
c
c     locals
      integer i
c
100   if( prompt_style .eq. 0 ) then
         write(luout,1000) prompt
1000     format(' ',a,$)
      else
         write(luout,1001) prompt
1001     format(' ',a)
      endif
c
      read(luin,*,err=200) ( int_vec(i), i=1,num_int_vals )
      goto 300
c
200   write(luout,1010)
1010  format(' ','Illegal input of integer values...re-enter')
      goto 100
c
300   continue
      return
      end

      subroutine get_char(ch,prompt,prompt_style)
      implicit none
c
      integer prompt_style
      character*1 ch
      character*(*) prompt
c
      include 'menu.cmn'
c
c     Write prompt, read in character.
c     'prompt_style' is 0 if there is no linefeed after prompt;
c                       1 if there is a  linefeed after prompt.
c
      if( prompt_style .eq. 0 ) then
         write(luout,1000) prompt
1000     format(' ',a,$)
      else
         write(luout,1001) prompt
1001     format(' ',a)
      endif
c
      read(luin,1100,end=2000) ch
1100  format(a1)
      goto 2001
c
c     EOF trap, return a blank character
2000  ch = ' '
c
2001  continue
      return
      end
c
      subroutine beep_terminal
      implicit none
c
      include 'menu.cmn'
c
c     Rings (ANSI) terminal bell
c
      character*1 BELL
      parameter ( BELL = CHAR(7) )
c
      write(luout,100) BELL
100   format('+',a1,$)
c
      return
      end      
c
      subroutine get_reals_with_default(real_vec, num_real_vals,
     1                                  prompt, format, style)
      implicit none
c
      integer num_real_vals, style
      real real_vec(num_real_vals)
      character*(*) prompt, format(num_real_vals)
c
      include 'menu.cmn'
c
c     Write prompt, then values of real_vec using format specified
c     in character array 'format'.
c     Read next input line. If line is empty, then return
c     Else try to read new values of real_vec from the input line.
c     Repeat if there are errors.
c
c     If style = 0, then do not issue a line feed after prompt
c
c     format must be no more than 10 characters long
c
c     locals
      integer i, ilen, string_len
      logical non_blank
      character*132 buffer
      character*40 tmp
c
c
100   if( style .eq. 0 ) then
         write(luout,1000) prompt
1000     format(' ',a,'[',$)
      else
         write(luout,1001) prompt
1001     format(' ',a/' ','   [',$)
      endif
      do i=1,num_real_vals
c        Do a "trial" write of the data using the format specified
c        If we get an error, punt, and use an "safe" exponential format
         tmp = '(' // format(i) // ')'
         write(buffer,tmp,err=1500) real_vec(i)
c        Ah so, MIPS f77 doesn't think output conversion error
c        ("*****") is an error! So we conpensate...sigh
1500     continue
         if( buffer(1:1) .eq. '*' ) then
            write(buffer,1501,err=1500) real_vec(i)
1501        format(1pe12.3)
         endif
         ilen = string_len(buffer)
         if( i .LT. num_real_vals ) then
            write(luout,1600) buffer(1:ilen)
1600        format('+',a,',',$)
         else
            write(luout,1601) buffer(1:ilen)
1601        format('+',a,'] ',$)
         endif
      end do
c
      read(luin,2000,err=200) buffer
2000  format(a)
      non_blank = .FALSE.
      do i=1,132
         if( buffer(i:i) .NE. ' ' ) non_blank = .TRUE.
      end do
      if( non_blank ) then
         read(buffer,*,err=200) (real_vec(i), i=1,num_real_vals)
      else
         return
      endif
c
      goto 300
c
200   write(luout,1010)
1010  format(' ','Illegal input of real values...re-enter')
      goto 100
c
300   continue
      return
      end
c
      subroutine get_ints_with_default(int_vec, num_int_vals,
     1                                 prompt, format, style)
      implicit none
c
      integer num_int_vals, style
      integer int_vec(num_int_vals)
      character*(*) prompt, format(num_int_vals)
c
      include 'menu.cmn'
c
c     Write prompt, then values of int_vec using format specified
c     in character array 'format'.
c     Read next input line. If line is empty, then return
c     Else try to read new values of int_vec from the input line.
c     Repeat if there are errors.
c
c     If style = 0, then do not issue a line feed after prompt
c
c     format must be no more than 10 characters long
c
c     locals
      integer i
      logical non_blank
      character*132 buffer
      character*80 local_format
c
c
100   if( style .eq. 0 ) then
         write(luout,1000) prompt
1000     format(' ',a,'[',$)
      else
         write(luout,1001) prompt
1001     format(' ',a/' ','   [',$)
      endif
      do i=1,num_int_vals
         local_format = '(''+'',          ,'','',$)'
         local_format(6:15) = format(i)
         if( i .EQ. num_int_vals ) local_format(17:20) = '    '
         write(luout,local_format) int_vec(i)
      end do
      write(luout,1002)
1002  format('+','] ',$)
c
      read(luin,2000,err=200) buffer
2000  format(a)
      non_blank = .FALSE.
      do i=1,132
         if( buffer(i:i) .NE. ' ' ) non_blank = .TRUE.
      end do
      if( non_blank ) then
         read(buffer,*,err=200) (int_vec(i), i=1,num_int_vals)
      else
         return
      endif
c
      goto 300
c
200   write(luout,1010)
1010  format(' ','Illegal input of integer values...re-enter')
      goto 100
c
300   continue
      return
      end
c
      subroutine get_str_with_default(str, prompt, style)
      implicit none
c
      integer style
      character*(*) str, prompt
c
      include 'menu.cmn'
c
c     Write prompt, then "str" in brackets.
c     Read next input line. If line is empty, then return with str
c     unchanged. Else line in str.
c
c     If style = 0, then do not issue a line feed after prompt
c
c     str should not be longer than 132 characters, or input will truncated
c
c     locals
      integer i, string_len
      logical non_blank
      character*132 buffer
c
      i = MAX(1,string_len(str))
100   if( style .eq. 0 ) then
         write(luout,1000) prompt ,str(1:i)
1000     format(' ',a,'[ ',a,' ] '$)
      else
         write(luout,1001) prompt, str(1:i)
1001     format(' ',a/' ','   [ ',a,' ]')
      endif
c
      read(luin,2000,end=300) buffer
2000  format(a)
      non_blank = .FALSE.
      do i=1,132
         if( buffer(i:i) .NE. ' ' ) non_blank = .TRUE.
      end do
      if( non_blank ) then
         str = buffer
      endif
c
300   continue
      return
      end
c
      block data menu_block
      implicit none
c
      include 'menu.cmn'
c
c     Provide default values for menu routine logical units
c
      data luin  /5/
      data luout /6/
c
      end
