home *** CD-ROM | disk | FTP | other *** search
/ RISC DISC 2 / RISC_DISC_2.iso / pd_share / program / fortran77_210 / library / f77 / tutils < prev    next >
Encoding:
Text File  |  1992-09-14  |  4.2 KB  |  143 lines
  1.       PROGRAM TUTILS
  2. C          tests all the Utils library
  3. C          needs the 'utils' library
  4.       DIMENSION III(2),IREGS(0:7)
  5.       CHARACTER*8 FRED
  6.       CHARACTER*12 FILE
  7.       CHARACTER*25 CDATE
  8.       LOGICAL SWIF77
  9.       DATA FRED/'FRED    '/
  10. C           tests the operations in utils assembler library
  11. C           test CDATE
  12.       WRITE (*,103)CDATE()
  13.   103 FORMAT(' today''s date/time is: ',A)
  14. C           test IBITS
  15.       WRITE(*,102)IBITS(?I12345678,4,10)
  16.   102 FORMAT(' 10-byte at 4 in &12345678 is ',Z8)
  17. C           test LOC
  18.       WRITE(*,*)' LOC(1),LOC(2) ',LOC(III(1)),LOC(III(2))
  19. C           test LOCC
  20.       WRITE(*,*)' F(RED) at ',LOCC(FRED(1:1)),
  21.      +         ', (FRE)D at ',LOCC(FRED(4:4))
  22.       WRITE(*,*)' Testing LNBLNK'
  23.       WRITE(*,*)' FRED is ',LNBLNK(FRED),
  24.      +' bytes long, press a key to continue'
  25.       I=IGET()
  26. C           test SWIF77 with OS_GBPB to read file names in library
  27.       N=0
  28.       IREGS(0)=9
  29.       IREGS(1)=LOCC('$.LIBRARY'//?H00)
  30.       IREGS(2)=LOCC(FILE)
  31.       IREGS(3)=1
  32.       IREGS(4)=0
  33.       IREGS(5)=11
  34.       IREGS(6)=0
  35.       WRITE(*,*)' files in $.LIBRARY are:'
  36.     2 IF(SWIF77(?I0C,IREGS,IFLAG)) CALL ERROR
  37.       IF(IREGS(4).LT.0.OR.IREGS(3).LE.0) GO TO 4
  38.       N=N+1
  39.       I=INDEX(FILE,?H00)
  40.       WRITE(*,*)' ',FILE(1:I-1)
  41.       GO TO 2
  42.     4 WRITE(*,*)' number of files = ',N
  43.       WRITE(*,*)' now cause SWI error by reading from unopened file'
  44.       CALL OSCLI('CLOSE')
  45. C          file handle
  46.       IREGS(1)=20
  47.       IF(SWIF77(?I0A,IREGS,IFLAG)) CALL ERROR
  48.    10 WRITE(*,*)'press any legal key 0 to end'
  49. C           test IGET
  50.       J=IGET()
  51.       WRITE(*,*)' ASCII value is ',J,' key is ',CHAR(J)
  52.       IF(J.EQ.27) STOP'Escape'
  53.       IF(J.NE.48)GOTO10   
  54. C                   tes INKEY
  55.       WRITE(*,*)' testing INKEY....'
  56.    20 J=INKEY(260)
  57.       WRITE(*,*)CHAR(7)
  58.       IF(J.GE.0)WRITE(*,*)' ASCII value is ',J,' key is ',CHAR(J)
  59.       IF(J.NE.48)GOTO20
  60. C             test -ve INKEYs and -256
  61.       WRITE(*,*)' testing -ve INKEY...'
  62.    30 DO 36 I=1,124
  63.       IF(INKEY(-I).NE.0)THEN
  64.         WRITE(*,*)' key pressed I=',I
  65.         IF(I.EQ.40)GOTO 38
  66.       ENDIF
  67.    36 CONTINUE
  68.       GOTO30
  69.    38 WRITE(*,*)' testing -256 ',INKEY(-256)
  70.       READ(*,*)KMC
  71. C               TEST Mouse  1st turn it on
  72.       WRITE(*,101)12
  73.       CALL OSCLI('POINTER')          
  74. C      CALL OSCLI('MOUSE ON')
  75.    40 CALL MOUSE(MX,MY,MBUTN)
  76.       WRITE(*,101)31,0,0,Mx,My,MButn
  77.   101 FORMAT($,3A1,' Mouse Mx,My,MButn ',3I4)
  78.       IF(INKEY(0).NE.48)GOTO40
  79. C                now test the sorting
  80.       CALL TSORT
  81.       STOP 'OK'
  82.       END
  83.       SUBROUTINE ERROR
  84.       CHARACTER*50 REPORT
  85.       CALL SWIERR(IERR,REPORT,LEN)
  86.       WRITE(*,*)' SWIF77 reports error ',IERR
  87.       WRITE(*,101)REPORT(1:LEN)
  88.   101 FORMAT(1X,A)
  89.       RETURN
  90.       END
  91.       SUBROUTINE TSORT
  92.       PARAMETER(N2=10000,N=N2+N2)
  93.       DOUBLE PRECISION D(N2)
  94.       REAL R(N)
  95.       INTEGER I(N),INDEX(N)
  96.       EQUIVALENCE(D(1),R(1),I(1))
  97.       DO 10 J=1,N
  98.    10 INDEX(J)=J
  99.       PRINT 101,N2
  100.   101 FORMAT(/' creating',I6,' random double precision words')
  101.       DO 20 J=1,N2,2
  102.       D(J)=RND01()-0.5
  103.       D(J+1)=D(J)+(RND01()-0.5)*5.D-6
  104.    20 CONTINUE
  105.       PRINT *,' sorting'
  106.       CALL QSORTD(D,INDEX,N2)
  107.       PRINT *,' checking'
  108.       DO 30 J=1,N2-1
  109.       IF(D(INDEX(J)).GT.D(INDEX(J+1))) THEN
  110.         PRINT 102,J,INDEX(J),INDEX(J+1),D(INDEX(J)),D(INDEX(J+1))
  111.   102   FORMAT(' sort failed ',3I6,2F18.15)
  112.       ENDIF
  113.    30 CONTINUE
  114.       PRINT 103,N
  115.   103 FORMAT(/' creating',I6,' random single precision words')
  116.       DO 40 J=1,N
  117.       R(J)=(RND01()-0.5)*10.
  118.    40 CONTINUE
  119.       PRINT *,' sorting'
  120.       CALL QSORTR(R,INDEX,N)
  121.       PRINT *,' checking'
  122.       DO 50 J=1,N-1
  123.       IF(R(INDEX(J)).GT.R(INDEX(J+1))) THEN
  124.         PRINT 104,J,INDEX(J),INDEX(J+1),R(INDEX(J)),R(INDEX(J+1))
  125.   104   FORMAT(' sort failed ',3I6,2F13.9)
  126.       ENDIF
  127.    50 CONTINUE
  128.       PRINT 105,N
  129.   105 FORMAT(/' sorting',I6,' random integer words')
  130.       DO 60 J=1,N
  131.       INDEX(J)=J
  132.    60 CONTINUE
  133.       CALL QSORTI(I,INDEX,N)
  134.       PRINT *,' checking'
  135.       DO 70 J=1,N-1
  136.       IF(I(INDEX(J)).GT.I(INDEX(J+1))) THEN
  137.         PRINT 106,J,INDEX(J),INDEX(J+1),I(INDEX(J)),I(INDEX(J+1))
  138.   106   FORMAT(' sort failed ',3I6,2I12)
  139.       ENDIF
  140.    70 CONTINUE
  141.       RETURN
  142.       END
  143.