**   subroutine fillpoly(x,y,npts,index) *jc*

      subroutine fillpoly(xarg,yarg,npts,index,xadd,lmin,lmax)

      real xarg(*),yarg(*)
      integer npts,index
*
*  This software was developed by the Thermal Modeling and Analysis
*  Project(TMAP) of the National Oceanographic and Atmospheric
*  Administration's (NOAA) Pacific Marine Environmental Lab(PMEL),
*  hereafter referred to as NOAA/PMEL/TMAP.
*
*  Access and use of this software shall impose the following
*  obligations and understandings on the user. The user is granted the
*  right, without any fee or cost, to use, copy, modify, alter, enhance
*  and distribute this software, and any derivative works thereof, and
*  its supporting documentation for any purpose whatsoever, provided
*  that this entire notice appears in all copies of the software,
*  derivative works and supporting documentation.  Further, the user
*  agrees to credit NOAA/PMEL/TMAP in any publications that result from
*  the use of this software or in any product that includes this
*  software. The names TMAP, NOAA and/or PMEL, however, may not be used
*  in any advertising or publicity to endorse or promote any products
*  or commercial entity unless specific written permission is obtained
*  from NOAA/PMEL/TMAP. The user also understands that NOAA/PMEL/TMAP
*  is not obligated to provide the user with any support, consulting,
*  training or assistance of any kind with regard to the use, operation
*  and performance of this software nor to provide the user with any
*  updates, revisions, new versions or "bug fixes".
*
*  THIS SOFTWARE IS PROVIDED BY NOAA/PMEL/TMAP "AS IS" AND ANY EXPRESS
*  OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
*  WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
*  ARE DISCLAIMED. IN NO EVENT SHALL NOAA/PMEL/TMAP BE LIABLE FOR ANY SPECIAL,
*  INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER
*  RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
*  CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, ARISING OUT OF OR IN
*  CONNECTION WITH THE ACCESS, USE OR PERFORMANCE OF THIS SOFTWARE. 
*
C** 
C**    @(#)fillpoly.F	1.2   1/27/91
C**
C**
C***********************************************************************
C**
C**                 PLOT+ Scientific Graphics System
C**
C***********************************************************************
C**
C**
C      lots of places ---> PPLMOD_PPLCMD ---> PPLMOD_PLTIT 
C              ---> PPLMOD_PLOTZ ---> PPLMOD_ARFILL ---> PPLMOD_FILLPOLY
C       
C
C     call fillpoly(x,y,npts,index)
C
C     This subroutine creates a color filled convex polygon using the
C     using the coordinates.
C
C     THE VARIOUS PARAMETERS AND THEIR DEFINITIONS ARE LISTED
C     BELOW:
C        X,Y    - COORDINATES OF THE POLYGON`S CORNERS IN USER'S UNITS.
*	 ?? jd ?? Coordinates in inches from origin == nouser ??

C        npts   - number of vertices
C        index  - color index (0 - max_color)
C
C

*	MOD *JD* to include in TMAP PPL+ 1.14.92
*	Mod *jd* 10.12.92 for new hatching scheme
*	Mod *jd* 11.09.92 to get viewport size right for clipping
*     V4.50 *jc* 04.25.97 add 'curvilinear' capability
*                'x' and 'y' are  arrays of 50 to match xt, yt, etc.
*                (What is the maximum number of vertices in a polygon?)
*       Mod *jd* 02.16.99 Make arrays 128 not 50 for better FILL optimization
*     v5.51 *acm* 2/3/03 Get viewport sizing as in shade routines, using
*                        gks calls; else the clipping is wrong for fill 
*                        plots in viewports that were defined with /AXES.
*     v5.81 *acm* 4/05 Changes for FILL/MOD. Draw replications for curvilinear datasets
* V68  *acm* 1/12  changes for double-precision ferret, single-precision pplus
* V687 *acm* 3/14 tickets 2151 and 2147: allow missing coordinate data in 3-arg 
*                 and 4-arg plot commands. 

#ifdef double_p
      real*8 x(128),y(128), xplus
#else
      real x(128),y(128), xplus
#endif
      real xt(128),yt(128),xc(128),yc(128),xtrns,ytrns
      integer i,nout,fill_ndx
      real xadd, lmin, lmax

	include 'PLTCOM.DAT'
	include 'pltcom_dat.decl'
	include 'shade_vars.cmn'
        include 'axis_inc.decl'
        include 'AXIS.INC'
        include 'gkscm1_inc.decl'
        include 'GKSCM1.INC'
        include 'gkscm2.cmn' 
        INCLUDE 'gkspar.inc'
        include 'xcurvilinear.cmn'
	include 'ppl_in_ferret.cmn'	

      common/plyclp/acmin,acmax,bcmin,bcmax
      real acmin,acmax,bcmin,bcmax

      real vwidth,vheight,amax2,bmax2

*  From shade_sub; to use GKS calls to get scaling 

	INTEGER		error, trans_no
	REAL	 	w(4), v(4), wc(4)

	xplus = xadd

*     Get viewport width and height in ferret; otherwise leave it alone

      IF (ppl_in_ferret) THEN

*    Do scaling as in shade_sub, using gks calls.
*    Get proper scaling, world coordinates, etc for fill

	CALL gqcntn (error,trans_no)
	IF (error .NE. 0) GOTO 1000
	CALL gqnt (trans_no,error,w,v)
	IF (error .NE. 0) GOTO 1000

*     Get world coordinates for for clipping region.

	CALL get_world_coords (w,v,wc)

      else
	 amax2 = amax
	 bmax2 = bmax
      endif


*     We're not sure if the xarg and yarg indices are needed in the calling routine
*     so copy all of the values to the x() and y() arrays.
*
*     pplmod_fillpoly doesn't use the 'inverse' flag.  (Should it?)
         DO 1 i=1,npts
#ifdef double_p
            x(i) = DBLE(xarg(i))
            y(i) = DBLE(yarg(i))
#else
            x(i) = xarg(i)
            y(i) = yarg(i)
#endif
 1       CONTINUE 
         
*     Curvilinear section
      IF (curvilinear) THEN

         CALL CURV_COORD(x, y, npts, 1.0, 1.0, status) ! xform the pts
	 IF (curv_missing) RETURN

* add offset for modulo transformation.

           DO 48, i = 1, npts
              x(i) = x(i) + xplus
 48        CONTINUE

* What is the max and min x coordinate value covered by this call?

           DO 49, i = 1, npts
              lmin = MIN(lmin, x(i))
              lmax = MAX(lmax, x(i))
 49        CONTINUE
      ENDIF
c
c scale and transform the vertices

*jd* begin -- temporary -- no projections permitted

      do 5 i=1,npts

	    if (itypex .gt. 1) then
	       xtemp = xlen*log10(x(i)/xlo)/log10(xhi/xlo)
	    else
	       xtemp = xlen*(x(i) - xlo)/(xhi-xlo)
	    endif

	    if (itypey .gt. 1) then
	       ytemp = ylen*log10(y(i)/ylo)/log10(yhi/ylo)
	    else
	       ytemp = ylen*(y(i) - ylo)/(yhi-ylo)
	    endif

            XTEMP = xtemp * XSCALE
            YTEMP = ytemp * YSCALE
*         endif
c
         call tform(xtemp,ytemp,ztemp)
         xt(i)=anew
         yt(i)=bnew
c
 5    continue
c
c find clipping region
c
      if(windof)then
         acmin = wc(1)
         acmax = wc(2)
         bcmin = wc(3)
         bcmax = wc(4)
      else
         acmin = amin
         acmax = amax2
         bcmin = bmin
         bcmax = bmax2
      endif
c
c clip polygon
c
      call clippoly(xt,yt,npts,xc,yc,nout)
c
      if(nout.eq.0) return
c

*jd begin
	fill_ndx = index + 2

	call set_fill_ndx (fill_ndx) 
	call gfa (nout,xc,yc)

*	TO RETAIN ABILITY FOR COLOR OR HATCHING IN METAFILE, WRITE 
*	NDX TO PRIVATE ITEM - forget it 10.22
*	if (meta_actv .and. .not. area_bundles) call meta_fill_ndx (fill_ndx)

*      goto (10,50,30,10,10,20,20),ptype+3
*c
*c tekterminal
*c
* 10   goto 100
*c
*c window device X11
*c
*#ifdef X11
* 20   if(havex)then
*         if(.not.gksopn)then
*            call xwinit
*         endif
*         call fillpolyx(xc,yc,nout,index)
*      endif
*#else
* 20   continue
*#endif
*c
*c check for other devices
*c
*100   goto (50,50,50,50,30,50,30),ptype+3
*c
*c meta file
*c
* 30   if(wrtclr)then
*c
*c write color map
*c
*         wrtclr=.false.
*         call binbuf(float(numclr),-2.)
*         do 31 i=1,numclr,2
*            call binbuf(float(rdclr(i)),float(rdclr(i+1)))
* 31      continue
*         do 32 i=1,numclr,2
*            call binbuf(float(grnclr(i)),float(grnclr(i+1)))
* 32      continue
*         do 33 i=1,numclr,2
*            call binbuf(float(blclr(i)),float(blclr(i+1)))
* 33      continue
*      endif
*c
*c write poly
*c
*      call binbuf(float(index),-3.)
*      call binbuf(float(nout),-3.)
*      do 34 i=1,nout
*         call binbuf(xc(i),yc(i))
* 34   continue
*c
*jd end

 50   return
*     FATAL ERROR
1000  RETURN
      END
c
      subroutine clippoly(xt,yt,npts,xc,yc,nout)
      real xt(*),yt(*),xc(*),yc(*)
      integer npts,nout
c
      real x,y
      logical inregion
      integer i0,i1

      nout = 0
      do 10 i0 = 1,npts
         i1 = i0+1
         if(i1.gt.npts)i1=1
         if(inregion(xt(i0),yt(i0))) then
            call putunique(xt(i0),yt(i0),xc,yc,nout)
            if(inregion(xt(i1),yt(i1)))then
               call putunique(xt(i1),yt(i1),xc,yc,nout)
            else
               call getinterp(xt(i0),yt(i0),xt(i1),yt(i1),x,y)
               call putunique(x,y,xc,yc,nout)
            endif
         else
            if(inregion(xt(i1),yt(i1))) then
               call getinterp(xt(i1),yt(i1),xt(i0),yt(i0),x,y)
               call putunique(x,y,xc,yc,nout)
               call putunique(xt(i1),yt(i1),xc,yc,nout)
            endif
         endif
 10   continue

      if(nout .le. 2) nout = 0
      return
      end
c
      logical function inregion(x,y)
      real x,y
c
      common/plyclp/acmin,acmax,bcmin,bcmax
      real acmin,acmax,bcmin,bcmax
c
      inregion = ((x.ge.acmin) .and. (x.le.acmax)) .and. 
     *           ((y.ge.bcmin) .and. (y.le.bcmax))
      return
      end
c
      subroutine putunique(x, y, xc, yc, nout)
      real x,y,xc(*),yc(*)
      integer nout,i
c
      if(nout .eq. 0) goto 100
      do 10 i=1,nout
         if((x.eq.xc(i)) .and. (y.eq.yc(i)))return
 10   continue
 100  nout = nout + 1
      xc(nout)=x
      yc(nout)=y
      return
      end
c
      subroutine getinterp(xin,yin,xout,yout,x,y)
      real xin,yin,xout,yout,x,y
c
      common/plyclp/acmin,acmax,bcmin,bcmax
      real acmin,acmax,bcmin,bcmax
c
      real f
c
      if(xout.lt.acmin)then
         f = (acmin - xin)/(xout - xin)
      else if(xout.gt.acmax) then
         f = (acmax - xin)/(xout - xin)
      else
         goto 100
      endif
      x = xin + (f * (xout - xin))
      y = yin + (f * (yout - yin))
      if((y.ge.bcmin).and.(y.le.bcmax))return
 100  if(yout.lt.bcmin) then
         f = (bcmin - yin)/(yout - yin)
      else
         f = (bcmax - yin)/(yout - yin)
      endif
      x = xin + (f * (xout - xin))
      y = yin + (f * (yout - yin))
      return
      end


