C              Fortran Friends (6 Feb 1993).
      PROGRAM TUTILS
C          tests all the Utils library
C          needs the 'utils' library
C
C           test message trans utilities
      CALL TMESG
C           wait for keypress
      CALL KWAIT
C           test file utilities
      CALL TFILE
      CALL KWAIT
C           test BEEP
      PRINT *,'test BEEP... should make a noise'
      CALL BEEP
      CALL KWAIT
C           test GTARGS and LNBLNK
      CALL TGTARG
      CALL KWAIT
C           test LOC, LOCC
      CALL TLOC
      CALL KWAIT
C           test NEXTWD
      CALL TNEXTWD
      CALL KWAIT
C           test OSBYTE
      CALL TOSBYTE
      CALL KWAIT
C           test OSWORD
      CALL TOSWORD
      CALL KWAIT
C           test SoftWare Interrupts / OSCLI
      CALL TARCSWI
      CALL KWAIT
C           test EVALF
      CALL TEVALF
C           test IGET
      CALL TIGET
      CALL KWAIT
C           test INKEY
      CALL TINKEY
      CALL KWAIT
C           test MOUSE
      CALL TMOUSE
      CALL KWAIT
C           test trace-back
      CALL TTRACE
      CALL KWAIT
C           test the sorting
      CALL TSORT
      CALL KWAIT
C           test reserving space
      CALL TSPAC
      CALL KWAIT
C           finally test the floating point trap routines
      CALL TTRAP
      END
C
      SUBROUTINE KWAIT
C         wait for keypress
      PRINT 101
  101 FORMAT('  **    press any key to continue (Escape to stop)')
C         stop if 'escape'
      IF(IGET().EQ.27) STOP 'Escape'
      RETURN
      END
C
      SUBROUTINE TFILE
C          test the file utilities
      CHARACTER FNAME*10,TYPES(2)*9,ACCESS*6,NAM1*10,ACCS1*6,DATE*20
      DATA TYPES/'File','Directory'/,NAM1/' '/
      DIMENSION IB(10)
C          list the files in the current directory
      PRINT *,' file  name             type access  date/time'
      DO 10 JF = 1, 77
        FNAME = ' '
        CALL FLDIRE(JF,'@',FNAME,IRES)
        IF(IRES.GT.0) THEN
          CALL FLACCS(.FALSE.,FNAME,ACCESS,IERR)
          IF(IERR.NE.0) STOP'FLACCS has made a mistake!'
          IF(IRES.EQ.1) THEN
            CALL FLTYPE(.FALSE.,FNAME,ITYPE,IERR)
            IF(IERR.NE.0) STOP 'problem 1 in FLTYPE'
          ELSE
            ITYPE = 0
          ENDIF
          CALL FLDATE(FNAME,DATE,IERR)
          IF(IERR.NE.0) STOP'problem in FLDATE'
          PRINT 101,JF,FNAME,TYPES(IRES),ITYPE,ACCESS,DATE
  101     FORMAT(I3,' ',A10,'/',A9,Z4.3,'   ',A6,' ',A20)
          IF(IRES.EQ.1) THEN
C             save real file name for later testing
            NAM1 = FNAME
            ACCS1 = ACCESS
            ITYP1 = ITYPE
          ENDIF
        ELSE
          GO TO 20
        ENDIF
   10 CONTINUE
