program main

!*****************************************************************************80
!
!! MAIN is the main program for DRAWCGM_PRB3.
!
!  Discussion:
!
!    DRAWCGM_PRB3 tests the DEVICE routine.
!
!    If DEVICE is not called by a user program, then a CGM binary
!    metafile is created by default.
!
!  Modified:
!
!    25 September 2002
!
  implicit none

  character ( len = 10 ) dev
  integer ios
  integer itable

  call timestamp ( )

  write ( *, * ) ' '
  write ( *, * ) 'DRAWCGM_PRB3'
  write ( *, * ) '  Allow the user to pick the output device to be'
  write ( *, * ) '  used with DRAWCGM graphics.'
!
!  Prompt user for device
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'Please enter an output device.'
  write ( *, '(a)' ) 'The legal choices are:'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'cgmb     CGM binary metafile.'
  write ( *, '(a)' ) 'cgmc     CGM cleartext metafile.'
  write ( *, '(a)' ) 'ps       PostScript file.'
  write ( *, '(a)' ) 'tek      Tektronix 4010 monochrome screen.'
  write ( *, '(a)' ) 'tek4207  Tektronix 4207 color screen.'
  write ( *, '(a)' ) 'xws      X-Windows screen'
  write ( *, '(a)' ) ' '

  read ( *, '(a)', iostat = ios ) dev

  if ( ios /= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'DRAWCGM_PRB3 - Warning!'
    write ( *, '(a)' ) '  User input missing.'
    write ( *, '(a)' ) '  Program will behave as though CGMB were chosen.'
    dev = 'cgmb'
  else if ( dev == 'cgmb' ) then
    write ( *, * ) 'CGM binary metafile graphics requested.'
  else if ( dev == 'cgmb' ) then
    write ( *, * ) 'CGM binary metafile graphics requested.'
  else if ( dev == 'cgmc' ) then
    write ( *, * ) 'CGM cleartext metafile graphics requested.'
  else if ( dev == 'ps' ) then
    write ( *, * ) 'PostScript file output requested.'
  else if ( dev == 'tek' ) then
    write ( *, * ) 'Tektronix 4010 screen graphics requested.'
  else if ( dev == 'tek4207' ) then
    write ( *, * ) 'Tektronix 4207 color screen graphics requested.'
  else if ( dev == 'xws' ) then
    write ( *, * ) 'X Window screen graphics output requested.'
  else
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'DRAWCGM_PRB3 - Warning!'
    write ( *, '(a)' ) '  User input unacceptable.'
    write ( *, '(a)' ) '  Program will behave as though CGMB were chosen.'
    dev = 'cgmb'
  end if

  call device ( dev )
!
!  If output is to an interactive screen device, then request that
!  the program wait between frames...
!
  if ( dev == 'tek' .or. dev == 'tek4207' .or. dev == 'xws' ) then
    call stpaus ( )
  end if
!
!  ...otherwise, output is to a file, so name that output file!
!
  if ( dev == 'cgmb' ) then
    call outfil ( 'drawcgm_prb3.cgmb' )
  else if ( dev == 'cgmc' ) then
    call outfil ( 'drawcgm_prb3.cgmc' )
  else if ( dev == 'ps' ) then
    call outfil ( 'drawcgm_prb3.ps' )
  end if
!
!  Set the color table.
!
  itable  =  2
  call setctb ( itable )
!
!  Initialize the DRAWCGM graphics package.
!
  call grfini
!
!  Draw the first plot.
!
  call test01
!
!  End old plot, begin next one.
!
  call newfrm
!
!  Second plot
!
  call test02
!
!  End old plot, begin next one.
!
  call newfrm
!
!  Draw the third plot.
!
  call test03
!
!  Shut down the graphics package
!
  call grfcls

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

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

  stop
end
subroutine test01

!*****************************************************************************80
!
!! TEST01 draws a simple line curve: Y  =  SIN(3*X)+SIN(X)
!
  implicit none

  integer, parameter :: ndata = 50

  integer i
  integer icolor
  integer itable
  real r_pi
  real x(ndata)
  real y(ndata)

  write ( *, * ) ' '
  write ( *, * ) 'TEST01'
  write ( *, * ) '  Draw a simple line curve.'
  write ( *, * ) ' '
!
!  Place a label on the plot
!
  call label ( 0.1, 0.5, 'Oscillatory curve', 1, 0.025 )
!
!  Set up the X and Y vectors of data:
!
  do i = 1, ndata
    x(i) = real ( i - 1 ) * 2.0 * r_pi ( ) / real ( ndata - 1 )
    y(i) = sin ( 3.0 * x(i) ) + sin ( x(i) )
  end do
!
!  Scale picture frame to the data.
!
  call setscl ( x, y, ndata )
!
!  Choose color table 4, pseudospectral red to blue.
!
  itable = 4
  call setctb ( itable )
!
!  Draw the line of points x(i), y(i)
!
  call mrktyp ( 4 )
  icolor = 12
  call mrkclr ( icolor )

  icolor = 6
  call linclr ( icolor )
  call plylin ( ndata, x, y )

  return
end
subroutine test02

!*****************************************************************************80
!
!! TEST02 draws a hexagon, and fills it in.
!
  implicit none

  integer, parameter :: ntab = 6
  integer, parameter :: npts = 3

  real angle
  integer i
  integer icolor
  integer ierror
  integer itable
  real r_pi
  real x(ntab+1)
  real xtab(ntab)
  real y(ntab+1)
  real ytab(ntab)

  write ( *, * ) ' '
  write ( *, * ) 'TEST02'
  write ( *, * ) ' Draw a hexagon, and fill it in.'
  write ( *, * ) ' '
!
!  Set up the data for the hexagon.
!
  do i = 1, ntab
    angle = real ( i - 1 ) * 2.0 * r_pi ( ) / real ( ntab )
    xtab(i) = cos ( angle )
    ytab(i) = sin ( angle )
  end do
!
!  Set the coordinate system to be -1.0 < =  X <= 1.0,
!  and -1.0 < =  Y <= 1.0
!
  call setwcd ( -1.0, -1.0, 1.0, 1.0, ierror )
!
!  Use color table 3, waves of green in red fading to blue.
!
  itable = 3
  call setctb ( itable )

  icolor = 2
  call filclr ( icolor )
  x(1) = xtab(1)
  x(2) = xtab(2)
  x(3) = 0.0
  y(1) = ytab(1)
  y(2) = ytab(2)
  y(3) = 0.0
  call plygon ( npts, x, y )

  icolor = 8
  call filclr ( icolor )
  x(1) = xtab(3)
  x(2) = xtab(4)
  x(3) = 0.0
  y(1) = ytab(3)
  y(2) = ytab(4)
  y(3) = 0.0
  call plygon ( npts, x, y )

  icolor = 14
  call filclr ( icolor )
  x(1) = xtab(5)
  x(2) = xtab(6)
  x(3) = 0.0
  y(1) = ytab(5)
  y(2) = ytab(6)
  y(3) = 0.0
  call plygon ( npts, x, y )
!
!  Now draw just the outline of a hexagon that's half as large.
!
  icolor = 20
  call linclr ( icolor )

  x(1:ntab) = 0.5 * xtab(1:ntab)
  x(ntab+1) = x(1)

  y(1:ntab) = 0.5 * ytab(1:ntab)
  y(ntab+1) = y(1)

  call plylin ( ntab+1, x, y )

  return
end
subroutine test03
!
!*****************************************************************************80
!
!! TEST03 draws a 16 by 16 box, filling each entry with a color.
!
  implicit none
!
  integer, parameter :: npoly = 4
!
  character ( len = 20 ) :: filename
  integer i
  integer icolor
  integer ierror
  integer itable
  integer j
  integer maxclr
  integer minclr
  real x(npoly)
  real y(npoly)
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST03'
  write ( *, '(a)' ) '  Draw 256 boxes, each with a different polygon.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Repeat this for each of the five built in'
  write ( *, '(a)' ) '  color tables.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Then read in an external color table.'
  write ( *, '(a)' ) ' '
!
!  Set the coordinate system to be 0 < =  X <= 16.0,
!  and 0.0 < =  Y <= 16.0
!
  call setwcd ( 0.0, 0.0, 16.0, 16.0, ierror )
!
!  Choose a color table.
!
  do itable = 1, 7


    if ( itable <= 5 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Set color table ', itable
      call setctb ( itable )
    else if ( itable == 6 ) then
      filename = 'colors.dat'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Read color table ' // trim ( filename )
      minclr = 20
      maxclr = 247
      call getctb ( minclr, maxclr, filename, ierror )
    else if ( itable == 7 ) then
      filename = 'redblu.dat'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Read color table ' // trim ( filename )
      minclr = 2
      maxclr = 255
      call getctb ( minclr, maxclr, filename, ierror )
    end if
!
!  You have to call NEWFRM before you use the new color table, in
!  order to make the new color table effective!
!
    call newfrm
    icolor = 0
    do i  =  1, 16
      do j  =  1, 16
        call filclr ( icolor )
        icolor = icolor+1
        x(1) = real ( j-1)
        y(1) = real ( 16-i)
        x(2) = real ( j)
        y(2) = real ( 16-i)
        x(3) = real ( j)
        y(3) = real ( 16+1-i)
        x(4) = real ( j-1)
        y(4) = real ( 16+1-i)
        call plygon ( npoly, x, y )
      end do
    end do

  end do

  return
end