-+-+-+-+-+-+-+-+ START OF PART 168 -+-+-+-+-+-+-+-+
X call ptkf_point(0.3, 0.2, size)
X call ptkf_createrotator(1, rotator3, PTKETHREED, size,`20
X : '3D rotator', 0.02)
X if (colour .gt. 2) then
X blue = ptkf_stringtoint('colourindex', 'blue')
X white = ptkf_stringtoint('colourindex', 'white')
X black = ptkf_stringtoint('colourindex', 'black')
X call ptkf_setrotatorattrs(1, rotator1, 1, white,`20
X : blue, white, blue, white, blue, white, black)
X call ptkf_setrotatorattrs(1, rotator2, 1, white,`20
X : blue, white, blue, white, blue, white, black)
X call ptkf_setrotatorattrs(1, rotator3, 1, white,`20
X : blue, white, blue, white, blue, white, black)
X endif
X call ptkf_point(0.5, 0.3, pos)
X call ptkf_setmenuposition(rotator1, pos)
X call ptkf_point(0.5, 0.55, pos)
X call ptkf_setmenuposition(rotator2, pos)
X call ptkf_point(0.5, 0.8, pos)
X call ptkf_setmenuposition(rotator3, pos)
X call ptkf_setrotatortitle(rotator1, 'zoom')
X
X RETURN
X END
X `20
XC--------------------------------------------------------------------------
X `20
X SUBROUTINE testboxmenu()
X LOGICAL boxmenuquit, picked
X INTEGER itemnum
X LOGICAL getmenupick
X INTEGER ptkf_stringtoint
X
X include '`5B`5Dvmsphigs77.for'
X
X call ptkf_unpostmenu(1, ptkf_stringtoint('menuid', 'mainmenu')) `20
X call ptkf_postmenu(1, ptkf_stringtoint('menuid', 'inputmenu'))
X call ptkf_postmenu(1, ptkf_stringtoint('menuid', 'boxmenu')) `20
X
X call prst(1, PALWAY)
X boxmenuquit = .FALSE.
X
X 10 itemnum = 0
X picked = getmenupick(ptkf_stringtoint('menuid', 'inputmenu'),`20
X : itemnum)`20
X if (picked .eq. .TRUE.) then
X print *,('Testing ptkf_setboxmenuhighlightitem()...')
X call ptkf_setboxmenuhighlightitem(ptkf_stringtoint('menuid',
X : 'inputmenu'), itemnum)
X call prst(1, PALWAY)
X
X if (itemnum .eq. 1) then
X call pickinput(itemnum)
X call ptkf_setboxmenuhighlightitem(ptkf_stringtoint(
X : 'menuid', 'boxmenu'), itemnum)
X else if (itemnum .eq. 2) then
X call pointinput(itemnum)
X call ptkf_setboxmenuhighlightitem(ptkf_stringtoint(
X : 'menuid', 'boxmenu'), itemnum)
X else if (itemnum .eq. 3) then
X call stringinput(itemnum)
X call ptkf_setboxmenuhighlightitem(ptkf_stringtoint(
X : 'menuid', 'boxmenu'), itemnum)
X else
X boxmenuquit = .TRUE.
X endif
X endif
X
X call prst(1, PALWAY)
X
X if (boxmenuquit .eq. .TRUE.) then
X goto 20
X else`20
X goto 10
X endif
X
X 20 call ptkf_clearboxmenuhighlight(ptkf_stringtoint('menuid',`20
X : 'inputmenu'))
X call ptkf_clearboxmenuhighlight(ptkf_stringtoint('menuid',`20
X : 'boxmenu'))
X call ptkf_unpostmenu(1, ptkf_stringtoint('menuid', 'boxmenu'))
X
X RETURN
X END
X `20
XC--------------------------------------------------------------------------
X `20
X SUBROUTINE testrotator()
X LOGICAL rotatorquit, picked
X INTEGER err, itemnum
X LOGICAL getmenupick
X INTEGER ptkf_stringtoint
X
X include '`5B`5Dvmsphigs77.for'
X
X print *,('Testing ptkf_delmenuitem...')
X call ptkf_delmenuitem(ptkf_stringtoint('menuid',`20
X : 'inputmenu'), 3)
X call ptkf_unpostmenu(1, ptkf_stringtoint('menuid',`20
X : 'mainmenu')) `20
X call ptkf_postmenu(1, ptkf_stringtoint('menuid',`20
X : 'inputmenu'))
X `20
X call ptkf_postmenu(1, ptkf_stringtoint('menuid',`20
X : '1drotator'))
X call ptkf_postmenu(1, ptkf_stringtoint('menuid',`20
X : '2drotator'))
X call ptkf_postmenu(1, ptkf_stringtoint('menuid',`20
X : '3drotator'))
X call prst(1, PALWAY)
X rotatorquit = .FALSE.
X 10 itemnum = 0
X picked = getmenupick(ptkf_stringtoint('menuid', 'inputmenu'),
X : itemnum)
X if (picked .eq. .TRUE.) then
X if (itemnum .eq. 1) then
X call pickinput(itemnum)
X else if (itemnum .eq. 2) then
X call pointinput(itemnum)
X else
X rotatorquit = .TRUE.
X endif
X endif
X
X if (rotatorquit .eq. .TRUE.) then
X goto 20
X else`20
X goto 10
X endif
X
X 20 call ptkf_unpostmenu(1, ptkf_stringtoint('menuid',`20
X : '1drotator'))
X call ptkf_unpostmenu(1, ptkf_stringtoint('menuid',`20
X : '2drotator'))
X call ptkf_unpostmenu(1, ptkf_stringtoint('menuid',`20
X : '3drotator'))
X call ptkf_createtextmenuitem(ptkf_stringtoint('menuid',`20
X : 'inputmenu'), 'string', 3, PINSRT, err)
X
X RETURN
X END
X `20
XC--------------------------------------------------------------------------
X `20
XC end of menutest.f
$ CALL UNPACK [.FORTRAN.SOURCE.DEMO]MENUTEST.FOR;2 661524456
$ create 'f'
XC---------------------------------------------------------------------------
V`20
X
XC Program name: Phinter utility program.
X
XC Author: Gareth Williams
X
XC Description:
X
XC Modification history : (Version), (Date), (Name), (Description).
X
XC 1.0, 1st March 1991, G. Williams, First Version.
X
XC---------------------------------------------------------------------------
V-
X
X PROGRAM phinter
X
X call ptkf_inithashtables()
X call ptkf_createhashtable('structureid', 1, 500)
X call ptkf_createhashtable('label', 1, 100)
X call ptkf_createhashtable('viewindex', 1, 50)
X call ptkf_createhashtable('colourindex', 2, 256)
X call ptkf_createhashtable('name', 1, 500)
X call ptkf_callphinter()
X
X STOP
X END
X `20
XC--------------------------------------------------------------------------
X
XC end of phinter.f
$ CALL UNPACK [.FORTRAN.SOURCE.DEMO]PHINTER.FOR;1 92144592
$ create 'f'
XC---------------------------------------------------------------------------
V`20
X
XC Program name: StructureDraw test program.
X
XC Author: Gareth Williams
X
XC Description:
X
XC Modification history : (Version), (Date), (Name), (Description).
X
XC 1.0, 1st July 1991, G. Williams, First Version.
X
XC---------------------------------------------------------------------------
V-
X `20
X PROGRAM stcttest
X
X implicit none
X
X INTEGER err, minid, maxid, pid
X LOGICAL ptkf_readphinterscript
X INTEGER ptkf_stringtoint
X
X include '`5B`5Dvmsphigs77.for'
X
X print *,('Testing the structure draw module of the PHIGS`20
X : Toolkit...')
X print *,('Opening DEC PHIGS...')
X
X call popph(0, 0)
X
XC create the workstation type (either tool or canvas)`20
X `20
XC open the workstation`20
X `20
X call popwk(1, 0, 0)
X
X call psdus(1, PWAITD, PNIVE)
X minid = 1
X maxid = 30
X call ptkf_inithashtables()
X call ptkf_createhashtable('structureid', minid, maxid)
X call ptkf_createhashtable('label', 0, maxid)
X call ptkf_createhashtable('name', 0, maxid)
X `20
X if (ptkf_readphinterscript('`5B-.-.scripts`5Dpostcard.scr',`20
X : 0, 0)) then
X call popst(ptkf_stringtoint('structureid', 'content'))
X pid = ptkf_stringtoint('structureid', 'postcard')
X call ptkf_structcontent(1, pid, 1, 0, 0, 1, err)
X call pclst()
X `20
X if (err .eq. 0) then
X call ppost(1, ptkf_stringtoint('structureid', 'content'),`20
X : 0.0)
X endif
X
X call prst(1, PALWAY)
X call options()
X endif
X
X call pclwk(1)
X call pclph()
X
X STOP
X END
X
XC--------------------------------------------------------------------------
X
X SUBROUTINE options()
X CHARACTER*20 commandstr, postcdstr, rangestr, pointstr, quitstr
X INTEGER lencom, err, elem1, elem2, eptr, postcardid
X LOGICAL structquit
X REAL echoarea(4)
X INTEGER ptkf_readint
X INTEGER ptkf_stringtoint
X REAL devx, devy
X `20
X postcdstr = 'postcard'
X rangestr = 'range'
X pointstr = 'pointer'
X quitstr = 'quit'
X structquit = .FALSE.
X eptr = 0
X postcardid = ptkf_stringtoint('structureid', 'postcard')
X call ptkf_inqmaxdevicecoords(1, devx, devy)
X call ptkf_limit(0.0, 0.5 * devx, 0.0, 0.05 * devy, echoarea)
X 10 call ptkf_readstring(1, 'range', 'Input command`20
X : (default = range) >', echoarea, 20, commandstr, lencom)
X if (commandstr(1:lencom) .eq. rangestr(1:lencom)) then
X elem1 = ptkf_readint(1, 1, 'Input element number (1) >',`20
X : echoarea)
X elem2 = ptkf_readint(1, 0, 'Input element number (0) >',`20
X : echoarea)
X call pemst(ptkf_stringtoint('structureid', 'content'))
X call popst(ptkf_stringtoint('structureid', 'content'))
X call ptkf_structcontent(1, postcardid, elem1, elem2, eptr, 1,`20
X : err)
X call pclst()
X call prst(1, PALWAY)
X else if (commandstr(1:lencom) .eq. pointstr(1:lencom)) then
X eptr = ptkf_readint(1, 0, 'Input element pointer (0) >',`20
X : echoarea)
X call popst(ptkf_stringtoint('structureid', 'content'))
X call ptkf_setstructcontentelemptr(ptkf_stringtoint(
X : 'structureid', 'content'), eptr)
X call pclst()
X call prst(1, PALWAY)
X else if (commandstr(1:lencom) .eq. quitstr(1:lencom)) then
X structquit = .TRUE.
X else
X print *,('Command unknown') `20
X endif
X
X if (structquit .eq. .TRUE.) then
X goto 20
X else`20
X goto 10
X endif
X
X 20 RETURN
X END
X
XC--------------------------------------------------------------------------
X `20
XC end of stcttest.f
$ CALL UNPACK [.FORTRAN.SOURCE.DEMO]STCTTEST.FOR;2 908042371
$ create 'f'
XC---------------------------------------------------------------------------
V`20
X
XC Program name: TopDraw test program.
X
XC Author: Gareth Williams
X
XC Description:
X
XC Modification history : (Version), (Date), (Name), (Description).
X
XC 1.0, 1st June 1991, G. Williams, First Version.
X
XC---------------------------------------------------------------------------
V-
X
X PROGRAM toptest
X
X implicit none
X
X include '`5B`5Dvmsphigs77.for'
X include '`5B`5Dvmsptk77.for'
X
XC--------------------------------------------------------------------------
X
X INTEGER err, minid, maxid
X LOGICAL ptkf_readphinterscript
X INTEGER ptkf_stringtoint
X `20
X print *,('Testing the topdraw module of the PHIGS Toolkit...')
X print *,('Opening DEC PHIGS...')
X
X call popph(0, 0)
X
XC create the workstation type (either tool or canvas)`20
X `20
XC open the workstation`20
X `20
X call popwk(1, 0, 0)
X
X call psdus(1, PWAITD, PNIVE)
X
X minid = 0
X maxid = 30
X call ptkf_inithashtables()
X call ptkf_createhashtable('structureid', 17, 100)
X call ptkf_createhashtable('label', minid, maxid)
X call ptkf_createhashtable('topologyid', minid, maxid)
X call ptkf_createhashtable('name', minid, maxid)
X `20
XC make dummy network`20
X `20
X if (ptkf_readphinterscript('`5B-.-.scripts`5Dlamp.scr',`20
X : 0, 0)) then
X print *,('Testing ptkf_topology()...')
X call ptkf_createtopology(ptkf_stringtoint('topologyid',`20
X : 'topology'), ptkf_stringtoint('structureid', 'lamp'), err)
X print *,('Testing ptkf_posttopology()...')
X call ptkf_posttopology(1, ptkf_stringtoint('topologyid',`20
X : 'topology'), 0.0)
X call prst(1, PALWAY)
X
X call options()
X endif
X
X call pclwk(1)
X call pclph()
X
X STOP
X END
X
XC--------------------------------------------------------------------------
X
X SUBROUTINE options()
X
X implicit none
X
X CHARACTER*20 commandstr
X INTEGER lencom
X LOGICAL topquit
X REAL echoarea(4)
X INTEGER ptkf_stringtoint
X INTEGER topid
X INTEGER lldr, pldr
X REAL ra(2)
X INTEGER ia(2), lstr(2)
X CHARACTER*80 str
X CHARACTER*80 ldatrec(10), pdatrec(10)
X CHARACTER*80 storename
X INTEGER*4 fileptr, err
X INTEGER ptkf_fopen
X INTEGER ptkf_fclose
X REAL devx, devy
X
X include '`5B`5Dvmsphigs77.for'
X include '`5B`5Dvmsptk77.for'
X
X storename = '`5B-.-.data`5Dstore.dat'
X topid = ptkf_stringtoint('topologyid', 'topology')
X topquit = .FALSE.
X call ptkf_inqmaxdevicecoords(1, devx, devy)
X call ptkf_limit(0.0, 0.5 * devx, 0.0, 0.05 * devy, echoarea)
X 10 call ptkf_readstring(1, 'boxtopology',`20
X : 'Input command (default = boxtopology) >', echoarea, 20,`20
X : commandstr, lencom)
X if (commandstr(1:lencom) .eq. 'boxtopology') then
X print *,('Testing ptkf_settopologytype()...')
X call ptkf_settopologytype(topid, PTKEBOXTOPOLOGY)
X
X else if (commandstr(1:lencom) .eq. 'structnettopology') then
X print *,('Testing ptkf_settopologytype()...')
X call ptkf_settopologytype(topid, PTKESTRUCTNETTOPOLOGY)
X
X else if (commandstr(1:lencom) .eq. 'structtopology') then
X print *,('Testing ptkf_settopologytype()...')
X call ptkf_settopologytype(topid, PTKESTRUCTTOPOLOGY)
X
X else if (commandstr(1:lencom) .eq. 'tidysingle') then
X print *,('Testing ptkf_tidytopology()...')
X ra(1) = 0.01
X call pprec(0, ia, 1, ra, 0, lstr, str, 10, err, pldr,
X : pdatrec)
X call pprec(0, ia, 0, ra, 0, lstr, str, 10, err, lldr,
X : ldatrec)
X call ptkf_tidytopology(1, ptkf_stringtoint('topologyid',`20
X : 'topology'), PTKESINGLE, 1, 1, pldr, pdatrec, 1, 1,`20
X : lldr, ldatrec)
X
+-+-+-+-+-+-+-+- END OF PART 168 +-+-+-+-+-+-+-+-