C  ECHO routines: IASK, CASK, FASK, FASK8, LASK,
C	 ITRIM , OPEN_FILE, UPPERCASE, UNIQUE_NAME
C-------------------------------------------------------------------------------
C  *ASK: Display current value for a integer*2, character, real*4 or logical along with QUERY prompt.
C	 User is asked for an updated value  (default is the old value)
C  ITRIM : Returns length of character string (position last non-blank)
C  OPEN_FILE : Opens a standard HELIOS data file
C  UNIQUE_NAME : Returns a unique file name matching a pattern string
C-------------------------------------------------------------------------------
      subroutine IASK(QUERY,IVAL)
      implicit integer*2 (I-N)
      character CH*58/' '/,NEW*20,QUERY*(*),CFORM*20 /'(1H$,A,2H< ,I4,2H >)'/
      data LINE/58/					!Line width
      L = ITRIM(QUERY)					!Number of chars in QUERY
      I1 = 1
      I2 = 1
      if (L .lt. LINE-2) then		!If QUERY fits line with one blank on each side...
         I1 = (LINE-L)/2 				!.. center QUERY on line
         I2 = LINE-L-I1
      end if
      IERR = 1
      J = 1
      if (IVAL .ne. 0) J = alog10(abs(float(IVAL)))+1
      if (IVAL .lt. 0) J = J+1
      write (CFORM(14:14),'(I1.1)') max(J,3)
      do while (IERR .ne. 0)
          write (*,CFORM) CH(1:I1)//QUERY(1:L)//CH(1:I2),IVAL
          read (*,'(A)') NEW
          J = ITRIM(NEW)
          if (J .eq. 0) return				!Previous value retained
          IERR = 0
          I = 0
          do while (IERR .eq. 0 .and. I .lt. J)		!Check for funny input
              I = I+1
              if (llt(NEW(I:I),'-') .or. lgt(NEW(I:I),'9')) IERR = 1
          end do					!Only numericals excepted
          if (IERR .eq. 0) read (NEW,*,iostat=IERR) IVAL	!New value adopted
      end do
      return
      end
C-------------------------------------------------------------------------------
      subroutine CASK(QUERY,CVAL)
      implicit integer*2 (I-N)
      character OLD*64,NEW*64,CH*61/' '/,QUERY*(*),CVAL*(*)
      data LINE/58/
      IFULL = LINE+7
      L = ITRIM(QUERY)
      M = ITRIM(CVAL)
      OLD(1:M) = CVAL(1:M)
      do while (M .lt. 3)
          NEW(1:M) = OLD(1:M)
          OLD(1:M+1) = ' '//NEW(1:M)
          M = M+1
      end do
      K = IFULL-M-4
      I1 = 1
      I2 = 1
      if (L .lt. K-2) then
         I1 = (K-L)/2
         if (L .lt. 2*K-LINE-2) I1 = (LINE-L)/2
         I2 = K-L-I1
      end if
      write (*,'(1H$,A,2H< ,A,2H >)') CH(1:I1)//QUERY(1:L)//CH(1:I2),OLD(1:M)
      read (*,'(A)') NEW
      if (ITRIM(NEW) .ne. 0) CVAL = NEW			!New value conditionally adopted
      return
      end
C-------------------------------------------------------------------------------
      subroutine FASK(QUERY,VAL)
      implicit integer*2 (I-N)
      character NEW*20,CHAR*12,CHAR1*12,CH*58/' '/,CC,QUERY*(*)
      data LINE/58/
      L  = ITRIM(QUERY)					!Number of chars in QUERY
      I1 = 1
      I2 = 1
      if (L .lt. LINE-2) then		!If QUERY fits line with one blank on each side...
         I1 = (LINE-L)/2				!.. center QUERY on line
         I2 = LINE-L-I1
      end if

      if (VAL .eq. 0.) then
          CHAR = '  0'
          NRS = 3
          go to 1
      end if
      write (CHAR,'(G12.5)') VAL
      if (CHAR(9:9) .eq. 'E') then
          read (CHAR(10:12),'(I3.2)') I
          I = I-1
          write (CHAR(10:12),'(I3.2)') I
          CHAR(2:2) = CHAR(4:4)
          do I=5,8
             J = I-1
             CHAR(J:J) = CHAR(I:I)
          end do
          CHAR(8:8) = '0'
      end if
      NRS = len(CHAR)-4					!4: exp. field
      do while (CHAR(NRS:NRS) .eq. '0')			!Find last non-trivial digit
          NRS = NRS-1
      end do
      if (CHAR(NRS:NRS) .eq. '.') NRS = NRS-1
      I = 1
      do while (CHAR(I:I) .eq. ' ')			!Find first non-trivial digit
          I = I+1
      end do
      NRS = NRS-I+1					!Number of non-trivial digits
      do J=1,NRS
          IDUM = J+I-1
          CHAR(J:J) = CHAR(IDUM:IDUM)			!Shift number to left side of field
      end do
      if (CHAR(9:9) .eq. 'E') then			!Extra characters for exponent
          read (CHAR(10:12),'(I3.2)') I
          if (I .ne. 0) then
              NRS = NRS+1
              CHAR(NRS:NRS) = 'E'
              if (CHAR(10:10) .eq. '-') then
                 NRS = NRS+1
                 CHAR(NRS:NRS) = '-'
              end if
              if (CHAR(11:11) .ne. '0') then
                 NRS = NRS+1
                 CHAR(NRS:NRS) = CHAR(11:11)
              end if
              if (CHAR(12:12) .ne. ' ') then
                  NRS = NRS+1
                  CHAR(NRS:NRS) = CHAR(12:12)
              end if
          end if
      end if
      CHAR1 = CHAR
      do while (NRS .lt. 3)
          CHAR(1:NRS+1) = ' '//CHAR1(1:NRS)
          NRS = NRS+1
          CHAR1 = CHAR
      end do

