inqstructs.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 InqStructs			! program "InqStructs.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	StructureID			! structure identifier
      parameter (StructureID=1)			! value chosen by the user
      integer*4	Error				! error-return variable
      integer*4 ChoiceStatus, ChoiceNum		! choice status and value
      real	AreaX(4), AreaY(4), AreaZ(4)	! points for fill area
      data	AreaX /0.25, 0.75, 0.75, 0.25/	! points for fill area
      data	AreaY /0.25, 0.25, 0.75, 0.75/
      data	AreaZ /0.0,  0.0,  0.0,  0.0/
      integer*4	ElementType, IntSize, RealSize, StringSize
      integer*4	ElementPos, NumElements, CurrentElement
      character*6 ElementNames(105)
      data	ElementNames /'PENIL','PEPL3',  'PEPL',   'PEPM3',
     +  'PEPM',   'PETX3',  'PETX',   'PEATR3', 'PEATR',  'PEFA3',
     +  'PEFA',   'PEFAS3', 'PEFAS',  'PECA3',  'PECA',   'PEGDP3',
     +  'PEGDP',  'PEPLI',  'PEPMI',  'PETXI',  'PEII',   'PEEDI',
     +  'PELN',   'PELWSC', 'PEPLCI', 'PEMK',   'PEMKSC', 'PEPMCI',
     +  'PETXFN', 'PETXPR', 'PECHXP', 'PECHSP', 'PETXCI', 'PECHH',
     +  'PECHUP', 'PETXP',  'PETXAL', 'PEATCH', 'PEATCU', 'PEATP',
     +  'PEATAL', 'PEANST', 'PEIS',   'PEISI',  'PEICI',  'PEEDFG',
     +  'PEEDT',  'PEEWSC', 'PEEDCI', 'PEPA',   'PEPRPV', 'PEPARF',
     +  'PEADS',  'PERES',  'PEIASF', 'PEHRID', 'PELMT3', 'PELMT',
     +  'PEGMT3', 'PEGMT',  'PEMCV3', 'PEMCV',  'PEMCLI', 'PERMCV',
     +  'PEVWI',  'PEEXST', 'PELB',   'PEAP',   'PEGSE',  'PEPKID',
     +  'PEPSD3', 'PEFAD3', 'PEFSD3', 'PECAP3', 'PETSD3', 'PEQMD3',
     +  'PESFSD', 'PENBSC', 'PENBSS', 'PEDPCI', 'PECMI',  'PERCM',
     +  'PEAPR',  'PEBAPR', 'PEPLSM', 'PEBIS',  'PEBISI', 'PEISM',
     +  'PEBISM', 'PEIRE',  'PEBIRE', 'PELSS',  'PEFDM',  'PEFCM',
     +  'PEPLC',  'PEPMC',  'PETC',   'PEIC',   'PEBIC',  'PEEC',
     +  'PECAC',  'PETCAC', 'PESAC',  'PEPSC',  'PEBPSC'/
      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 ppost(WorkstnID, StructureID, 1.)	! mark structure for display
      !--- define the structure ----------------------------------------------
      call popst(StructureID)			! open structure
      call psis(PHOLLO)				! set interior color index
      call pfa3(4, AreaX, AreaY, AreaZ)		! fill area 3 primitive
      call pschh(0.04)				! set character height
      call ptx(0.3, 0.5, 'Hello World')		! text
      call pclst				! close the structure
      !--- display the structure ---------------------------------------------
      call ppost(WorkstnID, StructureID, 1.0)	! post structure
      call puwk(WorkstnID, PPERFO)		! update workstation
      !--- make keyboard a choice device so "[Return] to go on." works -------
      print *, "Press [Return] to continue."
      call pschm(WorkstnID, 2, PREQU, PNECHO)	! set choice mode on keyboard
      call prqch(WorkstnID, 2, ChoiceStatus, ChoiceNum) ! request choice
      !--- edit the structure ------------------------------------------------
      call psedm(PREPLC)			! set edit mode: replace
      call popst(StructureID)			! open structure
      call pqep(Error, ElementPos)		! inquire element pointer
      if (Error .ne. 0) then
	  print *, "Error", Error, " in pqcets; terminating."
	  stop
      endif
      print *, "Number of elements in structure: ", ElementPos
      NumElements=ElementPos
      do CurrentElement=1, NumElements
	  call psep(CurrentElement)		! set element pointer
	  call pqcets(Error, ElementType, 	! inquire element type, size
     +      IntSize, RealSize, StringSize)
	  if (Error .ne. 0) then
	      print *, "Error", Error, " in pqcets; terminating."
	      stop
	  endif
	  print *, "---------------------------------------------------"
	  print *, "Element type: ", ElementType,
     +      " (", ElementNames(ElementType), ")"
	  if (ElementType .eq. PEIS) then	! if int. style, replace it
	      call psis(PSOLID)			! set interior style
	  endif
	  call GetInfo
      end do
      call pclst				! close the structure
      call puwk(WorkstnID, PPERFO)		! update the workstation
      call pclwk(WorkstnID)			! close workstation
      call pclph				! close phigs
      stop					! stop processing
      end					! end of program
!*****************************************************************************
      subroutine GetInfo
      include 'phigs.f2.h'			! get the HP-PHIGS constants

      integer*4		Error, I
      integer*4		IntSize, RealSize, StrSize
      integer*4		Ints(100)
      real		Reals(100)
      integer*4		StrLen(100), Length
      character*80	String, Strings(100)

      call pqceco(100, 100, 100,		! inq. current element content
     +	Error, IntSize, Ints, RealSize, Reals, StrSize, StrLen, Strings)
      if (Error .ne. 0) then
	  print *, "Error", Error, " in pqceco, terminating."
	  stop
      endif
      !--- print the integers ------------------------------------------------
      print *, "  Number of integers: ", IntSize
      if (IntSize .gt. 0) then
	  print *, "    Integers:"
	  do I=1, IntSize
	      write(6, '(6X, I2)') Ints(I)
	  end do
      end if
      !--- print the reals ---------------------------------------------------
      print *, "  Number of reals: ", RealSize
      if (RealSize .gt. 0) then
          print *, "    Reals:"
	  do i=1, RealSize
              write(6, '(6X, F4.2)') Reals(I)
	  end do
      endif
      !--- print the strings -------------------------------------------------
      print *, "  Number of strings: ", StrSize
      if (StrSize .gt. 0) then
	  print *, "    Strings:"
	  do I=1, StrSize
	      Length=StrLen(I)
	      String=Strings(I)
              print *, '      "', String(1:Length), '"'
	  end do
      end if
      return
      end