*********************************************************************
*                                                                   *
*       Copyright 1987 Pittsburgh Supercomputing Center             *
*       All Rights Reserved                                         *
*       Author Joel Welling                                         *
*                                                                   *
*       CGMGEN_TEST.FOR version 3.0                                 *
*                                                                   *
*********************************************************************
*
*       Open CGM; 255 is max color index.
*
	ierr= 0
	call setdev('tek',ierr)
	write(6,*) ' setdev: ierr= ',ierr
	call tgldbg(ierr)
	write(6,*) ' tgldbg: ierr= ',ierr
        call wrtopn('CGMOUT',ierr)
        write(6,*) ' wrtopn: ierr= ',ierr
        call wrmxci(255,ierr)
        write(6,*) ' wrmxci: ierr= ',ierr
	call tgldbg(ierr)
	write(6,*) ' tgldbg: ierr= ',ierr
*
*       This routine tests indexed color functions, exclusive of
*       arbitrary precision cell array generation.
*
        call tindxc()
*
*       This routine tests direct color functions.
*
        call tdrctc()
*
*       The following routine tests the queried direct color cell
*       array facility.  To use it, you MUST uncomment the section
*	of wqcadc containing qclarw in cgmgen.c, and the following
*	subroutine call!
*
*        call tqcadc()
*
*       This routine tests arbitrary precision cell arrays, for run
*       length mode followed by packed list mode.
*
        call tarbca(0)
        call tarbca(1)
*
*       The following routine tests the generation of arbitrary
*       precision cell arrays from packed lists.  This routine is
*       written in C to facilitate bit manipulation.
*
        call tpcla(0)
        call tpcla(1)
*
*       The following routine tests the coordinate system redefinition
*       facility.
*
        call tcoord()
*
* End CGM and exit
*
        call wrtend(ierr)
        write(6,*) ' wrtend: ierr=',ierr
        stop
        end
        subroutine genclrs(rarray,garray,barray)
*
*       This routine generates a color table
*
        dimension rarray(256),garray(256),barray(256)
        rarray(1)= 0.0
        garray(1)= 0.0
        barray(1)= 0.0
        rarray(2)= 1.0
        garray(2)= 1.0
        barray(2)= 1.0
        rarray(3)= 1.0
        garray(3)= 0.0
        barray(3)= 0.0
        rarray(4)= 0.0
        garray(4)= 1.0
        barray(4)= 0.0
        rarray(5)= 0.0
        garray(5)= 0.0
        barray(5)= 1.0
        rarray(6)= 0.0
        garray(6)= 1.0
        barray(6)= 1.0
        do 10 i= 7,256
                rarray(i)= float(i-1)/255.
                garray(i)= float(i-1)/255.
                barray(i)= float(i-1)/255.
10              continue
666     return
        end
        subroutine genimage(image)
*
*       Generate indexed color test image
*
        dimension image(16,16)
        do 10 i= 1,16
                do 10 j= 1,16
10                      image(i,j)= mod(i*j,256)
666     return
        end
        subroutine gnimg2(image)
*
*       Generate indexed color test image
*
        dimension image(9,10)
        do 10 i= 1,9
                do 10 j= 1,10
10                      image(i,j)= mod((5*i)/j,2)
666     return
        end
        subroutine gendcimg(rarray,garray,barray)
*
*       Generate direct color test image
*
        dimension rarray(40,40),garray(40,40),barray(40,40)
        do 10 i= 1,40
                do 10 j= 1,40
                        rarray(i,j)= float(i-1)/39.0
                        garray(i,j)= float(j-1)/39.0
                        barray(i,j)= float(i+j-2)/78.0
10      continue
666     return
        end
        subroutine tindxc()
