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