1     write(*,'(1H$,A,2H< ,A,2H >)') CH(1:I1)//QUERY(1:L)//CH(1:I2),CHAR(1:NRS)
      read  (*,'(A)') NEW
      J = ITRIM(NEW)
      if (J .eq. 0) return				!Previous value retained
      IEX = 0
      do I=1,J						!Check for funny input characters
          CC = NEW(I:I)
          if (CC .eq. 'e' .or. CC .eq. 'E') then
             IEX = IEX+1				!The first 'E' indicates presence of exponent
             if (IEX .eq. 2) go to 1			!A second 'E' implies non-sensical input
          else if (llt(CC,',') .or. lgt(CC,'9') .or. CC .eq. '/') then
             go to 1     			!Anything other than '-','.' or a numerical is rejected
          end if
      end do
      read (NEW,*,err=1) VAL				!New value adopted
      return
      end
C-------------------------------------------------------------------------------
      subroutine FASK8(QUERY,VAL)
      implicit integer*2 (I-N)
      real*8 VAL
      character NEW*20,CHAR*18,CHAR1*18,CH*58/' '/,CC,QUERY*(*)
      data LINE/58/
      L  = ITRIM(QUERY)					!Number of chars in QUERY
      I1 = 1
      I2 = 1
      if (L .lt. LINE-2) then		!If QUERY fits line with one blank on each side...
         I1 = (LINE-L)/2				!.. center QUERY on line
         I2 = LINE-L-I1
      end if

      if (VAL .eq. 0.) then
          CHAR = '  0'
          NRS = 3
          go to 1
      end if
      write (CHAR,'(G18.11)') VAL
      IPEX = 15				!Position of exponential symbol 'E' (if present)
      IPEX1 = IPEX+1
      IPEX2 = IPEX+2
      IPEX3 = IPEX+3
      if (CHAR(IPEX:IPEX) .eq. 'E') then
          read (CHAR(IPEX1:IPEX3),'(I3.2)') I
          I = I-1					!Decrease exponent by one
          write (CHAR(IPEX1:IPEX3),'(I3.2)') I
          CHAR(2:2) = CHAR(4:4)				!CHAR(2:3) is always "0."
          IDUM = IPEX-1
          do I=5,IDUM				!Shift mantissa one position to the left ...
             J = I-1				!.. (multiplication by ten)
             CHAR(J:J) = CHAR(I:I)
          end do
          CHAR(IDUM:IDUM) = '0'
      end if
      NRS = len(CHAR)-4				!4: exp. field
      do while (CHAR(NRS:NRS) .eq. '0')		!Find last non-trivial digit
          NRS = NRS-1
      end do
      if (CHAR(NRS:NRS) .eq. '.') NRS = NRS-1
      I = 1
      do while (CHAR(I:I) .eq. ' ')		!Find first non-trivial digit
          I = I+1
      end do
      NRS = NRS-I+1				!Number of non-trivial digits
      do J=1,NRS
          IDUM = J+I-1
          CHAR(J:J) = CHAR(IDUM:IDUM)		!Shift number to left side of field
      end do
      if (CHAR(IPEX:IPEX) .eq. 'E') then	!Extra characters for exponent
          
          read (CHAR(IPEX1:IPEX3),'(I3.2)') I
          if (I .ne. 0) then
              NRS = NRS+1
              CHAR(NRS:NRS) = 'E'
              if (CHAR(IPEX1:IPEX1) .eq. '-') then
                 NRS = NRS+1
                 CHAR(NRS:NRS) = '-'
              end if
              if (CHAR(IPEX2:IPEX2) .ne. '0') then
                 NRS = NRS+1
                 CHAR(NRS:NRS) = CHAR(IPEX2:IPEX2)
              end if
              if (CHAR(IPEX3:IPEX3) .ne. ' ') then
                  NRS = NRS+1
                  CHAR(NRS:NRS) = CHAR(IPEX3:IPEX3)
              end if
          end if
      end if
      CHAR1 = CHAR
      do while (NRS .lt. 3)
          CHAR(1:NRS+1) = ' '//CHAR1(1:NRS)
          NRS = NRS+1
          CHAR1 = CHAR
      end do