*
*       Test indexed color functions, exclusive of arbitrary precision
*       cell arrays
*
        dimension rarray(256),garray(256),barray(256),image(16,16)
        dimension xlin(5),ylin(5),xpgn(3),ypgn(3),xpmk(3),ypmk(3)
        data xlin/.4,.5,.5,.4,.4/
        data ylin/.6,.6,.7,.7,.6/
        data xpgn/.7,.9,.8/
        data ypgn/.3,.3,.45/
        data xpmk/.7,.9,.8/
        data ypmk/.6,.6,.7/
	data xtxt1,ytxt1,xtxt2,ytxt2/0.2,0.9,0.5,0.75/
        data xclap,xclaq,xclar/0.1,0.4,0.355/
        data yclap,yclaq,yclar/0.355,0.25,0.505/

*       Set up test color table and image
        call genclrs(rarray,garray,barray)
        call genimage(image)

        ierr= 0
	call stpcnm('Indexed Color Tests',ierr)
	write(6,*) ' stpcnm: ierr= ',ierr
        call wrbegp(ierr)
        write(6,*) ' wrbegp: ierr= ',ierr
        call wrbgdc(0.0,0.0,0.0,ierr)
        write(6,*) ' wrbgdc: ierr= ',ierr
        call wrbgpb(ierr)
        write(6,*) ' wrbgpb: ierr= ',ierr
        call wristl(1,ierr)
        write(6,*) ' wristl: ierr= ',ierr
        call wrctbl(rarray,garray,barray,0,255,ierr)
        write(6,*) ' wrctbl: ierr= ',ierr
        call wrtxtc(2,ierr)
        write(6,*) ' wrtxtc: ierr= ',ierr
        call wrtxts(0.03,ierr)
        write(6,*) ' wrtxts: ierr= ',ierr
        call wrftxt('This text in color 2',xtxt1,ytxt1,ierr)
        write(6,*) ' wrftxt: ierr= ',ierr
	call wtxtpr(2,ierr)
	write(6,*) ' wtxtpr: ierr= ',ierr
	call wrtxta(2,3,0.0,0.0,ierr)
        write(6,*) ' wrtxta: ierr= ',ierr
	call wrtxtp(1,ierr)
	write(6,*) ' wrtxtp: ierr= ',ierr
	call wrtxte(0.8,ierr)
	write(6,*) ' wrtxte: ierr= ',ierr
	call wrtxtf(2,ierr)
	write(6,*) ' wrtxtf: ierr= ',ierr
	call wrtxto(0.5,0.5,0.5,-0.5,ierr)
	write(6,*) ' wrtxto: ierr= ',ierr
	call wtxtsp(0.5,ierr)
	write(6,*) ' wtxtsp: ierr= ',ierr
        call wrftxt('This text in color 2',xtxt2,ytxt2,ierr)
        write(6,*) ' wrftxt: ierr= ',ierr
        call wrplnc(3,ierr)
        write(6,*) ' wrplnc: ierr= ',ierr
        call wrplin(xlin,ylin,5,ierr)
        write(6,*) ' wrplin: ierr= ',ierr
        call wrpgnc(4,ierr)
        write(6,*) ' wrpgnc: ierr= ',ierr
        call wrtpgn(xpgn,ypgn,3,ierr)
        write(6,*) ' wrtpgn: ierr= ',ierr
        call wrpmkc(5,ierr)
        write(6,*) ' wrpmkc: ierr= ',ierr
        call wrpmkt(1,ierr)
        write(6,*) ' wrpmkt: ierr= ',ierr
        call wrpmks(3.0,ierr)
        write(6,*) ' wrpmks: ierr= ',ierr
        call wrtpmk(xpmk,ypmk,3,ierr)
        write(6,*) ' wrtpmk: ierr= ',ierr
        call wrtcla(image,16,16,
     1          xclap,yclap,xclaq,yclaq,xclar,yclar,ierr)
        write(6,*) ' wrtcla: ierr= ',ierr
        call wrendp(ierr)
        write(6,*) ' wrendp: ierr= ',ierr
        return
        end
        subroutine tdrctc()
