C*********************************************************************** C Module: contest.f C C Copyright (C) 1996 Harold Youngren, Mark Drela C C This program is free software; you can redistribute it and/or modify C it under the terms of the GNU General Public License as published by C the Free Software Foundation; either version 2 of the License, or C (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a copy of the GNU General Public License C along with this program; if not, write to the Free Software C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. C C Report problems to: guppy@maine.com C or drela@mit.edu C*********************************************************************** program contest C C--- Test of Xplot11 quadrilateral and triangle contour primitives C CHARACTER CHR*2, HUES*10 DIMENSION X(4), Y(4), Z(4) DIMENSION XTRI(3), YTRI(3), ZTRI(3) C DIMENSION XCU(50), YCU(50) DIMENSION XCL(50), YCL(50) DIMENSION XP(50), YP(50), NE(50) C DATA X / 0., 1., 1., 0. / DATA Y / 0., 0., 1., 1. / DATA Z / 0., 1., 0., 2. / C IDEV = 3 nlevel = 50 ncolors = 64 WRITE(*,*) ' ' WRITE(*,*) 'Contour primitives test:' WRITE(*,*) ' (contour fills on single square polygon)' WRITE(*,*) ' ' WRITE(*,*) 'Data points...' do i = 1, 4 write(*,*) i,' x = ',X(i),' y = ',Y(i),' z = ',Z(i) end do C C---Decide about what devices to plot to WRITE(*,*) ' ' 1 WRITE(*,*) ' Enter -1 for no PS, 0 for B&W PS, 1 for color PS' READ(*,1000,end=2000) CHR ips = -1 if(CHR.ne.' ') then READ(CHR,*,end=2000,err=2000) ips endif IDEV = 1 IF(ips.eq.0) IDEV = 3 IF(ips.ge.1) IDEV = 5 ipslu = 0 C C--- Get contour data ZL = 0. ZU = 2. write(*,*) ' ' write(*,*) 'Contour limits ',ZL,' to ',ZU write(*,*) 'Enter # of contour levels' read (*,*) nlevel C ipslu = 0 CALL PLINITIALIZE HUES = 'ROYGCBM' C C---Set up colormap spectrum colors if(ncolors.LE.1) ncolors = 0 CALL COLORSPECTRUMHUES(ncolors,HUES) C do ITYP = 1, 2 C CALL PLOPEN(0.5,ipslu,IDEV) call newcolorname('green') CALL PLOTABS(.75,.75,-3) CALL PLCHAR (999.,999.,.1,'Contour test ',0.,-1) if(ITYP.NE.2) then WRITE(*,*) 'Polygon contoured and filled as quadrilateral' CALL PLCHAR (999.,999.,.1,'Quadrilateral',0.,-1) else WRITE(*,*) 'Polygon contoured and filled as two triangles' CALL PLCHAR (999.,999.,.1,'Two Triangles',0.,-1) endif CALL PLOT(0.,-0.5,-3) CALL PLCHAR (999.,999.,.1,'Nlevels = ',0.,-1) CALL PLNUMB (999.,999.,.1,FLOAT(nlevel),0.,-1) CALL PLCHAR (999.,999.,.1,' Ncolors = ',0.,-1) CALL PLNUMB (999.,999.,.1,FLOAT(ncolors),0.,-1) CALL PLOT(2.,2.,-3) call factor(4.) C C--- Set contour levels and increments NCONT = NLEVEL + 1 DZ = (ZU-ZL)/FLOAT(NCONT) C DO N = 1, NCONT ZUPR = FLOAT(N)*DZ ZLWR = FLOAT(N-1)*DZ C C--- Set color based on contour # ICOL = (NCOLORS-1)*FLOAT(N-1)/FLOAT(NCONT-1) + 1 CALL NEWCOLOR(-ICOL) C C--- Reset the line and area counters for each level NA = 0 NV = 0 NCU = 0 NCL = 0 C if(ITYP.NE.2) then C C--- Contour a quadrilateral CALL CONTQUAD(X,Y,Z,ZUPR,ZLWR, & NCU,XCU,YCU, & NCL,XCL,YCL, & NA,NE,NV,XP,YP) C else C C--- Triangle contouring, use two triangles, split quad on 1-3 diagonal xtri(1) = x(1) ytri(1) = y(1) ztri(1) = z(1) xtri(2) = x(2) ytri(2) = y(2) ztri(2) = z(2) xtri(3) = x(3) ytri(3) = y(3) ztri(3) = z(3) CALL CONTTRI(xtri,ytri,ztri,ZUPR,ZLWR, & NCU,XCU,YCU, & NCL,XCL,YCL, & NA,NE,NV,XP,YP) xtri(1) = x(3) ytri(1) = y(3) ztri(1) = z(3) xtri(2) = x(4) ytri(2) = y(4) ztri(2) = z(4) xtri(3) = x(1) ytri(3) = y(1) ztri(3) = z(1) CALL CONTTRI(xtri,ytri,ztri,ZUPR,ZLWR, & NCU,XCU,YCU, & NCL,XCL,YCL, & NA,NE,NV,XP,YP) endif C C C--- Plot the filled contour polygons nv = 1 DO IA = 1, NA call polyline(xp(nv),yp(nv),ne(ia),1) nv = nv+ne(ia) END DO C C--- Plot the contour lines (w/o color in this case). C Otherwise you could leave out the polygon fills and comment out the C color change to BLACK to get colored line contours. C call newcolorname('BLACK') C--- All lower contour lines do nn = 1, ncl,2 call plot(xcl(nn),ycl(nn),3) call plot(xcl(nn+1),ycl(nn+1),2) end do C--- And the last upper line if(N.EQ.NCONT) then do nn = 1, ncu,2 call plot(xcu(nn),ycu(nn),3) call plot(xcu(nn+1),ycu(nn+1),2) end do endif C END DO CALL PLFLUSH C read(*,1000) chr CALL PLOT(0.,0.,-999) C end do CALL PLOT(0.,0.,+999) C 1000 FORMAT(A) C 2000 STOP END