C
   20 IF(NAM1.NE.' ') THEN
        PRINT *,'file ',NAM1,' of type ',ITYP1,' has access ',ACCS1
        PRINT *,' change it to rwL and type &111'
        CALL FLACCS(.TRUE.,NAM1,'rwL',IERR)
        IF(IERR.NE.0) STOP 'problem 1 in FLACCS'
        CALL FLTYPE(.TRUE.,NAM1,?I111,IERR)
        IF(IERR.NE.0) STOP 'problem 2 in FLTYPE'
        CALL FLACCS(.FALSE.,NAM1,ACCESS,IERR)
        IF(IERR.NE.0) STOP 'problem 2 in FLACCS'
        CALL FLTYPE(.FALSE.,NAM1,ITYPE,IERR)
        IF(IERR.NE.0) STOP 'problem 3 in FLTYPE'
        PRINT *,' type is now',ITYPE,', access is now ',ACCESS
        CALL FLACCS(.TRUE.,NAM1,ACCS1,IERR)
        IF(IERR.NE.0) STOP 'problem 3 in FLACCS'
        CALL FLTYPE(.TRUE.,NAM1,ITYP1,IERR)
        IF(IERR.NE.0) STOP 'problem 4 in FLTYPE'
        CALL FLACCS(.FALSE.,NAM1,ACCESS,IERR)
        IF(IERR.NE.0) STOP 'problem 4 in FLACCS'
        CALL FLTYPE(.FALSE.,NAM1,ITYPE,IERR)
        IF(IERR.NE.0) STOP 'problem 5 in FLTYPE'
        PRINT *,'type restored to ',ITYPE,', access restored to ',ACCESS
      ENDIF
C             now create a file
      PRINT *,'Now create a little file "Freddy_"'
      DO 30 I=1,10
   30 IB(I)=I
      CALL FLSAVE('Freddy_',IB,40,100,IER)
      IF(IER.NE.0) THEN
        PRINT *,'Error',IER,' creating file'
        STOP
      ENDIF
      CALL FLTYPE(.FALSE.,'Freddy_',ITYPE,IERR)
      IF(IERR.NE.0) STOP 'Can not read Freddy_''s type'
      PRINT *,'Freddy_ has type',ITYPE,', should be 100'
      CALL FLSIZE('Freddy_',ISIZE,IERR)
      IF(IERR.NE.0) STOP 'Can not read Freddy_''s size'
      PRINT *,'Freddy_ has size',ISIZE,', should be 40'
      DO 40 I=1,10
   40 IB(I)=-1
C         load the first 8 words only as a test
      CALL FLLOAD('Freddy_',IB,32,IER)
      IF(IERR.NE.0) STOP 'Can not load Freddy_'
      DO 50 I=1,10
        IF((I.LE.8.AND.IB(I).NE.I) .OR. (I.GT.8.AND.IB(I).NE.-1)) THEN
          PRINT *,'Error loading word',I,', it is',IB(I)
        ENDIF
   50 CONTINUE
C         delete Freddy_
      CALL OSCLI('delete Freddy_')
      RETURN
      END
C
      SUBROUTINE TEVALF
      CHARACTER TEXT*40,KEYW*10
   10 PRINT 102
  102 FORMAT(' Testing EVALF'/
     +'Do you want to enter a keyword? (Y/N) ',$)
      I=IGET()
      IF(I.GT.96) I=I-32
      PRINT 107,CHAR(I)
      IF(I.EQ.ICHAR('Y')) THEN
        PRINT 103
  103 FORMAT(' Enter keyword (not more than 4 alphabetic characters) '
     +        ,$)
        READ 107,KEYW
        PRINT 104
  104   FORMAT(' Value (may be an expression) ',$)
        READ 107,TEXT
        J=JVALK(TEXT,KEYW)
        IF(J.GT.0) THEN
          PRINT *,'Illegal value: ',TEXT(1:LNBLNK(TEXT)),', error=',J
          GO TO 10
        ELSEIF(J.LT.0) THEN
          PRINT *,'Illegal keyword ',KEYW(1:LNBLNK(KEYW)),', error=',J
          GO TO 10
        ENDIF
      ELSEIF(I.NE.ICHAR('N')) THEN
        GO TO 10
      ENDIF
   20 PRINT 101
  101 FORMAT('Enter numeric expression (blank to terminate): ',$)
      READ 107,TEXT
  107 FORMAT(A)
      IF(TEXT.EQ.' ') RETURN
      F=EVALF(TEXT,IERR)
      PRINT *,'Result =',F,', error:',IERR
      GO TO 20
      END
