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='<PGPLOT_FONT>')
      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 <RETURN> for next page: " and wait for the user to
C type <CR> 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 <RETURN> 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