flatsmooth.f

Intro/: Directory containing introductory examples. HelloWorld.c A simple program that draws a bo

$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