C
      SUBROUTINE TGTARG
      CHARACTER*25 COMMND
      PRINT *,'Testing GTARGS and LNBLNK'
      CALL GTARGS(COMMND)
      PRINT *,'Command line is:'
      PRINT *,COMMND
      PRINT *,'It is of length ',LNBLNK(COMMND)
      RETURN
      END
C
      SUBROUTINE TIGET
      PRINT *,'testing IGET'
   10 PRINT *,'press any legal key... 0 to end'
C           test IGET
      J=IGET()
      PRINT *,'ASCII value is ',J,' key is ',CHAR(J)
      IF(J.EQ.27) STOP'Escape'
      IF(J.NE.48)GOTO10
      RETURN
      END
C
      SUBROUTINE TINKEY   
C                   test INKEY
   20 PRINT *,'testing INKEY...  press 0 to stop'
      J=INKEY(200)
      IF(J.EQ.-1) PRINT *,'2 seconds have elapsed'
      IF(J.GE.0) PRINT *,'ASCII value is ',J,' key is ',CHAR(J)
      IF(J.NE.48) GO TO 20
C             test -ve INKEYs and -256
      I=INKEY(-256)
      PRINT *,'testing INKEY(-256) =',I
      PRINT *,'press any key to continue... '
      I=IGET()
      PRINT *,'testing -ve INKEY, press any key...  0 to stop'
   30 DO 36 I=1,124
      IF(INKEY(-I).NE.0)THEN
        PRINT *,'key pressed I=',I
   35   IF(INKEY(-I).NE.0) GO TO 35
        IF(I.EQ.40) RETURN
      ENDIF
   36 CONTINUE
      GOTO30
      END
C
      SUBROUTINE TLOC
      DIMENSION III(2)
      CHARACTER*8 FRED
      DATA FRED/'FRED    '/
      PRINT *,'testing LOC and LOCC'
      PRINT *,'LOC(1),LOC(2) ',LOC(III(1)),LOC(III(2))
C           test LOCC
      PRINT *,'F(RED) starts at ',LOCC(FRED(1:1)),
     +        ', (FRE)D ends at ',LOCC(FRED(4:4))
      RETURN
      END
C
      SUBROUTINE TMESG
C    based on example published in Acorn User Jan 1994 page 109
      PARAMETER (MAXP=420)
      CHARACTER MEM*(MAXP)
      CHARACTER NAME*40,RESULT*256
C
      PRINT *,'Testing MessageTrans utilities'
      ISIZE = MSGSIZ('Messages')
      IF(ISIZE.GE.0) THEN
        PRINT *,'Buffer space needed',ISIZE
      ELSE
        PRINT *,'Messages file does not exist'
        STOP
      ENDIF
      IERR = MSGOPN('Messages',MEM)
      IF(IERR.NE.0) THEN
        PRINT *,'messages file failed to open with ierr=',IERR
        STOP
      ENDIF
      IERR = MSGGET(0,'Title',RESULT)
      L = LNBLNK(RESULT)
      PRINT *,'after MSGGET IERR=',IERR,', L=',L
      PRINT *,RESULT(1:L)
      IERR = MSGGET(0,'Name?',RESULT)
      IF(IERR.NE.0) CALL MSGERR(IERR,'Name?')
      L = LNBLNK(RESULT)
      PRINT *,RESULT(1:L)
      READ(*,101)NAME
  101 FORMAT(A80)
      L=LNBLNK(NAME)
      IERR = MSGGET(1,'Hello',NAME(1:L),RESULT)
      IF(IERR.NE.0) CALL MSGERR(IERR,'Hello')
      L = LNBLNK(RESULT)
      PRINT *,RESULT(1:L)
      IERR = MSGGET(4,'Str4','One','Two','Three','Four',RESULT)
      IF(IERR.NE.0) CALL MSGERR(IERR,'Str4')
      L = LNBLNK(RESULT)
      PRINT *,RESULT(1:L)
