pickbox.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 PickBox				! program "PickBox.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	Error				! error-return variable
      integer*4	SpecType			! specific workstation type 
      integer*4	UnitType			! device unit type
      integer*4	Root, LineSquare, Trans1, Trans2! structure IDs
      parameter (Root=2, LineSquare=1, Trans1=3, Trans2=4)
      real	AreaX(4), AreaY(4)		! points for fill area 
      data	AreaX /0.0, 0.0, 0.2, 0.2/, AreaY /0.0, 0.2, 0.2, 0.0/
      real	LineX(2), LineY(2)		! points for polyline 
      data	LineX /0.2, 0.4/, LineY /0.1, 0.1/
      integer*4	PixelsX, PixelsY, PixelsZ	! display space size in pixels
      real	DCsX, DCsY, DCsZ		! display space size in DCs
      real	EchoVolume(6)			! Echo volume limits
      !--- picking variables -------------------------------------------------
      integer*4	Pointer				! pointer device number
      parameter (Pointer=1)
      integer*4	PET				! prompt/echo type
      integer*4	PathDepth			! input pick path depth
      parameter(PathDepth=5)			! input pick path value
      integer*4	PickPath(3, PathDepth)		! PickPath array
      integer*4	PickStatus			! return pick status
      integer*4	ReturnDepth			! return pick path depth
      integer*4	Incl(2), Excl(2)		! include and exclude filters
      integer*4	NameList(255)			! namelist array for name sets
      integer*4 Name1				! a name for the namelist
      parameter (Name1=1)
      !-- variables for packing the data record ------------------------------
      integer*4		IntCount		! DataRec integer count
      parameter		(IntCount=1)		! DataRec integer count value
      integer*4		Ints(IntCount)		! DataRec integer array
      integer*4		RealCount		! DataRec real count
      parameter		(RealCount=3)		! DataRec real count value
      real		Reals(RealCount)	! DataRec real array
      integer*4		StrCount		! DataRec string count
      parameter		(StrCount=0)		! DataRec string count value
      integer*4		StrLength		! DataRec string length
      parameter		(StrLength=1)		! DataRec string length value
      character*1	Strings(1)		! DataRec string array
      integer*4		RecCount		! DataRec element count
      parameter		(RecCount=1)		! DataRec element count value
      integer*4		Length			! DataRec element return length
      character*80	DataRec(RecCount)	! DataRec array
      !--- miscellaneous items -----------------------------------------------
      integer*4 fdopen				! to get file descriptor
      real	Matrix(3, 3)			! transformation matrix
      logical	Done				! loop control variable
      integer*4	Index				! loop control variable
      real	rad, degrees
      rad(degrees)=(degrees*3.14159265358979323846/180.0)

      !=== initialize ========================================================
      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
      !--- define the structure with the line and square ---------------------
      call popst(LineSquare)		! open structure 
      call ppl(2, LineX, LineY)		! polyline
      call psis(PSOLID)			! set interior style: solid 
      call pfa(4, AreaX, AreaY)		! fill area    
      call pclst			! close structure 
      !--- define first transformation structure -----------------------------
      call popst(Trans1)		! open structure
      call pbltm(0.0, 0.0, 0.2, 0.2, 	! build local transformation matrix
     +  rad(0.0), 1.0, 1.0, Error, Matrix)
      call pslmt(Matrix, PCREPL)	! set local modelling transformation
      call pexst(LineSquare)		! execute structure
      call pclst			! close structture
      !--- build second transformation structure -----------------------------
      call popst(Trans2)		! open structure
      call pbltm(0.0, 0.0, 0.8, 0.8, 	! build local transformation matrix
     +  rad(180.0), 1.0, 1.0, Error, Matrix)
      call pslmt(Matrix, PCREPL)	! set local modelling transformation
      call pexst(LineSquare)		! execute structure
      call pclst			! close structure
      !--- build root structure ----------------------------------------------
      call popst(Root)			! open structure 
      Namelist(1)=Name1			! put Name 1 in array
      call pads(1, NameList)		! add names to set
      call pspkid(1)			! set pick id
      call pexst(Trans1)		! execute transformation one
      call pexst(Trans2)		! execute transformation two
      call pbltm(0.0, 0.0, 0.2, 0.8, 	! build local transformation matrix
     +  rad(-90.0), 1.0, 1.0, Error, Matrix)
      call pslmt(Matrix, PCREPL)	! set local modelling transformation
      call pspkid(2)			! set pick identifier
      call pexst(LineSquare)		! execute structure
      call pbltm(0.0, 0.0, 0.8, 0.2, 	! build local transformation matrix
     +  rad(90.0), 1.0, 1.0, Error, Matrix)
      call pslmt(Matrix, PCREPL)	! set local modelling transformation
      call pexst(LineSquare)		! execute LineSquare
      call pclst			! close the structure
      !=== display the structure network =====================================
      call ppost(WorkstnID, Root, 1.0)
      call prst(WorkstnID, PALWAY)
      call pqwkc(WorkstnID, Error,	! get specific workstation type
     +  ConnID, SpecType)
      call pqdsp3(SpecType, Error,	! inquire display size
     +  UnitType, DCsX, DCsY, DCsZ, PixelsX, PixelsY, PixelsZ)
      EchoVolume(1)=DCsX*0.0		! \
      EchoVolume(2)=DCsX*1.0		!  \
      EchoVolume(3)=DCsY*0.0		!   > this must be specified,
      EchoVolume(4)=DCsY*1.0		!  /  though it is ignored
      EchoVolume(5)=DCsZ*0.0		! /
      EchoVolume(6)=DCsZ*1.0		!/
      !--- pack pick aperture size into data record --------------------------
      Reals(1)=0.005
      Reals(2)=0.005
      Reals(3)=2.0
      Ints(1)=2
      call pprec(IntCount, Ints, RealCount, Reals, 
     +  StrCount, StrLength, Strings, RecCount, Error, Length, DataRec)
      PickStatus=PNPICK
      PET=1
      call pinpk3(WorkstnID, Pointer, PickStatus, PathDepth, PickPath, 
     + 	PET, EchoVolume, Length, DataRec, PPOTOP)
      Incl(1)=Name1			! put Name 1 into the pick filter
      call pspkft(WorkstnID, Pointer, 1, Incl, 0, Excl)
      print *, "Ready for pick input; click on the background (or press"
      print *, "the [Break] key) to quit."
      Done=.false.
      do while (.not. Done)
          call prqpk(WorkstnID, Pointer, PathDepth, 
     +	    PickStatus, ReturnDepth, PickPath)
          if (PickStatus .eq. POK) then	! print pick path
	      print *, "ReturnDepth: ", ReturnDepth
	      do Index=1, ReturnDepth
		  print *, "  Structure No.:   ", PickPath(1, Index) 
		  print *, "    Pick ID:       ", PickPath(2, Index) 
		  print *, "    Element Offset:", PickPath(3, Index)
	      end do
	  else
              print *, "PickStatus:", PickStatus,"; terminating."
              Done=.true.
          endif
      end do
      call pclwk(WorkstnID)			! close workstation
      call pclph				! close phigs
      stop					! stop processing
      end					! end of program