1     write (*,'(1H$,A,2H< ,A,2H >)') CH(1:I1)//QUERY(1:L)//CH(1:I2),CHAR(1:NRS)
      read  (*,'(A)') NEW
      J = ITRIM(NEW)
      if (J .eq. 0) return			!Previous value retained
      IEX = 0
      do I=1,J					!Check for funny input characters
          CC = NEW(I:I)
          if (CC .eq. 'e' .or. CC .eq. 'E') then
             IEX = IEX+1			!The first 'E' indicates presence of exponent
             if (IEX .eq. 2) go to 1		!A second 'E' implies non-sensical input
          else if (llt(CC,',') .or. lgt(CC,'9') .or. CC .eq. '/') then
             go to 1			!Anything other than '-','.' or a numerical is rejected
          end if
      end do
      read (NEW,*,err=1) VAL			!New value adopted
      return
      end
C-------------------------------------------------------------------------------
      subroutine LASK(QUERY,VAL)
      implicit integer*2 (I-N)
      character NEW*5,CH*58/' '/,QUERY*(*),ADD*14/' (0=No; 1=Yes)'/
      logical VAL
      data LINE/58/
      L  = ITRIM(QUERY)+14
      I1 = 1
      I2 = 1
      if (L .lt. LINE-2) then
         I1 = (LINE-L)/2
         I2 = LINE-L-I1
      end if

  1   IVAL = 1
      if (.not. VAL) IVAL = 0
      write (*,'(1H$,A,4H<   ,I1,2H >)') CH(1:I1)//QUERY(1:L-14)//ADD//CH(1:I2),IVAL
      read (*,'(A)') NEW
      if (ITRIM(NEW) .eq. 0) return
      do I=1,ITRIM(NEW)				!Check for funny input characters
          if (llt(NEW(I:I),'-') .or. lgt(NEW(I:I),'9')) go to 1
      end do					!Only numericals excepted
      read (NEW,*,err=1) IVAL			!New value adopted
      if (IVAL .ne. 0 .and. IVAL .ne. 1) go to 1
      VAL = .TRUE.
      if (IVAL .eq. 0) VAL = .FALSE.
      return
      end
C-------------------------------------------------------------------------------
      integer*2 function ITRIM(S)
C-------------------------------------------------------------------------------
C  Returns the index of the last non-blank character in S.
C-------------------------------------------------------------------------------
      character*(*) S
      ITRIM = len(S)
      do while (ITRIM .gt. 0 .and. S(ITRIM:ITRIM) .eq. ' ')
          ITRIM = ITRIM-1
      end do
      return
      end
C-------------------------------------------------------------------------------
      subroutine CWRITE(MESSAGE)
      implicit integer*2 (I-N)
      character MESSAGE*(*),CH*58/' '/
      data LINE/58/
      L = ITRIM(MESSAGE)
      I1 = 1
      if (L .lt. LINE-2) I1 = (LINE-L)/2
      write (*,'(1H0,2A,/)') CH(1:I1),MESSAGE(1:L)
      return
      end
C-------------------------------------------------------------------------------
      subroutine OPEN_FILE(MESSAGE,IU,FILE,LNGTH)
