You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
199 lines
7.3 KiB
199 lines
7.3 KiB
2 years ago
|
C Copyright(C) 1999-2020 National Technology & Engineering Solutions
|
||
|
|
C of Sandia, LLC (NTESS). Under the terms of Contract DE-NA0003525 with
|
||
|
|
C NTESS, the U.S. Government retains certain rights in this software.
|
||
|
|
C
|
||
|
|
C See packages/seacas/LICENSE for details
|
||
|
|
|
||
|
|
C=======================================================================
|
||
|
|
SUBROUTINE CMDDEV (INLINE,
|
||
|
|
& VERB, IFLD, INTYP, CFIELD, IFIELD, RFIELD, *)
|
||
|
|
C=======================================================================
|
||
|
|
|
||
|
|
C --*** CMDDEV *** (BLOT) Process device parameter command
|
||
|
|
C -- Written by Amy Gilkey - revised 04/26/88
|
||
|
|
C --
|
||
|
|
C --CMDDEV processes a device parameter command. The commands are:
|
||
|
|
C -- SOFTCHAR - sets the software vs. hardware characters flag
|
||
|
|
C -- COLOR - sets the number of standard colors to use
|
||
|
|
C -- SPECTRUM - sets the number of spectrum colors
|
||
|
|
C -- FONT - sets font to use
|
||
|
|
C -- SNAP - sets the number of frames to snap
|
||
|
|
C -- AUTO - sets the device for automatic plotting
|
||
|
|
C --
|
||
|
|
C --Parameters:
|
||
|
|
C -- INLINE - IN/OUT - the parsed input lines for the log file
|
||
|
|
C -- VERB - IN/OUT - the command verb; set for SHOW
|
||
|
|
C -- IFLD - IN/OUT - the field number
|
||
|
|
C -- INTYP - IN - the input types from the free field reader
|
||
|
|
C -- CFIELD - IN - the character fields
|
||
|
|
C -- IFIELD - IN - the integer fields
|
||
|
|
C -- RFIELD - IN - the real fields
|
||
|
|
C -- * - return statement if command error; message is printed
|
||
|
|
|
||
|
|
include 'params.blk'
|
||
|
|
include 'colormap.blk'
|
||
|
|
CHARACTER*(*) INLINE(*)
|
||
|
|
CHARACTER*(*) VERB
|
||
|
|
INTEGER INTYP(*)
|
||
|
|
CHARACTER*(*) CFIELD(*)
|
||
|
|
INTEGER IFIELD(*)
|
||
|
|
REAL RFIELD(*)
|
||
|
|
include 'icrnbw.blk'
|
||
|
|
|
||
|
|
LOGICAL MATSTR
|
||
|
|
CHARACTER*80 ERRMSG
|
||
|
|
CHARACTER*(MXSTLN) WORD, WORDM
|
||
|
|
INTEGER ISON
|
||
|
|
include 'shades.blk'
|
||
|
|
|
||
|
|
IF (VERB .EQ. 'SOFTCHAR') THEN
|
||
|
|
CALL FFADDC (VERB, INLINE(1))
|
||
|
|
CALL FFONOF (IFLD, INTYP, CFIELD, ISON, *110)
|
||
|
|
CALL FFADDO (ISON, INLINE(1))
|
||
|
|
CALL FFINTG (IFLD, INTYP, IFIELD,
|
||
|
|
& 'device number', 0, IDEV, *110)
|
||
|
|
IF (IDEV .NE. 0) CALL FFADDI (IDEV, INLINE(1))
|
||
|
|
CALL GRSPAR (VERB, IDEV, ISON, ERRMSG)
|
||
|
|
IF (ERRMSG .NE. ' ') GOTO 100
|
||
|
|
|
||
|
|
ELSE IF (VERB .EQ. 'FONT') THEN
|
||
|
|
CALL FFADDC (VERB, INLINE(1))
|
||
|
|
CALL FFCHAR (IFLD, INTYP, CFIELD, 'STICK', WORD)
|
||
|
|
IF (MATSTR (WORD, 'STICK', 2)) THEN
|
||
|
|
CALL FFADDC ('STICK', INLINE(1))
|
||
|
|
IFONT = 1
|
||
|
|
ELSE IF (MATSTR (WORD, 'SANSERIF', 2)) THEN
|
||
|
|
CALL FFADDC ('SANSERIF', INLINE(1))
|
||
|
|
IFONT = 2
|
||
|
|
ELSE IF (MATSTR (WORD, 'ROMAN', 1)) THEN
|
||
|
|
CALL FFADDC ('ROMAN', INLINE(1))
|
||
|
|
IFONT = 3
|
||
|
|
ELSE
|
||
|
|
CALL PRTERR ('CMDERR',
|
||
|
|
& 'Expected "STICK", "SANSERIF" or "ROMAN"')
|
||
|
|
GOTO 110
|
||
|
|
END IF
|
||
|
|
CALL FFINTG (IFLD, INTYP, IFIELD,
|
||
|
|
& 'device number', 0, IDEV, *110)
|
||
|
|
IF (IDEV .NE. 0) CALL FFADDI (IDEV, INLINE(1))
|
||
|
|
CALL GRSPAR (VERB, IDEV, IFONT, ERRMSG)
|
||
|
|
IF (ERRMSG .NE. ' ') GOTO 100
|
||
|
|
|
||
|
|
ELSE IF (VERB .EQ. 'COLOR') THEN
|
||
|
|
CALL FFADDC (VERB, INLINE(1))
|
||
|
|
CALL FFINTG (IFLD, INTYP, IFIELD,
|
||
|
|
& 'number of colors', 0, NCOL, *110)
|
||
|
|
CALL FFADDI (NCOL, INLINE(1))
|
||
|
|
CALL GRSPAR (VERB, -1, NCOL, ERRMSG)
|
||
|
|
IF (ERRMSG .NE. ' ') GOTO 100
|
||
|
|
|
||
|
|
ELSE IF (VERB .EQ. 'SPECTRUM') THEN
|
||
|
|
CALL FFADDC (VERB, INLINE(1))
|
||
|
|
CALL FFINTG (IFLD, INTYP, IFIELD,
|
||
|
|
& 'number of spectrum colors', 5, NCOL, *110)
|
||
|
|
CALL FFADDI (NCOL, INLINE(1))
|
||
|
|
ISINV = 0
|
||
|
|
10 continue
|
||
|
|
CALL FFCHAR (IFLD, INTYP, CFIELD, 'DEFAULT', WORD)
|
||
|
|
CALL FFADDC (WORD, INLINE(1))
|
||
|
|
IF (MATSTR (WORD, 'DEFAULT', 3)) THEN
|
||
|
|
ISPEC = DEFAULT
|
||
|
|
ELSE IF (MATSTR (WORD, 'RAINBOW', 3)) THEN
|
||
|
|
ISPEC = RAINBW
|
||
|
|
ELSE IF (MATSTR (WORD, 'VIRIDIS', 3)) THEN
|
||
|
|
ISPEC = VIRDIS
|
||
|
|
ELSE IF (MATSTR (WORD, 'GRAY', 2) .or.
|
||
|
|
* MATSTR (WORD, 'GREY', 2)) THEN
|
||
|
|
ISPEC = GRAY
|
||
|
|
ELSE IF (MATSTR (WORD, 'TERRAIN', 3) .or.
|
||
|
|
* MATSTR (WORD, 'TOPOGRA', 3)) THEN
|
||
|
|
ISPEC = TERRAIN
|
||
|
|
ELSE IF (MATSTR (WORD, 'HOT', 3) .or.
|
||
|
|
* MATSTR (WORD, 'HEATED', 3) .or.
|
||
|
|
* MATSTR (WORD, 'THERMAL', 3)) THEN
|
||
|
|
ISPEC = IRON
|
||
|
|
ELSE IF (MATSTR (WORD, 'ASTRO', 3)) THEN
|
||
|
|
ISPEC = ASTRO
|
||
|
|
ELSE IF (MATSTR (WORD, 'ZEBRA', 3)) THEN
|
||
|
|
ISPEC = ZEBRA
|
||
|
|
ELSE IF (MATSTR (WORD, 'COOL', 3)) THEN
|
||
|
|
ISPEC = COOL
|
||
|
|
ELSE IF (MATSTR (WORD, 'METAL', 3) .or.
|
||
|
|
* MATSTR (WORD, 'USER', 3)) THEN
|
||
|
|
ISPEC = METAL
|
||
|
|
IF (INTYP(IFLD) .EQ. 0) then
|
||
|
|
C ... User has specified a 'predefined' color.
|
||
|
|
CALL FFCHAR (IFLD, INTYP, CFIELD, 'DEFAULT', WORD)
|
||
|
|
CALL FFADDC (WORD, INLINE(1))
|
||
|
|
CALL ABRSTR (WORDM, WORD, SHDLST)
|
||
|
|
IF (WORDM .EQ. ' ') THEN
|
||
|
|
WRITE (*, 10000) WORD
|
||
|
|
10000 FORMAT (1X, A, ' not a valid color name.')
|
||
|
|
CALL SHOCMD ('Valid predefined colors', SHDLST)
|
||
|
|
RMULT = 1.000
|
||
|
|
GMULT = 1.000
|
||
|
|
BMULT = 1.000
|
||
|
|
ELSE
|
||
|
|
IDCOL = LOCSTR(WORDM, NCLSHD, SHDLST)
|
||
|
|
RMULT = shades(1,IDCOL)
|
||
|
|
GMULT = shades(2,IDCOL)
|
||
|
|
BMULT = shades(3,IDCOL)
|
||
|
|
END IF
|
||
|
|
else
|
||
|
|
C ... User has specified the RGB components of the color.
|
||
|
|
CALL FFREAL (IFLD, INTYP, RFIELD,
|
||
|
|
* 'Red Multiplier', 1.0, RMULT, *110)
|
||
|
|
CALL FFADDR (RMULT, INLINE(1))
|
||
|
|
CALL FFREAL (IFLD, INTYP, RFIELD,
|
||
|
|
* 'Green Multiplier', 1.0, GMULT, *110)
|
||
|
|
CALL FFADDR (GMULT, INLINE(1))
|
||
|
|
CALL FFREAL (IFLD, INTYP, RFIELD,
|
||
|
|
* 'Blue Multiplier', 1.0, BMULT, *110)
|
||
|
|
CALL FFADDR (BMULT, INLINE(1))
|
||
|
|
END IF
|
||
|
|
ELSE IF (MATSTR (WORD, 'INVERSE', 3)) THEN
|
||
|
|
ISINV = 1
|
||
|
|
GO TO 10
|
||
|
|
ELSE IF (MATSTR (WORD, 'HELP', 4)) THEN
|
||
|
|
CALL PRTERR ('CMDSPEC',
|
||
|
|
* 'Valid: RAINBOW, VIRIDIS, GRAY, TERRAIN, THERMAL, ASTRO,')
|
||
|
|
CALL PRTERR ('CMDSPEC',
|
||
|
|
* ' COOL, METAL, a color, or enter rgb triplet')
|
||
|
|
ERRMSG = 'Unknown Color Map'
|
||
|
|
GO TO 100
|
||
|
|
ELSE
|
||
|
|
ERRMSG = 'Unknown Color Map'
|
||
|
|
GO TO 100
|
||
|
|
END IF
|
||
|
|
CALL FFREAL (IFLD, INTYP, RFIELD,
|
||
|
|
* 'SATURATION', 1.0, SATUR, *110)
|
||
|
|
CALL FFADDR (SATUR, INLINE(1))
|
||
|
|
CALL GRSPAR (VERB, -1, NCOL, ERRMSG)
|
||
|
|
IF (ERRMSG .NE. ' ') GOTO 100
|
||
|
|
|
||
|
|
ELSE IF (VERB .EQ. 'SNAP') THEN
|
||
|
|
CALL FFADDC (VERB, INLINE(1))
|
||
|
|
CALL FFINTG (IFLD, INTYP, IFIELD,
|
||
|
|
& 'number of frames to snap', 1, N, *110)
|
||
|
|
CALL FFADDI (N, INLINE(1))
|
||
|
|
IDEV = 0
|
||
|
|
CALL GRSPAR (VERB, IDEV, N, ERRMSG)
|
||
|
|
IF (ERRMSG .NE. ' ') GOTO 100
|
||
|
|
|
||
|
|
ELSE IF (VERB .EQ. 'AUTO') THEN
|
||
|
|
CALL FFADDC (VERB, INLINE(1))
|
||
|
|
CALL FFONOF (IFLD, INTYP, CFIELD, ISON, *110)
|
||
|
|
CALL FFADDO (ISON, INLINE(1))
|
||
|
|
IDEV = 0
|
||
|
|
CALL GRSPAR (VERB, IDEV, ISON, ERRMSG)
|
||
|
|
IF (ERRMSG .NE. ' ') GOTO 100
|
||
|
|
END IF
|
||
|
|
|
||
|
|
RETURN
|
||
|
|
|
||
|
|
100 CONTINUE
|
||
|
|
CALL PRTERR ('CMDERR', ERRMSG(:LENSTR(ERRMSG)))
|
||
|
|
110 CONTINUE
|
||
|
|
RETURN 1
|
||
|
|
END
|