home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 1 / ARM_CLUB_CD.iso / contents / apps / graphs / progs / pgplot / SYS_ARC_f77_PGPack < prev    next >
Encoding:
Text File  |  1994-02-27  |  4.6 KB  |  130 lines
  1.       PROGRAM PACK
  2. C-----------------------------------------------------------------------
  3. C
  4. C February 1994 Converted to INTEGER*4 because the Acorn Archimedes
  5. C               complier does not support INTEGER*2. The resultant
  6. C               file format is the same as if INTEGER*2 were supported.
  7. C               
  8. C               Input file name changed to: <PGPLOT_DIR>.grfont/txt
  9. C               Output file name changed to: <PGPLOT_FONT>
  10. C
  11. C               These names circumvent the 30 character limit in
  12. C               Archimedes Fortran.
  13. C                                D.J. Crennell (Fortran Friends)
  14. C
  15. C Convert unpacked (ASCII) representation of GRFONT into packed
  16. C (binary) representation used by PGPLOT.
  17. C
  18. C This version ignores characters in the input file with Hershey
  19. C numbers 1000-1999 ("indexical" fonts) and 3000-3999 ("triplex"
  20. C and "gothic" fonts).
  21. C
  22. C The binary file contains one record, and is a direct copy of the
  23. C internal data structure used in PGPLOT. The format of the internal
  24. C data structure (and the binary file) are private to PGPLOT: i.e.,
  25. C they may be changed in a future release.
  26. C
  27. C NC1   Integer*4       Smallest Hershey number defined in file (1)
  28. C NC2   Integer*4       Largest Hershey number defined in file (3000)
  29. C NC3   Integer*4       Number of words of buffer space used
  30. C INDEX Integer*4 array (dimension 3000)
  31. C                       Element NC of INDEX contains either 0 if
  32. C                       NC is not a defined Hershey character, or the
  33. C                       index in array BUFFER at which the digitization
  34. C                       of character number NC begins
  35. C BUFFER Integer*2 array (dimension 27000)
  36. C                       Coordinate pairs defining each character are
  37. C                       packed two to a word in this array.
  38. C
  39. C Note: the array sizes are fixed by dimension statements in PGPLOT.
  40. C New characters cannot be added if they would increase the size of
  41. C the arrays.  Array INDEX is not very efficiently used as only about
  42. C 1000 of the possible 3000 characters are defined.
  43. C-----------------------------------------------------------------------
  44.       INTEGER MAXCHR, MAXBUF
  45.       PARAMETER (MAXCHR=3000)
  46.       PARAMETER (MAXBUF=27000,MAXPK=MAXBUF/2)
  47. C
  48.       INTEGER   INDEX(MAXCHR)
  49.       INTEGER   BUFPK(MAXPK)
  50.       INTEGER   I, LENGTH, LOC, NC, NC1, NC2, NCHAR, XYGRID(400)
  51. C-----------------------------------------------------------------------
  52.  1000 FORMAT (7(2X,2I4))
  53.  2000 FORMAT (' Characters defined: ', I5/
  54.      1        ' Array cells used:   ', I5)
  55.  3000 FORMAT (' ++ERROR++ Buffer is too small: ',I7)
  56. C-----------------------------------------------------------------------
  57. C
  58. C Initialize index.
  59. C
  60.       DO 1 I=1,MAXCHR
  61.           INDEX(I) = 0
  62.     1 CONTINUE
  63.       LOC = 0
  64.       NCHAR = 0
  65. C
  66. C Open input file.
  67. C
  68.       OPEN (UNIT=1, STATUS='OLD', FILE='<PGPLOT_DIR>.grfont/txt')
  69. C
  70. C Read input file.
  71. C
  72.    10 CONTINUE
  73. C         -- read next character
  74.           READ (1,1000,END=20) NC,LENGTH,(XYGRID(I),I=1,5)
  75.           READ (1,1000) (XYGRID(I),I=6,LENGTH)
  76. C         -- skip if Hershey number is outside required range
  77.           IF (NC.LT.1 .OR. (NC.GT.999.AND.NC.LT.2000) .OR.
  78.      1        NC.GT.2999) GOTO 10
  79. C         -- store in index and buffer
  80.           NCHAR = NCHAR+1
  81.           LOC = LOC+1
  82.           IF (LOC.GT.MAXBUF) GOTO 500
  83.           INDEX(NC) = LOC
  84. C              pack as integer*2 
  85.           LC = ISHFT(LOC+1,-1)
  86. C***  new INTEGER*4 instructions follow:
  87.           IF(LC+LC.EQ.LOC) THEN
  88.             BUFPK(LC) = IOR(BUFPK(LC),ISHFT(XYGRID(1),16))
  89.           ELSE
  90.             BUFPK(LC) = IAND(XYGRID(1),65535)
  91.           ENDIF
  92. C *** old INTEGER*2 instruction          BUFFER(LOC) = XYGRID(1)
  93.           DO 15 I=2,LENGTH,2
  94.               LOC = LOC + 1
  95.               IF (LOC.GT.MAXBUF) GOTO 500
  96. C              pack as integer*2 
  97.               IIPK = 128*(XYGRID(I)+64) + XYGRID(I+1) + 64
  98.               LC = ISHFT(LOC+1,-1)
  99. C***  new INTEGER*4 instructions follow:
  100.               IF(LC+LC.EQ.LOC) THEN
  101.                 BUFPK(LC) = IOR(BUFPK(LC),ISHFT(IIPK,16))
  102.               ELSE
  103.                 BUFPK(LC) = IAND(IIPK,65535)
  104.               ENDIF
  105. C *** old INTEGER*2:  BUFFER(LOC) = 128*(XYGRID(I)+64) + XYGRID(I+1) + 64
  106.    15     CONTINUE
  107.       GOTO 10
  108.    20 CONTINUE
  109.       CLOSE (UNIT=1)
  110. C
  111. C Write output file.
  112. C
  113.       OPEN (UNIT=2, STATUS='NEW', FORM='UNFORMATTED', 
  114.      +      FILE='<PGPLOT_FONT>')
  115.       NC1 = 1
  116.       NC2 = 3000
  117.       WRITE (2) NC1,NC2,LOC,INDEX,BUFPK
  118.       CLOSE (UNIT=2)
  119. C
  120. C Write summary.
  121. C
  122.       WRITE (6,2000) NCHAR, LOC
  123.       STOP
  124. C
  125. C Error exit.
  126. C
  127.   500 WRITE (6,3000) MAXBUF
  128. C-----------------------------------------------------------------------
  129.       END
  130.