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.
191 lines
6.5 KiB
191 lines
6.5 KiB
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 SHDSPH (LENE, LINK, NUMLNK, NUMATR, XN, YN, ZN, ATRIB,
|
|
* BLKCOL, IDELB, ISPSOR, RAD,
|
|
* IELBST, ISPBLK, SHDCOL, ISHDCL, HIDENP, *)
|
|
C=======================================================================
|
|
|
|
C --*** SYMSPH *** (DETOUR) Plot element spheres
|
|
C -- Written by Lee Taylor, 07/12/88
|
|
C -- Amy Gilkey, 10/12/87
|
|
C -- D. P. Flanagan, 12/08/83
|
|
C -- Modified version 1.1a November 1990 - R.J. Meyers
|
|
C -- added color coded sphere capability
|
|
C --
|
|
C --SYMSPH drives the user symbol interface for element variables.
|
|
C --It processes each element by element block, computing scaling factors
|
|
C --and element information, then calling the user symbol routine.
|
|
C --Only elements of selected element blocks are drawn.
|
|
C --
|
|
C --Parameters:
|
|
C -- LENE - IN - the cumulative element counts by element block
|
|
C -- LINK - IN - the connectivity array
|
|
C -- NUMLNK - IN - the number of nodes per element by block
|
|
C -- NUMATR - IN - the number of attributes per element by block
|
|
C -- XN, YN, ZN - IN - the nodal coordinates
|
|
C -- ATRIB - IN - the element attributes array
|
|
C -- BLKCOL - IN/OUT - the user selected colors of the element blocks.
|
|
C -- BLKCOL(0) = 1 if the user defined material
|
|
C -- colors should be used in mesh plots.
|
|
C -- = -1 if program selected colors should
|
|
C -- be used.
|
|
C -- BLKCOL(i) = the user selected color of element
|
|
C -- block i:
|
|
C -- -2 - no color selected by user.
|
|
C -- -1 - black
|
|
C -- 0 - white
|
|
C -- 1 - red
|
|
C -- 2 - green
|
|
C -- 3 - yellow
|
|
C -- 4 - blue
|
|
C -- 5 - cyan
|
|
C -- 6 - magenta
|
|
C -- * - return statement if the cancel function is active
|
|
C --
|
|
C --Common Variables:
|
|
C -- Uses NELBLK of /DBNUMS/
|
|
|
|
PARAMETER (KLFT=1, KRGT=2, KBOT=3, KTOP=4, KNEA=5, KFAR=6)
|
|
include 'mshlim.blk'
|
|
include 'd3nums.blk'
|
|
include 'dbnums.blk'
|
|
include 'sphele.blk'
|
|
|
|
INTEGER LENE(0:NELBLK),LINK(*)
|
|
INTEGER NUMLNK(NELBLK),NUMATR(NELBLK)
|
|
REAL XN(*), YN(*), ZN(*), ATRIB(*)
|
|
INTEGER BLKCOL(0:NELBLK)
|
|
INTEGER IDELB(*)
|
|
INTEGER ISPSOR(NUMEL)
|
|
REAL RAD(NUMEL)
|
|
INTEGER IELBST(NELBLK), ISPBLK(NUMEL)
|
|
C ... SHDCOL(1, *) = Red Component
|
|
C SHDCOL(2, *) = Green Component
|
|
C SHDCOL(3, *) = Blue Component
|
|
C SHDCOL(4-7,*) - Future Use
|
|
REAL SHDCOL(7,NELBLK)
|
|
C ... ISHDCL(1, *) = -1 if color not set, >0 if color set
|
|
C ISHDCL(2, *) = Number of colors to use for this block (SET if 0)
|
|
C ISHDCL(3, *) = Starting location in color map (SET)
|
|
INTEGER ISHDCL(3,NELBLK)
|
|
LOGICAL HIDENP(*)
|
|
|
|
REAL XSI(4),YSI(4)
|
|
LOGICAL FIRST
|
|
|
|
include 'icrnbw.blk'
|
|
include 'light.blk'
|
|
include 'sphere.blk'
|
|
DATA FIRST /.TRUE./
|
|
|
|
XMIN = ZMMESH(KLFT)
|
|
XMAX = ZMMESH(KRGT)
|
|
YMIN = ZMMESH(KBOT)
|
|
YMAX = ZMMESH(KTOP)
|
|
|
|
if (.not. is3dim) return
|
|
|
|
IF ( FIRST ) THEN
|
|
FIRST = .FALSE.
|
|
END IF
|
|
|
|
C ... Calculate surface normals
|
|
C ... On a unit sphere, normals are simply x,y,z coords of point.
|
|
do 30 ip=1, npoly
|
|
i = icon(1,ip)
|
|
j = icon(2,ip)
|
|
k = icon(3,ip)
|
|
l = icon(4,ip)
|
|
XMAG = (xpts(i) + xpts(j) + xpts(k) + xpts(l)) / 4.0
|
|
YMAG = (ypts(i) + ypts(j) + ypts(k) + ypts(l)) / 4.0
|
|
ZMAG = 1.0 - SQRT(XMAG**2 + YMAG**2)
|
|
|
|
C ... Determine dot product of surface normal and light vector.
|
|
SMAG = 0.0
|
|
SHDMX = 0.0
|
|
DO 20 J = 1, NLIT
|
|
SMAG = SMAG + max(0.0, (XMAG * LITE(5,J) +
|
|
* YMAG * LITE(6,J) + ZMAG * LITE(7,J)) * LITE(8,J))
|
|
20 CONTINUE
|
|
SHADE(IP) = SMAG
|
|
SHDMX = MAX(SHDMX, SMAG)
|
|
30 CONTINUE
|
|
SHDMX = MIN(1.0, 1.0 / SHDMX)
|
|
DO 40 ip = 1, npoly
|
|
SHADE(IP) = SHADE(IP) * SHDMX
|
|
40 continue
|
|
|
|
iel = 0
|
|
IRAD = 1
|
|
ILNK = 1
|
|
do 104 ielb = 1, nelblk
|
|
nel = lene(ielb) - lene(ielb-1)
|
|
if (numlnk(ielb) .eq. 1 .AND. IELBST(IELB) .GT. 0) then
|
|
DO 102 ISPH = ILNK, ILNK+NEL-1
|
|
NODE = LINK(ISPH)
|
|
IF (IS3DIM) THEN
|
|
IF (HIDENP(NODE)) GOTO 102
|
|
END IF
|
|
if (numatr(ielb) .ge. 1) then
|
|
RAD(NODE) = DEFRAD * ATRIB(IRAD)
|
|
else
|
|
RAD(NODE) = DEFRAD
|
|
end if
|
|
X = XN(NODE)
|
|
Y = YN(NODE)
|
|
R = RAD(NODE)
|
|
C ... Determine if portion of sphere is in viewing window
|
|
if (x+r .ge. xmin .and. x-r .le. xmax .and.
|
|
* y+r .ge. ymin .and. y-r .le. ymax) then
|
|
iel = iel + 1
|
|
ISPSOR(IEL) = NODE
|
|
ISPBLK(NODE) = ielb
|
|
end if
|
|
IRAD = IRAD + NUMATR(IELB)
|
|
102 continue
|
|
ELSE
|
|
IRAD = IRAD + NEL * NUMATR(IELB)
|
|
END IF
|
|
ILNK = ILNK + NEL * NUMLNK(IELB)
|
|
104 continue
|
|
numsph = iel
|
|
C ... Sort elements from smallest Z coord to largest.
|
|
C Sort is based on element center.
|
|
call indexx (zn, ispsor, numsph, .FALSE.)
|
|
|
|
C ... Set colors for all blocks
|
|
call setcol (nelblk, shdcol, ishdcl, ielbst, blkcol, idelb)
|
|
|
|
C ... Plotting of spheres starts here.
|
|
do 130 iel = 1, numsph
|
|
node = ispsor(iel)
|
|
xc = xn(node)
|
|
yc = yn(node)
|
|
rd = rad(node)
|
|
ielb = ispblk(node)
|
|
mincol = ishdcl(3,ielb)
|
|
ncol = ishdcl(2,ielb)
|
|
|
|
do 120 ip = 1, npoly
|
|
do 118 in = 1, 4
|
|
xsi(in) = xc + rd * xpts(icon(in,ip))
|
|
ysi(in) = yc + rd * ypts(icon(in,ip))
|
|
118 continue
|
|
smag = shade(ip)
|
|
ICOL = MINCOL +
|
|
* min(NCOL-1, max(1, NINT(SHADE(IP) * DBLE(NCOL))))
|
|
CALL GRCOLR (ICOL)
|
|
CALL MPD2PG (4, XSI, YSI, 'S')
|
|
120 continue
|
|
130 continue
|
|
call pltflu
|
|
|
|
CALL GRCOLU('STANDARD')
|
|
|
|
RETURN
|
|
END
|
|
|