C-------------------------------------------------------------------------------
C  Opens a data file.
C
C  INPUT:
C
C  MESSAGE   character       Prompt string (used in CASK)
C  IU        integer*2       Unit number of file to be opened
C
C  OUTPUT:
C
C  FILE      character*13    File name of file to be opened
C  LNGTH     integer*2       record length of opened file (6 or 37)
C                            If LNGTH = 0 no file was opened
C-------------------------------------------------------------------------------
C  A default for FILE is read from the global DCL variable DEF_FILE.
C  Any file name may be entered, but the subroutine is most flexible when file 
C  names are used of the type created by the program CONNECT.FOR. If for 
C  instance the default is A76V4_007.DAT, then the following abbreviated 
C  responses are possible:
C    .ZLD           results in FILE = 'A76V4_007.ZLD'
C    _111           results in FILE = 'A76V4_111.DAT'
C    _111.ZLD       results in FILE = 'A76V4_111.ZLD'
C    9              results in FILE = 'A76V9_007.DAT'
C    0              no file is opened  (LNGTH is returned zero)
C  Only existing (status='OLD') with DIRECT access can be opened. The record
C  length is returned in the variable LNGTH.
C------------------------------------------------------------------------------
      implicit integer*2 (I-N)
      character MESSAGE*(*),FILE*(*),GET_FILE*80

      call LIB$GET_SYMBOL('DEF_FILE',FILE)	!Read default file name
      I = 1
      do while (I .ne. 0)			!Do while opening not succesful
          GET_FILE = FILE
          call CASK(MESSAGE,GET_FILE)
          K = ITRIM(GET_FILE)
          if (GET_FILE(1:1) .eq. '_') then	!Change doy label and/or extension
              FILE(6:5+K) = GET_FILE(1:K)
          else if (GET_FILE(1:1) .eq. '.') then	!Change or add extension
              L = index(FILE,'.')-1
              if (L .eq. -1) L = ITRIM(FILE)	!No extension in def. name
              FILE = FILE(1:L)//GET_FILE(1:K)	!Add/overwrite extension
          else if (GET_FILE(1:1) .eq. ';') then	!Change or add version number
              L = index(FILE,';')-1
              if (L .eq. -1) L = ITRIM(FILE)	!No version number in def. name
              FILE = FILE(1:L)//GET_FILE(1:K)	!Change or add version number
          else if (GET_FILE(1:1) .eq. '9') then	!Change to 90 deg file ...
              FILE(5:4+K) = GET_FILE(1:K)	!.. and/or doy/extension
          else if (ichar(GET_FILE(1:1)) .ge. 49 .and. ichar(GET_FILE(1:1)) .le. 53) then
              FILE(5:4+K) = GET_FILE(1:K)	!Change filter and/or doy/extension
          else					!Change to new file name
              FILE = GET_FILE
          end if

          if (FILE(1:1) .eq. '0') then		!Cancel opening procedure
              LNGTH = 0
              call CWRITE('NO FILE OPENED')
              return
          end if

          call UPPERCASE(FILE)
          K = ITRIM(FILE)
          if (index(FILE,'.') .eq. 0) then
              FILE(K+1:K+4) = '.DAT'		!Default extension
              K = K+4
          end if

          open (IU,iostat=I,file=FILE,status='OLD',access='DIRECT')
          if (I .ne. 0) call CWRITE('OPENING ERROR ON FILE '//FILE(1:K))
      end do

      call LIB$SET_SYMBOL('DEF_FILE',FILE(1:K),2)	!Write default file name
      inquire (IU,recl=LNGTH,name=FILE)
      call CWRITE(FILE(1:ITRIM(FILE))//' opened')
      return
      end
C-------------------------------------------------------------------------------
      subroutine UPPERCASE(C)
      implicit integer*2 (I-N)
      character C*(*)
      do I=1,LEN(C)
          J = ichar(C(I:I))
          if (J .ge. 97 .and. J .le. 122) C(I:I) = char(J-32)
      end do
      return
      end
C------------------------------------------------------------------------------
	subroutine UNIQUE_NAME(FILE,PATTERN)
C
C Returns a unique file name FILE by replacing the question mark in the
C PATTERN string by a 10 digit number. The 10 digit number is made up
C of the system time (8 digits) and a counter (2 digits).
C
	implicit integer*2 (I-N)
	character CT*23,CNUM*10,FILE*(*),PATTERN*(*)
	save ICOUNT

	MARKQ = index(PATTERN,'?')
	if (MARKQ .eq. 0) stop 'PATTERN must contain question mark (?)'

	call LIB$DATE_TIME(CT)
	CNUM(1:8) = CT(13:14)//CT(16:17)//CT(19:20)//CT(22:23)
	ICOUNT = ICOUNT+1
	ICOUNT = ICOUNT-ICOUNT/100*100
	write (CNUM(9:10),'(I2.2)') ICOUNT

	LENGTH = ITRIM(PATTERN)
	FILE = CNUM
	if (MARKQ .gt. 1) FILE = PATTERN(1:MARKQ-1)//CNUM
	if (MARKQ .lt. LENGTH) FILE = FILE(1:MARKQ+9)//PATTERN(MARKQ+1:LENGTH)

	return
	end