C Acorn Archimedes specific code C 17 February 1994 version 1.00 C C*GRSY00 -- initialize font definition C+ SUBROUTINE GRSY00 C C This routine must be called once in order to initialize the tables C defining the symbol numbers to be used for ASCII characters in each C font, and to read the character digitization from a file. C C Arguments: none. C C Implicit input: C The file with name specified in environment variable PGPLOT_FONT C is read, if it is available. C This is a binary file containing two arrays INDEX and BUFFER. C The digitization of each symbol occupies a number of words in C the INTEGER*2 array BUFFER; the start of the digitization C for symbol number N is in BUFFER(INDEX(N)), where INDEX is an C integer array of 3000 elements. Not all symbols 1...3000 have C a representation; if INDEX(N) = 0, the symbol is undefined. C * PGPLOT uses the Hershey symbols for two `primitive' operations: * graph markers and text. The Hershey symbol set includes several * hundred different symbols in a digitized form that allows them to * be drawn with a series of vectors (polylines). * * The digital representation of all the symbols is stored in common * block /GRSYMB/. This is read from a disk file at run time. The * name of the disk file is specified in environment variable * PGPLOT_FONT. * * Modules: * * GRSY00 -- initialize font definition * GRSYDS -- decode character string into list of symbol numbers * GRSYMK -- convert marker number into symbol number * GRSYXD -- obtain the polyline representation of a given symbol * * PGPLOT calls these routines as follows: * * Routine Called by * * GRSY00 GROPEN * GRSYDS GRTEXT, GRLEN * GRSYMK GRMKER, * GRSYXD GRTEXT, GRLEN, GRMKER *********************************************************************** C-- C (2-Jan-1984) C 22-Jul-1984 - revise to use DATA statements [TJP]. C 5-Jan-1985 - make missing font file non-fatal [TJP]. C 9-Feb-1988 - change default file name to Unix name; overridden C by environment variable PGPLOT_FONT [TJP]. C 29-Nov-1990 - move font assignment to GRSYMK. C----------------------------------------------------------------------- CHARACTER*(*) ARCHI PARAMETER (ARCHI='') INTEGER BUFFER(13500) INTEGER FNTFIL, IER, INDEX(3000), NC1, NC2, NC3 INTEGER L COMMON /GRSYMB/ NC1, NC2, INDEX, BUFFER CHARACTER*128 FF C C Read the font file. If an I/O error occurs, it is ignored; the C effect will be that all symbols will be undefined (treated as C blank spaces). C CALL GRGLUN(FNTFIL) OPEN (UNIT=FNTFIL, FILE=ARCHI, FORM='UNFORMATTED', 2 STATUS='OLD', IOSTAT=IER) IF (IER.EQ.0) READ (UNIT=FNTFIL, IOSTAT=IER) 1 NC1,NC2,NC3,INDEX,BUFFER IF (IER.EQ.0) CLOSE (UNIT=FNTFIL, IOSTAT=IER) CALL GRFLUN(FNTFIL) IF (IER.NE.0) CALL GRWARN('Unable to read font file: '//ARCHI) RETURN END C*GRDATE -- get date and time as character string Archimedes C+ SUBROUTINE GRDATE(CDATE, LDATE) CHARACTER CDATE*(*), TEMP*18, FORM*22 INTEGER LDATE,IREGS(0:7),ITIME(2) DATA FORM(1:21)/'%DY-%M3-19%YR %24:%MI'/FORM(22:22)/?H00/ C C Return the current date and time, in format 'dd-Mmm-yyyy hh:mm'. C To receive the whole string, the CDATE should be declared C CHARACTER*17. C C Arguments: C CDATE : receives date and time, truncated or extended with C blanks as necessary. C L : receives the number of characters in STRING, excluding C trailing blanks. This will always be 17, unless the length C of the string supplied is shorter. C-- C 1989-Mar-17 - [AFT] C----------------------------------------------------------------------- ITIME(1) = 3 CALL OSWORD(14,ITIME) IREGS(0)=LOC(ITIME) IREGS(1)=LOCC(TEMP) IREGS(2)=18 IREGS(3)=LOCC(FORM) CALL SWIF77(?IC1,IREGS,IFLAG) CDATE=TEMP(1:17) LDATE=17 RETURN END C*GRFLUN -- free a Fortran logical unit number C+ SUBROUTINE GRFLUN(LUN) INTEGER LUN C C Free a Fortran logical unit number allocated by GRGLUN. [This version C is pretty stupid; GRGLUN allocates units starting at 81, and GRFLUN C does not free units.] C C Arguments: C LUN : the logical unit number to free. C-- C 25-Nov-1988 C----------------------------------------------------------------------- RETURN END C*GRGCOM -- read with prompt from user's terminal C+ INTEGER FUNCTION GRGCOM(CREAD, CPROM, LREAD) CHARACTER CREAD*(*), CPROM*(*) INTEGER LREAD C C Issue prompt and read a line from the user's terminal; in VMS, C this is equivalent to LIB$GET_COMMAND. C C Arguments: C CREAD : (output) receives the string read from the terminal. C CPROM : (input) prompt string. C LREAD : (output) length of CREAD. C C Returns: C GRGCOM : 1 if successful, 0 if an error occurs (e.g., end of file). C-- C 1989-Mar-29 C----------------------------------------------------------------------- INTEGER IER C--- 11 FORMAT(A) C--- GRGCOM = 0 LREAD = 0 WRITE (*, 101, IOSTAT=IER) CPROM 101 FORMAT(1X,A,' ',$) IF (IER.EQ.0) READ (*, 11, IOSTAT=IER) CREAD IF (IER.EQ.0) GRGCOM = 1 LREAD = LNBLNK(CREAD) RETURN END C********* C*GRMSG -- issue message to user C+ SUBROUTINE GRMSG (TEXT) CHARACTER*(*) TEXT C C Display a message on standard error. C C Argument: C TEXT (input): text of message to be printed (the string C may not be blank). C-- C 1991-Jul-27 - From SUN version [AFT] C----------------------------------------------------------------------- INTEGER I C I = LNBLNK(TEXT) IF(I.GT.0) WRITE (*, '(1X,A)') TEXT(1:I) END C*GRGENV -- get value of PGPLOT environment parameter C+ SUBROUTINE GRGENV(CNAME, CVALUE, LVALUE) CHARACTER CNAME*(*), CVALUE*(*) INTEGER LVALUE C C Return the value of a PGPLOT environment parameter. C C Arguments: C CNAME : (input) the name of the parameter to evaluate. C CVALUE : receives the value of the parameter, truncated or extended C with blanks as necessary. If the parameter is undefined, C a blank string is returned. C LVALUE : receives the number of characters in CVALUE, excluding C trailing blanks. If the parameter is undefined, zero is C returned. C-- C 1990-Mar-19 - [AFT] C----------------------------------------------------------------------- C CHARACTER*64 CTIN,CTOUT INTEGER I, LTMP,IREGS(0:7) LOGICAL SWIF77 C CTIN = 'PGPLOT_'//CNAME LTMP = INDEX(CTIN,' ') IF(LTMP.EQ.0) LTMP=LEN(CTIN)-1 CTIN(LTMP:LTMP)=CHAR(0) IREGS(0)=LOCC(CTIN) IREGS(1)=LOCC(CTOUT) IREGS(2)=64 IREGS(3)=0 IREGS(4)=0 IF(SWIF77(?I23,IREGS,IFLAG)) THEN LVALUE = 0 ELSE LVALUE = IREGS(2) CVALUE = CTOUT(1:LVALUE) ENDIF RETURN END C*GRGLUN -- get a Fortran logical unit number C+ SUBROUTINE GRGLUN(LUN) INTEGER LUN C C Get an unused Fortran logical unit number. C Returns a Logical Unit Number that is not currently opened. C After GRGLUN is called, the unit should be opened to reserve C the unit number for future calls. Once a unit is closed, it C becomes free and another call to GRGLUN could return the same C number. Also, GRGLUN will not return a number in the range 1-9 C as older software will often use these units without warning. C C Arguments: C LUN : receives the logical unit number, or -1 on error. C-- C 12-Feb-1989 [AFT/TJP]. C----------------------------------------------------------------------- INTEGER I LOGICAL QOPEN C--- DO 10 I=10,60 INQUIRE (UNIT=I, OPENED=QOPEN) IF (.NOT.QOPEN) THEN LUN = I RETURN ENDIF 10 CONTINUE CALL GRWARN('GRGLUN: out of units.') LUN = -1 RETURN END C*GRGMSG -- print system message C+ SUBROUTINE GRGMSG (ISTAT) INTEGER ISTAT C C This routine obtains the text of the VMS system message corresponding C to code ISTAT, and displays it using routine GRWARN. On non-VMS C systems, it just displays the error number. C C Argument: C ISTAT (input): 32-bit system message code. C-- C 1989-Mar-29 C----------------------------------------------------------------------- CHARACTER CBUF*10 C WRITE (CBUF, 101) ISTAT 101 FORMAT(I10) CALL GRWARN('system message number: '//CBUF) END C*GRLGTR -- translate logical name C+ SUBROUTINE GRLGTR (CNAME) CHARACTER CNAME*(*) C C Recursive translation of a logical name. C Up to 20 levels of equivalencing can be handled. C This is used in the parsing of device specifications in the C VMS implementation of PGPLOT. In other implementations, it may C be replaced by a null routine. C C Argument: C CNAME (input/output): initially contains the name to be C inspected. If an equivalence is found it will be replaced C with the new name. If not, the old name will be left there. The C escape sequence at the beginning of process-permanent file C names is deleted and the '_' character at the beginning of C device names is left in place. C-- C 18-Feb-1988 C----------------------------------------------------------------------- RETURN END C*GROPTX -- open output text file C+ INTEGER FUNCTION GROPTX (UNIT, NAME, DEFNAM) INTEGER UNIT CHARACTER*(*) NAME, DEFNAM C C Input: C UNIT : Fortran unit number to use C NAME : name of file to create C DEFNAM : default file name (used to fill in missing fields for VMS) C C Returns: C 0 => success; any other value => error. C----------------------------------------------------------------------- INTEGER IER OPEN (UNIT=UNIT, FILE=NAME, 2 STATUS='UNKNOWN', 2 IOSTAT=IER) GROPTX = IER C----------------------------------------------------------------------- RETURN END C*GRPROM -- prompt user before clearing screen C+ SUBROUTINE GRPROM C C Display "Type for next page: " and wait for the user to C type before proceeding. C C Arguments: C none C-- C 1989-Mar-29 C----------------------------------------------------------------------- INTEGER IER CHARACTER CMESS*14 C--- 11 FORMAT(A) C--- WRITE(*,101,IOSTAT=IER) CHAR(7)//'Type for next page: ' 101 FORMAT(1X,A,$) IF (IER.EQ.0) READ (*, 11, IOSTAT=IER) CMESS RETURN END C*GRQUIT -- report a fatal error and abort execution C+ SUBROUTINE GRQUIT (CTEXT) CHARACTER CTEXT*(*) C C Report a fatal error (via GRWARN) and exit with fatal status; a C traceback is generated unless the program is linked /NOTRACE. C C Argument: C CTEXT (input): text of message to be sent to GRWARN. C-- C 18-Feb-1988 C----------------------------------------------------------------------- CALL GRWARN(CTEXT) STOP 'Fatal error in PGPLOT library' END C*GRTRML -- get name of user's terminal C+ SUBROUTINE GRTRML(CTERM, LTERM) CHARACTER CTERM*(*) INTEGER LTERM C C Return the device name of the user's terminal, if any. C C Arguments: C CTERM : receives the terminal name, truncated or extended with C blanks as necessary. C LTERM : receives the number of characters in CTERM, excluding C trailing blanks. If there is not attached terminal, C zero is returned. C-- C 1989-Nov-08 C----------------------------------------------------------------------- CTERM = 'Archimedes' LTERM = 10 RETURN END C*GRTTER -- test whether device is user's terminal C+ SUBROUTINE GRTTER(CDEV, QSAME) CHARACTER CDEV*(*) LOGICAL QSAME C C Return a logical flag indicating whether the supplied device C name is a name for the user's controlling terminal or not. C (Some PGPLOT programs wish to take special action if they are C plotting on the user's terminal.) C C Arguments: C CDEV : (input) the device name to be tested. C QSAME : (output) .TRUE. is CDEV contains a valid name for the C user's terminal; .FALSE. otherwise. C-- C 18-Feb-1988 C----------------------------------------------------------------------- CHARACTER CTERM*64 INTEGER LTERM C CALL GRTRML(CTERM, LTERM) QSAME = (CDEV.EQ.CTERM(:LTERM)) END C*GRUSER -- get user name C+ SUBROUTINE GRUSER(CUSER, LUSER) CHARACTER CUSER*(*) INTEGER LUSER C C Return the name of the user running the program. C C Arguments: C CUSER : receives user name, truncated or extended with C blanks as necessary. C LUSER : receives the number of characters in VALUE, excluding C trailing blanks. C-- C 1989-Mar-19 - [AFT] C----------------------------------------------------------------------- C CALL GRGENV('USER', CUSER, LUSER) RETURN END C*GRWARN -- issue warning message to user C+ SUBROUTINE GRWARN (CTEXT) CHARACTER CTEXT*(*) C C Report a warning message on standard error, with prefix "%PGPLOT, ". C It is assumed that Fortran unit 0 is attached to stderr. C C Argument: C CTEXT (input): text of message to be printed (the string C may not be blank). C-- C 18-Feb-1988 C----------------------------------------------------------------------- INTEGER I C I = LNBLNK(CTEXT) IF(I.GT.0) WRITE (*,*) ' %PGPLOT, ',CTEXT(1:I) RETURN END