$alias fdopen='fdopen'(%val, %ref)      include 'phigs.f1.h'			! get the HP-PHIGS aliases      program FlatSmooth			! program "FlatSmooth.f"      include 'phigs.f2.h'			! get the HP-PHIGS constants      integer*4		WorkstnID		! workstation identifier      parameter		(WorkstnID=1)		! value chosen by the user      integer*4		ConnID			! connection identifier      integer*4		WorkstnType		! workstation type      parameter		(WorkstnType=POIDDX)	! out/in, direct, dbl bfr, X      integer*4		FillArea, Scene		! structure IDs      parameter		(FillArea=1, Scene=2)	! values chosen by user      real*4		Colour(3)		! for color table values      integer*4		RampSize		! size of colour ramps      parameter		(RampSize=50)		! nice round number      real		Matrix(4, 4)		! for transformation matrices      real		WeightVector(3)		! for determining colour index      data		weightvector /1.0, 0.0, 0.0/	! arbitrarily use red      character*15	String(2)		! for textual labels      data		String	/"Flat Shading", "Smooth Shading"/      integer*4	Error				! error-return variable      integer*4 fdopen				! to get file descriptor      call popph(fdopen(fnum(7), 'w'//char(0)), 0)	! open phigs      call pue004('/dev/screen/phigs_window', ConnID)	! get connection ID      call popwk(WorkstnID, ConnID, WorkstnType)! open workstation      call pue250(WorkstnID, 0)			! set color env: direct      call pue240(WorkstnID, 1)			! turn off dithering      !--- define the filled areas -------------------------------------------      call popst(FillArea)			! open structure      call CreatePrimitives(RampSize)		! make filled areas      call pclst				! close structure      !--- define whole scene ------------------------------------------------      call popst(Scene)				! open the Scene structure      call DefineColourRamps(WorkstnID, RampSize, 1, WeightVector)      call pscmi(1)				! set color mapping index      call pstxfn(-4)				! set text font index      Colour(1) = 2.0/(3*RampSize+2)		! \  white text, which is in      Colour(2) = 0.0				!  > the second entry in the      Colour(3) = 0.0				! /  color list      call pstxc(PRGB, 0, 3, Colour)		! set text color      call psatch(0.05)				! set annotation text height      call patr(0.1, 0.9, 0.0, 0.0, String(1))	! annotation text rel.      call patr(0.1, 0.4, 0.0, 0.0, String(2))	! annotation text rel.      call psis(PSOLID)				! set interior style: solid      call psrfm(PNORM)				! set reflectance model      call psism(PNOIS)				! set interior shading method      call pexst(FillArea)			! execute structure      call ptr3(0.0, -0.5, 0.0, Error, Matrix)	! translate      call pslmt3(Matrix, PCREPL)		! set local transformation      call psism(PCIS)				! set interior shading method      call pexst(FillArea)			! execute structure      call pclst				! close structure      !--- close up shop -----------------------------------------------------      call ppost(WorkstnID, Scene, 1.0)		! post structure      call pclwk(WorkstnID)			! close workstation      call pclph				! close phigs      stop					! stop processing      end					! end of program!*****************************************************************************      subroutine CreatePrimitives(RampSize)      integer*4	RampSize			! size of colour ramps      include 'phigs.f2.h'      real	PointsX(4), PointsY(4), PointsZ(4)	! XYZ data      real	FacetColour(3)			! direct RGB color      real	VertexColour(12)		! direct RGB color      real	Colour, dColour			! value to increment Colour      integer*4	LastVerts(1)			! last-vertex index array      integer*4	I, J				! loop control variables      integer*4	Dummy				! place-holder for unused vars      integer*4	Lint      LastVerts(1) = 4				! 4 points in each fill area      Colour=3.0/(3*RampSize+2)      dColour=(3*RampSize)/(3.0*RampSize+2)/9	! incr: 1/9 of colour range      do I=1, 10	  do J=1, 4	      PointsX(J)=(I+Lint(J.eq.2 .or. J.eq.3))/12.0	      PointsY(J)=0.55+0.3*Lint(J.ge.3)	      PointsZ(J)=0.0	  end do          FacetColour(1) = Colour          FacetColour(2) = 0.0          FacetColour(3) = 0.0          VertexColour(1)  = Colour          VertexColour(2)  = 0.0          VertexColour(3)  = 0.0          VertexColour(4)  = Colour+dColour          VertexColour(5)  = 0.0          VertexColour(6)  = 0.0          VertexColour(7)  = Colour+dColour          VertexColour(8)  = 0.0          VertexColour(9)  = 0.0          VertexColour(10) = Colour          VertexColour(11) = 0.0          VertexColour(12) = 0.0	  call pfas3d(				! fill area set 3 with data     +	    PFC,				!   facet flag: colour     +	    PENO,				!   edge flag: none     +	    PCDC,				!   vertex flag: verts, colr     +	    PRGB, 3,				!   colour type: RGB (3 comps)     +	    Dummy,				!   indirect facet colour     +	    FacetColour,			!   direct facet colour     +	    Dummy, Dummy, Dummy,		!   facet normals     +	    Dummy, Dummy,			!   facet application data     +	    1,					!   number of fill areas     +	    LastVerts,				!   final area indexes     +	    POFF,				!   edge visibility flag     +	    PointsX, PointsY, PointsZ,		!   XYZ data     +	    Dummy,				!   indirect vertex colours     +	    VertexColour,			!   direct vertex colours     +	    Dummy, Dummy, Dummy,		!   vertex normals     +	    Dummy, Dummy)			!   vertex application data	  Colour=Colour+dColour      end do      return      end!*****************************************************************************      subroutine DefineColourRamps(WorkstnID, RampSize, CMappingIndex,     +  WeightVector)      integer*4	WorkstnID			! workstation identifier      integer*4	RampSize			! size of ramp      integer*4	CMappingIndex			! colour mapping table index      real	WeightVector(3)			! for colour->gray conversion      include 'phigs.f2.h'      real	FirstColour(3), LastColour(3)	! extremes of ramp      !--- variables for packing data record ---------------------------------      integer*4		IntCount	! DataRec's integer count      integer*4		Ints(3)		! DataRec's integer array      integer*4		RealCount	! DataRec's real count      real		Reals(768)	! max needed for DataRec's real array      integer*4		StrCount	! DataRec's string count      integer*4		StrLength	! DataRec's string length      character*1	Strings(1)	! DataRec's string array      integer*4		RecCount	! DataRec's element count      data		StrCount /0/, StrLength /0/, RecCount /100/      integer*4		Length		! DataRec's element return length      character*80	DataRec(100)	! DataRec array itself      !--- miscellaneous variables -------------------------------------------      integer*4		Idx		! ramp-starting locations      integer*4		Error		! error-return variable      integer*4		Red, Green, Blue! mnemonics      parameter		(Red = 1, Green = 2, Blue = 3)      IntCount=3			! three significant integers in array      Ints(1)=PRGB			! specify colour as RGB      Ints(2)=3				! RGBs have 3 components      Ints(3)=2+3*RampSize		! how big is colour ramp?      RealCount=3+3*(2+3*RampSize)	! weight vector + b/w + ramps      Reals(1)=WeightVector(1)		! \      Reals(2)=WeightVector(2)		!  > assign weight vector      Reals(3)=WeightVector(3)		! /      Idx=1				! start location of 2-entry ramp      FirstColour(Red)  =0.0		! \      FirstColour(Green)=0.0		!  > create a single black entry...      FirstColour(Blue) =0.0		! /				      LastColour(Red)   =1.0            ! \                                   LastColour(Green) =1.0            !  > ...and a single white entry        LastColour(Blue)  =1.0            ! /                                   call DefineColourRamp(FirstColour, LastColour, Idx, 2, Reals)      Idx=Idx+2				! increment by size of last ramp      FirstColour(Red)  =0.0		!  \      FirstColour(Green)=0.0		!   \      FirstColour(Blue) =1.0		!    > create the blue-to-green ramp      LastColour(Red)   =0.0		!   /      LastColour(Green) =1.0		!  /      LastColour(Blue)  =0.0		! /				           call DefineColourRamp(FirstColour, LastColour, Idx, RampSize+1,     +  Reals)      Idx=Idx+RampSize			! increment by size of last ramp      FirstColour(Red)  =0.0            !  \      FirstColour(Green)=1.0            !   \                                      FirstColour(Blue) =0.0            !    > create the green-to-yellow ramp      LastColour(Red)   =1.0            !   /      LastColour(Green) =1.0            !  /                                       LastColour(Blue)  =0.0            ! /                                        call DefineColourRamp(FirstColour, LastColour, Idx, RampSize+1,     +  Reals)      Idx=Idx+RampSize			! increment by size of last ramp      FirstColour(Red)  =1.0            !  \      FirstColour(Green)=1.0            !   \      FirstColour(Blue) =0.0            !    > create the yellow-to-red ramp      LastColour(Red)   =1.0            !   /                                      LastColour(Green) =0.0            !  /       LastColour(Blue)  =0.0            ! /                                        call DefineColourRamp(FirstColour, LastColour, Idx, RampSize,     +  Reals)      call pprec(IntCount, Ints, RealCount, Reals, StrCount, StrLength,     +  Strings, RecCount, Error, Length, DataRec)      if(Error .ne. 0) print *, "Error", Error, " in pprec."      call pscmr(WorkstnID, CMappingIndex, PSUD, ! set colour mapping rep.     +  Length, DataRec)      return      end!*****************************************************************************      subroutine DefineColourRamp(FirstColour, LastColour, Idx,     +  RampSize, Reals)      real	FirstColour(3), LastColour(3)	! extremes of ramp      integer*4	Idx				! location in Reals array      integer*4	RampSize			! size of ramp      real	Reals(500)			! array being filled      real	DeltaColour(3)		! diff. between colr(i) and colr(i+1)      integer*4	I			! loop control variable      do I=1, 3	  DeltaColour(I)=(LastColour(I)-FirstColour(I))/(RampSize-1)      end do      do I=0, RampSize-1          Reals((Idx+I)*3+1)=FirstColour(1)+DeltaColour(1)*I          Reals((Idx+I)*3+2)=FirstColour(2)+DeltaColour(2)*I          Reals((Idx+I)*3+3)=FirstColour(3)+DeltaColour(3)*I      end do      return      end!*****************************************************************************      integer*4 function Lint(Expr)      logical	Expr            if (Expr) then	  Lint=1      else	  Lint=0      end if      return      end