C           print values of Global variables as parameters.    
      IERR = MSGGGS(2,'Time','<Sys$Time>','<Sys$Date>',RESULT)
      IF(IERR.NE.0) CALL MSGERR(IERR,'Time')
      L = LNBLNK(RESULT)
      PRINT *,RESULT(1:L)
      IERR = MSGGET(0,'Long',RESULT)
      IF(IERR.NE.0) CALL MSGERR(IERR,'Long')
      L = LNBLNK(RESULT)
      PRINT *,RESULT(1:L)
      IERR = MSGGET(0,'Absent',RESULT)
      IF(IERR.NE.0) THEN
        PRINT *,'Token ''Absent'' correctly not found'
      ELSE
        PRINT *,'Absent token not detected'
      ENDIF
      CALL MSGCLS
      RETURN
      END
C
      SUBROUTINE MSGERR(IERR,NAME)
      CHARACTER*(*) NAME 
      PRINT *,'Error',IERR,' trying to find token ',NAME
      RETURN
      END
C
      SUBROUTINE TMOUSE
C          open a stream direct to screen with printer controls
      OPEN(10,FILE='rawvdu:',FORM='FORMATTED')
C          set # buffers for immediate print
*      CALL SETBUF(10,1)
C         clear screen and print header
      WRITE(10,101)12,31,1,4
  101 FORMAT(A1,' Testing mouse, press 0 to stop...  ',3A1,
     +'Mouse Mx,My,MButn  ')
C               TEST Mouse  1st turn it on
      CALL OSCLI('POINTER')
   40 CALL MOUSE(MX,MY,MBUTN)
      WRITE(10,102)31,20,4,MX,MY,MBUTN
  102 FORMAT(3A1,3I5)
      IF(INKEY(0).NE.48)GOTO40
      CLOSE(10)
      PRINT *
      RETURN
      END
C
      SUBROUTINE TNEXTWD
      CHARACTER*50 STRING
      CHARACTER*8 WORD
      DATA STRING/'Albert Benjamin Caroline Dan   Englebert Fanny   *'/
      PRINT *,'Parse the string:'
      PRINT *,'"'//STRING//'"'
      PRINT *,'into 8-byte words using NEXTWD'
      JS=1
   10 CALL NEXTWD(STRING,JS,WORD,LW)
      PRINT *,WORD,' with length',LW,', next pointer at',JS
      IF(LW.NE.0 .AND. JS.LE.LEN(STRING)) GO TO 10
      RETURN
      END
C
      SUBROUTINE TOSBYTE
C           to test the 3 TopExpress OS_Byte functions
      PRINT *,'Testing OSBYTE. press a key to turn off num lock'
      I=IGET()
      CALL OSBYTE1(202,0,255,ISTAT)
      ISTAT = IBSET(ISTAT,2)
      CALL OSBYTE(202,ISTAT,0)
      CALL OSBYTE(118,0,0)
      PRINT *,'Testing OSBYTE. press a key to turn on num lock'
      I=IGET()
      ISTAT = IBCLR(ISTAT,2)
      CALL OSBYTE(202,ISTAT,0)
      CALL OSBYTE(118,0,0)
      INNP = -1
      CALL OSBYTE2(237,0,255,ISTAT,INNP)
      PRINT *,'Numeric Keypad offset (should be 48) =',INNP
      RETURN
      END
C
      SUBROUTINE TOSWORD
C         to test the TopExpress OS_Word function
      BYTE IB(8)
      PRINT *,'testing OSWORD by reading the palette'
      PRINT *,'works properly only in 16-colour modes'
      DO 10 I=0,15
      IB(1)=I
      CALL OSWORD(11,IB)
      PRINT 101,I,(IAND(IB(J+1),255),J=1,4)
  101 FORMAT(' log col.',I3,', phys col.',I3,', RGB ',3I4)
   10 CONTINUE
      RETURN
      END
