home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / programming / fortranf1_1 / !WimpPoly_f77_WimpPoly < prev    next >
Encoding:
Text File  |  1993-11-11  |  47.1 KB  |  1,440 lines

  1.       PROGRAM WimpPoly                             
  2. C     Draws polyhedra from datafiles in directories dat1,2,3
  3. C     format from netlib, index in POLYLIST
  4. C
  5. C     needs libraries  Drawf, graphics, utils, Wimp
  6. C
  7. C                  common for solids
  8.       INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
  9.       INCLUDE '<WimpPoly$Dir>.f77.WPolyCH'
  10.        INCLUDE '<WimpPoly$Dir>.f77.WPolyWimp'
  11. C                    allow for long lines up to 256 characters
  12.       CHARACTER *256 KARD,KARD2            
  13.       COMMON/WORK/KARD,KARD2
  14. C                                      set up null terminated Version number
  15.       VERS='2.01 ( 08 Nov 93 )'//?H00
  16. C                INITIALISE WIMP
  17.       CALL WMPI('WimpPoly',ITHAND)
  18. C                    initialise all windows, icons etc.
  19.       CALL INIT                                        
  20. C                WIMP POLL bits mean 'no background work', 'not notified of
  21. C                moving pointer into window'
  22.    10 CALL WMPP(?I1831,IBLOCK,IREASN)
  23. C          check for file dragging etc.
  24.       CALL SAVEBX(IBLOCK,IREASN)
  25.       IF(IREASN.LT.0) GO TO 10
  26.       IF(IREASN.EQ.1) CALL REDRAW
  27.       IF(IREASN.EQ.2) CALL WMPOW(IBLOCK)
  28.       IF(IREASN.EQ.3) THEN         
  29. C                   end job when click on close icon of list window
  30.         IF(IBLOCK(1).EQ.IWLIST)THEN
  31.           CALL QUIT
  32.         ELSE         
  33. C                      Close Window using handle
  34.           CALL WMPCLW(IBLOCK(1))
  35.         ENDIF
  36.       ENDIF
  37. C                  mouse button clicked
  38.       IF(IREASN.EQ.6) CALL BUTTON(IBLOCK(3),IBLOCK(4),IBLOCK(5))
  39. C                   key board pressed 
  40.       IF(IREASN.EQ.8)CALL KEYS
  41. C                   mouse click over menu
  42.       IF(IREASN.EQ.9)CALL MENU
  43. C       message received
  44.       IF(IREASN.EQ.17.OR.IREASN.EQ.18) THEN
  45. C               requesting close down
  46. C               some other wimp task says it's time to close
  47.         IF(IBLOCK(5).EQ.0) CALL QUIT
  48.       ENDIF
  49.       GO TO 10
  50.       END                     
  51.       SUBROUTINE BUTTON(IBUT,IWIN,ICON)
  52. C                       decides which mouse button has been pressed
  53. C   given the numbers of the button (IBUT), window, (IWIN) and the icon.
  54.       INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
  55.       INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
  56. C                 only look at one button pressed at a time 
  57.       IF(IBUT.GT.4)RETURN
  58.       IF(IWIN.EQ.IWINTR)THEN
  59. C                  close the Intro window
  60.         CALL WMPCLW(IWINTR)
  61. C                OPEN WINDOW with list of Polyhedra
  62.         IBLOCK(1)=IWLIST
  63.         CALL WMPGWS(IBLOCK)
  64.         CALL WMPOW(IBLOCK)      
  65.         RETURN
  66.       ENDIF
  67.       IF(IBUT.EQ.4.AND.IWIN.EQ.IWLIST.AND.ICON.GE.0)THEN
  68. C                close other 2 windows
  69.         CALL WMPCLW(IWNET)
  70.         CALL WMPCLW(IW3D)
  71. C                 select button pressed over an icon in the LIST window
  72.         CALL RDDAT(ICON,IERR)
  73.         IF(IERR.NE.0)RETURN
  74. C                  scale net vertices to window
  75.         CALL CENNET
  76. C                  scale 3D vertices to window
  77.         CALL CEN3D
  78. C                  open net window 
  79.         IBLOCK(1)=IWNET
  80.         CALL WMPGWS(IBLOCK)
  81.         CALL WMPOW(IBLOCK)        
  82. C                  open 3D window 
  83.         IBLOCK(1)=IW3D
  84.         CALL WMPGWS(IBLOCK)              
  85. C                   get window state and then open window
  86.         CALL WMPOW(IBLOCK)         
  87. C                   make this window the one in which the caret goes
  88.         CALL WMPSCP(IW3D,-1,100,-100,?I02000000,0)
  89.       ENDIF
  90.       IF(IBUT.EQ.2)THEN
  91.         IF(IWIN.EQ.IW3D)CALL WMPCM(MBLK3D,IBLOCK(1),IBLOCK(2))
  92. C             save window handle
  93.         MENWIN=IWIN
  94. C                       open menu at mouse position
  95.         IF(IWIN.EQ.IWNET)CALL WMPCM(MBLKNT,IBLOCK(1),IBLOCK(2))        
  96.         IF(IWIN.EQ.IWLIST)CALL WMPCM(MBLK1,IBLOCK(1),IBLOCK(2)) 
  97.       ELSE
  98. C                     set caret into window with input focus
  99.         IF(IWIN.EQ.IW3D)CALL WMPSCP(IW3D,-1,100,-100,?I02000000,0)
  100.       ENDIF
  101.       RETURN
  102.       END
  103.       SUBROUTINE CENNET
  104. C               IS=2   similarly but for CENTRE OF NET
  105.       INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
  106.       INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
  107.       XMIN= 99999.
  108.       XMAX=-99999.
  109.       YMIN= 99999.
  110.       YMAX=-99999.
  111.       ZMIN= 99999.
  112.       ZMAX=-99999.
  113. C                      net use planar vertices
  114.       IN=1
  115.       ND=NNET
  116.       IF(NNET.LE.0)THEN
  117. C          WRITE(*,*)' Sorry, no net vertices'
  118. C          READ(*,*)KMC
  119.         RETURN
  120.       ENDIF 
  121. C        SCLWIN=MIN(IWIDNT,IHINT)         
  122. C        D=1./NNET
  123.       DO 10 I=IN,ND
  124.       XMIN=MIN(XMIN,X(I))
  125.       XMAX=MAX(XMAX,X(I))
  126.       YMIN=MIN(YMIN,Y(I))
  127.       YMAX=MAX(YMAX,Y(I))
  128.       ZMIN=MIN(ZMIN,Z(I))
  129.       ZMAX=MAX(ZMAX,Z(I))      
  130.    10 CONTINUE        
  131.       XORG=(XMIN+XMAX)*0.5
  132.       YORG=(YMIN+YMAX)*0.5
  133.       ZORG=(ZMIN+ZMAX)*0.5
  134. C                net here, turn round to fit window
  135.       XSIZE=XMAX-XMIN
  136.       YSIZE=YMAX-YMIN
  137.       IF(XSIZE.GT.YSIZE)THEN        
  138.         SCLNET=MIN(FLOAT(IHINT),XSIZE*IWIDNT/YSIZE)
  139.         SCLWIN=1./XSIZE
  140.         DO 30 I=IN,ND           
  141.          YY=SCLWIN*(X(I)-XORG)
  142.          X(I)=SCLWIN*(YORG-Y(I))
  143.          Y(I)=YY
  144.    30   CONTINUE
  145.       ELSE 
  146.         SCLNET=MIN(YSIZE*IWIDNT/XSIZE,FLOAT(IHINT))
  147.         SCLWIN=1./YSIZE
  148.         DO 40 I=IN,ND
  149.          X(I)=SCLWIN*(X(I)-XORG)
  150.          Y(I)=SCLWIN*(Y(I)-YORG)
  151.    40   CONTINUE
  152.       ENDIF
  153. C                set scale to default
  154.       SCLNET=0.8*SCLNET
  155.       RETURN
  156.       END
  157.       SUBROUTINE CEN3D
  158. C               IS=1   finds centre of SOLID and translates to it and scales
  159.       INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
  160.       INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
  161.       RSQMAX=0.
  162. C                  square of the radius of circumscribing sphere
  163.       IF(NVTOT.LE.NNET) RETURN
  164. C                      solid use 3D vertices
  165.       IN=1+NNET
  166.       ND=NVTOT
  167. C                 denominator when finding origin of plot
  168.       D=1./(NVTOT-NNET)
  169.       XORG=0.
  170.       YORG=0.
  171.       ZORG=0.
  172.       DO 10 I=IN,ND
  173.       XORG=XORG+X(I)
  174.       YORG=YORG+Y(I)
  175.       ZORG=ZORG+Z(I)
  176.    10 CONTINUE        
  177. C      SIZE=MAX(XMAX-XMIN,YMAX-YMIN,ZMAX-ZMIN)
  178. C      SCLWIN=1./SIZE
  179.       XORG=XORG*D
  180.       YORG=YORG*D
  181.       ZORG=ZORG*D
  182.       DO 16 I=IN,ND
  183.       RSQ=(X(I)-XORG)**2 +(Y(I)-YORG)**2+(Z(I)-ZORG)**2
  184.       RSQMAX=MAX(RSQMAX,RSQ)
  185.    16 CONTINUE
  186.       SCLWIN=0.5/SQRT(RSQMAX)
  187. C                         TRANSLATE 3D TO origin and scale to window size
  188. C                          -0.5 < all co-ords < 0.5
  189.       DO 20 I=IN,ND
  190.       X(I)=SCLWIN*(X(I)-XORG)
  191.       Y(I)=SCLWIN*(Y(I)-YORG)
  192.       Z(I)=SCLWIN*(Z(I)-ZORG)
  193.    20 CONTINUE
  194. C                   set scale to default
  195.       SCL3D=0.8*MIN(IWID3D,IHI3D)
  196.       RETURN
  197.       END
  198.       SUBROUTINE CRLIST
  199. C                  makes window for names of stored polyhedra
  200. C                  common for solids MAXW= max length of a name
  201.       INCLUDE '<WimpPoly$Dir>.f77.WPolyCH'
  202.       INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
  203. C
  204.       CHARACTER TITLE*10,ITITL*6,DUMMY*1
  205.       DATA TITLE /'Polyhedra.'/,ITITL/'Icon1.'/
  206. C       x,y,width,depth,extx,exty,title,flags
  207. C       extx & exty are total size 
  208.       IW=16*MAXW
  209.       IWLIST=IWMPCW(200,700,IW,500,IW,64*NS+64,TITLE,?IFF00001F)
  210. C                Create Icons only one selectable (group name 1)
  211.       DO 10 I=1,NS
  212. C                find last non-blank character in the name
  213.       NX=LNBLNK(SOLIDS(I))
  214.       IF(SOLIDS(I)(1:1).EQ.' ')THEN
  215. C                    title not a name of solid, cannot be selected
  216.         ICONH=IWMPCI(IWLIST,16,-64*I,NX*16,48,?I1B000431,
  217.      +        SOLIDS(I)(6:NX+1),DUMMY)
  218. C                         use different colour text red
  219.       ELSE
  220.         IF(SOLIDS(I)(1:1).EQ.'-')THEN
  221. C             title is an alternate name use different colour text
  222.          ICONH=IWMPCI(IWLIST,16,-64*I,NX*16,48,?I1A000431,
  223.      1   SOLIDS(I)(6:NX+1),DUMMY)
  224.         ELSE
  225. C             title is an alternate name use different colour text
  226.          ICONH=IWMPCI(IWLIST,16,-64*I,NX*16,48,?I0801B431,
  227.      1   SOLIDS(I)(6:NX+1),DUMMY)
  228.         ENDIF
  229.       ENDIF
  230.    10 CONTINUE
  231.       RETURN
  232.       END
  233.       SUBROUTINE DR3D(ARRAY,MAXPR,NPTS,L1,L2,L3,L4,IER)
  234. C User routine called by DRPOL, sets up co-ordinate pairs for lines into 
  235. C ARRAY.assume units mm  MAXPR max no of Pairs, NPTS returned   
  236. C     plots the polyhedra as 3D solid (ISTK3D=0)
  237.       INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
  238.       INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
  239.       INCLUDE '<WimpPoly$Dir>.f77.WPOLYCH'               
  240.       DIMENSION SL(3)
  241. C                SL = light source         
  242.       DIMENSION ARRAY(2,MAXPR)                           
  243. C               0.3*Sqrt(2) so range of dotproducts -0.6 to 1 in shading
  244.       DATA SL/2*0.6,0.52915/
  245. C               light at top right slightly in front
  246.       IER=0
  247.       IF(NPTS.EQ.0)THEN
  248. C                     1st call NPTS =0
  249.         A=SL(1)*SQRT(2.)
  250. C                    coefficients for colour of filled solid
  251.         B=255./(1.+A)
  252.         I=0
  253.       ENDIF
  254. C         check there are vertices for 3D window
  255.       IF(NVTOT.LE.NNET) THEN
  256.         IER=99
  257. C                     no 3D vertices
  258.         RETURN
  259.       ENDIF
  260. C           centres and normals to all faces calculated by PLT3D already
  261. C                     ready to start plotting
  262.       I=I+1
  263.       IF(I.GT.NFPLOT)THEN
  264. C                      all faces plotted, end object
  265.         NPTS=-1
  266.         RETURN
  267.       ENDIF
  268.     8 NF=INDX(I) 
  269. C                NF= face to plot
  270.       NV=NVTX(NF) 
  271.       IF(NV.GE.MAXPR)THEN
  272.         IER=99
  273.         RETURN
  274.       ENDIF      
  275. C      CALL VDU(4)
  276. C      CALL VDU(26)  
  277.       DO 10 N=1,NV
  278.       ARRAY(1,N)=(X(IVTX(N,NF))+0.5)*130.
  279. C       scale the vertex to the screen A5 size mm translate to centre
  280. C             should be 138. but want to try it a bit smaller
  281.       ARRAY(2,N)=(Y(IVTX(N,NF))+0.5)*130. + 60.
  282. C      CALL TAB((N-1)*16,NF)
  283. C      PRINT 101,ARRAY(1,N),ARRAY(2,N)
  284. C  101 FORMAT($,2F8.1)
  285.    10 CONTINUE       
  286. C      CALL VDU(5)
  287.       ARRAY(1,NV+1)=ARRAY(1,1)
  288. C                close the polygon
  289.       ARRAY(2,NV+1)=ARRAY(2,1)
  290.       NPTS=NV+1
  291. C                decide on colour
  292.       IF(ISTK3D.EQ.0) THEN
  293. C                       filled face
  294.         COSANG=SL(1)*DCFACE(1,NF)+SL(2)*DCFACE(2,NF)+
  295.      1         SL(3)*DCFACE(3,NF)
  296. C       KOL=(0.9718+COSANG)*8.114*0.5
  297.         KOL=(COSANG+A)*B
  298. C                  colour of filled face a shade of grey
  299.         L1=ISHFT(KOL,8)+ISHFT(KOL,16)+ISHFT(KOL,24)
  300.       ELSE
  301.         IF(ISTK3D.EQ.1)THEN
  302. C                    now draw outline 2nd word is colour
  303.           IF(DCFACE(3,NF).GT.0.0) THEN
  304. C                 front of solid blue
  305.            L2=?IFF000000
  306.           ELSE
  307. C                    back of solid medium grey
  308.             L2=?IC0C0C000
  309.           ENDIF 
  310.         ELSE
  311. C              must be colour option =2 set colour dependent on # vertices  
  312.           KOL=5+NV
  313.           IF(KOL.GT.15)KOL=15
  314.           L1=KLRS(KOL)
  315.           LOL=0
  316.           IF(KOL.EQ.9.or.kol.eq.12.or.KOL.EQ.14)LOL=7
  317.           L2=KLRS(LOL)
  318.         ENDIF 
  319.       ENDIF
  320.       RETURN
  321.       END           
  322.       FUNCTION KLRS(K)
  323. C              given a colour number K, assumed to be a wimp 16 colour
  324. C     returns the word L2 for DRAW colours set up as ?IBBGGRR00
  325.       DIMENSION KOLSDR(0:15)
  326.       DATA KOLSDR/?IFFFFFF00,?IDDDDDD00,?IBBBBBB00,?I09090900,
  327.      1            ?I07070700,?I05050500,?I03030300,?I00000000,
  328.      2            ?IFF000000,?I00FFFF00,?I00FF0000,?I0000FF00,
  329.      3            ?I99FFFF00,?I05FF0500,?I0008FF00,?IFFFF0000/ 
  330. C                    white     greys   to black at 7
  331. C                    blue      yellow      green     red
  332. C                   cream   army green   orange     cyan
  333.       IF(K.GT.15)K=15
  334.       IF(K.LT.0)K=0
  335.       KLRS=KOLSDR(K)
  336.       RETURN 
  337.       END
  338.       SUBROUTINE DRCHAR(CHARAY,MAXCHR,NCHARS,L1,L2,L3,L4,XL,YL,IER)
  339. C         adds user text to the picture
  340. C L1,L2 are colours of text, L3 font number, L4 point size (same for x and y)
  341. C XL,YL lower left corner of text in the picture, IER =error return
  342.       CHARACTER *(*) CHARAY
  343.       INCLUDE '<WimpPoly$Dir>.f77.WPOLYCH'               
  344.       IER=0
  345.       IF(NCHARS.EQ.0)INIT=-1
  346. C                     1st call NCHARS =0
  347.       INIT=INIT+1
  348.       IF(INIT-1)2,10,20
  349.     2 NCHARS=INDEX(TITL3D,CHAR(0))-1
  350.       CHARAY(1:NCHARS)=TITL3D(1:NCHARS)
  351.       XL=1.
  352.       YL= 200.
  353.       L4=12
  354. C                  need smaller characters if longer names
  355.       IF(NCHARS.GT.32)L4=10
  356.       IF(NCHARS.GT.40)L4=8
  357.       RETURN          
  358.    10 NCHARS=LNBLNK(DUAL)
  359.       CHARAY(1:NCHARS+6)='Dual: '//DUAL(1:NCHARS)
  360.       NCHARS=NCHARS+6
  361.       XL=1.
  362.       YL=55.
  363.       L4=8
  364.       RETURN
  365.    20 NCHARS=-1
  366.       RETURN
  367.       END
  368.       SUBROUTINE DRNT(ARRAY,MAXPR,NPTS,L1,L2,L3,L4,IER)
  369. C User routine called from DRPOL, sets up co-ordinate pairs for lines into
  370. C ARRAY. assume units mm  MAXPR max no of Pairs, NPTS returned   
  371. C     plots the net as filled face solid (ISTKNT=0) or wire (ISTKNT=1 )
  372.       INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
  373.       INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
  374.       INCLUDE '<WimpPoly$Dir>.f77.WPOLYCH'               
  375.       DIMENSION ARRAY(2,MAXPR)
  376. C                 1st call NPTS =0
  377.       IF(NPTS.EQ.0)THEN
  378. C            INET = flag 0 while drawing faces, 1 when drawing hinges
  379.         INET=0         
  380.         I=0
  381. C             TEST IF ANy NET
  382.         IF(NNET.EQ.0)THEN
  383.           CALL MOVE(LX0+64,LY0-64)
  384.           WRITE(*,*)' Sorry, no net vertices'
  385.           NPTS=-1
  386.           RETURN
  387.         ENDIF
  388.       ENDIF
  389.    40 I=I+1         
  390.       IF(INET.EQ.1)GOTO60
  391.       IF(I.LE.NFACES)THEN
  392. C                NF= face to plot
  393.         NV=NETVX(I)
  394.         DO 50 N=1,NV
  395.         ARRAY(1,N)=(X(NETNV(N,I))+0.5)*138.
  396. C      scale the vertex to the screen A5 size mm translate to centre
  397.         ARRAY(2,N)=(Y(NETNV(N,I))+0.5)*138. +60.
  398.    50   CONTINUE
  399.         ARRAY(1,NV+1)=ARRAY(1,1)
  400. C                close the polygon
  401.         ARRAY(2,NV+1)=ARRAY(2,1)
  402.         NPTS=NV+1
  403. C                decide on colour
  404.         IF(ISTKNT.EQ.0)THEN
  405. C                  filled net
  406.           L1=?I00FF0000
  407.           L2=-1
  408. C                set foreground colour to green to draw polygons
  409.         ELSE
  410. C                  outline faces in black
  411.           L1=-1
  412.           L2=0
  413.         ENDIF
  414.         RETURN
  415.       ELSE
  416. C                    set flag faces all plotted
  417.         INET=1
  418.         I=1
  419.       ENDIF
  420. C                         now plot the hinges 
  421.    60 IF(I.LE.NHINGS)THEN
  422.         J=IHING(I,1) 
  423. C                   J = face K=side of the face in the net
  424.         K=IHING(I,2)                             
  425.         L=NETVX(J) 
  426. C                   L=no of vertices that face need ones for kth side
  427.         M1=NETNV(K,J)          
  428.         KK=K+1
  429.         IF(KK.GT.L)KK=1
  430.         M2=NETNV(KK,J)
  431.         ARRAY(1,1)=(X(M1)+0.5)*138.
  432.         ARRAY(1,2)=(X(M2)+0.5)*138.
  433.         ARRAY(2,1)=(Y(M1)+0.5)*138.+60.
  434.         ARRAY(2,2)=(Y(M2)+0.5)*138.+60.
  435.         L1=-1
  436.         IF(HINANG(I).GT.0.AND.HINANG(I).LT.3.142)THEN
  437. C            plot black dotted lines when hinge angle < PI
  438.           L4=3
  439. C             if stick plot have white lines 
  440.           IF(ISTKNT.EQ.0)THEN
  441.             L2=0
  442.           ELSE
  443.             L2=?IFFFFFF00
  444.           ENDIF
  445.         ELSE
  446.           L2=?IA0A0A000
  447. C               mid grey solid lines unless plot is filled
  448.           IF(ISTKNT.EQ.0)L2=0
  449.           L4=0
  450.         ENDIF
  451. C             in both case plot one line, 2 points
  452.         NPTS=2
  453.       ELSE
  454. C                    end of plotting
  455.         NPTS=-1
  456.       ENDIF
  457.       RETURN
  458.       END
  459.       SUBROUTINE DRPOL(ARRAY,MAXPR,NPTS,L1,L2,L3,L4,IER)
  460. C        User routine sets up co-ordinate pairs for lines into ARRAY
  461. C               assume units mm  MAXPR max no of Pairs, NPTS returned   
  462. C     plots the polyhedra as 3D solid (ISTK3D=0) or wire (ISTK3D=1 )
  463.       INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
  464.       INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
  465.       INCLUDE '<WimpPoly$Dir>.f77.WPOLYCH'               
  466.       DIMENSION ARRAY(2,MAXPR)
  467.       IER=0
  468.       IF(MENWIN.EQ.IW3D)THEN
  469. C              make a Drawfile for the 3D solid
  470.         CALL DR3D(ARRAY,MAXPR,NPTS,L1,L2,L3,L4,IER)
  471.       ELSE
  472. C               make a Drawfile for the net
  473.          CALL DRNT(ARRAY,MAXPR,NPTS,L1,L2,L3,L4,IER)
  474.       ENDIF
  475.       RETURN
  476.       END        
  477.       SUBROUTINE FACENT
  478. C             finds the Z of centres of the surfaces and normals to them
  479.       INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
  480.       REAL V1(3),V2(3),V3(3),XYZ(MAXVTX,3)
  481.       EQUIVALENCE(X(1),XYZ(1,1))
  482. C                       V1,V2 are 2 adjacent edges of the face
  483.       DO 60 I=1,NFACES
  484.       ZC=0.
  485.       DO 10 J=1,NVTX(I)
  486.       ZC=ZC+Z(IVTX(J,I))
  487.    10 CONTINUE 
  488. C                    store centre of face
  489.       ZFACE(I)=ZC/NVTX(I)
  490.       DO 20 J=1,3
  491.       V1(J)=XYZ(IVTX(2,I),J)-XYZ(IVTX(1,I),J)
  492.    20 V2(J)=XYZ(IVTX(3,I),J)-XYZ(IVTX(2,I),J)
  493. C                    cross product
  494.       DO 30 J=1,3
  495.       K=MOD(J,3)+1
  496.       L=6-J-K
  497.    30 V3(J)=V1(K)*V2(L)-V1(L)*V2(K)
  498.       W=SQRT(V3(1)*V3(1)+V3(2)*V3(2)+V3(3)*V3(3))
  499.       DO 40 J=1,3
  500. C                  store normalised direction cosines for normal face
  501.    40 DCFACE(J,I)=V3(J)/W
  502.    60 CONTINUE            
  503.       RETURN
  504.       END
  505.       SUBROUTINE FINDHD(INDAT,ITYPE,IERR)
  506. C                 reads file INDAT until it finds a line beginning with :
  507. C                  checks the rest of line and sets up ITYPE
  508.       PARAMETER (NHEADS=14)
  509.       CHARACTER *80 KARD            
  510.       COMMON/WORK/KARD                  
  511.       CHARACTER *9 TYPES(NHEADS),THIS
  512.       DATA TYPES/'name','number','symbol','dual','sfaces','svertices',
  513.      1            'net','solid','hinges','dih','vertices','EOF',
  514.      2      'netformul','comment  '/
  515.       IERR=0
  516.    10 READ(INDAT,101,END=90,ERR=98)KARD
  517.   101 FORMAT(A)
  518.       IF(KARD(1:1).NE.':') GOTO10
  519. C                         find what kind of header
  520.       THIS=KARD(2:10)            
  521.       ITYPE=0
  522.       DO 20 I=1,NHEADS 
  523.       IF(THIS.EQ.TYPES(I))ITYPE=I
  524.    20 CONTINUE
  525.       IF(ITYPE.GT.0)RETURN
  526.       CALL WMPRE(3,'Unknown header '//THIS,3,'WimpPoly',IERR)
  527. C              user has selected 'Cancel' when Ierr=2, OK when =1
  528.       IF(IERR.EQ.2)CALL QUIT
  529. C      WRITE(*,*)' error found a header line ',THIS
  530. C      WRITE(*,*)' but only known types are ',(TYPES(I),I=1,NHEADS)
  531. C      READ(*,*)KMC
  532.       IERR=1
  533.       RETURN
  534. C                   found the end of file
  535. C   90 IERR=-1
  536. C      WRITE(*,*)' Found the End of File'
  537.    90 CALL WMPRE(3,'END of Datafile, OK to try another',3,
  538.      1'WimpPoly',IERR)
  539. C              user has selected 'Cancel' when Ierr=2, OK when =1
  540.       IF(IERR.EQ.2)CALL QUIT
  541.    98 IERR=-1
  542.       RETURN
  543.       END                                                     
  544.       SUBROUTINE INIT
  545. C                      initialises all windows
  546. C                  common for solids, WIMP and Pictures
  547.       INCLUDE '<WimpPoly$Dir>.f77.WPolyCH'
  548.       INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'               
  549.       INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
  550.       PARAMETER(MAXL=100)
  551.       DIMENSION INFICN(MAXL),JWIN(MAXVTX)
  552.       EQUIVALENCE (X(1),JWIN(1))
  553.       CHARACTER*12 TTEM
  554. C
  555. C                   read the names of the NS files containing data
  556.       CALL RDLIST(NS)                       
  557. C                CREATE WINDOW for names of polyhedra
  558.       CALL CRLIST 
  559. C                  read the text of the HELP window
  560.       CALL RDHELP
  561. C                Create menu for first window
  562.       TITLM1='Poly'
  563.       LIST1(1)='Info'
  564.       LIST1(2)='Help'
  565.       LIST1(3)='Quit'
  566.       CALL WMPMNU(MBLK1,TITLM1,LIST1,NMENU1)
  567. C                open template file of windows
  568.       CALL WMPOT('<WimpPoly$Dir>.Templates')
  569. C                load templates
  570. C                Read Intro window
  571.       L=MAXL
  572.       IP=0
  573.       TTEM='Intro'//CHAR(0)
  574.       CALL WMPLT(JWIN,INFICN(1),L,-1,TTEM,IP)
  575. C                Create Intro window 
  576.       CALL WMPCRW(JWIN,IWINTR)
  577. C                Read info window
  578.       L1=MAXL-L
  579.       IP=0
  580.       TTEM='Info'//CHAR(0)
  581.       CALL WMPLT(JWIN,INFICN(L1+1),L,-1,TTEM,IP)
  582. C                 add in Version number
  583.       JWIN(60)=LOCC(VERS)
  584. C                create info window and link to menu
  585.       CALL WMPCRW(JWIN,MBLK1(9))
  586. C                Read Help window
  587.       L1=MAXL-L
  588.       IP=0
  589.       TTEM='help'//CHAR(0)
  590.       CALL WMPLT(JWIN,INFICN(L1+1),L,-1,TTEM,IP)
  591. C                Create Help window
  592.       CALL WMPCRW(JWIN,IWHELP)
  593. C                close template file
  594.       CALL WMPCT
  595. C                Create window for drawing the net
  596. C               
  597.       TITLNT='Net.'                          
  598.       IWIDNT=360
  599.       IHINT=550
  600. C       x,y,width,depth,extx,exty,title,flags, extx & exty are total size
  601.       IWNET=IWMPCW(0,1020,IWIDNT,IHINT,IWIDNT,IHINT,TITLNT,?IFF00000F)
  602. C                Create window for drawing the solid
  603. C      TITL3D='Solid.' this one set in RDDAT
  604.       IWID3D=800
  605.       IHI3D=864
  606.       IW3D=IWMPCW(480,1020,IWID3D,IHI3D,IWID3D,IHI3D,TITL3D,?IFF00000F)
  607. C             create a menu for the 3D window
  608.       TITLM3='3D menu'
  609.       LIST3D(1)='wire'
  610.       LIST3D(2)='solid'
  611.       LIST3D(3)='colour'
  612.       LIST3D(4)='Save'
  613.       CALL WMPMNU(MBLK3D,TITLM3,LIST3D,NMENU3) 
  614. C             create a menu for the net window
  615.       TITLMN='net menu'
  616.       LISTNT(1)='wire'
  617.       LISTNT(2)='solid'
  618.       LISTNT(3)='Save'
  619.       CALL WMPMNU(MBLKNT,TITLMN,LISTNT,NMENUN) 
  620. C                   set up drag box window with Drawfile type
  621.       CALL SAVEMN(?I0AFF,IWSAVE)
  622. C                  connect to 3D menu as 4th item
  623.       MBLK3D(9+6*3)=IWSAVE                  
  624. C                   connect to net window as 3rd item
  625.       MBLKNT(9+6*2)=IWSAVE
  626. C               read datafile on UNIT 10
  627.       INDAT=10
  628. C                         initial rotations
  629.       ROTX=0.
  630.       ROTY=0.
  631.       ROTZ=0.
  632. C                         screen origin for plot
  633.       IX0=600
  634.       IY0=600
  635. C                        OPEN Intro window
  636.       IBLOCK(1)=IWINTR
  637.       CALL WMPGWS(IBLOCK)
  638.       CALL WMPOW(IBLOCK)      
  639.       RETURN
  640.       END
  641.       SUBROUTINE INTRO(LX0,LY0)
  642. C                displays Introduction window
  643.       INCLUDE'<WimpPoly$Dir>.f77.WPOLYCH'
  644.       INCLUDE'<WimpPoly$Dir>.f77.WPOLYPIC'
  645.       INCLUDE'<WimpPoly$Dir>.f77.WPOLYWimp'
  646. C                  set colour of text 
  647.       CALL WMPSC(0,7,0)                        
  648. C                   title bigger letters
  649.       CALL WOGBIG(LX0+340,LY0-200,'WimpPoly',3) 
  650.       CALL WMPTXT(LX0+440,LY0-232,'K.M.Crennell')
  651.       CALL WMPTXT(LX0+496,LY0-280,'1991')
  652.       CALL WMPTXT(LX0+200,LY0-400,
  653.      1             'Draws polyhedra as a 3D solid or planar net')
  654.       CALL WMPTXT(LX0+200,LY0-460,
  655.      1             'from data files mostly obtained from "netlib"')
  656.       CALL WMPTXT(LX0+200,LY0-520,
  657.      1             'on the Joint Academic Network (JANET).')
  658.       CALL WMPTXT(LX0+200,LY0-620,
  659.      1             'It uses the "Fortran Friends" PD_F77 library.')
  660.       CALL WMPSC(0,11,0)
  661. C                     change last message to red    
  662.       CALL WMPTXT(LX0+180,LY0-700,
  663.      1       'Click any mouse button over this window to start')
  664. C                  draw the net, hope no errors
  665.       CALL RDDAT(2,IER)
  666. C                  scale net vertices to window
  667.       CALL CENNET
  668. C                  scale 3D vertices to window
  669.       CALL CEN3D
  670.       SCLNET=SCLNET*0.8 
  671.       CALL PLTNET(LX0-IWIDNT/2+160,LY0+IHINT/2-200)
  672.       SCL3D=SCL3D*0.4
  673.       CALL PLT3D(LX0-IWID3D/2+900,LY0+IHI3D/2-200)
  674.       RETURN
  675.       END 
  676.       SUBROUTINE KEYS
  677. C             handles keyboard input
  678.       INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
  679.       EQUIVALENCE(IBLOCK(7),KODE),(IBLOCK(1),IWIND)
  680. C                     KODE is ASCII of  key pressed
  681.       IF(KODE.EQ.60.OR.KODE.EQ.44.OR.KODE.EQ.62.OR.KODE.EQ.46)THEN
  682. C                       Scale the solid for <, or >.
  683.         CALL SCAL3D(KODE)
  684.       ELSE   
  685.         IF(KODE.GE.396.AND.KODE.LE.399)THEN
  686. C                        rotate with cursor keys              
  687.           CALL ROTPOL(KODE)    
  688.         ELSE
  689. C                   hand back key to Wimp
  690.           CALL WMPPK(KODE) 
  691.         ENDIF
  692.       ENDIF
  693.       RETURN
  694.       END
  695.       SUBROUTINE MENU
  696. C      called when a mouse button has been clicked over a menu in a window
  697.       INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
  698.       INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
  699.       DIMENSION MYB(5)
  700.       CHARACTER *20  FILNAM
  701.       DATA FILNAM/'<WimpPoly$Dir>.Polly'/
  702.       IF(MENWIN.EQ.IW3D)THEN
  703. C   menu options for 3D window 1= 'wire' 2 = 'solid'  3 = 'colour'
  704.         IF(IBLOCK(1).EQ.0)THEN
  705.           ISTK3D=1 
  706.         ELSE
  707.           IF(IBLOCK(1).EQ.1)THEN
  708.             ISTK3D=0
  709.           ELSE
  710.             ISTK3D=2           
  711.           ENDIF
  712.         ENDIF
  713.         CALL WMPFR(IW3D,0,-IHI3D+64,IWID3D,0)
  714. C                   restore menu if 'Adjust' button pressed
  715.         CALL WMPGPI(MYB)
  716.         IF(MYB(3).EQ.1) CALL WMPCM(MBLK3D,MYB(1),MYB(2))
  717.       ENDIF
  718.       IF(MENWIN.EQ.IWLIST)THEN
  719. C                    click over 1st window
  720.         IF(IBLOCK(1).EQ.2)CALL QUIT
  721. C                    display INFO done by Wimp with arrow =0
  722. C                    open HELP window
  723.         IF(IBLOCK(1).EQ.1)THEN
  724.           IBLOCK(1)=IWHELP
  725.           CALL WMPGWS(IBLOCK)
  726. C                              open Help window
  727.           CALL WMPOW(IBLOCK)
  728.         ENDIF
  729.       ENDIF        
  730.       IF(MENWIN.EQ.IWNET)THEN
  731. C                   click over Net window
  732. C                1st menu option for net window is 'wire' 2nd is 'solid'
  733.         IF(IBLOCK(1).EQ.0)THEN
  734.           ISTKNT=1 
  735.         ELSE
  736.           IF(IBLOCK(1).EQ.1)THEN
  737.             ISTKNT=0
  738. C          ELSE   thes done in SAVEFL now ****************
  739. C            CALL DRFILE('A5P',FILNAM,IER)
  740.           ENDIF
  741.         ENDIF
  742.         CALL WMPFR(IWNET,0,-IHINT,IWIDNT,0)
  743. C                   restore menu if 'Adjust' button pressed
  744.         CALL WMPGPI(MYB)
  745.         IF(MYB(3).EQ.1) CALL WMPCM(MBLKNT,MYB(1),MYB(2))
  746.       ENDIF
  747.       RETURN
  748.       END
  749.       SUBROUTINE PLTNET(LX0,LY0)
  750. C                   LX0,LY0 top left corner of window
  751.       INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
  752.       INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
  753.       INCLUDE '<WimpPoly$Dir>.f77.WPOLYCH'               
  754.       DIMENSION IX(MXVTF+1),IY(MXVTF+1)
  755. C             TEST IF ANy NET
  756.       CALL WMPSC(0,13,0)
  757. C                set foreground colour to green to draw polygons
  758.       IF(NNET.EQ.0)THEN
  759.          CALL MOVE(LX0+64,LY0-64)
  760.          WRITE(*,*)' Sorry, no net vertices'
  761.          RETURN
  762.       ENDIF
  763. C                    move origin to middle of window
  764.       CALL ORIGIN(LX0+IWIDNT/2,LY0-IHINT/2)
  765. C      CALL GCOL(0,15) 
  766.       DO 40 I=1,NFACES
  767. C                NF= face to plot
  768.       NV=NETVX(I)
  769.       DO 10 N=1,NV
  770.       IX(N)=X(NETNV(N,I))*SCLNET
  771. C                   scale the vertex to the screen
  772.       IY(N)=Y(NETNV(N,I))*SCLNET
  773.    10 CONTINUE
  774.       IX(NV+1)=IX(1)
  775.       IY(NV+1)=IY(1)
  776. C                close the polygon and draw filled  depending on ISTKNT
  777.       IF(ISTKNT.EQ.0)THEN
  778.         CALL POLY(NV+1,IX,IY,.TRUE.)
  779.       ELSE
  780.         CALL POLY(NV+1,IX,IY,.FALSE.)
  781.       ENDIF
  782.    40 CONTINUE
  783. C                         now plot the hinges dotted overwrite in black
  784.       CALL WMPSC(0,0,0)
  785.       DO 60 I=1,NHINGS
  786.       J=IHING(I,1) 
  787. C              J = face K=side of the face in the net
  788.       K=IHING(I,2)                             
  789.       L=NETVX(J) 
  790. C              L=no of vertices that face need ones for kth side
  791.       M1=NETNV(K,J)          
  792.       KK=K+1
  793.       IF(KK.GT.L)KK=1
  794.       M2=NETNV(KK,J)
  795.       IX(1)=X(M1)*SCLNET
  796.       IX(2)=X(M2)*SCLNET
  797.       IY(1)=Y(M1)*SCLNET
  798.       IY(2)=Y(M2)*SCLNET
  799.       CALL MOVE(IX(1),IY(1))
  800.       IF(HINANG(I).GT.0.AND.HINANG(I).LT.3.142)THEN
  801. C            plot dotted lines when hinge angle < PI
  802.          CALL PLOT(21,IX(2),IY(2))
  803.       ELSE
  804.          CALL PLOT(5,IX(2),IY(2))
  805.       ENDIF
  806.    60 CONTINUE 
  807.       CALL ORIGIN(0,0)
  808.       RETURN
  809.       END
  810.       SUBROUTINE PLT3D(LX0,LY0)
  811. C                            plots the polyhedra as 3D solid     
  812.       INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
  813.       INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
  814.       INCLUDE '<WimpPoly$Dir>.f77.WPOLYCH'               
  815.       DIMENSION SL(3)
  816. C                SL = light source         
  817.       DIMENSION IX(MXVTF+1),IY(MXVTF+1)
  818. C               0.3*Sqrt(2) so range of dotproducts -0.6 to 1 in shading
  819.       DATA SL/2*0.6,0.52915/
  820. C               light at top right slightly in front
  821. C         check there are vertices
  822.       IF(NVTOT.LE.NNET) THEN
  823.         CALL MOVE(LX0+16,LY0-64)
  824.         WRITE(*,*)'Sorry, no 3D vertices'
  825.         CALL WMPSC(0,11,0)
  826.         CALL MOVE (LX0+16,LY0-100)
  827.         WRITE(*,*)'Dual: ',DUAL
  828.         RETURN
  829.       ENDIF
  830. C                 set origin to centre
  831.       CALL ORIGIN(LX0+IWID3D/2,LY0-IHI3D/2)
  832. C                 find centres and normals to all faces
  833.       CALL FACENT
  834. C                 sort into Z order
  835.       CALL ZSORT 
  836. C                     ready to start plotting
  837. C      CALL GWIND(0,64,1280,1136)
  838. C      CALL CLG
  839. C                        clear graphics screen
  840. C      CALL ORIGIN(IX0,IY0)
  841.       DO 20 I=1,NFPLOT
  842.       NF=INDX(I) 
  843. C                NF= face to plot
  844.       NV=NVTX(NF)         
  845.       DO 10 N=1,NV
  846.       IX(N)=X(IVTX(N,NF))*SCL3D
  847. C                   scale the vertex to the screen
  848.       IY(N)=Y(IVTX(N,NF))*SCL3D
  849.    10 CONTINUE
  850.       IX(NV+1)=IX(1)
  851. C                close the polygon
  852.       IY(NV+1)=IY(1)
  853.       IF(ISTK3D.EQ.0) THEN
  854. C                                                  grey shaded solid
  855.         COSANG=SL(1)*DCFACE(1,NF)+SL(2)*DCFACE(2,NF)+SL(3)*DCFACE(3,NF)
  856.         KOL=(0.9718+COSANG)*8.114*0.5
  857.         CALL WMPSC(0,7-KOL,0)
  858.         CALL POLY(NV,IX,IY,.TRUE.)
  859.       ELSE
  860.         IF(ISTK3D.EQ.2)THEN
  861. C                                 colour faces according to number of sides
  862.           KOL=5+NV
  863.           IF(KOL.GT.15)KOL=15
  864.           CALL WMPSC(0,KOL,0)
  865.           CALL POLY(NV,IX,IY,.TRUE.)
  866.         ENDIF          
  867.       ENDIF
  868. C                    now draw outline
  869.       IF(ISTK3D.EQ.0.OR.ISTK3D.EQ.2.OR.DCFACE(3,NF).GT.0.0) THEN
  870.         IF(ISTK3D.NE.2)THEN
  871.           CALL WMPSC(0,8,0)
  872.         ELSE
  873. C                 for coloured ones
  874.           LOL=0
  875.           IF(KOL.EQ.9.or.kol.eq.12.or.KOL.EQ.14)LOL=7
  876.           CALL WMPSC(0,LOL,0)
  877.         ENDIF
  878.       ELSE
  879.         CALL WMPSC(0,2,0)
  880.       ENDIF
  881.       CALL POLY(NV+1,IX,IY,.FALSE.)
  882.    20 CONTINUE
  883.       IF(IBLOCK(1).EQ.IW3D.AND.DUAL.NE.' ')THEN
  884. C            only plot name when in the 3D window and Dual not blank
  885.         CALL WMPSC(0,11,0)
  886.         CALL MOVE (16-IWID3D/2,40-IHI3D/2)
  887.         WRITE(*,*)'Dual: ',DUAL
  888.       ENDIF
  889.    90 CALL ORIGIN(0,0)
  890. C                       restore origin of co-ordinates
  891.       RETURN
  892.       END
  893.       SUBROUTINE QUIT
  894.       CALL WMPCD
  895.       STOP
  896.       END
  897.       SUBROUTINE RDDAT(ICON,IERR)
  898. C                  read the data for the polyhedra file number ICON
  899.       INCLUDE '<WimpPoly$Dir>.f77.WPolyCH'
  900.       INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
  901.       INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
  902. C
  903. C                get polyhedron number from beginning of list
  904.       READ(SOLIDS(ICON+1),111)NPOLY
  905.   111 FORMAT(I3)
  906.       IF(NPOLY.LT.74)THEN
  907.          FNAME='<WimpPoly$Dir>.DAT1.P'//SOLIDS(ICON+1)(1:3)
  908.       ELSE
  909.         IF(NPOLY.LT.142)THEN
  910.           FNAME='<WimpPoly$Dir>.DAT2.P'//SOLIDS(ICON+1)(1:3)
  911.         ELSE 
  912.           FNAME='<WimpPoly$Dir>.DAT3.P'//SOLIDS(ICON+1)(1:3)
  913.         ENDIF
  914.       ENDIF                           
  915.       IERR=0
  916.       OPEN(UNIT=INDAT, FILE=FNAME,FORM='FORMATTED')
  917.       NAME=' '
  918.       DUAL=' '
  919.       NDIH=0
  920.       NFACES=0
  921.       NHING=0
  922.       NNET=0
  923.       NVTOT=0
  924. C                find the next header record
  925.    20 CALL FINDHD(INDAT,ITYPE,IERR)
  926.       IF(IERR.NE.0)GOTO80
  927. C                    error while reading
  928.       GOTO(21,22,20,24,20,20,27,28,29,30,31,100,20,20)ITYPE
  929. C                       name of poly
  930.    21 READ(INDAT,101)NAME
  931.   101 FORMAT(A)  
  932. C                 make window title
  933.       NX=LNBLNK(NAME)
  934.       TITL3D=NAME(1:NX)//CHAR(0)
  935.       TITLNT=SOLIDS(ICON+1)(1:4)//'Net'//CHAR(0)
  936.       GOTO20    
  937. C                      read number
  938.    22 READ(INDAT,101)NUMBER
  939.       GOTO20
  940. C              dual of poly
  941.    24 READ(INDAT,101)DUAL
  942.       GOTO20
  943. C                read the net
  944.    27 CALL RDFACE(INDAT,NETVX,NETNV)
  945.       GOTO20
  946. C              read solid line store vertex numbers each face
  947.    28 CALL RDFACE(INDAT,NVTX,IVTX)
  948.       GOTO 20
  949. C               read the hinges
  950.    29 CALL RDHING(INDAT)
  951.       GOTO20
  952. C                read the dihedral angles
  953.    30 READ(INDAT,*)NDIH
  954.       GOTO20
  955. C              read vertices line and store X,Y,Z
  956.    31 CALL RDVTX(INDAT,IERR) 
  957. C           this should be last header in the file but read for EOF anyway
  958.       IF(IERR)90,100,90
  959. C   80 WRITE(*,*)' enter 1 to try another file, -1 to stop'
  960.    80 CALL WMPRE(3,'Error in Datafile, OK to try another',3,
  961.      1'WimpPoly',IERR)
  962. C              user has selected 'Cancel' when Ierr=2, OK when =1
  963.       IF(IERR.EQ.2)CALL QUIT
  964.       RETURN
  965.    90 IERR=-1
  966.   100 CLOSE (INDAT)
  967.       RETURN 
  968.       END
  969.       SUBROUTINE RDFACE(INDAT,KVTX,IVBUF)
  970. C                   reads the lines following the headers :net and :solid
  971. C                   on unit INDAT KVTX= storage for no of vertices per face
  972. C                    IVBUF 
  973.       INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
  974.       DIMENSION IVBUF(MXVTF,MXFACE),KVTX(*) 
  975.       CHARACTER *80 KARD            
  976.       COMMON/WORK/KARD
  977.       READ(INDAT,*)NFACES, MAXVF
  978.       IF(NFACES.GT.MXFACE)THEN
  979.         CALL WMPRE(1,'Too many Faces',2,'WimpPoly',IERR)
  980. C        WRITE(*,*)' Nfaces=',NFACES,' Maxvf=',Maxvf
  981. C        WRITE(*,*)' but only ',MXFACE,' faces allowed'
  982. C        READ(*,*)KMC                             
  983. C        STOP 'too many faces'
  984.         CALL QUIT
  985.       ENDIF
  986.       DO 20 I=1,NFACES
  987. C                   read the vertex numbers associated with this face
  988.       READ(INDAT,*)N,(IVBUF(J,I),J=1,N)
  989.   110 FORMAT(A)                               
  990.       KVTX(I)=N            
  991. C                  vertex numbers in data start at zero
  992.       DO 10 J=1,N
  993.    10 IVBUF(J,I)=IVBUF(J,I)+1
  994.    20 CONTINUE                          
  995.       RETURN
  996.       END
  997.       SUBROUTINE RDHELP
  998. C         reads the help text to an array ready to display on the screen
  999.       INCLUDE '<WimpPoly$Dir>.f77.WPolyCH'
  1000.       CHARACTER *30 FLHLP
  1001.       DATA FLHLP/'<WimpPoly$Dir>.PolyHelp'/
  1002.       OPEN(22,FILE=FLHLP,STATUS='OLD',FORM='FORMATTED')
  1003. C              ignore 1st line, repeats the title
  1004.       I=1
  1005.       READ(22,101,END=80)HELPTX(1)
  1006.       DO 20 I=1,MAXHLP
  1007.       READ(22,101,END=80)HELPTX(I)
  1008.   101 FORMAT(A)
  1009.    20 CONTINUE
  1010.       CLOSE(22)
  1011.       RETURN   
  1012.    80 CLOSE(22)
  1013. C                       end of file before MAXHLP lines
  1014.       DO 30 J=I,MAXHLP
  1015.    30 HELPTX(J)=' '
  1016.       RETURN
  1017.       END
  1018.       SUBROUTINE RDHING(INDAT)
  1019. C                        read in the hinge data
  1020.       INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
  1021.       READ(INDAT,*)NHINGS
  1022.       IF(NHINGS.GT.MAXHIN)THEN
  1023.         CALL WMPRE(1,'Too many Hinges',2,'WimpPoly',IERR)
  1024.         CALL QUIT
  1025. C        WRITE(*,*)' too many hinges ',NHINGS,' no. allowed ',MAXHIN
  1026. C        STOP 'many hinges'
  1027.       ENDIF
  1028.       DO 20 I=1,NHINGS
  1029. C                   read the data for each hinge
  1030.       READ(INDAT,*)(IHING(I,J),J=1,4),HINANG(I)
  1031. C                   increment vertex nos by 1 to match the vertices
  1032.       DO 10 J=1,4
  1033.    10 IHING(I,J)=IHING(I,J)+1
  1034.    20 CONTINUE
  1035.       RETURN
  1036.       END                                      
  1037.       SUBROUTINE RDLIST(N)
  1038. C            reads the file of names of polyhedra into array SOLIDS
  1039. C             returns N the number of lines read
  1040.       CHARACTER * 80 BUFR
  1041.       INCLUDE '<WimpPoly$Dir>.f77.WPolyCH'
  1042.        CHARACTER *25 FSOLID
  1043.       DATA FSOLID/'<WimpPoly$Dir>.POLYLIST'/
  1044.       INT=2
  1045.       OPEN(INT,FILE=FSOLID,FORM='FORMATTED')
  1046.       N=1
  1047.    10 READ(INT,101,ERR=90,END=60)SOLIDS(N)
  1048.   101 FORMAT(A)                           
  1049.       IF(N.GE.MAXSOL)GOTO50
  1050.       N=N+1
  1051.       GOTO10 
  1052. C                 more entries than dimensions
  1053. C                 put in code for red triangle here
  1054.    50 CALL WMPRE(2,'Too many entries in list',3,'WimpPoly',IERR)
  1055. C              user has selected 'Cancel' when Ierr=2
  1056.       IF(IERR.EQ.2)CALL QUIT
  1057. C                 found the END of file
  1058.    60 N=N-1
  1059.       CLOSE(INT)
  1060.       RETURN
  1061.    90  WRITE(BUFR,102)N,SOLIDS(N)(1:20)
  1062.   102 FORMAT(' error while reading after ',I3,'records',
  1063.      1' last one was',A20)
  1064.       CALL WMPRE(1,BUFR,2,'WimpPoly',IERR)
  1065. C                 can only reply with IERR=2 for cancel
  1066.       CALL QUIT
  1067.       END
  1068.       SUBROUTINE RDVTX(INDAT,IERR)
  1069. C                  reads the vertices following the header line :vertices
  1070.       INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
  1071.       CHARACTER *80 BUFR
  1072. C                     Returns IERR=0 for good read, 1 or -1 otherwise
  1073.       IERR=0
  1074.       READ(INDAT,*)NVTOT,NNET
  1075.       IF(NVTOT.GE.MAXVTX)THEN
  1076.        WRITE(BUFR,102)MAXVTX,NVTOT
  1077.   102 FORMAT('too many vertices ',I3,'allowed,',I3,'read')
  1078.       CALL WMPRE(1,BUFR,2,'WimpPoly',IERR)
  1079. C                 can only reply with IERR=2 for cancel
  1080.       CALL QUIT
  1081.       ENDIF
  1082.       IF(NVTOT.EQ.NNET)THEN
  1083.         WRITE(*,*)' no co-ordinates for solid vertices'
  1084.       ENDIF
  1085. C                    now read the X,Y,Z for the solid
  1086.       DO 30 I=1,NVTOT
  1087.         READ(INDAT,*,END=90,ERR=80)X(I),Y(I),Z(I)
  1088.    30 CONTINUE                         
  1089.       RETURN
  1090.    80 WRITE(*,*)' Error reading vertex ',I
  1091.       IERR=-1
  1092.       RETURN  
  1093.    90 WRITE(*,*)' Unexpected EOF '
  1094.       IERR=1
  1095.       RETURN
  1096.       END
  1097.       SUBROUTINE REDRAW
  1098.       INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
  1099.       CALL WMPRW(IBLOCK,MORE)
  1100.       IF(MORE.EQ.0) RETURN
  1101. C                          set up top left corner of window to draw
  1102.    10 LX0=IBLOCK(2)-IBLOCK(6)
  1103.       LY0=IBLOCK(5)-IBLOCK(7)
  1104.       IF(IBLOCK(1).EQ.IWNET)CALL PLTNET(LX0,LY0)
  1105.       IF(IBLOCK(1).EQ.IW3D)CALL PLT3D(LX0,LY0)
  1106.       IF(IBLOCK(1).EQ.IWHELP)CALL SHOHLP(LX0,LY0)
  1107.       IF(IBLOCK(1).EQ.IWINTR)CALL INTRO(LX0,LY0)
  1108.       CALL WMPGR(IBLOCK,MORE)
  1109.       IF(MORE.NE.0) GO TO 10
  1110.       RETURN
  1111.       END
  1112.       SUBROUTINE ROTPOL(IANS)
  1113. C                  applies the rotation angles in X, Y, not Z
  1114. C                 IANS = which cursor key pressed
  1115. C               396=left arrow 397=right arrow 398=down 399 =up
  1116.       PARAMETER(DEGTOR=0.017453293)
  1117.       INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'            
  1118.       INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
  1119. C                  
  1120.       IF(IANS.LT.398)THEN
  1121. C                     rotations about Y
  1122.         ROTY=10.
  1123.         IF(IANS.EQ.397)ROTY=-10.
  1124.         CY=COS(DEGTOR*ROTY)
  1125.         SY=SIN(DEGTOR*ROTY)
  1126. C           if no 3D vertices, NNET = NVTOT
  1127.         DO 20 I=1+NNET, NVTOT
  1128.         Z2=Z(I)*CY+X(I)*SY
  1129.         X(I)=X(I)*CY-Z(I)*SY
  1130.         Z(I)=Z2
  1131.    20   CONTINUE
  1132.       ELSE
  1133. C                rotations about X
  1134.         ROTX=10.
  1135.         IF(IANS.EQ.399)ROTX=-10.
  1136.         C=COS(DEGTOR*ROTX)
  1137.         S=SIN(DEGTOR*ROTX)
  1138.         DO 40 I=1+NNET,NVTOT
  1139.         Y2=Y(I)*C-Z(I)*S
  1140.         Z(I)=Z(I)*C+Y(I)*S
  1141.         Y(I)=Y2
  1142.    40   CONTINUE 
  1143.       ENDIF
  1144.       CALL WMPFR(IW3D,0,-IHI3D+64,IWID3D,0)
  1145.       RETURN  
  1146.       END
  1147.       SUBROUTINE SAVEBX(JBLOC,IREASN)
  1148. C    two routines for saving files from menu windows using DragBoxes
  1149. C       
  1150. C       firstly:
  1151. C
  1152. C  SAVEMN(ITYPE,IWINDO) creates the window containing a sprite, filename
  1153. C  OK box, to be attached to a menu which includes a 'Save' option.
  1154. C  It returns IWINDO, the handle of the created window.
  1155. C  It must be given ITYPE, the file type to be saved.
  1156. C         at the moment ITYPE can be either ?I0FFF (text) or ?I0AFF (draw)
  1157. C         others can be included by incrementing NTYPES and the associated 
  1158. C         DATA statements below
  1159. C
  1160. C       then the work is done by:
  1161. C
  1162. C  SAVEBX(JBLOC,IREASN) called in the Wimp_Poll loop
  1163. C    JBLOC and IREASN are the WimpPoll block and reason code
  1164. C    IREASN is returned negative if SAVEBX has used this poll
  1165. C
  1166. C      the user must also supply the following routine:
  1167. C
  1168. C  SAVEFL(IERR) user routine to save the file to '<F77$File>' which is a
  1169. C    system alias for the name in the icon of the 'save' window. This is to
  1170. C    get round the bug in Fortran77 where file names are truncated to 30
  1171. C    characters in the OPEN statement. 
  1172. C         returns IERR=0 if OK; 
  1173. C if the save failed, it returns IERR<>0 when the file must not be written
  1174. C or it must be deleted if one has been written. 
  1175. C
  1176.       DIMENSION JBLOC(*)
  1177.       DIMENSION IBLOC(22),IREGS(0:7)
  1178.       EQUIVALENCE(IREGS(2),ITYPS)
  1179.       PARAMETER (NTYPES=2)
  1180.       CHARACTER DUMMY*1,FTYPE*9,VALID*4,FNAME*100,FOK*3
  1181.       CHARACTER*11 OLDFNM
  1182.       CHARACTER*4 TYPE(NTYPES),LTYP(NTYPES)*3
  1183.       DIMENSION JTYP(NTYPES)
  1184.       DATA VALID/'A~ .'/,FOK/'OK.'/,DUMMY/'.'/
  1185.       DATA TYPE/'Text','Draw'/
  1186.       DATA JTYP/?I0FFF,?I0AFF/
  1187.       DATA LTYP/  'fff', 'aff'/
  1188.       DATA IBLOC/0,-164,264,0,0,0,-1,?I84000012,?I01070207,?I020103,
  1189.      +0,-164,264,0,?I3D,?I3000,0,0,?I65766153,?I3A736120,0,0/
  1190.       DATA IREGS/18,7*0/
  1191. C
  1192.       IF((IREASN.EQ.17.OR.IREASN.EQ.18).AND.JBLOC(5).EQ.2) THEN
  1193. C
  1194. C  'User message of type 2' (Wimp_Poll reason 17 or 18, JBLOC(5) is type)
  1195. C       this is the filer replying to request to save file
  1196. C       JBLOC contains the reply from the filer
  1197. C              get file name into FNAME
  1198.         CALL WMPH2C(JBLOC(12),FNAME,L)
  1199. C                close menu
  1200.         CALL WMPCM(-1,0,0)
  1201. C                set up alias for name
  1202.         CALL OSCLI('Set F77$File '//FNAME(1:L))
  1203. C                write the file
  1204.         CALL SAVEFL(IERR)
  1205. C                set file type with OS_File 18
  1206.         IF(IERR.EQ.0) CALL SWIF77(8,IREGS,IFLAG)
  1207. C                reset filename if not confirmed
  1208.         IF(JBLOC(10).LE.-1) FNAME=OLDFNM
  1209. C          send data-load message to filer
  1210.         JBLOC(4)=JBLOC(3)
  1211.         JBLOC(5)=3
  1212.         JBLOC(1)=64
  1213.         CALL WMPSMG(18,JBLOC,JBLOC(6),JBLOC(7))
  1214. C          set 'used' flag
  1215.         IREASN=-1
  1216.         RETURN
  1217.       ENDIF
  1218. C
  1219. C         is this mouse click over 'save' window
  1220.       IF(IREASN.EQ.6.AND.JBLOC(4).EQ.IWSAVE) THEN
  1221. C          set 'used' flag
  1222.         IREASN=-1
  1223. C             click over 'OK' icon, go save file...
  1224.         IF(JBLOC(5).EQ.ICOK) GO TO 300
  1225. C
  1226.         IF(JBLOC(5).EQ.ICSPRT .AND. IAND(JBLOC(3),?I50).GT.0) THEN
  1227. C              drag initiated with mouse
  1228. C              set up drag box attached to mouse
  1229.           IBLOC(1)=IWSAVE
  1230. C             Find coordinates of save window
  1231.           CALL WMPGWS(IBLOC)
  1232.           IX0=IBLOC(2)-IBLOC(6)
  1233.           IY0=IBLOC(5)-IBLOC(7)
  1234.           IBLOC(2)=ICSPRT
  1235. C             Find coordinates of sprite icon
  1236.           CALL WMPGIS(IBLOC)
  1237. C             Set up for drag
  1238.           IBLOC(1)=IWSAVE
  1239. C             Drag type 5
  1240.           IBLOC(2)=5
  1241. C             coordinates of sprite boundary
  1242.           IBLOC(3)=IX0+IBLOC(3)
  1243.           IBLOC(4)=IY0+IBLOC(4)
  1244.           IBLOC(5)=IX0+IBLOC(5)
  1245.           IBLOC(6)=IY0+IBLOC(6)
  1246. C             bounds for dragging to
  1247.           IBLOC(7)=0
  1248.           IBLOC(8)=0
  1249.           IBLOC(9)=99999
  1250.           IBLOC(10)=99999
  1251. C             initiate drag
  1252.           CALL WMPDB(IBLOC)
  1253.         ENDIF
  1254.         RETURN
  1255.       ENDIF
  1256. C
  1257. C             is key pressed over save window?
  1258.       IF(IREASN.EQ.8.AND.JBLOC(1).EQ.IWSAVE) THEN
  1259. C     (Wimp_Poll reason 8, window handle in JBLOC(1), Key value in JBLOC(7))
  1260. C            set 'used' flag
  1261.         IREASN=-1
  1262. C              accept <CR> only
  1263.         IF(JBLOC(7).EQ.13) GO TO 300
  1264. C            otherwise give back to Wimp
  1265.         CALL WMPPK(JBLOC(7))
  1266.         RETURN
  1267.       ENDIF
  1268. C  
  1269.       IF(IREASN.EQ.7) THEN
  1270. C      drag finished (reason 7 from Wimp_Poll)
  1271. C            initiate save dialogue
  1272. C
  1273. C            set 'used' flag
  1274.         IREASN=-1
  1275. C            find where we are
  1276.         CALL WMPGPI(IBLOC)
  1277. C            check we are over a window
  1278.         IF(IBLOC(4).LT.0) RETURN
  1279. C            set up datasave message
  1280. C
  1281. C            Window & icon handles
  1282.         IBLOC(6)=IBLOC(4)
  1283.         IBLOC(7)=IBLOC(5)
  1284. C             coordinates
  1285.         IBLOC(8)=IBLOC(1)
  1286.         IBLOC(9)=IBLOC(2)
  1287. C              size of file (a guess only!!!)
  1288.         IBLOC(10)=9999
  1289. C              file type
  1290.         IBLOC(11)=ITYPS
  1291. C              null terminated file name
  1292.         L=INDEX(FNAME,CHAR(0))
  1293.         DO 210 I=L-1,1,-1
  1294.           IF(FNAME(I:I).EQ.'.') GO TO 220
  1295.   210   CONTINUE
  1296.         I=0
  1297.   220   IF(L-I.LT.2 .OR. L-I.GT.11) THEN
  1298.           CALL WMPRE(20,'Problem in file name length calculation',
  1299.      +    1,'Drag File',IR)
  1300.           RETURN
  1301.         ENDIF
  1302.         OLDFNM=FNAME(I+1:L)
  1303.         CALL WMPC2H(FNAME(I+1:L-1),IBLOC(12))
  1304. C              block length in bytes & dummy reference #
  1305.         IBLOC(1)=64
  1306.         IBLOC(4)=0
  1307. C              action (1 = save)
  1308.         IBLOC(5)=1
  1309. C              now send message
  1310.         CALL WMPSMG(17,IBLOC,IBLOC(6),IBLOC(7))
  1311.       ENDIF
  1312.       RETURN
  1313. C
  1314. C           file name FNAME entered by hand, save the file
  1315.   300 IF(INDEX(FNAME,'$.').EQ.0) THEN
  1316.         CALL WMPRE(20,'Please set up the complete file and path name'
  1317.      +  ,1,'Drag File',IR)
  1318.       ELSE
  1319. C                close menu
  1320.         CALL WMPCM(-1,0,0)
  1321. C                set up alias for name
  1322.         L=INDEX(FNAME,CHAR(0))-1
  1323.         CALL OSCLI('Set F77$File '//FNAME(1:L))
  1324. C                write the file
  1325.         CALL SAVEFL(IERR)
  1326. C            set file type with OS_File 18
  1327.         IF(IERR.EQ.0) CALL SWIF77(8,IREGS,IFLAG)
  1328.       ENDIF
  1329.       RETURN
  1330. C
  1331. C          SAVEMN(ITYPE,IWINDO) sets up a save window with handle IWINDO
  1332. C                               for files of type ITYPE
  1333. C
  1334.       ENTRY SAVEMN(ITYPE,IWINDO)
  1335. C           set up file name location for OS_File
  1336.       IREGS(1)=LOCC(FNAME)
  1337. C           find file type in list
  1338.       ITYPS=ITYPE
  1339.       DO 10 IT=1,NTYPES
  1340.         IF(ITYPE.EQ.JTYP(IT)) GO TO 20
  1341.    10 CONTINUE
  1342.       IWINDO=-1
  1343.       RETURN
  1344. C            construct Wimp sprite name
  1345.    20 FTYPE='file_'//LTYP(IT)
  1346. C                  make window
  1347.       CALL WMPCRW(IBLOC,IWSAVE)
  1348.       IWINDO=IWSAVE
  1349. C                  make file sprite
  1350.       ICSPRT=IWMPCI(IWSAVE,100,-92,68,68,?I6102,FTYPE,DUMMY)
  1351. C                  make file name
  1352.       FNAME=TYPE(IT)//'File'//CHAR(0)
  1353.       ICNAME=IWMPCI(IWSAVE,8,-156,192,48,?I0700F12D,FNAME,VALID)  
  1354. C                  make 'OK' box
  1355.       ICOK=IWMPCI(IWSAVE,208,-156,48,48,?IC701903D,FOK,DUMMY)
  1356.       RETURN
  1357.       END
  1358.       SUBROUTINE SAVEFL(IER)
  1359. C  routine to create Drawfile to be saved to file FILNAM using drag box
  1360. C  IER is error return, =0 when OK
  1361. C
  1362.       CHARACTER *24 TRUBL
  1363.       CALL DRFILE('A5P','<F77$File>',IER)
  1364. C                   save the window here as a DrawFile display error number
  1365.       IF(IER.NE.0)THEN
  1366.         WRITE(TRUBL,101)IER
  1367.   101   FORMAT('Error ',I3,' from DRFILE',$)
  1368.         CALL WMPRE(IER,TRUBL,1,'WimpPoly',IERR)     
  1369. C               if file still exists remove it
  1370.          CALL OSCLI('REMOVE <F77$File>')
  1371.       ENDIF
  1372.       RETURN
  1373.       END
  1374.       SUBROUTINE SCAL3D(KODE)
  1375. C                  scales the solid by fixed amount
  1376. C                   60 44 <, smaller  62 46 >. bigger
  1377.       INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'            
  1378.       INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
  1379.       DATA DSCALE/0.9/,SMIN/64/
  1380. C                     SMIN is in screen units
  1381.       IF(KODE.EQ.60.OR.KODE.EQ.44)THEN
  1382. C                make smaller by delta scale
  1383.         SCL3D=SCL3D*DSCALE
  1384.         IF(SCL3D.LE.SMIN)SCL3D=SMIN
  1385.       ELSE
  1386.         SCL3D=SCL3D/DSCALE
  1387.         IF(SCL3D.GT.IWID3D)SCL3D=IWID3D-32
  1388.       ENDIF
  1389.       CALL WMPFR(IW3D,0,-IHI3D+64,IWID3D,0)
  1390.       RETURN
  1391.       END 
  1392.       SUBROUTINE SHOHLP(LX0,LY0)
  1393. C                displays Help text within the help window
  1394.       INCLUDE'<WimpPoly$Dir>.f77.WPOLYCH'
  1395.       CALL WMPSC(0,7,0)
  1396. C                  set colour of text               
  1397.       DO 20 I=1,MAXHLP
  1398.       CALL WMPTXT(LX0,LY0+32-32*I,HELPTX(I))
  1399.    20 CONTINUE
  1400. C      CALL VDU(4)
  1401. C      CALL TAB(0,0)
  1402. C      WRITE(*,101)LX0,LY0,(MVDUVAR(I),I=128,131)
  1403. C      CALL VDU(5)
  1404. C  101 FORMAT(' LX0,LY0=',2I6,' X1,Y1,X2,Y2=',4I6)
  1405.       RETURN
  1406.       END              
  1407.       SUBROUTINE ZSORT 
  1408. C                                       COMMON BLOCK
  1409.       INCLUDE'<WimpPoly$Dir>.f77.WPOLYPic'
  1410. C                   SET UP INDEX to which faces to plot
  1411.       IF(ISTK3D.NE.1) THEN 
  1412. C                         3d solid gray shades or colour
  1413.         NFPLOT=0
  1414.         DO 10 I=1,NFACES
  1415.         IF(DCFACE(3,I).GT.-0.0001)THEN
  1416.           NFPLOT=NFPLOT+1
  1417.           INDX(NFPLOT)=I
  1418.         ENDIF
  1419.    10   CONTINUE
  1420.       ELSE                                   
  1421. C                        wire model
  1422.         NFPLOT=NFACES
  1423.         DO 15 I=1,NFACES
  1424.    15   INDX(I)=I
  1425.       ENDIF
  1426.       CALL QSORTR(ZFACE,INDX,NFPLOT)
  1427. C      I=1
  1428. C   20 IF(ZFACE(INDX(I)).LE.ZFACE(INDX(I+1))) THEN
  1429. C        I=I+1
  1430. C      ELSE
  1431. C        J=INDX(I)
  1432. C        INDX(I)=INDX(I+1)
  1433. C        INDX(I+1)=J
  1434. C        I=I-1
  1435. C        IF(I.EQ.0) I=2
  1436. C      ENDIF
  1437. C      IF(I.LT.NFPLOT) GO TO 20
  1438.       RETURN
  1439.       END
  1440.