C*********************************************************************** C Module: spectrum.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 spectrum C C Displays chosen COLORSPECTRUMDEFAULT colors in a circle and bar C C dimension xp(100), yp(100) C CHARACTER*12 HUES CHARACTER*4 INP CH = 0.02 C PI = 4.0*ATAN(1.0) 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) INP ips = -1 if(INP.ne.' ') then READ(INP,*,end=2000,err=2000) ips endif IDEV = 1 IF(ips.eq.0) IDEV = 3 IF(ips.ge.1) IDEV = 5 ipslu = 0 C C---- for REPLOT: X11 only IDEVRP = 1 CALL PLINITIALIZE C C---Now, how many colors... WRITE(*,*) ' Enter number of colors' READ(*,1000,end=2000) INP ncolors = 128 if(INP.ne.' ') then READ(INP,*,end=2000,err=2000) ncolors endif C WRITE(*,*) ' Specify hue string (out of ROYGCBM)' READ (*,1000) HUES IF(HUES.EQ.' ') HUES = 'ROYGCBM' C C---Set up colormap spectrum colors if(ncolors.LE.1) ncolors = 0 CALL COLORSPECTRUMHUES(ncolors,HUES) C C---- radius of circle rad = 3.0 c CALL PLOPEN(0.7,ipslu,IDEV) CALL PLOT(1.3*rad,1.3*rad,-3) c c---- plot circle do ii = 1,ncolors call NEWCOLOR(-ii) t0 = float(ii-1)/float(ncolors) ! + 0.167 t1 = float(ii )/float(ncolors) ! + 0.167 C xp(1) = 0.0 yp(1) = 0.0 xp(2) = rad*cos(2.0*pi*t0) yp(2) = rad*sin(2.0*pi*t0) xp(3) = rad*cos(2.0*pi*(t0+0.25*(t1-t0))) yp(3) = rad*sin(2.0*pi*(t0+0.25*(t1-t0))) xp(4) = rad*cos(2.0*pi*(t0+0.50*(t1-t0))) yp(4) = rad*sin(2.0*pi*(t0+0.50*(t1-t0))) xp(5) = rad*cos(2.0*pi*(t0+0.75*(t1-t0))) yp(5) = rad*sin(2.0*pi*(t0+0.75*(t1-t0))) xp(6) = rad*cos(2.0*pi*t1) yp(6) = rad*sin(2.0*pi*t1) call POLYLINE(xp,yp,6,1) end do C CALL PLOT(1.5*rad,-rad,-3) C c---- plot bar dx = 1.0 dy = 2.0*rad/float(ncolors) do ii = 1,ncolors call NEWCOLOR(-ii) c x0 = 0.0 y0 = dy*float(ii-1) c xp(1) = x0 yp(1) = y0 xp(2) = x0+dx yp(2) = y0 xp(3) = x0+dx yp(3) = y0+dy xp(4) = x0 yp(4) = y0+dy call POLYLINE(xp,yp,4,1) end do C CALL NEWCOLORNAME('black') CALL PLOTABS(1.,.75,-3) CALL PLCHAR (999.,999.,.1,'SPECTRUM ',0.,+10) CALL PLCHAR (999.,999.,.1,HUES,0.,LEN(HUES)) CALL PLOTABS(1.,0.5,-3) CALL PLCHAR (999.,999.,.1,'Ncolors = ',0.,+10) CALL PLNUMB (999.,999.,.1,FLOAT(ncolors),0.,-1) C CALL PLFLUSH WRITE(*,*) 'Hit return to test replot' READ(5,1000) DUMMY C CALL REPLOT(IDEVRP) CALL PLFLUSH C WRITE(*,*) 'Hit return to end test' READ(5,1000) DUMMY 1000 FORMAT(A) C C GO TO 1 C 2000 CALL PLOT(0.0,0.0,+999) STOP END