home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ARM Club 3
/
TheARMClub_PDCD3.iso
/
hensa
/
maths
/
pgplot_1
/
SYS_ARC
/
f77
/
GRArchi
< prev
next >
Wrap
Text File
|
1996-01-02
|
14KB
|
440 lines
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