program main

!*****************************************************************************80
!
!! MAIN is the main program for CGMTEST.
!
!  Discussion:
!
!    CGMTEST performs some tests of the DRAWCGM library.
!
!  Modified:
!
!    25 September 2002
!
  integer ierr
!
!  Open CGM; 255 is max color index.
!
  call timestamp ( )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'CGMTEST'
  write ( *, '(a)' ) '  FORTRAN90 version'
  write ( *, '(a)' ) '  A test program for DRAWCGM.'

  ierr = 0

  call setdev ( 'cgmb', ierr )

  if ( ierr /= 0 ) then
    write ( *, * ) ' setdev: ierr = ',ierr
    stop
  end if

  call tgldbg ( ierr )

  if ( ierr /= 0 ) then
    write ( *, * ) ' tgldbg: ierr = ',ierr
  end if

  call wrtopn ( 'cgmtest.cgmb', ierr )

  write ( *, * ) ' wrtopn: ierr = ',ierr

  call wrmxci ( 255, ierr )

  write ( *, * )  ' wrmxci: ierr = ',ierr

!      call tgldbg ( ierr )
!      write ( *, * )  ' tgldbg: ierr = ',ierr
!
!  Test indexed color functions, exclusive of
!  arbitrary precision cell array generation.
!
  call tindxc ( )
!
! read ( *, * )
!
!  Test direct color functions.
!
  call tdrctc ( )
!
! read(*,*)
!
!  Test 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()
!
!  Test arbitrary precision cell arrays, for run
!  length mode followed by packed list mode.
!
  call tarbca(0)
  call tarbca(1)
!
!  Test 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)
!
!  Test the coordinate system redefinition facility.
!
  call tcoord()

! read(*,*)
!
!  End CGM and exit
!
  call wrtend ( ierr )
  write ( *, * )  ' wrtend: ierr =', ierr

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'CGMTEST:'
  write ( *, '(a)' ) '  Normal end of execution.'

  write ( *, '(a)' ) ' '
  call timestamp ( )

  stop
end
subroutine genclrs ( rarray, garray, barray )