C
      SUBROUTINE TSORT
      PARAMETER(N2=5000,N=N2+N2)
      DOUBLE PRECISION D(N2)
      REAL R(N)
      CHARACTER*8 TEXT(N2)
      COMMON I(N),INDX(N)
      EQUIVALENCE(D(1), R(1), I(1))
      PRINT *,'checking the sorting routines...'
      DO 10 J=1,N
   10 INDX(J)=J
      PRINT *,'creating',N2,' random double precision words'
      DO 20 J=1,N2,2
      D(J)=RND01()-0.5
      D(J+1)=D(J)+(RND01()-0.5)*5.D6
   20 CONTINUE
      PRINT *,'sorting'
      CALL QSORTD(D,INDX,N2)
      PRINT *,'checking'
      DO 30 J=1,N2-1
      IF(D(INDX(J)).GT.D(INDX(J+1))) 
     +PRINT *,'sort failed',J,INDX(J),INDX(J+1),D(INDX(J)),D(INDX(J+1))
   30 CONTINUE
      PRINT *,'creating',N,' random single precision words'
      DO 40 J=1,N
      R(J)=(RND01()-0.5)*100.
   40 CONTINUE
      PRINT *,'creating',N2,' random 8-bit text strings'
      DO 70 J=1,N2
        WRITE(TEXT(J),101)R(J)
  101   FORMAT(F8.5)
   70 CONTINUE
      PRINT *,'sorting',N2,' random text strings'
      CALL QSORTC(TEXT,INDX,N2)
      PRINT *,'checking text sort'
      DO 80 J=1,N2-1
      IF(TEXT(INDX(J)).GT.TEXT(INDX(J+1))) THEN
       PRINT *,'sort failed',J,INDX(J),INDX(J+1),TEXT(INDX(J)),
     +  TEXT(INDX(J+1))
      ENDIF
   80 CONTINUE
      PRINT *,'sorting single precision'
      CALL QSORTR(R,INDX,N)
      PRINT *,'checking single precision sort'
      DO 50 J=1,N-1
      IF(R(INDX(J)).GT.R(INDX(J+1)))
     +PRINT *,'sort failed',J,INDX(J),INDX(J+1),R(INDX(J)),R(INDX(J+1))
   50 CONTINUE
      PRINT *,'sorting',N,' random integer words'
      CALL QSORTI(I,INDX,N)
      PRINT *,'checking'
      DO 60 J=1,N-1
      IF(I(INDX(J)).GT.I(INDX(J+1)))
     +PRINT *,'sort failed',J,INDX(J),INDX(J+1),I(INDX(J)),I(INDX(J+1))
   60 CONTINUE
      PRINT *,'check the index is still intact'
      DO 90 J=1,N
        I(J)=J
   90 CONTINUE
      CALL QSORTI(INDX,I,N)
      DO 100 J=1,N
        IF(INDX(I(J)).NE.J) PRINT *,J,' lost from index'
  100 CONTINUE
      RETURN
      END
C
      SUBROUTINE TARCSWI
      DIMENSION IREGS(0:9)
      CHARACTER*11 DIR,FILE(77)
      CHARACTER*50 ERMSG
      LOGICAL OSCLI
      DATA DIR(1:9)/'$.LIBRARY'/
