home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 1 / ARM_CLUB_CD.iso / contents / apps / graphs / progs / pgplot / SYS_ARC_f77_GRArchi < prev    next >
Encoding:
Text File  |  1994-10-08  |  13.4 KB  |  445 lines
  1. C       Acorn Archimedes specific code
  2. C  17 February 1994 version 1.00
  3. C
  4. C*GRSY00 -- initialize font definition
  5. C+
  6.       SUBROUTINE GRSY00
  7. C
  8. C This routine must be called once in order to initialize the tables
  9. C defining the symbol numbers to be used for ASCII characters in each
  10. C font, and to read the character digitization from a file.
  11. C
  12. C Arguments: none.
  13. C
  14. C Implicit input:
  15. C  The file with name specified in environment variable PGPLOT_FONT
  16. C  is read, if it is available.
  17. C  This is a binary file containing two arrays INDEX and BUFFER.
  18. C  The digitization of each symbol occupies a number of words in
  19. C  the INTEGER*2 array BUFFER; the start of the digitization
  20. C  for symbol number N is in BUFFER(INDEX(N)), where INDEX is an
  21. C  integer array of 3000 elements. Not all symbols 1...3000 have
  22. C  a representation; if INDEX(N) = 0, the symbol is undefined.
  23. C
  24. *  PGPLOT uses the Hershey symbols for two `primitive' operations:
  25. *  graph markers and text.  The Hershey symbol set includes several
  26. *  hundred different symbols in a digitized form that allows them to
  27. *  be drawn with a series of vectors (polylines).
  28. *
  29. *  The digital representation of all the symbols is stored in common
  30. *  block /GRSYMB/.  This is read from a disk file at run time. The
  31. *  name of the disk file is specified in environment variable
  32. *  PGPLOT_FONT.
  33. *
  34. * Modules:
  35. *
  36. * GRSY00 -- initialize font definition
  37. * GRSYDS -- decode character string into list of symbol numbers
  38. * GRSYMK -- convert marker number into symbol number
  39. * GRSYXD -- obtain the polyline representation of a given symbol
  40. *
  41. * PGPLOT calls these routines as follows:
  42. *
  43. * Routine          Called by
  44. *
  45. * GRSY00          GROPEN
  46. * GRSYDS          GRTEXT, GRLEN
  47. * GRSYMK          GRMKER,
  48. * GRSYXD          GRTEXT, GRLEN, GRMKER
  49. ***********************************************************************
  50. C--
  51. C (2-Jan-1984)
  52. C 22-Jul-1984 - revise to use DATA statements [TJP].
  53. C  5-Jan-1985 - make missing font file non-fatal [TJP].
  54. C  9-Feb-1988 - change default file name to Unix name; overridden
  55. C               by environment variable PGPLOT_FONT [TJP].
  56. C 29-Nov-1990 - move font assignment to GRSYMK.
  57. C-----------------------------------------------------------------------
  58.       CHARACTER*(*) ARCHI
  59.       PARAMETER  (ARCHI='<PGPLOT_FONT>')
  60.       INTEGER    BUFFER(13500)
  61.       INTEGER    FNTFIL, IER, INDEX(3000), NC1, NC2, NC3
  62.       INTEGER    L
  63.       COMMON     /GRSYMB/ NC1, NC2, INDEX, BUFFER
  64.       CHARACTER*128 FF
  65. C
  66. C Read the font file. If an I/O error occurs, it is ignored; the
  67. C effect will be that all symbols will be undefined (treated as
  68. C blank spaces).
  69. C
  70.       CALL GRGLUN(FNTFIL)
  71.       OPEN (UNIT=FNTFIL, FILE=ARCHI, FORM='UNFORMATTED',
  72.      2      STATUS='OLD', IOSTAT=IER)
  73.       IF (IER.EQ.0) READ (UNIT=FNTFIL, IOSTAT=IER)
  74.      1            NC1,NC2,NC3,INDEX,BUFFER
  75.       IF (IER.EQ.0) CLOSE (UNIT=FNTFIL, IOSTAT=IER)
  76.       CALL GRFLUN(FNTFIL)
  77.       IF (IER.NE.0) CALL GRWARN('Unable to read font file: '//ARCHI)
  78.       RETURN
  79.       END
  80. C*GRDATE -- get date and time as character string Archimedes
  81. C+
  82.       SUBROUTINE GRDATE(CDATE, LDATE)
  83.       CHARACTER CDATE*(*), TEMP*18, FORM*22
  84.       INTEGER   LDATE,IREGS(0:7),ITIME(2)
  85.       DATA FORM(1:21)/'%DY-%M3-19%YR %24:%MI'/FORM(22:22)/?H00/
  86. C
  87. C Return the current date and time, in format 'dd-Mmm-yyyy hh:mm'.
  88. C To receive the whole string, the CDATE should be declared
  89. C CHARACTER*17.
  90. C
  91. C Arguments:
  92. C  CDATE : receives date and time, truncated or extended with
  93. C           blanks as necessary.
  94. C  L      : receives the number of characters in STRING, excluding
  95. C           trailing blanks. This will always be 17, unless the length
  96. C           of the string supplied is shorter.
  97. C--
  98. C 1989-Mar-17 - [AFT]
  99. C-----------------------------------------------------------------------
  100.       ITIME(1) = 3
  101.       CALL OSWORD(14,ITIME)
  102.       IREGS(0)=LOC(ITIME)
  103.       IREGS(1)=LOCC(TEMP)
  104.       IREGS(2)=18
  105.       IREGS(3)=LOCC(FORM)
  106.       CALL SWIF77(?IC1,IREGS,IFLAG)
  107.       CDATE=TEMP(1:17)
  108.       LDATE=17
  109.       RETURN
  110.       END
  111. C*GRFLUN -- free a Fortran logical unit number
  112. C+
  113.       SUBROUTINE GRFLUN(LUN)
  114.       INTEGER LUN
  115. C
  116. C Free a Fortran logical unit number allocated by GRGLUN. [This version
  117. C is pretty stupid; GRGLUN allocates units starting at 81, and GRFLUN
  118. C does not free units.]
  119. C
  120. C Arguments:
  121. C  LUN    : the logical unit number to free.
  122. C--
  123. C 25-Nov-1988
  124. C-----------------------------------------------------------------------
  125.       RETURN
  126.       END
  127.  
  128. C*GRGCOM -- read with prompt from user's terminal
  129. C+
  130.       INTEGER FUNCTION GRGCOM(CREAD, CPROM, LREAD)
  131.       CHARACTER CREAD*(*), CPROM*(*)
  132.       INTEGER   LREAD
  133. C
  134. C Issue prompt and read a line from the user's terminal; in VMS,
  135. C this is equivalent to LIB$GET_COMMAND.
  136. C
  137. C Arguments:
  138. C  CREAD : (output) receives the string read from the terminal.
  139. C  CPROM : (input) prompt string.
  140. C  LREAD : (output) length of CREAD.
  141. C
  142. C Returns:
  143. C  GRGCOM : 1 if successful, 0 if an error occurs (e.g., end of file).
  144. C--
  145. C 1989-Mar-29
  146. C-----------------------------------------------------------------------
  147.       INTEGER IER
  148. C---
  149.    11 FORMAT(A)
  150. C---
  151.       GRGCOM = 0
  152.       LREAD = 0
  153.       WRITE (*, 101, IOSTAT=IER) CPROM
  154.   101 FORMAT(1X,A,' ',$)
  155.       IF (IER.EQ.0) READ (*, 11, IOSTAT=IER) CREAD
  156.       IF (IER.EQ.0) GRGCOM = 1
  157.       LREAD = LNBLNK(CREAD)
  158.       RETURN
  159.       END
  160. C*********
  161. C*GRMSG -- issue message to user
  162. C+
  163.       SUBROUTINE GRMSG (TEXT)
  164.       CHARACTER*(*) TEXT
  165. C
  166. C Display a message on standard error.
  167. C
  168. C Argument:
  169. C  TEXT (input): text of message to be printed (the string
  170. C      may not be blank).
  171. C--
  172. C 1991-Jul-27 - From SUN version [AFT]
  173. C-----------------------------------------------------------------------
  174.       INTEGER   I
  175. C
  176.       I = LNBLNK(TEXT)
  177.       IF(I.GT.0) WRITE (*, '(1X,A)') TEXT(1:I)
  178.       END
  179. C*GRGENV -- get value of PGPLOT environment parameter
  180. C+
  181.       SUBROUTINE GRGENV(CNAME, CVALUE, LVALUE)
  182.       CHARACTER CNAME*(*), CVALUE*(*)
  183.       INTEGER   LVALUE
  184. C
  185. C Return the value of a PGPLOT environment parameter.
  186. C
  187. C Arguments:
  188. C CNAME   : (input) the name of the parameter to evaluate.
  189. C CVALUE  : receives the value of the parameter, truncated or extended
  190. C           with blanks as necessary. If the parameter is undefined,
  191. C           a blank string is returned.
  192. C LVALUE  : receives the number of characters in CVALUE, excluding
  193. C           trailing blanks. If the parameter is undefined, zero is
  194. C           returned.
  195. C--
  196. C 1990-Mar-19 - [AFT]
  197. C-----------------------------------------------------------------------
  198. C
  199.       CHARACTER*64 CTIN,CTOUT
  200.       INTEGER   I, LTMP,IREGS(0:7)
  201.       LOGICAL SWIF77
  202. C
  203.       CTIN = 'PGPLOT_'//CNAME
  204.       LTMP = INDEX(CTIN,' ')
  205.       IF(LTMP.EQ.0) LTMP=LEN(CTIN)-1
  206.       CTIN(LTMP:LTMP)=CHAR(0)
  207.       IREGS(0)=LOCC(CTIN)
  208.       IREGS(1)=LOCC(CTOUT)
  209.       IREGS(2)=64
  210.       IREGS(3)=0
  211.       IREGS(4)=0
  212.       IF(SWIF77(?I23,IREGS,IFLAG)) THEN
  213.         LVALUE = 0
  214.       ELSE
  215.         LVALUE = IREGS(2)
  216.         CVALUE = CTOUT(1:LVALUE)
  217.       ENDIF
  218.       RETURN
  219.       END
  220. C*GRGLUN -- get a Fortran logical unit number
  221. C+
  222.       SUBROUTINE GRGLUN(LUN)
  223.       INTEGER LUN
  224. C
  225. C Get an unused Fortran logical unit number.
  226. C Returns a Logical Unit Number that is not currently opened.
  227. C After GRGLUN is called, the unit should be opened to reserve
  228. C the unit number for future calls.  Once a unit is closed, it
  229. C becomes free and another call to GRGLUN could return the same
  230. C number.  Also, GRGLUN will not return a number in the range 1-9
  231. C as older software will often use these units without warning.
  232. C
  233. C Arguments:
  234. C  LUN    : receives the logical unit number, or -1 on error.
  235. C--
  236. C 12-Feb-1989 [AFT/TJP].
  237. C-----------------------------------------------------------------------
  238.       INTEGER I
  239.       LOGICAL QOPEN
  240. C---
  241.       DO 10 I=10,60
  242.           INQUIRE (UNIT=I,  OPENED=QOPEN)
  243.           IF (.NOT.QOPEN) THEN
  244.               LUN = I
  245.               RETURN
  246.           ENDIF
  247.    10 CONTINUE
  248.       CALL GRWARN('GRGLUN: out of units.')
  249.       LUN = -1
  250.       RETURN
  251.       END
  252. C*GRGMSG -- print system message
  253. C+
  254.       SUBROUTINE GRGMSG (ISTAT)
  255.       INTEGER   ISTAT
  256. C
  257. C This routine obtains the text of the VMS system message corresponding
  258. C to code ISTAT, and displays it using routine GRWARN. On non-VMS
  259. C systems, it just displays the error number.
  260. C
  261. C Argument:
  262. C  ISTAT (input): 32-bit system message code.
  263. C--
  264. C 1989-Mar-29
  265. C-----------------------------------------------------------------------
  266.       CHARACTER CBUF*10
  267. C
  268.       WRITE (CBUF, 101) ISTAT
  269.   101 FORMAT(I10)
  270.       CALL GRWARN('system message number: '//CBUF)
  271.       END
  272. C*GRLGTR -- translate logical name
  273. C+
  274.       SUBROUTINE GRLGTR (CNAME)
  275.       CHARACTER CNAME*(*)
  276. C
  277. C Recursive translation of a logical name.
  278. C Up to 20 levels of equivalencing can be handled.
  279. C This is used in the parsing of device specifications in the
  280. C VMS implementation of PGPLOT. In other implementations, it may
  281. C be replaced by a null routine.
  282. C
  283. C Argument:
  284. C  CNAME (input/output): initially contains the name to be
  285. C       inspected.  If an equivalence is found it will be replaced
  286. C       with the new name. If not, the old name will be left there. The
  287. C       escape sequence at the beginning of process-permanent file
  288. C       names is deleted and the '_' character at the beginning of
  289. C       device names is left in place.
  290. C--
  291. C 18-Feb-1988
  292. C-----------------------------------------------------------------------
  293.       RETURN
  294.       END
  295. C*GROPTX -- open output text file
  296. C+
  297.       INTEGER FUNCTION GROPTX (UNIT, NAME, DEFNAM, MODE)
  298.       INTEGER UNIT,MODE
  299.       CHARACTER*(*) NAME, DEFNAM
  300. C
  301. C Input:
  302. C  UNIT : Fortran unit number to use
  303. C  NAME : name of file to create
  304. C  DEFNAM : default file name (used to fill in missing fields for VMS)
  305. C  MODE : 0 for input, 1 for output
  306. C
  307. C Returns:
  308. C  0 => success; any other value => error.
  309. C
  310. C 1994-Oct-04 - found routine needs 4 parameters, nfc objected [DJC]
  311. C-----------------------------------------------------------------------
  312.       INTEGER IER
  313.       IF(MODE.EQ.1) THEN
  314.         OPEN (UNIT=UNIT, FILE=NAME, STATUS='NEW', IOSTAT=IER)
  315.       ELSE
  316.         OPEN (UNIT=UNIT, FILE=NAME, STATUS='OLD', IOSTAT=IER)
  317.       ENDIF
  318.       GROPTX = IER
  319. C-----------------------------------------------------------------------
  320.       RETURN
  321.       END
  322. C*GRPROM -- prompt user before clearing screen
  323. C+
  324.       SUBROUTINE GRPROM
  325. C
  326. C Display "Type <RETURN> for next page: " and wait for the user to
  327. C type <CR> before proceeding.
  328. C
  329. C Arguments:
  330. C  none
  331. C--
  332. C 1989-Mar-29
  333. C-----------------------------------------------------------------------
  334.       INTEGER   IER
  335.       CHARACTER CMESS*14
  336. C---
  337.    11 FORMAT(A)
  338. C---
  339.       WRITE(*,101,IOSTAT=IER) CHAR(7)//'Type <RETURN> for next page: '
  340.   101 FORMAT(1X,A,$)
  341.       IF (IER.EQ.0) READ (*, 11, IOSTAT=IER) CMESS
  342.       RETURN
  343.       END
  344. C*GRQUIT -- report a fatal error and abort execution
  345. C+
  346.       SUBROUTINE GRQUIT (CTEXT)
  347.       CHARACTER CTEXT*(*)
  348. C
  349. C Report a fatal error (via GRWARN) and exit with fatal status; a
  350. C traceback is generated unless the program is linked /NOTRACE.
  351. C
  352. C Argument:
  353. C  CTEXT (input): text of message to be sent to GRWARN.
  354. C--
  355. C 18-Feb-1988
  356. C-----------------------------------------------------------------------
  357.       CALL GRWARN(CTEXT)
  358.       STOP 'Fatal error in PGPLOT library'
  359.       END
  360. C*GRTRML -- get name of user's terminal
  361. C+
  362.       SUBROUTINE GRTRML(CTERM, LTERM)
  363.       CHARACTER CTERM*(*)
  364.       INTEGER   LTERM
  365. C
  366. C Return the device name of the user's terminal, if any.
  367. C
  368. C Arguments:
  369. C  CTERM : receives the terminal name, truncated or extended with
  370. C           blanks as necessary.
  371. C  LTERM : receives the number of characters in CTERM, excluding
  372. C           trailing blanks. If there is not attached terminal,
  373. C           zero is returned.
  374. C--
  375. C 1989-Nov-08
  376. C-----------------------------------------------------------------------
  377.       CTERM = 'Archimedes'
  378.       LTERM = 10
  379.       RETURN
  380.       END
  381. C*GRTTER -- test whether device is user's terminal
  382. C+
  383.       SUBROUTINE GRTTER(CDEV, QSAME)
  384.       CHARACTER CDEV*(*)
  385.       LOGICAL   QSAME
  386. C
  387. C Return a logical flag indicating whether the supplied device
  388. C name is a name for the user's controlling terminal or not.
  389. C (Some PGPLOT programs wish to take special action if they are
  390. C plotting on the user's terminal.)
  391. C
  392. C Arguments:
  393. C  CDEV : (input) the device name to be tested.
  394. C  QSAME   : (output) .TRUE. is CDEV contains a valid name for the
  395. C           user's terminal; .FALSE. otherwise.
  396. C--
  397. C 18-Feb-1988
  398. C-----------------------------------------------------------------------
  399.       CHARACTER CTERM*64
  400.       INTEGER   LTERM
  401. C
  402.       CALL GRTRML(CTERM, LTERM)
  403.       QSAME = (CDEV.EQ.CTERM(:LTERM))
  404.       END
  405. C*GRUSER -- get user name
  406. C+
  407.       SUBROUTINE GRUSER(CUSER, LUSER)
  408.       CHARACTER CUSER*(*)
  409.       INTEGER   LUSER
  410. C
  411. C Return the name of the user running the program.
  412. C
  413. C Arguments:
  414. C  CUSER  : receives user name, truncated or extended with
  415. C           blanks as necessary.
  416. C  LUSER  : receives the number of characters in VALUE, excluding
  417. C           trailing blanks.
  418. C--
  419. C 1989-Mar-19 - [AFT]
  420. C-----------------------------------------------------------------------
  421. C
  422.       CALL GRGENV('USER', CUSER, LUSER)
  423.       RETURN
  424.       END
  425. C*GRWARN -- issue warning message to user
  426. C+
  427.       SUBROUTINE GRWARN (CTEXT)
  428.       CHARACTER CTEXT*(*)
  429. C
  430. C Report a warning message on standard error, with prefix "%PGPLOT, ".
  431. C It is assumed that Fortran unit 0 is attached to stderr.
  432. C
  433. C Argument:
  434. C  CTEXT (input): text of message to be printed (the string
  435. C      may not be blank).
  436. C--
  437. C 18-Feb-1988
  438. C-----------------------------------------------------------------------
  439.       INTEGER   I
  440. C
  441.       I = LNBLNK(CTEXT)
  442.       IF(I.GT.0) WRITE (*,*) ' %PGPLOT, ',CTEXT(1:I)
  443.       RETURN
  444.       END
  445.