!*****************************************************************************80
!
!! GENCLRS generates a color table
!
  real barray(256)
  real garray(256)
  integer i
  real rarray(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 i = 7, 256
    rarray(i) = real ( i - 1 ) / 255.0
    garray(i) = real ( i - 1 ) / 255.0
    barray(i) = real ( i - 1 ) / 255.0
  end do

  return
end
subroutine genimage ( image )

!*****************************************************************************80
!
!! GENIMAGE indexed color test image.
!
  integer i
  integer image(16,16)
  integer j

  do i = 1, 16
    do j = 1, 16
      image(i,j) = mod ( i * j, 256 ) 
    end do
  end do

  return
end
subroutine gnimg2 ( image )

!*****************************************************************************80
!
!! GNIMG2 generates an indexed color test image.
!
  integer i
  integer image(9,10)
  integer j

  do i = 1, 9
    do j = 1, 10
      image(i,j) = mod ( ( 5 * i ) / j, 2 )
    end do
  end do

  return
end
subroutine gendcimg ( n, rarray, garray, barray )

!*****************************************************************************80
!
!! GENDCIMG generates a direct color test image.
!
  integer n

  real barray(n,n)
  real garray(n,n)
  integer i
  integer j
  real rarray(n,n)

  do i = 1, n
    do j = 1, n
      rarray(i,j) = real ( i - 1 ) / real ( n - 1 )
      garray(i,j) = real ( j - 1 ) / real ( n - 1 )
      barray(i,j) = 0.5 * real ( i + j - 2 ) / real ( n - 1 )
    end do
  end do

  return
end
subroutine tindxc ( )

!*****************************************************************************80
!
!! TINDXC tests indexed color functions.
!
  real barray(256)
  real garray(256)
  integer ierr
  integer image(16,16)
  real rarray(256)
  real xclap
  real xclaq
  real xclar
  real xlin(5)
  real xpgn(3)
  real xpmk(3)
  real xtxt1
  real xtxt2
  real yclap
  real yclaq
  real yclar
  real ylin(5)
  real ypgn(3)
  real ypmk(3)
  real ytxt1
  real ytxt2

  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 ( *, * )  ' stpcnm: ierr = ',ierr

  call wrbegp ( ierr )

  write ( *, * )  ' wrbegp: ierr = ',ierr

  call wrbgdc ( 0.0, 0.0, 0.0, ierr )

  write ( *, * )  ' wrbgdc: ierr = ',ierr

  call wrbgpb ( ierr )

  write ( *, * )  ' wrbgpb: ierr = ',ierr

  call wristl ( 1, ierr )

  write ( *, * )  ' wristl: ierr = ',ierr

  call wrctbl ( rarray, garray, barray, 0, 255, ierr )

  write ( *, * )  ' wrctbl: ierr = ',ierr
  call wrtxtc ( 2, ierr )
  write ( *, * )  ' wrtxtc: ierr = ',ierr
  call wrtxts ( 0.03, ierr )
  write ( *, * )  ' wrtxts: ierr = ',ierr
  call wrftxt ( 'This text in color 2', xtxt1, ytxt1, ierr )
  write ( *, * )  ' wrftxt: ierr = ',ierr
  call wtxtpr ( 2, ierr )
  write ( *, * )  ' wtxtpr: ierr = ',ierr
  call wrtxta ( 2, 3, 0.0, 0.0, ierr )
  write ( *, * )  ' wrtxta: ierr = ',ierr
  call wrtxtp ( 1, ierr )
  write ( *, * )  ' wrtxtp: ierr = ',ierr
  call wrtxte ( 0.8, ierr )
  write ( *, * )  ' wrtxte: ierr = ',ierr
  call wrtxtf ( 2, ierr )
  write ( *, * )  ' wrtxtf: ierr = ',ierr
  call wrtxto ( 0.5, 0.5, 0.5, -0.5, ierr )
  write ( *, * )  ' wrtxto: ierr = ',ierr
  call wtxtsp ( 0.5, ierr )
  write ( *, * )  ' wtxtsp: ierr = ',ierr
  call wrftxt ( 'This text in color 2', xtxt2, ytxt2, ierr )
  write ( *, * )  ' wrftxt: ierr = ',ierr
  call wrplnc ( 3, ierr )
  write ( *, * )  ' wrplnc: ierr = ',ierr
  call wrplnw ( 4.0, ierr )
  write ( *, * )  ' wrplnw: ierr = ',ierr
  call wrplin ( xlin, ylin, 5, ierr )
  write ( *, * )  ' wrplin: ierr = ',ierr
  call wrpgnc ( 4, ierr )
  write ( *, * )  ' wrpgnc: ierr = ',ierr
  call wrtpgn ( xpgn, ypgn, 3, ierr )
  write ( *, * )  ' wrtpgn: ierr = ',ierr
  call wrpmkc ( 5, ierr )
  write ( *, * )  ' wrpmkc: ierr = ',ierr
  call wrpmkt ( 1, ierr )
  write ( *, * )  ' wrpmkt: ierr = ',ierr
  call wrpmks ( 3.0, ierr )
  write ( *, * )  ' wrpmks: ierr = ',ierr
  call wrtpmk ( xpmk, ypmk, 3, ierr )
  write ( *, * )  ' wrtpmk: ierr = ',ierr
  call wrtcla ( image, 16, 16, xclap, yclap, xclaq, yclaq, xclar, yclar, ierr )
  write ( *, * )  ' wrtcla: ierr = ',ierr
  call wrendp ( ierr )
  write ( *, * )  ' wrendp: ierr = ',ierr

  return
end
subroutine tdrctc()

!*****************************************************************************80
!
!! TRDCTC tests direct color functions.
!
  integer, parameter :: n = 40

  real bimage(n,n)
  real gimage(n,n)
  integer ierr
  real rimage(n,n)
  real xclap
  real xclaq
  real xclar
  real xlin(5)
  real xpgn(3)
  real xpmk(3)
  real yclap
  real yclaq
  real yclar
  real ylin(5)
  real ypgn(3)
  real 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 ( n, rimage, gimage, bimage )

  ierr = 0                               
  call stpcnm ( 'Direct Color Tests', ierr )
  write ( *, * )  ' stpcnm: ierr = ',ierr
  call wrbegp ( ierr )
  write ( *, * )  ' wrbegp: ierr = ',ierr
  call wrtcsm ( 1, ierr )
  write ( *, * )  ' wrtcsm: ierr = ',ierr
  call wrbgdc ( 0.0, 0.0, 0.5, ierr )
  write ( *, * )  ' wrbgdc: ierr = ',ierr
  call wrbgpb ( ierr )
  write ( *, * )  ' wrbgpb: ierr = ',ierr
  call wristl ( 1, ierr )
  write ( *, * )  ' wristl: ierr = ',ierr
  call wtxtdc ( 0.2, 0.3, 0.8, ierr )
  write ( *, * )  ' wtxtdc: ierr = ',ierr
  call wrtxts ( 0.03, ierr )
  write ( *, * )  ' wrtxts: ierr = ',ierr
  call wrftxt ( 'Red 0.2, green 0.3, blue 0.8', 0.2, 0.9, ierr )
  write ( *, * )  ' wrftxt: ierr = ',ierr
  call wplndc ( 0.8, 0.8, 0.2, ierr )
  write ( *, * )  ' wplndc: ierr = ',ierr
  call wrplin ( xlin, ylin, 5, ierr )
  write ( *, * )  ' wrplin: ierr = ',ierr
  call wpgndc ( 0.8, 0.2, 0.2, ierr )
  write ( *, * )  ' wpgndc: ierr = ',ierr
  call wrtpgn ( xpgn, ypgn, 3, ierr )
  write ( *, * )  ' wrtpgn: ierr = ',ierr
  call wpmkdc ( 0.2, 0.8, 0.2, ierr )
  write ( *, * )  ' wpmkdc: ierr = ',ierr
  call wrpmkt ( 2, ierr )
  write ( *, * )  ' wrpmkt: ierr = ',ierr
  call wrpmks ( 3.0, ierr )
  write ( *, * )  ' wrpmks: ierr = ',ierr
  call wrtpmk ( xpmk, ypmk, 3, ierr )
  write ( *, * )  ' wrtpmk: ierr = ',ierr
  call wcladc ( rimage, gimage, bimage, 40, 40, xclap, yclap, xclaq, yclaq, &
    xclar, yclar, ierr )
  write ( *, * )  ' wcladc: ierr = ',ierr
  call wrendp ( ierr )
  write ( *, * )  ' wrendp: ierr = ',ierr

  return
end
subroutine tarbca ( mode )

!*****************************************************************************80
!
!! TARBCA tests the arbitrary precision cell array software.
!
  real barray(256)
  real garray(256)
  integer ierr
  integer image(9,10)
  integer mode
  real rarray(256)
  real xclap1
  real xclap2
  real xclap3
  real xclap4
  real xclap5
  real xclap6
  real xclap7
  real xclaq1
  real xclaq2
  real xclaq3
  real xclaq4
  real xclaq5
  real xclaq6
  real xclaq7
  real xclar1
  real xclar2
  real xclar3
  real xclar4
  real xclar5
  real xclar6
  real xclar7
  real xlbl1
  real xlbl2
  real xlbl3
  real xlbl4
  real xlbl5
  real xlbl6
  real xlbl7
  real yclap1
  real yclap2
  real yclap3
  real yclap4
  real yclap5
  real yclap6
  real yclap7
  real yclaq1
  real yclaq2
  real yclaq3
  real yclaq4
  real yclaq5
  real yclaq6
  real yclaq7
  real yclar1
  real yclar2
  real yclar3
  real yclar4
  real yclar5
  real yclar6
  real yclar7
  real ylbl1
  real ylbl2
  real ylbl3
  real ylbl4
  real ylbl5
  real ylbl6
  real ylbl7
!
  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 ( *, * )  ' stpcnm: ierr = ',ierr
  call wrbegp ( ierr )
  write ( *, * )  ' wrbegp: ierr = ',ierr
  call wrbgdc(0.0,0.0,0.0,ierr)
  write ( *, * )  ' wrbgdc: ierr = ',ierr
  call wrbgpb ( ierr )
  write ( *, * )  ' wrbgpb: ierr = ',ierr
  call wrctbl(rarray,garray,barray,0,255,ierr)
  write ( *, * )  ' wrctbl: ierr = ',ierr
  call wrtxtc(1,ierr)
  write ( *, * )  ' wrtxtc: ierr = ',ierr

  call wrtxts(0.03,ierr)
  write ( *, * )  ' wrtxts: ierr = ',ierr
  if ( mode == 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 ( *, * )  ' wrftxt: ierr = ',ierr

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

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

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

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

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

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

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

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

  call wrendp ( ierr )
  write ( *, * )  ' wrendp: ierr = ',ierr

  return
end
subroutine tqcadc()

!*****************************************************************************80
!
!! TQCADC tests queried direct color cell array.
!
  integer ierr
  real xclap
  real xclaq
  real xclar
  real yclap
  real yclaq
  real yclar

  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 ( *, * )  ' stpcnm: ierr = ',ierr
  call wrbegp ( ierr )
  write ( *, * )  ' wrbegp: ierr = ',ierr
  call wrtcsm(1,ierr)
  write ( *, * )  ' wrtcsm: ierr = ',ierr
  call wrbgdc(0.0,0.0,0.5,ierr)
  write ( *, * )  ' wrbgdc: ierr = ',ierr
  call wrbgpb ( ierr )
  write ( *, * )  ' wrbgpb: ierr = ',ierr
  call wtxtdc(1.0,1.0,1.0,ierr)
  write ( *, * )  ' wtxtdc: ierr = ',ierr
  call wrtxts(0.025,ierr)
  write ( *, * )  ' wrtxts: ierr = ',ierr
  call wrftxt('Queried direct color cell array',0.2,0.9,ierr)
  write ( *, * )  ' wrftxt: ierr = ',ierr
  call wqcadc ( 40, 40, xclap, yclap, xclaq, yclaq, xclar, yclar, ierr )
  write ( *, * )  ' wcladc: ierr = ',ierr
  call wrendp ( ierr )
  write ( *, * )  ' wrendp: ierr = ',ierr

  return          
end
function qclarw ( rrow, grow, brow, nxdim, nydim, iy )

!*****************************************************************************80
!
!! QCLARW returns rows of colors to wqcadc.
!
  integer nxdim
  integer nydim

  integer i
  integer iy
  integer qclarw
  real rrow(nxdim)
  real grow(nxdim)
  real brow(nxdim)

  do i = 1, nxdim
    rrow(i) = real ( i - 1 ) / real ( nxdim )
    grow(i) = real ( iy - 1 ) / real ( nydim )
    brow(i) = real ( i + iy - 2 ) / real ( nxdim + nydim )
  end do

  qclarw = 0

  return
end
subroutine tcoord()

!*****************************************************************************80
!
!! TCOORD tests the coordinate system redefinition facility.
!
!  TCOORD draws a rectangle with reset coordinates.
!
  implicit none

  integer ierr
  real xloc(4)
  real 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 ( *, * )  ' stpcnm: ierr = ', ierr
  call wrbegp ( ierr )
  write ( *, * )  ' wrbegp: ierr = ', ierr
  call wrbgpb ( ierr )
  write ( *, * )  ' wrbgpb: ierr = ', ierr
  call wrtxts ( 0.025, ierr )
  write ( *, * )  ' wrtxts: ierr = ', ierr
  call wrftxt ( 'Coordinate rescaling test', 0.2, 0.9, ierr )
  write ( *, * )  ' wrftxt: ierr = ', ierr
  call setwcd ( -8.0, -5.0, 2.0, 2.0, ierr )
  write ( *, * )  ' setwcd: ierr = ', ierr
  call wrtpgn ( xloc, yloc, 4, ierr)
  write ( *, * )  ' wrtpgn: ierr = ', ierr
  call wrendp ( ierr )
  write ( *, * )  ' wrendp: ierr = ', ierr

  return
end