*
*       Test direct color functions
*
        dimension rimage(40,40),gimage(40,40),bimage(40,40),
     1          xlin(5),ylin(5),xpgn(3),ypgn(3),xpmk(3),ypmk(3)
        data xlin/.4,.5,.5,.4,.4/
        data ylin/.6,.6,.7,.7,.6/
        data xpgn/.7,.9,.8/
        data ypgn/.3,.3,.45/
        data xpmk/.7,.9,.8/
        data ypmk/.6,.6,.7/
        data xclap,xclaq,xclar/0.1,0.4,0.355/
        data yclap,yclaq,yclar/0.355,0.25,0.505/

*       Generate test image
        call gendcimg(rimage,gimage,bimage)

        ierr= 0                               
	call stpcnm('Direct Color Tests',ierr)
	write(6,*) ' stpcnm: ierr= ',ierr
        call wrbegp(ierr)
        write(6,*) ' wrbegp: ierr= ',ierr
        call wrtcsm(1,ierr)
        write(6,*) ' wrtcsm: ierr= ',ierr
        call wrbgdc(0.0,0.0,0.5,ierr)
        write(6,*) ' wrbgdc: ierr= ',ierr
        call wrbgpb(ierr)
        write(6,*) ' wrbgpb: ierr= ',ierr
        call wristl(1,ierr)
        write(6,*) ' wristl: ierr= ',ierr
        call wtxtdc(0.2,0.3,0.8,ierr)
        write(6,*) ' wtxtdc: ierr= ',ierr
        call wrtxts(0.03,ierr)
        write(6,*) ' wrtxts: ierr= ',ierr
        call wrftxt('Red 0.2, green 0.3, blue 0.8',0.2,0.9,ierr)
        write(6,*) ' wrftxt: ierr= ',ierr
        call wplndc(0.8,0.8,0.2,ierr)
        write(6,*) ' wplndc: ierr= ',ierr
        call wrplin(xlin,ylin,5,ierr)
        write(6,*) ' wrplin: ierr= ',ierr
        call wpgndc(0.8,0.2,0.2,ierr)
        write(6,*) ' wpgndc: ierr= ',ierr
        call wrtpgn(xpgn,ypgn,3,ierr)
        write(6,*) ' wrtpgn: ierr= ',ierr
        call wpmkdc(0.2,0.8,0.2,ierr)
        write(6,*) ' wpmkdc: ierr= ',ierr
        call wrpmkt(2,ierr)
        write(6,*) ' wrpmkt: ierr= ',ierr
        call wrpmks(3.0,ierr)
        write(6,*) ' wrpmks: ierr= ',ierr
        call wrtpmk(xpmk,ypmk,3,ierr)
        write(6,*) ' wrtpmk: ierr= ',ierr
        call wcladc(rimage,gimage,bimage,40,40,
     1          xclap,yclap,xclaq,yclaq,xclar,yclar,ierr)
        write(6,*) ' wcladc: ierr= ',ierr
        call wrendp(ierr)
        write(6,*) ' wrendp: ierr= ',ierr
        return
        end
        subroutine tarbca(mode)
*                                
*       This routine tests the arbitrary precision cell array software.
*
        dimension rarray(256),garray(256),barray(256),image(9,10)
        data xlbl1,ylbl1/0.1,0.26/
        data xlbl2,ylbl2/0.1,0.46/
        data xlbl3,ylbl3/0.1,0.66/
        data xlbl4,ylbl4/0.1,0.86/
        data xlbl5,ylbl5/0.6,0.46/
        data xlbl6,ylbl6/0.6,0.66/
        data xlbl7,ylbl7/0.6,0.86/
        data xclap1,xclaq1,xclar1/0.1,0.3,0.3/
        data yclap1,yclaq1,yclar1/0.25,0.1,0.25/
        data xclap2,xclaq2,xclar2/0.1,0.3,0.3/
        data yclap2,yclaq2,yclar2/0.45,0.3,0.45/
        data xclap3,xclaq3,xclar3/0.1,0.3,0.3/
        data yclap3,yclaq3,yclar3/0.65,0.5,0.65/
        data xclap4,xclaq4,xclar4/0.1,0.3,0.3/
        data yclap4,yclaq4,yclar4/0.85,0.7,0.85/
        data xclap5,xclaq5,xclar5/0.6,0.8,0.8/
        data yclap5,yclaq5,yclar5/0.45,0.3,0.45/
        data xclap6,xclaq6,xclar6/0.6,0.8,0.8/
        data yclap6,yclaq6,yclar6/0.65,0.5,0.65/
        data xclap7,xclaq7,xclar7/0.6,0.8,0.8/
        data yclap7,yclaq7,yclar7/0.85,0.7,0.85/