C           test ARCSWI with OS_GBPB to readfile names in library
      PRINT *,'test SWI facility'
      DIR(10:10)=CHAR(0)
      N=0
      IREGS(0)=9
      IREGS(1)=LOCC(DIR)
      IREGS(3)=1
      IREGS(4)=0
      IREGS(5)=11
      IREGS(6)=0
      PRINT *,'files in $.LIBRARY are:'
    2 IREGS(2)=LOCC(FILE(N+1))
      CALL ARCSWI(12,IREGS,IERR,ERMSG)
      IF(IERR.NE.0) THEN
        PRINT *,'Unexpected Error in ARCSWI:',ERMSG
        STOP 'Error'
      ENDIF
      IF(IREGS(4).LT.0.OR.IREGS(3).LE.0) GO TO 4
      N=N+1
      GO TO 2
    4 PRINT *,'number of files = ',N,'; files are:'
      DO 6 J=1,N
      I=INDEX(FILE(J),CHAR(0))
      FILE(J)(I:11)=' '
    6 CONTINUE
      PRINT 101,(FILE(J),J=1,N)
C               compiler feature... it doesn't understand end of record
  101 FORMAT(' ',4A11/)
      PRINT *,'now cause SWI error by reading from unopened file'
      IF(.NOT.OSCLI('CLOSE')) STOP 'Unexpected OSCLI error'
C          file handle
      IREGS(1)=20
      CALL ARCSWI('OS_BGet',IREGS,IERR,ERMSG)
      IF(IERR.NE.0) THEN
        PRINT *,' Anticipated error: ',ERMSG
      ELSE
        STOP' No error found - Problem!'
      ENDIF
      PRINT *,'Also test error message from OSCLI'
      IF(OSCLI('Fred was here')) THEN
        PRINT *,' No error found by OSCII!!!!'
      ELSE
        CALL OSGETERROR(IERR,ERMSG)
        PRINT *,'Expected OSCLI error found',IERR
        PRINT *,ERMSG
      ENDIF
      RETURN
      END
C
      SUBROUTINE TTRAP
C            to test the floating-point trap
      LOGICAL INX,UFL,OFL,DVZ,IVO
      CALL FPSTAT(INX,UFL,OFL,DVZ,IVO)
      PRINT 101,INX,UFL,OFL,DVZ,IVO
  101 FORMAT(' Default floating point traps'/' INX,UFL,OFL,DVZ,IVO'/
     +5L3//' Now set the UnderFLow flag and try repeated divisions'/
     +' This will cause an underflow failure'/
     +' (but we are at the end anyway)')
      CALL KWAIT
      UFL = .TRUE.
      CALL FPSSET(INX,UFL,OFL,DVZ,IVO)
      PRINT *,'INX,UFL,OFL,DVZ,IVO',INX,UFL,OFL,DVZ,IVO
      A = 1.0001
   10 A = A /1000.
      PRINT *,A
      IF(A.NE.0.) GO TO 10
      RETURN
      END
C
      SUBROUTINE TTRACE
C            to test the routine name trace-back
      CALL TRACEQ(6)
      RETURN
      END
C
      SUBROUTINE TRACEQ(LUN)
C                 to make a subroutine call traceback
      CHARACTER*12 NAME
C                 print header
      WRITE (LUN,101)
  101 FORMAT(/' Routine         at    called from'/)
      N = 0
   10 N = N + 1
C                 get name and locations of Nth routine
      CALL TRACEP(N,NAME,LBEG,LCALL)
C                 check it exists
      IF(LBEG.GT.0) THEN
        WRITE (LUN,102)NAME,LBEG,LCALL
  102   FORMAT(1X,A12,2Z8)
        GO TO 10
      ENDIF
      WRITE (LUN,103)
  103 FORMAT(/' End of trace-back'/)
      RETURN
      END
C
      SUBROUTINE TSPAC
      EXTERNAL SUB1
      PRINT *,'Testing reserving space'
      CALL RSPACE(SUB1,400000)
      CALL SUB2
      END
      SUBROUTINE SUB1(IW,NWD)
      DIMENSION IW(NWD)
      PRINT *,'In SUB1, #words=',NWD
      PRINT *,'initialise words'
      DO 10 I=1,NWD
   10 IW(I)=I
      PRINT *,'array now initialised'
      RETURN
      END
      SUBROUTINE SUB2
      PRINT *,'In SUB2'
      RETURN
      END
