cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c c Drawcgm.For v. 3.0 (7/89) c c Copyright 1987, 1989 Pittsburgh Supercomputing Center c c Authors Joel Welling, Jonathan Goldick, John Burkardt, c c and Chris Behanna c c c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C C Change Log: C C UPGRADES FOR RELEASE 3.0: C 7 July 1989 - Joel Welling C Added routine DEVICE to select device. cgmgen's SETDEV won't C do because it doesn't properly control access to the standard C output without an appropriate call to wrtopn. This caused a C particularly acute problem with the tektronix drivers. C Found and fixed bug resulting in color bars displaying 'colors' C for out-of-bounds indices. C C 11 January 1989 - Christopher BeHanna C Two new routines added: DRWCGM (move with "pen" down), MOVCGM C (move with "pen" up). C C Also, subroutine Mask duplicated the name of a built-in routine, C thereby causing many error messages. Mask was renamed to C Imgmsk. C C 19 January 1989 - Joel Welling C Added PLYMRK, MRKCLR, MRKTYP, and MRKSIZ (polymarker and color, C type, and size attribute routines). C Added SETSCL to set coordinate scale (via CGMGEN routine C setwcd). C @end(upgrade stuff) C Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C The following routine draws pixels as cell arrays. Parameters C are as follows: C C Istat: 0 for first call, 1 for subsequent, 2 for last call C xorg,yorg: real coordinates of lower left corner. C xmax,ymax: real coordinates of upper right corner. C Ipixel: the cell array C Nxdim,Nydim: cell array dimensions C SUBROUTINE Drwpix(Istat,Xorg,Yorg,Xmax,Ymax, 1 Ipixel,Nxdim,Nydim,Iclr) C IMPLICIT NONE INTEGER Istat,Nxdim,Nydim,Ipixel(Nxdim,Nydim),Iclr REAL Xorg,Yorg,Xmax,Ymax LOGICAL Iniflg,Psflg,Devflg COMMON /Drwstt/Iniflg,Psflg,Devflg EXTERNAL Grfini,Setctb,Drawit,Newfrm,Grfcls CALL Setctb(Iclr) IF (Istat.EQ.0) THEN CALL Grfini() CALL Drawit(Ipixel,Nxdim,Nydim,Xorg,Yorg,Xmax,Ymax) ELSE IF (Istat.EQ.1) THEN IF (Iniflg) THEN CALL Newfrm() ELSE CALL Grfini() END IF CALL Drawit(Ipixel,Nxdim,Nydim,Xorg,Yorg,Xmax,Ymax) ELSE IF (Istat.EQ.2) THEN IF (Iniflg) THEN CALL Newfrm() ELSE CALL Grfini() END IF CALL Drawit(Ipixel,Nxdim,Nydim,Xorg,Yorg,Xmax,Ymax) CALL Grfcls END IF 666 RETURN END C C Drawing routine follows C SUBROUTINE Drawit(Ipixel,Nxdim,Nydim,Xorg,Yorg,Xmax,Ymax) C IMPLICIT NONE INTEGER Nxdim,Nydim,Ipixel(Nxdim,Nydim),Ierr REAL Xorg,Yorg,Xmax,Ymax EXTERNAL Wrtcla Ierr= 0 CALL Wrtcla(Ipixel,Nxdim,Nydim, 1 Xorg,Yorg,Xmax,Ymax,Xmax,Yorg,Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wrtcla returned ierr=',Ierr 666 RETURN END C C This routine calculates a full set of color table entries. C The parameter given selects which color table is generated: C C Index Description C ----- ----------- C 1 Gray scale C 2 Blue fading into yellow C 3 Waves of green in red fading to blue C 4 Pseudospectral (red to blue) C 5 Inverted Pseudospectral (blue to red) C C An out-of-range index causes no color table to be generated; i.e. C the previous colors will remain in effect. Color indices 0 and 1 C are set to white and black respectively, if the index is in the C above range. C SUBROUTINE Setctb(Index) C IMPLICIT NONE INTEGER Mtblsz PARAMETER (Mtblsz=256) INTEGER Index,I REAL Pi,Ratio,Rval,Gval,Bval,Tval,Gauss,Theta EXTERNAL Setclr Gauss(Ratio)= EXP(-Ratio**2) IF (Index.GE.1.AND.Index.LE.5) THEN Pi= 2.0*Asin(1.0) DO 10 I= 0,Mtblsz-1 C gray scale IF (Index.EQ.1) THEN Rval= FLOAT(I)/FLOAT(Mtblsz-1) Gval= Rval Bval= Rval END IF C blue into yellow IF (Index.EQ.2) THEN Tval= FLOAT(Mtblsz-1) Rval= FLOAT(I)/Tval Gval= Rval Bval= 1.0 - Rval + 1.0/Tval END IF C waves IF (Index.EQ.3) THEN Theta= (FLOAT(I)/FLOAT(Mtblsz-1))*Pi/2.0 Rval= COS(Theta)**2 Bval= SIN(Theta)**2 Gval= 0.8*SIN(10.0*Theta)**6 END IF C pseudospectral IF (Index.EQ.4) THEN Theta= (FLOAT(I)/FLOAT(Mtblsz-1))*4.0 Tval= Gauss(Theta-4.0) Rval= Gauss(Theta-1.0) + Tval Gval= Gauss(Theta-2.0) + Tval Bval= Gauss(Theta-3.0) + Tval IF (Rval.GT.1.0) Rval= 1.0 IF (Gval.GT.1.0) Gval= 1.0 IF (Bval.GT.1.0) Bval= 1.0 END IF C inverted pseudospectral IF (Index.EQ.5) THEN Theta= (FLOAT(Mtblsz-I-1) 1 /FLOAT(Mtblsz-1))*4.0 Tval= Gauss(Theta-4.0) Rval= Gauss(Theta-1.0) + Tval Gval= Gauss(Theta-2.0) + Tval Bval= Gauss(Theta-3.0) + Tval IF (Rval.GT.1.0) Rval= 1.0 IF (Gval.GT.1.0) Gval= 1.0 IF (Bval.GT.1.0) Bval= 1.0 END IF C background is to be white IF (I.EQ.0) THEN Rval= 1.0 Gval= 1.0 Bval= 1.0 END IF C color 1 (foreground) is black IF (I.EQ.1) THEN Rval= 0.0 Gval= 0.0 Bval= 0.0 END IF 10 CALL Setclr(I,Rval,Gval,Bval) END IF 666 RETURN END C C This routine draws simple labels. C SUBROUTINE Label(Xorg,Yorg,String,Iclr,Size) C IMPLICIT NONE CHARACTER*(*) String REAL Xorg,Yorg,Size INTEGER Iclr,Ierr EXTERNAL Wrtxts,Wrtxtc,Wrftxt Ierr= 0 CALL Wrtxts(Size,Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wrtxts returned ierr=',Ierr Ierr= 0 CALL Wrtxtc(Iclr,Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wrtxtc returned ierr=',Ierr Ierr= 0 CALL Wrftxt(String,Xorg,Yorg,Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wrftxt returned ierr=',Ierr 666 RETURN END C C This routine draws a vertical color bar. C SUBROUTINE Vrtcbr(Xmin,Ymin,Xmax,Ymax, 1 Ncmin,Ncmax,Bstr,Tstr,Ilbclr,Size) C IMPLICIT NONE CHARACTER*(*) Bstr,Tstr REAL X(5),Y(5),Xmin,Ymin,Xmax,Ymax,Ystep,Ybot,Ytop,Size INTEGER Ncmin,Ncmax,Ncolors,Icolor,J,Ilbclr INTEGER Mincdp,Maxcdp,Mtblsz PARAMETER (Mtblsz=256) EXTERNAL Filclr,Plygon,Linclr,Plylin EXTERNAL Label C C -set up coordinates C Mincdp= Ncmin Maxcdp= Ncmax IF (Mincdp.LT.0) Mincdp= 0 IF (Maxcdp.LT.0) Maxcdp= 0 IF (Maxcdp.GE.Mtblsz) Maxcdp= Mtblsz-1 IF (Mincdp.GE.Mtblsz) Mincdp= Mtblsz-1 IF (Mincdp.GT.Maxcdp) Maxcdp= Mincdp Ncolors= Maxcdp-Mincdp+1 Ystep= (Ymax-Ymin)/Ncolors C C -draw color bar C X(1)= Xmin X(2)= Xmax X(3)= Xmax X(4)= Xmin Ybot= Ymin DO 10 J= 1,Ncolors Icolor= J+Mincdp-1 CALL Filclr(Icolor) Ytop= Ybot+Ystep Y(1)= Ybot Y(2)= Ybot Y(3)= Ytop Y(4)= Ytop CALL Plygon(4,X,Y) Ybot= Ytop 10 CONTINUE C C -draw box around color bar C X(1)= Xmin X(2)= Xmax X(3)= Xmax X(4)= Xmin X(5)= Xmin Y(1)= Ymin Y(2)= Ymin Y(3)= Ymax Y(4)= Ymax Y(5)= Ymin CALL Linclr(1) CALL Plylin(5,X,Y) C C -draw labels C CALL Label(Xmax+(Xmax-Xmin)/5,Ymin-1./120.,Bstr,Ilbclr,Size) CALL Label(Xmax+(Xmax-Xmin)/5,Ymax-1./120.,Tstr,Ilbclr,Size) 666 RETURN END C C This routine draws a horizontal color bar. C SUBROUTINE Horcbr(Xmin,Ymin,Xmax,Ymax, 1 Ncmin,Ncmax,Lstr,Rstr,Ilbclr,Size) C IMPLICIT NONE CHARACTER*(*) Lstr,Rstr INTEGER Ncmin,Ncmax,Ncolors,Icolor,Ilbclr,J INTEGER Mincdp,Maxcdp,Mtblsz PARAMETER (Mtblsz=256) REAL X(5),Y(5),Xmin,Ymin,Xmax,Ymax,Xstep REAL Xleft,Xright,Size INTRINSIC Len EXTERNAL Filclr,Plygon,Linclr,Plylin,Label C C -set up coordinates C Mincdp= Ncmin Maxcdp= Ncmax IF (Mincdp.LT.0) Mincdp= 0 IF (Maxcdp.LT.0) Maxcdp= 0 IF (Maxcdp.GE.Mtblsz) Maxcdp= Mtblsz-1 IF (Mincdp.GE.Mtblsz) Mincdp= Mtblsz-1 IF (Mincdp.GT.Maxcdp) Maxcdp= Mincdp Xsize= Xmax-Xmin Ncolors= Maxcdp-Mincdp+1 Xstep= (Xmax-Xmin)/Ncolors C C -draw color bar C Y(1)= Ymin Y(2)= Ymin Y(3)= Ymax Y(4)= Ymax Xleft= Xmin DO 10 J= 1,Ncolors Icolor= J+Mincdp-1 CALL Filclr(Icolor) Xright= Xleft+Xstep X(1)= Xleft X(2)= Xright X(3)= Xright X(4)= Xleft CALL Plygon(4,X,Y) Xleft= Xright 10 CONTINUE C C -draw box around color bar C X(1)= Xmin X(2)= Xmax X(3)= Xmax X(4)= Xmin X(5)= Xmin Y(1)= Ymin Y(2)= Ymin Y(3)= Ymax Y(4)= Ymax Y(5)= Ymin CALL Linclr(1) CALL Plylin(5,X,Y) C C -draw labels C CALL Label(Xmin-0.5*Size*Len(Lstr),Ymin-1.5*Size, 1 Lstr,Ilbclr,Size) CALL Label(Xmax-0.5*Size*Len(Rstr),Ymin-1.5*Size, 1 Rstr,Ilbclr,Size) 666 RETURN END C C This routine expands a nsx by nsy field to a nx by ny field using C bicubic natural spline interpolation. C SUBROUTINE Strspl(Small,Y2a,Nsx,Nsy,Big,Nx,Ny) C IMPLICIT NONE INTEGER Nx,Ny,Nsx,Nsy,Nmax,I,J,Indx1,Indx2,K,L PARAMETER (Nmax=1200) REAL Small(Nsx,Nsy),Big(Nx,Ny),Xtemp(Nmax),Ytemp(Nmax) REAL Y2a(Nsx,Nsy),Ftemp(Nmax),F2temp(Nmax),Fftemp(Nmax) REAL Xscale,Yscale,X,Y,Val EXTERNAL Splie2,Stpspl,Spline Xscale= FLOAT(Nx-1)/FLOAT(Nsx-1) Yscale= FLOAT(Ny-1)/FLOAT(Nsy-1) DO 10 I= 1,Nsx 10 Xtemp(I)= (I-1)*Xscale DO 20 J= 1,Nsy 20 Ytemp(J)= (J-1)*Yscale CALL Splie2(Xtemp,Ytemp,Small,Nsx,Nsy,Y2a) DO 50 J= 1,Ny Y= FLOAT(J-1) Indx1= 1 DO 40 K= 1,Nsx DO 30 L= 1,Nsy Ftemp(L) = Small(K,l) F2temp(L)= Y2a(K,l) 30 CONTINUE CALL Stpspl(Ytemp,Ftemp,F2temp,Nsy,Y, 1 Fftemp(K),Indx1) 40 CONTINUE CALL Spline(Xtemp,Fftemp,Nsx,1.e30,1.e30,F2temp) Indx2= 1 DO 50 I= 1,Nx X= FLOAT(I-1) CALL Stpspl(Xtemp,Fftemp,F2temp,Nsx,X,Val,Indx2) 50 Big(I,J)= Val 666 RETURN END C C This routine expands a nsx by nsy field to a nx by ny field using C linear interpolation. C SUBROUTINE Strlin(Small,Nsx,Nsy,Big,Nx,Ny) C IMPLICIT NONE INTEGER Nsx,Nsy,Nx,Ny,I,J,Isx,Isy REAL Small(Nsx,Nsy),Big(Nx,Ny),Xscale,Yscale,T,U Xscale= FLOAT(Nsx-1)/FLOAT(Nx-1) Yscale= FLOAT(Nsy-1)/FLOAT(Ny-1) DO 10 I= 1,Nx Isx= (Xscale*(I-1))+1 T= (I-1)*Xscale-(Isx-1) DO 10 J= 1,Ny Isy= (Yscale*(J-1))+1 U= (J-1)*Yscale-(Isy-1) Big(I,J)= Small(Isx,Isy) 1 +T*(Small(Isx+1,Isy)-Small(Isx,Isy)) 2 +U*(Small(Isx,Isy+1)-Small(Isx,Isy)) 3 +T*U*(Small(Isx,Isy)-Small(Isx+1,Isy) 4 +Small(Isx+1,Isy+1)-Small(Isx,Isy+1)) 10 CONTINUE 666 RETURN END C C This routine does spline interpolation for ordered points. C SUBROUTINE Stpspl(XA,YA,Y2a,N,X,Y,Indx) C IMPLICIT NONE INTEGER N,Indx,Klo,Khi REAL XA(N),YA(N),Y2a(N),H,A,B,X,Y C EXTERNAL Exit 5 IF (XA(Indx).LE.X.AND.XA(Indx+1).GE.X) GOTO 10 Indx= Indx+1 IF (Indx.EQ.N) THEN WRITE (UNIT=6) 'Bad XA or INDX input to stpspl.' CALL Exit(2) END IF GOTO 5 10 Klo= Indx khi= Indx+1 H= XA(Khi)-XA(Klo) IF (H.EQ.0.) THEN WRITE (UNIT=6) 'Bad XA input.' CALL Exit(2) END IF A= (XA(Khi)-X)/H B= (X-XA(Klo))/H Y= A*YA(Klo)+B*YA(Khi)+ 1 ((A**3-1)*Y2a(Klo)+(B**3-B)*Y2a(Khi))*(H**2)/6. RETURN END C C This routine uses a small mask array to mask out regions of C a larger pixel array. Regions of the mask array which are C nonzero are set to the same value in the larger array. C SUBROUTINE Imgmsk(Mfield,Nxsmall,Nysmall,Ipixel,Nxbig,Nybig) C IMPLICIT NONE INTEGER Nxsmall,Nysmall,Nxbig,Nybig,I,Ismall,J,Jsmall INTEGER Nxbgst,Nybgst,Nxsmst,Nysmst INTEGER Mfield(Nxsmall,Nysmall),Ipixel(Nxbig,Nybig) Nxbgst= Nxbig-1 Nybgst= Nybig-1 Nxsmst= Nxsmall-1 Nysmst= Nysmall-1 DO 20 I= 1,Nxbig-1 Ismall= ((I-1)*Nxsmall)/Nxbgst+1 DO 10 J= 1,Nybig-1 Jsmall= ((J-1)*Nysmall)/Nybgst+1 IF (Mfield(Ismall,Jsmall).NE.0) 1 Ipixel(I,J) = Mfield(Ismall,Jsmall) 10 CONTINUE IF (Mfield(Ismall,Nysmall).NE.0) 1 Ipixel(I,Nybig) = Mfield(Ismall,Nysmall) 20 CONTINUE DO 30 J= 1,Nybig-1 Jsmall= ((J-1)*Nysmall)/Nybgst+1 IF (Mfield(Nxsmall,Jsmall).NE.0) 1 Ipixel(Nxbig,J) = Mfield(Nxsmall,Jsmall) 30 CONTINUE IF (Mfield(Nxsmall,Nysmall).NE.0) 1 Ipixel(Nxbig,Nybig) = Mfield(Nxsmall,Nysmall) 666 RETURN END C C The following routine copies its first parameter array to its C second; third and fourth parameters are dimensions. C SUBROUTINE Cpyint(Ifield,Ofield,Nxdim,Nydim) C IMPLICIT NONE INTEGER I,J,Nxdim,Nydim INTEGER Ifield(Nxdim,Nydim),Ofield(Nxdim,Nydim) DO 10 I= 1,Nxdim DO 10 J= 1,Nydim 10 Ofield(I,J)= Ifield(I,J) 666 RETURN END C C This code comes from Numerical Recipes by Press, Flannery, C Teukolsky, and Vetterling, chapter 3. C SUBROUTINE Spline(X,Y,N,Yp1,Ypn,Y2) C IMPLICIT NONE INTEGER Nmax,N,I,K PARAMETER (Nmax=1200) REAL X(N),Y(N),Y2(N),U(Nmax),Yp1,Ypn,Sig,P,Qn,Un IF (Yp1.GT..99e30) THEN Y2(1)= 0. U(1)= 0. ELSE Y2(1)= -0.5 U(1)= (3./(X(2)-X(1)))*((Y(2)-Y(1))/(X(2)-X(1))-Yp1) END IF DO 11 I= 2,N-1 Sig= (X(I)-X(I-1))/(X(I+1)-X(I-1)) P= Sig*Y2(I-1)+2. Y2(I)= (Sig-1.)/P U(I)=(6.*((Y(I+1)-Y(I))/(X(I+1)-X(I))-(Y(I)-Y(I-1)) 1 /(X(I)-X(I-1)))/(X(I+1)-X(I-1))-Sig*U(I-1))/P 11 CONTINUE IF (Ypn.GT..99e30) THEN Qn= 0. Un= 0. ELSE Qn= 0.5 Un= (3./(X(N)-X(N-1)))*(YpN-(Y(N)-Y(N-1))/(X(N)-X(N-1))) END IF Y2(N)= (Un-Qn*U(N-1))/(Qn*Y2(N-1)+1.) DO 12 K=N-1,1,-1 Y2(K)= Y2(K)*Y2(K+1)+U(K) 12 CONTINUE RETURN END SUBROUTINE Splie2(X1a,X2a,YA,M,N,Y2a) C IMPLICIT NONE INTEGER Nn,N,M,J,K PARAMETER (Nn=1200) REAL X1a(M),X2a(N),YA(M,N),Y2a(M,N),Ytmp(Nn),Y2tmp(Nn) EXTERNAL Spline DO 13 J= 1,M DO 11 K= 1,N Ytmp(K)= YA(J,K) 11 CONTINUE CALL Spline(X2a,Ytmp,N,1.e30,1.e30,Y2tmp) DO 12 K= 1,N Y2a(J,K)= Y2tmp(K) 12 CONTINUE 13 CONTINUE RETURN END C C This routine draws a window frame in the (full-screen) display C window which matches the window of our animation system. C SUBROUTINE winfrm C IMPLICIT NONE REAL X(5),Y(5),Ybot,Ytop EXTERNAL Plylin Ybot= 0.1 Ytop= 1.0 X(1)= 0.0 X(2)= 1.0 X(3)= 1.0 X(4)= 0.0 X(5)= 0.0 Y(1)= Ybot Y(2)= Ybot Y(3)= Ytop Y(4)= Ytop Y(5)= Ybot CALL Plylin(5,X,Y) X(1)= 0.0 X(2)= 1.0 Y(1)= (Ytop+Ybot)/2.0 Y(2)= Y(1) CALL Plylin(2,X,Y) X(1)= 0.5 X(2)= 0.5 Y(1)= Ytop Y(2)= Ybot CALL Plylin(2,X,Y) 666 RETURN END C C This routine calculates the integer array Ipixel by linear C interpolation between the arrays min and max. The array C dimensions are nxdim and nydim. The interpolated location C is iframe-1/nframes of the way from min to max, so that if C iframe=1 Ipixel takes the values of min, while if iframe=nframes+1 C Ipixel is equal to max. C SUBROUTINE Interp(Min,Max,Ipixel, 1 Nxdim,Nydim,Iframe,Nframes) C IMPLICIT NONE INTEGER Nxdim,Nydim,Iframe,Istep,I,J,Nframes INTEGER Min(Nxdim,Nydim),Max(Nxdim,Nydim),Ipixel(Nxdim,Nydim) Istep= Iframe-1 DO 10 I= 1,Nxdim DO 10 J= 1,Nydim Ipixel(I,J)= (Istep*(Max(I,J)-Min(I,J)))/Nframes 1 +Min(I,J) 10 CONTINUE 666 RETURN END C C This routine reads the color table in file fname, and maps it by C linear interpolation into the interval between color indices C min and max inclusive. The color table in the file is assumed C to contain all indices between some minimum and maximum value C of the color index. The maximum allowed value of the color indices C in the table is Mtblsz, set below. Ierror returns 0 if everything C went OK, 1 if it was impossible to open the file, and 2 if it was C impossible to read from the file. C SUBROUTINE Getctb(Min,Max,Fname,Ierror) C IMPLICIT NONE CHARACTER*(*) Fname INTEGER Min,Max,I,Ierror,Maxdup,Mindup INTEGER Mtblsz PARAMETER (Mtblsz=256) REAL Rarray(Mtblsz),Garray(Mtblsz),Barray(Mtblsz) LOGICAL Cstflg(Mtblsz) COMMON /Clrcom/Rarray,Garray,Barray,Cstflg External Rdclis C C Check that the given Min and Max are acceptable, and correct if C necessary. C Maxdup= Max Mindup= Min IF (Mindup.LT.0) Mindup= 0 IF (Maxdup.LT.0) Maxdup= 0 IF (Maxdup.GT.Mtblsz-1) Maxdup= Mtblsz-1 IF (Mindup.GT.Mtblsz-1) Mindup= Mtblsz-1 IF (Maxdup.LT.Mindup) Maxdup= Mindup C C Read in the color table C CALL Rdclis(Rarray,Garray,Barray,Mtblsz,Mindup,Maxdup, 1 Fname,Ierror) IF (Ierror.NE.0) RETURN C C Set the 'color set' flags. C DO 30 I= Mindup,Maxdup Cstflg(I+1)= .TRUE. 30 CONTINUE Ierror= 0 666 RETURN END C C This routine dumps the current working color table, from color C index min to color index max inclusive, to the file fname. C ierror returns 0 if everything went OK, 1 if the file could not C be opened, and 2 if an error occurred writing to the file. C SUBROUTINE Putctb(Min,Max,Fname,Ierror) C IMPLICIT NONE CHARACTER*(*) Fname INTEGER Mtblsz PARAMETER (Mtblsz=256) INTEGER Min,Max,Ierror REAL Rarray(Mtblsz),Garray(Mtblsz),Barray(Mtblsz) LOGICAL Cstflg(Mtblsz) COMMON /Clrcom/Rarray,Garray,Barray,Cstflg EXTERNAL Wrclis CALL Wrclis(Rarray,Garray,Barray,Mtblsz,Min,Max,Fname,Ierror) 666 RETURN END C C This routine draws a graph of the color intensities of the C color bar, in the rectangle given. irclr,igclr, and ibclr are C used to trace out the color curves for red, green, and blue C respectively. Color table entries between minclr and maxclr C inclusive are plotted. C SUBROUTINE Pltbar(Xmin,Ymin,Xmax,Ymax,Minclr,Maxclr, 1 Irclr,Igclr,Ibclr) C IMPLICIT NONE INTEGER Mincdp,Maxcdp,Minclr,Maxclr,Irclr,Igclr,Ibclr INTEGER I,Mtblsz PARAMETER (Mtblsz=256) REAL Rarray(Mtblsz),Garray(Mtblsz),Barray(Mtblsz) REAL X(Mtblsz),Y(5),Xmin,Ymin,Xmax,Ymax,Xsize,Ysize REAL Ybmin,Ybmax,Ygmin,Ygmax,Yrmin,Yrmax,Xcmin,Xstep REAL Rval,Gval,Bval LOGICAL Setflg EXTERNAL Getclr,Clrrct,Linclr,Plylin C C -set up coordinates C Mincdp= Minclr Maxcdp= Maxclr IF (Mincdp.LT.0) Mincdp= 0 IF (Maxcdp.LT.0) Maxcdp= 0 IF (Maxcdp.GE.Mtblsz) Maxcdp= Mtblsz-1 IF (Mincdp.GE.Mtblsz) Mincdp= Mtblsz-1 IF (Mincdp.GT.Maxcdp) Maxcdp= Mincdp Xsize= Xmax-Xmin Ysize= (Ymax-Ymin)/3.0 Ybmin= Ymin Ybmax= Ybmin+Ysize Ygmin= Ybmax Ygmax= Ygmin+Ysize Yrmin= Ygmax Yrmax= Yrmin+Ysize Xcmin= Xmin IF (Maxcdp.GT.Mincdp) THEN Xstep= Xsize/(Maxcdp-Mincdp) ELSE Xstep= 0.0 END IF C C Get the color table, translating values into y coordinates. C DO 10 I= 0,Maxcdp-Mincdp CALL Getclr(I+Mincdp,Rval,Gval,Bval,SetFlg) Rarray(I+1)= Yrmin +Rval*Ysize Garray(I+1)= Ygmin +Gval*Ysize Barray(I+1)= Ybmin +Bval*Ysize 10 X(I+1)= Xcmin+ I*Xstep C C Clear the drawing area C CALL Clrrct(Xmin,Ymin,Xmax,Ymax) C C Draw the curves for the case of maxclr >minclr, or alternately C the degenerate case (maxclr=minclr). C IF (Maxcdp.GT.Mincdp) THEN CALL Linclr(Irclr) CALL Plylin(Maxcdp-Mincdp+1,X,Rarray) CALL Linclr(Igclr) CALL Plylin(Maxcdp-Mincdp+1,X,Garray) CALL Linclr(Ibclr) CALL Plylin(Maxcdp-Mincdp+1,X,Barray) ELSE Rarray(2)= Rarray(1) Garray(2)= Garray(1) Barray(2)= Barray(1) X(2)= Xmax CALL Linclr(Irclr) CALL Plylin(2,X,Rarray) CALL Linclr(Igclr) CALL Plylin(2,X,Garray) CALL Linclr(Ibclr) CALL Plylin(2,X,Barray) END IF C C Draw a rectangle around the drawing area, and individual rectangles C around the curves. C X(1)= Xmin X(2)= Xmax X(3)= Xmax X(4)= Xmin X(5)= Xmin y(1)= Yrmin y(2)= Yrmin y(3)= Yrmax y(4)= Yrmax y(5)= Yrmin CALL Linclr(Irclr) CALL Plylin(5,X,y) X(1)= Xmin X(2)= Xmax X(3)= Xmax X(4)= Xmin X(5)= Xmin y(1)= Ygmin y(2)= Ygmin y(3)= Ygmax y(4)= Ygmax y(5)= Ygmin CALL Linclr(Igclr) CALL Plylin(5,X,y) X(1)= Xmin X(2)= Xmax X(3)= Xmax X(4)= Xmin X(5)= Xmin y(1)= Ybmin y(2)= Ybmin y(3)= Ybmax y(4)= Ybmax y(5)= Ybmin CALL Linclr(Ibclr) CALL Plylin(5,X,y) X(1)= Xmin X(2)= Xmax X(3)= Xmax X(4)= Xmin X(5)= Xmin y(1)= Ymin y(2)= Ymin y(3)= Yrmax y(4)= Yrmax y(5)= Ymin CALL Linclr(1) CALL Plylin(5,X,y) 666 RETURN END C C This routine clears a rectangular area of the display (corner C coords (Xmin,Ymin) and (Xmax,Ymax) by drawing over it with the C background color. C SUBROUTINE Clrrct(Xmin,Ymin,Xmax,Ymax) C IMPLICIT NONE REAL X(4),Y(4),Xmin,Ymin,Xmax,Ymax EXTERNAL Filclr,Plygon X(1)= Xmin X(2)= Xmax X(3)= Xmax X(4)= Xmin Y(1)= Ymin Y(2)= Ymin Y(3)= Ymax Y(4)= Ymax CALL Filclr(0) CALL Plygon(4,X,Y) 666 RETURN END C C This routine inverts the image left-to-right, in place. C SUBROUTINE Horflp(Ipixel,Nxdim,Nydim) C IMPLICIT NONE INTEGER Nxdim,Nydim,Ipixel(Nxdim,Nydim) INTEGER Ileft,J,Pxltmp,Iright Iright= Nxdim+1 DO 10 Ileft= 1,Nxdim/2 Iright= Iright-1 DO 10 J= 1,Nydim Pxltmp= Ipixel(Ileft,J) Ipixel(Ileft,J)= Ipixel(Iright,J) Ipixel(Iright,J)= Pxltmp 10 CONTINUE 666 RETURN END C C This routine inverts the image top-to-bottom, in place. C SUBROUTINE Vrtflp(Ipixel,Nxdim,Nydim) C IMPLICIT NONE INTEGER Nxdim,Nydim,Ipixel(Nxdim,Nydim) INTEGER I,Jtop,Pxltmp,Jbot Jbot= Nydim+1 DO 10 Jtop= 1,Nydim/2 Jbot= Jbot-1 DO 10 I= 1,Nxdim Pxltmp= Ipixel(I,Jtop) Ipixel(I,Jtop)= Ipixel(I,Jbot) Ipixel(I,Jbot)= Pxltmp 10 CONTINUE 666 RETURN END C C This routine reads the color list in file fname, and maps it by C linear interpolation into the interval between color indices C min+1 and max+1 inclusive in the r,g,and b color arrays. The C color table in the file is assumed to contain all indices C between some minimum and maximum value of the color index. C The maximum allowed value of the color indices in the table C is Mtblsz, set below. Ierror returns 0 if everything went C OK, 1 if it was impossible to open the file, 2 if it was C impossible to read from the file, and 3 if min or max would C result in writing outside the bounds of the color array. C SUBROUTINE Rdclis(Rarray,Garray,Barray,Nclrs,Min,Max, 1 Fname,Ierror) C IMPLICIT NONE CHARACTER*(*) Fname INTEGER Min,Max,Nclrs,I,Ierror,Itbl,Maxtbl,Mintbl,Mtblsz, 1 Mindup,Maxdup PARAMETER (Mtblsz=256) REAL Rarray(Nclrs),Garray(Nclrs),Barray(Nclrs) REAL Rraw(Mtblsz),Graw(Mtblsz),Braw(Mtblsz) REAL Interp,V1,V2,X,Rval,Gval,Bval,Stride,Rloc,Gap Interp(V1,V2,X)= (1.0-X)*V1 + X*V2 C C Check array bounds C IF (Min.LT.0.OR.Max.GE.Nclrs.OR.Min.GT.Max) THEN Ierror= 3 RETURN END IF C C Read in the color table C Maxtbl= 0 Mintbl= Mtblsz-1 OPEN(UNIT=99,FILE=Fname,STATUS='OLD',ERR=40) 10 READ(99,*,END=20,ERR=50) Itbl,Rval,Gval,Bval IF (Itbl.GT.Mtblsz-1) GOTO 10 IF (Itbl.LT.0) GOTO 10 Rraw(Itbl+1)= Rval Graw(Itbl+1)= Gval Braw(Itbl+1)= Bval IF (Itbl.GT.Maxtbl) Maxtbl= Itbl IF (Itbl.LT.Mintbl) Mintbl= Itbl GOTO 10 C C Map it into the requested interval C 20 Maxdup= Max Mindup= Min IF (Mindup.LT.0) Mindup= 0 IF (Maxdup.LT.0) Maxdup= 0 IF (Maxdup.GT.Mtblsz-1) Maxdup= Mtblsz-1 IF (Mindup.GT.Mtblsz-1) Mindup= Mtblsz-1 IF (Maxdup.LT.Mindup) Maxdup= Mindup IF (Maxdup.GT.Mindup) THEN Stride= FLOAT(Maxtbl-Mintbl)/FLOAT(Maxdup-Mindup) ELSE Stride= 0.0 END IF Rloc= Mintbl DO 30 I= Mindup+1,Maxdup+1 Itbl= Rloc Gap= Rloc-Itbl Rarray(I)= Interp(Rraw(Itbl+1),Rraw(Itbl+2),Gap) Garray(I)= Interp(Graw(Itbl+1),Graw(Itbl+2),Gap) Barray(I)= Interp(Braw(Itbl+1),Braw(Itbl+2),Gap) 30 Rloc= Rloc+Stride CLOSE(UNIT=99) Ierror= 0 666 RETURN C C Error handling: open error, then read error. C 40 Ierror= 1 RETURN 50 Ierror= 2 RETURN END C C This routine dumps the r, g, and b color arrays, from array C index min+1 to array index max+1 inclusive, to the file fname. C ierror returns 0 if everything went OK, 1 if the file could not C be opened, or 2 if an error occurred writing to the file. C SUBROUTINE Wrclis(Rarray,Garray,Barray,Nclrs,Min,Max, 1 Fname,Ierror) C IMPLICIT NONE CHARACTER*(*) Fname INTEGER Min,Max,Nclrs,I,Ierror,Maxdup,Mindup,Mtblsz PARAMETER (Mtblsz=256) REAL Rarray(Nclrs),Garray(Nclrs),Barray(Nclrs) OPEN(UNIT=99,FILE=Fname,STATUS='NEW',ERR=20) C C Check array bounds C Maxdup= Max Mindup= Min IF (Mindup.LT.0) Mindup= 0 IF (Maxdup.LT.0) Maxdup= 0 IF (Maxdup.GT.Mtblsz-1) Maxdup= Mtblsz-1 IF (Mindup.GT.Mtblsz-1) Mindup= Mtblsz-1 IF (Maxdup.LT.Mindup) Maxdup= Mindup C C Write out the color table C DO 10 I= Min+1,Max+1 10 WRITE(99,*,ERR=30) I-1,Rarray(I),Garray(I),Barray(I) CLOSE(UNIT=99) Ierror= 0 666 RETURN C C Error handling: open error, then write error. C 20 Ierror= 1 RETURN 30 Ierror= 2 RETURN END C C This routine sets color 'index' to the red, green, and blue values C given. It is included to insulate the user level from the base C level subroutine calls. C SUBROUTINE Setclr(Index,Rval,Gval,Bval) C IMPLICIT NONE INTEGER Mtblsz PARAMETER (Mtblsz=256) INTEGER Index REAL Rval,Gval,Bval REAL Rarray(Mtblsz),Garray(Mtblsz),Barray(Mtblsz) LOGICAL Cstflg(Mtblsz) COMMON /Clrcom/Rarray,Garray,Barray,Cstflg C DATA Cstflg/Mtblsz*.FALSE./ IF (Index.GE.0.AND.Index.LT.Mtblsz) THEN Rarray(Index+1)= Rval Garray(Index+1)= Gval Barray(Index+1)= Bval Cstflg(Index+1)= .TRUE. END IF 666 RETURN END C C This routine gets the red, green, and blue values associated with C the color index given. It is included to insulate the user level C from the base level subroutine calls. Setflg is .true. if the C particular color index has been set. If the color index has not C been set, Setflg returns .false. and Rval, Gval, and Bval are all C zero. C SUBROUTINE Getclr(Index,Rval,Gval,Bval,Setflg) C IMPLICIT NONE INTEGER Index REAL Rval,Gval,Bval INTEGER Mtblsz PARAMETER (Mtblsz=256) Real Rarray,Garray,Barray LOGICAL Cstflg,Setflg COMMON /Clrcom/Rarray(Mtblsz),Garray(Mtblsz),Barray(Mtblsz), * Cstflg(Mtblsz) IF (Cstflg(Index+1)) THEN Rval= Rarray(Index+1) Gval= Garray(Index+1) Bval= Barray(Index+1) Setflg= .TRUE. ELSE Rval= 0.0 Gval= 0.0 Bval= 0.0 Setflg= .FALSE. END IF 666 RETURN END C C This routine sets the output device. The setting is made C immediately; an appropriate output file name is saved C for later use by Grfini. C SUBROUTINE Device(Devnam) C IMPLICIT NONE CHARACTER*(*) Devnam INTEGER Ierr LOGICAL Iniflg,Psflg,Devflg CHARACTER*10 Filnam COMMON /Drwstt/Iniflg,Psflg,Devflg COMMON /Drwchr/Filnam EXTERNAL Setdev IF (Devflg) THEN WRITE(6,*) 1 ' ***warning*** device already set; call to DEVICE ignored' ELSE Ierr= 0 CALL Setdev(Devnam,Ierr) IF (Ierr.NE.0) THEN WRITE(6,*) 1 ' ***error*** setdev returned ierr=',Ierr RETURN ENDIF IF ((Devnam.EQ.'tek') 1 .OR.(Devnam(1:1).EQ.'x') 2 .OR. (Devnam(1:3).EQ.'uis') 3 .OR.(Devnam(1:3).EQ.'gks') 4 .OR.(Devnam(1:3).EQ.'igl') 5 .OR.(Devnam(1:7).EQ.'peritek')) THEN Filnam= '-' ELSE Filnam= 'CGMOUT' ENDIF Devflg= .TRUE. ENDIF 666 RETURN END C C Graphics initializer follows. It knows if it has been called C before in this run (via the variable Iniflg), and will do no C harm if called twice. It will use a device name if it has C been set (via Device), or the default name CGMOUT if none C has been set. C SUBROUTINE Grfini C IMPLICIT NONE INTEGER Mtblsz PARAMETER (Mtblsz=256) INTEGER Mxclr,I,Ierr,Nclrs,Minclr REAL Rarray(Mtblsz),Garray(Mtblsz),Barray(Mtblsz) LOGICAL Cstflg(Mtblsz),Iniflg,Psflg,Devflg CHARACTER*10 Filnam COMMON /Drwstt/Iniflg,Psflg,Devflg COMMON /Drwchr/Filnam COMMON /Clrcom/Rarray,Garray,Barray,Cstflg EXTERNAL Wrtopn,Wrmxci,Wrbegp,Wrbgpb,Wristl,Wrctbl DATA Iniflg/.FALSE./, Psflg/.FALSE./, Devflg/.FALSE./ IF (Iniflg) RETURN IF (.NOT.Devflg) THEN Filnam= 'CGMOUT' Devflg= .TRUE. ENDIF Mxclr= Mtblsz - 1 Ierr= 0 CALL Wrtopn(Filnam,Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wrtopn returned ierr=',Ierr CALL Wrmxci(Mxclr,Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wrmxci returned ierr=',Ierr CALL Wrbegp(Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wrbegp returned ierr=',Ierr CALL Wrbgpb(Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wrbgpb returned ierr=',Ierr CALL Wristl(1,Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wristl returned ierr=',Ierr Minclr= 1 Nclrs= 0 DO 10 I= 1,Mtblsz IF (Cstflg(I)) THEN IF (Nclrs.EQ.0) Minclr= I Nclrs= Nclrs + 1 ELSE IF (Nclrs.GT.0) THEN CALL Wrctbl(Rarray(Minclr),Garray(Minclr), 1 Barray(Minclr),Minclr-1,Nclrs,Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) 2 ' ***error*** wrctbl returned ierr=', 3 Ierr Nclrs= 0 END IF 10 CONTINUE IF (Nclrs.GT.0) THEN CALL Wrctbl(Rarray(Minclr),Garray(Minclr), 1 Barray(Minclr),Minclr-1,Nclrs,Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) 2 ' ***error*** wrctbl returned ierr=', 3 Ierr END IF Iniflg= .TRUE. 666 RETURN END C C Graphics shutdown routine follows. C SUBROUTINE Grfcls C IMPLICIT NONE INTEGER Ierr LOGICAL Iniflg,Psflg,Devflg COMMON /Drwstt/Iniflg,Psflg,Devflg EXTERNAL Wrendp,Wrtend Ierr= 0 CALL Wrendp(Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wrendp returned ierr=',Ierr IF (Psflg) THEN WRITE(6,10) Char(7) 10 FORMAT(A$) READ(5,*) END IF CALL Wrtend(Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wrtend returned ierr=',Ierr Iniflg= .FALSE. 666 RETURN END C C This routine ends a frame, and begins the next. Color table C entries which have been set are written to the new frame C automatically. Newfrm calls Grfini if necessary. C SUBROUTINE Newfrm C IMPLICIT NONE INTEGER Ierr,I,Mtblsz,Minclr,Nclrs PARAMETER (Mtblsz=256) REAL Rarray(Mtblsz),Garray(Mtblsz),Barray(Mtblsz) LOGICAL Cstflg(Mtblsz) COMMON /Clrcom/Rarray,Garray,Barray,Cstflg LOGICAL Iniflg,Psflg,Devflg COMMON /Drwstt/Iniflg,Psflg,Devflg EXTERNAL Wrendp,Wrbegp,Wrbgpb,Wristl,Wrctbl,Grfini IF (.NOT.Iniflg) THEN CALL Grfini() ELSE Ierr= 0 CALL Wrendp(Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wrendp returned ierr=',Ierr IF (Psflg) THEN WRITE(6,10) Char(7) 10 FORMAT(A$) READ(5,*) END IF CALL Wrbegp(Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wrbegp returned ierr=',Ierr CALL Wrbgpb(Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wrbgpb returned ierr=',Ierr CALL Wristl(1,Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wristl returned ierr=',Ierr Minclr= 1 Nclrs= 0 DO 20 I= 1,Mtblsz IF (Cstflg(I)) THEN IF ( Nclrs.EQ.0 ) Minclr= I Nclrs= Nclrs + 1 ELSE IF (Nclrs.GT.0) THEN CALL Wrctbl(Rarray(Minclr),Garray(Minclr), 1 Barray(Minclr),Minclr-1,Nclrs,Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) 2 ' ***error*** wrctbl returned ierr=', 3 Ierr Nclrs= 0 END IF 20 CONTINUE IF (Nclrs.GT.0) THEN CALL Wrctbl(Rarray(Minclr),Garray(Minclr), 1 Barray(Minclr),Minclr-1,Nclrs,Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) 2 ' ***error*** wrctbl returned ierr=', 3 Ierr END IF END IF 666 RETURN END C C This routine sets the color of filled polygons. C SUBROUTINE Filclr(Icolor) C IMPLICIT NONE INTEGER Icolor,Ierr EXTERNAL Wrpgnc Ierr= 0 CALL Wrpgnc(Icolor,Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wrpgnc returned ierr=',Ierr 666 RETURN END C C This routine draws polygons. C SUBROUTINE Plygon(Npts,X,Y) C IMPLICIT NONE INTEGER Npts,Ierr REAL X(Npts),Y(Npts) EXTERNAL Wrtpgn Ierr= 0 CALL Wrtpgn(X,Y,Npts,Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wrtpgn returned ierr=',Ierr 666 RETURN END C C This routine draws polylines. C SUBROUTINE Plylin(Npts,X,Y) C IMPLICIT NONE INTEGER Npts,Ierr REAL X(Npts),Y(Npts) EXTERNAL Wrplin Ierr= 0 CALL Wrplin(X,Y,Npts,Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wrplin returned ierr=',Ierr 666 RETURN END C C This routine sets the color of polylines. C SUBROUTINE Linclr(Icolor) C IMPLICIT NONE INTEGER Icolor,Ierr EXTERNAL Wrplnc Ierr= 0 CALL Wrplnc(Icolor,Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wrplnc returned ierr=',Ierr 666 RETURN END C C This routine draws polymarkers. C SUBROUTINE Plymrk(Npts,X,Y) C IMPLICIT NONE INTEGER Npts,Ierr REAL X(Npts),Y(Npts) EXTERNAL Wrtpmk Ierr= 0 CALL Wrtpmk(X,Y,Npts,Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wrtpmk returned ierr=',Ierr 666 RETURN END C C This routine sets the color of polymarkers. C SUBROUTINE Mrkclr(Icolor) C IMPLICIT NONE INTEGER Icolor,Ierr EXTERNAL Wrpmkc Ierr= 0 CALL Wrpmkc(Icolor,Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wrpmkc returned ierr=',Ierr 666 RETURN END C C This routine sets the marker type of polymarkers. The valid C values and their results are: 1:'.', 2:'+', 3:'*', 4:'o', 5:'x' C SUBROUTINE Mrktyp(Itype) C IMPLICIT NONE INTEGER Itype,Ierr EXTERNAL Wrpmkt Ierr= 0 CALL Wrpmkt(Itype,Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wrpmkt returned ierr=',Ierr 666 RETURN END C C This routine sets the size of polymarkers. The size given is C relative to the default size; 2.0 means twice as big, etc. C Note that '.' markers never scale; they are always as small C as possible. C SUBROUTINE Mrksiz(Size) C IMPLICIT NONE INTEGER Ierr REAL Size EXTERNAL Wrpmks Ierr= 0 CALL Wrpmks(Size,Ierr) IF (Ierr.NE.0) 1 WRITE(6,*) ' ***error*** wrpmks returned ierr=',Ierr 666 RETURN END C C This routine converts a real array to integers, given ranges. C SUBROUTINE Rtoint(Rarray,Iarray,Nxdim,Nydim,Rmn,Rmx,Imn,Imx) C IMPLICIT NONE INTEGER Nxdim,Nydim,Imn,Imx,Irange,I,J,Iarray(Nxdim,Nydim) REAL Rarray(Nxdim,Nydim),Rmn,Rmx,Rrange Rrange= Rmx-Rmn IF (Rrange.EQ.0.0) THEN WRITE(6,*) ' ***error*** rtoint called with rmx=rmn ' RETURN END IF Irange= Imx-Imn DO 10 I= 1,Nxdim DO 10 J= 1,Nydim Iarray(I,J)= 1 INT(Irange*(Rarray(I,J)-Rmn)/Rrange+Imn) 10 CONTINUE RETURN END SUBROUTINE Movcgm(X,Y) C----------------------------------------------------------------------- C ADDED 11 January 1989 by Chris BeHanna C AUTHOR: John Burkardt C This routine moves to a user-specified point with the "plotting pen" C up. C----------------------------------------------------------------------- C IMPLICIT NONE REAL X,Y,XD(2),YD(2) SAVE XD,YD C----------------------------------------------------------------------- C Variables: C X - abscissa of user's point, scaled to value between 0. and 1. C Y - ordinate of user's point, scaled to value between 0. and 1. C XD,YD - place to save user's points so Drwcgm will know where to draw C from when it's asked to draw to a point C----------------------------------------------------------------------- XD(1) = X YD(1) = Y RETURN C C Second entry point: draw from previous point set by movcgm to point C specified in drwcgm with "plotting pen" down: C ENTRY Drwcgm(X,Y) XD(2) = X YD(2) = Y CALL Plylin(2,XD,YD) XD(1) = X YD(1) = Y RETURN END C C This routine sets the coordinate system for drawing. The given C input arrays specify the x and y locations of a set of points; C the drawing coordinate system is set so that the aspect ratio C of the coordinates is preserved but the set of points is framed C within the display boundaries. The most widely separated C points in the most widely separated direction will be placed C 5 percent of the device width from the window sides. No C rotation is used. C SUBROUTINE Setscl(Xcoord,Ycoord,Npts) C IMPLICIT NONE INTEGER Npts,I,Ierr REAL Xcoord(Npts),Ycoord(Npts),Xmin,Xmax,Ymin,Ymax, 1 Xrange,Yrange,Xave,Yave,Margin PARAMETER (Margin=0.525) C C Find the extremes in each direction. C Xmin= Xcoord(1) Xmax= Xcoord(1) Ymin= Ycoord(1) Ymax= Ycoord(1) DO 10 I= 2,Npts IF ( Xcoord(I).LT.Xmin ) Xmin= Xcoord(I) IF ( Xcoord(I).GT.Xmax ) Xmax= Xcoord(I) IF ( Ycoord(I).LT.Ymin ) Ymin= Ycoord(I) IF ( Ycoord(I).GT.Ymax ) Ymax= Ycoord(I) 10 CONTINUE Xrange= Xmax - Xmin Yrange= Ymax - Ymin Xave= Xmin + 0.5*Xrange Yave= Ymin + 0.5*Yrange C C If the coordinate ranges are zero in both directions, exit C with an error message. C If ( (Xrange.EQ.0.0) .AND. (Yrange.EQ.0.0) ) THEN WRITE(6,*) 1 ' ***error*** Coordinate ranges degenerate in SETSCL' WRITE(6,*) 1 ' Coordinates not rescaled' RETURN END IF C C Two cases: If the span in the X direction is greater, set C coordinates so that direction is optimally framed. The C factor of Margin provides a 5 percent margin around the given C points. C Ierr= 0 IF (Xrange.GE.Yrange) THEN CALL Setwcd( Xave-Margin*Xrange, Yave-Margin*Xrange, 1 Xave+Margin*Xrange, Yave+Margin*Xrange, Ierr ) IF (Ierr.NE.0) WRITE(6,*) 1 ' ***error*** setwcd returned ierr=',Ierr C C Otherwise, set coordinates so that the Y direction is C optimally framed. C ELSE CALL Setwcd( Xave-Margin*Xrange, Yave-Margin*Xrange, 1 Xave+Margin*Xrange, Yave+Margin*Xrange, Ierr ) IF (Ierr.NE.0) WRITE(6,*) 1 ' ***error*** setwcd returned ierr=',Ierr END IF RETURN END C C This routine sets the 'pause' flag, Psflg, so that the user C will be asked to hit return at each end of frame. C SUBROUTINE Stpaus() C IMPLICIT NONE LOGICAL Iniflg,Psflg,Devflg COMMON /Drwstt/Iniflg,Psflg,Devflg Psflg= .TRUE. RETURN END C C This routine clears the 'pause' flag, Psflg, so that the user C will be not asked to hit return at each end of frame. C SUBROUTINE Unpaus() C IMPLICIT NONE LOGICAL Iniflg,Psflg,Devflg COMMON /Drwstt/Iniflg,Psflg,Devflg Psflg= .FALSE. RETURN END