*       Set up test color table and image
        call genclrs(rarray,garray,barray)
        call gnimg2(image)

        ierr= 0
	call stpcnm('Cell Array Tests',ierr)
	write(6,*) ' stpcnm: ierr= ',ierr
        call wrbegp(ierr)
        write(6,*) ' wrbegp: ierr= ',ierr
        call wrbgdc(0.0,0.0,0.0,ierr)
        write(6,*) ' wrbgdc: ierr= ',ierr
        call wrbgpb(ierr)
        write(6,*) ' wrbgpb: ierr= ',ierr
        call wrctbl(rarray,garray,barray,0,255,ierr)
        write(6,*) ' wrctbl: ierr= ',ierr
        call wrtxtc(1,ierr)
        write(6,*) ' wrtxtc: ierr= ',ierr

        call wrtxts(0.03,ierr)
        write(6,*) ' wrtxts: ierr= ',ierr
        if (mode.eq.0) then
                call wrftxt('Run length mode',0.1,0.9,ierr)
        else
                call wrftxt('Packed list mode',0.1,0.9,ierr)
        end if
        write(6,*) ' wrftxt: ierr= ',ierr

        call wrtxts(0.01,ierr)
        write(6,*) ' wrtxts: ierr= ',ierr

        call wrftxt('8 bits',xlbl1,ylbl1,ierr)
        write(6,*) ' wrftxt: ierr= ',ierr
        call wrgcla(image,9,10,
     1          xclap1,yclap1,xclaq1,yclaq1,xclar1,yclar1,
     2          8,mode,ierr)
        write(6,*) ' wrtcla: ierr= ',ierr

        call wrftxt('4 bits',xlbl2,ylbl2,ierr)
        write(6,*) ' wrftxt: ierr= ',ierr
        call wrgcla(image,9,10,
     1          xclap2,yclap2,xclaq2,yclaq2,xclar2,yclar2,
     2          4,mode,ierr)
        write(6,*) ' wrtcla: ierr= ',ierr

        call wrftxt('2 bits',xlbl3,ylbl3,ierr)
        write(6,*) ' wrftxt: ierr= ',ierr
        call wrgcla(image,9,10,
     1          xclap3,yclap3,xclaq3,yclaq3,xclar3,yclar3,
     2          2,mode,ierr)
        write(6,*) ' wrtcla: ierr= ',ierr

        call wrftxt('1 bit',xlbl4,ylbl4,ierr)
        write(6,*) ' wrftxt: ierr= ',ierr
        call wrgcla(image,9,10,
     1          xclap4,yclap4,xclaq4,yclaq4,xclar4,yclar4,
     2          1,mode,ierr)
        write(6,*) ' wrtcla: ierr= ',ierr

        call wrftxt('32 bits',xlbl5,ylbl5,ierr)
        write(6,*) ' wrftxt: ierr= ',ierr
        call wrgcla(image,9,10,
     1          xclap5,yclap5,xclaq5,yclaq5,xclar5,yclar5,
     2          32,mode,ierr)
        write(6,*) ' wrtcla: ierr= ',ierr

        call wrftxt('24 bits',xlbl6,ylbl6,ierr)
        write(6,*) ' wrftxt: ierr= ',ierr
        call wrgcla(image,9,10,
     1          xclap6,yclap6,xclaq6,yclaq6,xclar6,yclar6,
     2          24,mode,ierr)
        write(6,*) ' wrtcla: ierr= ',ierr

        call wrftxt('16 bits',xlbl7,ylbl7,ierr)
        write(6,*) ' wrftxt: ierr= ',ierr
        call wrgcla(image,9,10,
     1          xclap7,yclap7,xclaq7,yclaq7,xclar7,yclar7,
     2          16,mode,ierr)
        write(6,*) ' wrtcla: ierr= ',ierr

        call wrendp(ierr)
        write(6,*) ' wrendp: ierr= ',ierr
        return
        end
        subroutine tqcadc()
