cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c c Drawcgm_test.For v. 1.0 (12/87) c c Copyright 1987 Pittsburgh Supercomputing Center c c Authors Joel Welling and Jonathan Goldick c c This is one of two test routines for Drawcgm.for c c c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C IMPLICIT NONE INTEGER Maxclr,Minclr,Ierr PARAMETER (Maxclr=247,Minclr=20) EXTERNAL Getctb,Setclr,Grfini,Grfcls,Test1,Test2,Test3, 1 Test4,Test5,Test6,Test7,Stpaus,Unpaus,Device C EXTERNAL Exit * * Read in part of the color table, and add a couple of entries * by hand. Getctb reads DRAWCGM's internal floating point color * arrays from the named files, mapping them by linear * interpolation into the array entries bounded by the 1st and * 2nd parameters. Note that (by tradition) the color table * entries are numbered from zero, so that the minimum acceptable * value of the first parameter is zero. Color index zero * corresponds to the background color. Ierr returns 0 if all * went OK. * CALL Device('tek') CALL Getctb(Minclr,Maxclr,'COLORS.DAT',Ierr) IF (Ierr.NE.0) then WRITE(6,*) ' Getctb returned ',Ierr CALL Exit(2) ENDIF CALL Setclr(0,1.0,1.0,1.0) CALL Setclr(1,0.0,0.0,0.0) * * Initialize the CGM generator and begin output * CALL Grfini() * * Call the test routines. * CALL Test1() CALL Stpaus() CALL Test2() CALL Test3() CALL Test4() CALL Unpaus() CALL Test5() CALL Test6() CALL Stpaus() CALL Test7() * * Shut down the CGM generator and close output * CALL Grfcls END SUBROUTINE Getdat(Input,Nxdim,Nydim) C IMPLICIT NONE INTEGER Nxdim,Nydim,I,J REAL Input(Nxdim,Nydim) INTRINSIC Float,Mod DO 10 i= 1,Nxdim DO 10 j= 1,Nydim Input(i,j)= Float(I+J)/(2.0*Nxdim) * Input(i,j)= float(Mod((i*j),Nxdim))/Nxdim 10 CONTINUE RETURN END SUBROUTINE Test1() C IMPLICIT NONE INTEGER Nxsmall,Nysmall,Nxbig,Nybig PARAMETER (Nxsmall=10,Nysmall=10,Nxbig=300,Nybig=300) REAL Xmin,Ymin,Xmax,Ymax,Xmincb,Xmaxcb,Xlabel,Ylabel PARAMETER (Xmin= 0.1,Ymin=0.2,Xmax= 0.7,Ymax=0.8) PARAMETER (Xmincb=0.78, Xmaxcb=0.88, Xlabel=0.1, Ylabel=0.93) INTEGER Maxclr,Minclr PARAMETER (Maxclr=247,Minclr=20) INTEGER Ipixel(Nxbig,Nybig) REAL Input(Nxsmall,Nysmall),Pixel(Nxbig,Nybig) EXTERNAL Label,Strlin,Rtoint,Drawit,Vrtcbr,Getdat * * Get the data. (This routine is in this module) * CALL Getdat(Input,Nxsmall,Nysmall) * * Use linear interpolation to stretch the data, map it into * integers, draw it, and add a vertical color bar. * CALL Label(Xlabel,Ylabel,'Stretch by Linear Interp.', 1 1,0.03) CALL Strlin(Input,Nxsmall,Nysmall,Pixel,Nxbig,Nybig) CALL Rtoint(Pixel,Ipixel,Nxbig,Nybig,0.0,1.0,Minclr,Maxclr) CALL Drawit(Ipixel,Nxbig,Nybig,Xmin,Ymin,Xmax,Ymax) CALL Vrtcbr(Xmincb,Ymin,Xmaxcb,Ymax, 1 Minclr,Maxclr,'1e-7','1e+3',1,0.03) RETURN END SUBROUTINE Test2() C IMPLICIT NONE INTEGER Nxsmall,Nysmall,Nxbig,Nybig PARAMETER (Nxsmall=10,Nysmall=10,Nxbig=300,Nybig=300) REAL Xmin,Ymin,Xmax,Ymax,Xmincb,Xmaxcb,Xlabel,Ylabel PARAMETER (Xmin= 0.1,Ymin=0.2,Xmax= 0.7,Ymax=0.8) PARAMETER (Xmincb=0.78, Xmaxcb=0.88, Xlabel=0.1, Ylabel=0.93) INTEGER Maxclr,Minclr PARAMETER (Maxclr=247,Minclr=20) INTEGER Ipixel(Nxbig,Nybig) REAL Input(Nxsmall,Nysmall),Temp(Nxsmall,Nysmall), 1 Pixel(Nxbig,Nybig) EXTERNAL Label,Strspl,Rtoint,Drawit,Vrtcbr,Newfrm,Getdat * * Get the data. (This routine is in this module) * CALL Getdat(Input,Nxsmall,Nysmall) * * Stretch the data by spline interpolation, and draw it again. * CALL Newfrm() CALL Label(Xlabel,Ylabel,'Stretch by Spline Interp.', 1 1,0.03) CALL Strspl(Input,Temp,Nxsmall,Nysmall,Pixel,Nxbig,Nybig) CALL Rtoint(Pixel,Ipixel,Nxbig,Nybig,0.0,1.0,Minclr,Maxclr) CALL Drawit(Ipixel,Nxbig,Nybig,Xmin,Ymin,Xmax,Ymax) CALL Vrtcbr(Xmincb,Ymin,Xmaxcb,Ymax, 1 Minclr,Maxclr,'1e-7','1e+3',1,0.03) RETURN END SUBROUTINE Test3() C IMPLICIT NONE INTEGER Nxsmall,Nysmall,Nxbig,Nybig,Nxmask,Nymask PARAMETER (Nxsmall=10,Nysmall=10,Nxbig=300,Nybig=300) PARAMETER (Nxmask=3,Nymask=3) REAL Xmin,Ymin,Xmax,Ymax,Xlabel,Ylabel PARAMETER (Xmin= 0.1,Ymin=0.2,Xmax= 0.7,Ymax=0.8) PARAMETER (Xlabel=0.1, Ylabel=0.93) INTEGER Maxclr,Minclr PARAMETER (Maxclr=247,Minclr=20) INTEGER Ipixel(Nxbig,Nybig),Mfield(Nxmask,Nymask) REAL Input(Nxsmall,Nysmall),Pixel(Nxbig,Nybig) EXTERNAL Label,Strlin,Rtoint,Imgmsk,Winfrm,Drawit,Newfrm,Getdat DATA Mfield/1,1,1,1,0,0,1,1,1/ * * Get the data. (This routine is in this module) * CALL Getdat(Input,Nxsmall,Nysmall) * * Mask out a C-shaped region of the image, and draw it again. Add * a frame delimiting the animation system boundary. * CALL Newfrm() CALL Label(Xlabel,Ylabel,'Mask and Window Frame', 1 1,0.03) CALL Strlin(Input,Nxsmall,Nysmall,Pixel,Nxbig,Nybig) CALL Rtoint(Pixel,Ipixel,Nxbig,Nybig,0.0,1.0,Minclr,Maxclr) CALL Imgmsk(Mfield,Nxmask,Nymask,Ipixel,Nxbig,Nybig) CALL Drawit(Ipixel,Nxbig,Nybig,Xmin,Ymin,Xmax,Ymax) CALL Winfrm() RETURN END SUBROUTINE Test4() C IMPLICIT NONE INTEGER Nxsmall,Nysmall,Nxmed,Nymed REAL Xlabel,Ylabel PARAMETER (Nxsmall=10,Nysmall=10) PARAMETER (Nxmed=150,Nymed=150) PARAMETER (Xlabel=0.1, Ylabel=0.93) REAL Xmnmed1,Ymnmed1,Xmxmed1,Ymxmed1 PARAMETER (Xmnmed1= 0.1,Ymnmed1=0.5,Xmxmed1=0.4,Ymxmed1=0.8) REAL Xmnmed2,Ymnmed2,Xmxmed2,Ymxmed2 PARAMETER (Xmnmed2= 0.4,Ymnmed2=0.5,Xmxmed2=0.7,Ymxmed2=0.8) REAL Xmnmed3,Ymnmed3,Xmxmed3,Ymxmed3 PARAMETER (Xmnmed3= 0.1,Ymnmed3=0.2,Xmxmed3=0.4,Ymxmed3=0.5) REAL Xmnmed4,Ymnmed4,Xmxmed4,Ymxmed4 PARAMETER (Xmnmed4= 0.45,Ymnmed4=0.15,Xmxmed4=0.75,Ymxmed4=0.45) INTEGER Maxclr,Minclr PARAMETER (Maxclr=247,Minclr=20) INTEGER Ismimg1(Nxmed,Nymed),Ismimg2(Nxmed,Nymed), 1 Ismimg3(Nxmed,Nymed) REAL Input(Nxsmall,Nysmall),Smimg(Nxmed,Nymed) EXTERNAL Label,Strlin,Rtoint,Cpyint,Horflp,Vrtflp,Interp, 1 Drawit,Newfrm,Getdat * * Get the data. (This routine is in this module) * CALL Getdat(Input,Nxsmall,Nysmall) * * Scale the data up the make a medium-sized image, and make a * copy of it. Take one copy and plot it, flip it horizontally, * plot it again, flip it vertically, and plot it again. * Finally, interpolate between the other copy of the original * image and the result of the inversions and plot the resulting * image. The interpolated image should be a constant color. * CALL Newfrm() CALL Label(Xlabel,Ylabel,'Copy, Flips, and Interpolation', 1 1,0.03) CALL Strlin(Input,Nxsmall,Nysmall,Smimg,Nxmed,Nymed) CALL Rtoint(Smimg,Ismimg1,Nxmed,Nymed,0.0,1.0,Minclr,Maxclr) CALL Cpyint(Ismimg1,Ismimg2,Nxmed,Nymed) CALL Drawit(Ismimg1,Nxmed,Nymed,Xmnmed1,Ymnmed1,Xmxmed1,Ymxmed1) CALL Horflp(Ismimg1,Nxmed,Nymed) CALL Drawit(Ismimg1,Nxmed,Nymed,Xmnmed2,Ymnmed2,Xmxmed2,Ymxmed2) CALL Vrtflp(Ismimg1,Nxmed,Nymed) CALL Drawit(Ismimg1,Nxmed,Nymed,Xmnmed3,Ymnmed3,Xmxmed3,Ymxmed3) CALL Interp(Ismimg1,Ismimg2,Ismimg3,Nxmed,Nymed,5,8) CALL Drawit(Ismimg3,Nxmed,Nymed,Xmnmed4,Ymnmed4,Xmxmed4,Ymxmed4) RETURN END SUBROUTINE Test5() C IMPLICIT NONE REAL Xlabel,Ylabel PARAMETER (Xlabel=0.1, Ylabel=0.93) REAL Xminpt,Yminpt,Xmaxpt,Ymaxpt,Xminhb,Yminhb,Xmaxhb,Ymaxhb PARAMETER (Xminpt= 0.1,Yminpt=0.5,Xmaxpt= 0.8,Ymaxpt=0.9) PARAMETER (Xminhb= 0.1,Yminhb=0.2,Xmaxhb= 0.8,Ymaxhb=0.45) INTEGER I EXTERNAL Label,Setctb,Setclr,Pltbar,Horcbr,Newfrm * * Do a series of frames of the various color tables available from * Setctb. * DO 10 I= 1,5 CALL Setctb(I) CALL Setclr(2,1.0,0.0,0.0) CALL Setclr(3,0.0,1.0,0.0) CALL Setclr(4,0.0,0.0,1.0) CALL Newfrm() CALL Label(Xlabel,Ylabel,'Standard Color Bars.', 1 1,0.03) CALL Pltbar(Xminpt,Yminpt,Xmaxpt,Ymaxpt,2,256, 1 2,3,4) CALL Horcbr(Xminhb,Yminhb,Xmaxhb,Ymaxhb, 1 2,256,'1e-7','1e+3',1,0.03) 10 CONTINUE RETURN END SUBROUTINE Test6() REAL Xarr1(4),Yarr1(4),Xarr2(4),Yarr2(4),Xarr3(4),Yarr3(4), 1 Xmark(5),Ymark(5),Xlabel,Ylabel EXTERNAL Label,Setscl,Movcgm,Drwcgm,Newfrm,Square DATA Xarr1/-5.0,-5.0,5.0,5.0/ DATA Yarr1/-5.0,5.0,5.0,-5.0/ DATA Xarr2/-5.0,0.0,5.0,0.0/ DATA Yarr2/0.0,5.0,0.0,-5.0/ DATA Xarr3/-2.5,-2.5,2.5,2.5/ DATA Yarr3/-2.5,2.5,2.5,-2.5/ DATA Xmark/0.5,0.125,0.125,0.875,0.875/ DATA Ymark/0.5,0.125,0.875,0.125,0.875/ DATA Xlabel,Ylabel/0.03,0.93/ * * Test Setscl, DRWCGM, and MOVCGM routines by drawing three * nested squares with vertices that need scaling. Also test * the polymarker support routines by drawing some markers. * CALL Newfrm CALL Label(Xlabel,Ylabel,'Scaled Squares',1,0.03) * * Do some polymarkers. * CALL Mrkclr(2) CALL Mrktyp(2) CALL Mrksiz(3.0) CALL Plymrk(5,Xmark,Ymark) * * Rescale coordinates * CALL Setscl(Xarr2,Yarr2,4) * * Outer square: * CALL Square(Xarr1,Yarr1) * * Middle square: * CALL Square(Xarr2,Yarr2) * * Inner square: * CALL Square(Xarr3,Yarr3) RETURN END SUBROUTINE Square(Xarray,Yarray) *----------------------------------------------------------------------- * Pittsburgh supercomputing Center Christopher BeHanna * 11 January 1989 * * Test DRAWCGM routines MOVDRW and DRWCGM by making a picture that's a * square. *----------------------------------------------------------------------- C IMPLICIT NONE REAL Xarray(4),Yarray(4) EXTERNAL Movcgm,Drwcgm * * Move to initial position: * CALL Movcgm(Xarray(1),Yarray(1)) * * Draw to 2nd vertex: * CALL Drwcgm(Xarray(2),Yarray(2)) * * Draw to 3rd vertex: * CALL Drwcgm(Xarray(3),Yarray(3)) * * Draw to 4th vertex: * CALL Drwcgm(Xarray(4),Yarray(4)) * * Close the square: * CALL Drwcgm(Xarray(1),Yarray(1)) RETURN END SUBROUTINE Test7() C IMPLICIT NONE INTEGER Ierr EXTERNAL Putctb * * Using the currently set colors, check the color table output * routines by writing color indices 1 through 4 to a file. The * results (in file CLROUT) should be (rgb)=(000),(100),(010), * and (001) * CALL Putctb(1,4,'CLROUT',Ierr) IF (Ierr.NE.0) then write(6,*) ' Putctb returned ',Ierr ENDIF RETURN END