C Copyright(C) 2009-2017 National Technology & Engineering Solutions of
C 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 Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are
C met:
C
C     * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C     * Redistributions in binary form must reproduce the above
C       copyright notice, this list of conditions and the following
C       disclaimer in the documentation and/or other materials provided
C       with the distribution.
C     * Neither the name of NTESS nor the names of its
C       contributors may be used to endorse or promote products derived
C       from this software without specific prior written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

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 master 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
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) * FLOAT(NCOL))))
          CALL GRCOLR (ICOL)
          CALL MPD2PG (4, XSI, YSI, 'S')
 120    continue
 130  continue
      call pltflu
C
      CALL GRCOLU('STANDARD')

      RETURN
      END