*
*       Test queried direct color cell array
*
        data xclap,xclaq,xclar/0.35,0.65,0.65/
        data yclap,yclaq,yclar/0.65,0.35,0.65/

        ierr= 0                               
	call stpcnm('Queried Direct Color Cell Array',ierr)
	write(6,*) ' stpcnm: ierr= ',ierr
        call wrbegp(ierr)
        write(6,*) ' wrbegp: ierr= ',ierr
        call wrtcsm(1,ierr)
        write(6,*) ' wrtcsm: ierr= ',ierr
        call wrbgdc(0.0,0.0,0.5,ierr)
        write(6,*) ' wrbgdc: ierr= ',ierr
        call wrbgpb(ierr)
        write(6,*) ' wrbgpb: ierr= ',ierr
        call wtxtdc(1.0,1.0,1.0,ierr)
        write(6,*) ' wtxtdc: ierr= ',ierr
        call wrtxts(0.025,ierr)
        write(6,*) ' wrtxts: ierr= ',ierr
        call wrftxt('Queried direct color cell array',0.2,0.9,ierr)
        write(6,*) ' wrftxt: ierr= ',ierr
        call wqcadc(40,40,xclap,yclap,xclaq,yclaq,xclar,yclar,ierr)
        write(6,*) ' wcladc: ierr= ',ierr
        call wrendp(ierr)
        write(6,*) ' wrendp: ierr= ',ierr
        return          
        end
*
*       Function to return rows of colors to wqcadc.
*
        integer function qclarw(rrow,grow,brow,nxdim,nydim,iy)
        integer nxdim,nydim,iy
        real rrow(nxdim),grow(nxdim),brow(nxdim)
        do 10 i= 1,nxdim
                        rrow(i)= float(i-1)/float(nxdim)
                        grow(i)= float(iy-1)/float(nydim)
                        brow(i)= float(i+iy-2)/float(nxdim+nydim)
10      continue
        qclarw= 0
666     return
        end
        subroutine tcoord()
*
*       Test the coordinate system redefinition facility by drawing a
*       rectangle with reset coordinates.
*
        real xloc(4),yloc(4)
        data xloc/ -7.0, 1.0, 1.0, -7.0 /
        data yloc/ -4.0, -4.0, 1.0, 1.0 /

	ierr= 0
	call stpcnm('Coordinate Scaling Test',ierr)
	write(6,*) ' stpcnm: ierr= ',ierr
        call wrbegp(ierr)
        write(6,*) ' wrbegp: ierr= ',ierr
        call wrbgpb(ierr)
        write(6,*) ' wrbgpb: ierr= ',ierr
        call wrtxts(0.025,ierr)
        write(6,*) ' wrtxts: ierr= ',ierr
        call wrftxt('Coordinate rescaling test',0.2,0.9,ierr)
        write(6,*) ' wrftxt: ierr= ',ierr
        call setwcd( -8.0, -5.0, 2.0, 2.0 )
        write(6,*) ' setwcd: ierr= ',ierr
        call wrtpgn( xloc, yloc, 4, ierr)
        write(6,*) ' wrtpgn: ierr= ',ierr
        call wrendp(ierr)
        write(6,*) ' wrendp: ierr= ',ierr
        return
        end