program main

!*****************************************************************************80
!
!! MAIN is the main program for DRAWCGM_PRB1.
!
!  Discussion:
!
!    DRAWCGM_PRB1 is a sample calling program for DRAWCGM.
!
!  Modified:
!
!    25 September 2002
!
  implicit none

  character c
  character ( len = 20 ) dev
  character ( len = 20 ) filename
  integer ierror
  integer itable
  integer maxclr
  integer minclr
  logical pause
  character pause_input

  call timestamp ( )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'DRAWCGM_PRB1'
  write ( *, '(a)' ) '  FORTRAN90 version'
  write ( *, '(a)' ) '  Sample problems for DRAWCGM.'
!
!  Specify the output device.
!
  dev = 'cgmb'
  call device ( dev )

  if ( dev == 'XWS' .or. dev == 'xws' ) then
    pause = .true.
  else
    pause = .false.
  end if
!
!  Specify the name of the output file.
!
  if ( dev == 'PS' .or. dev == 'ps' ) then
    filename = 'drawcgm_prb1.ps'
    call outfil ( filename )
    write ( *, '(a)' ) '  Graphics output goes to the file ' &
      // trim ( filename )
  else if ( dev == 'CGMB' .or. dev == 'cgmb' ) then
    filename = 'drawcgm_prb1.cgmb'
    call outfil ( filename )
    write ( *, '(a)' ) '  Graphics output goes to the file ' &
      // trim ( filename )
  end if
!
!  Read in a color table, and add a couple of entries by hand.  
!
  maxclr = 247
  minclr = 20 
  call getctb ( minclr, maxclr, 'colors.dat', ierror )

  if ( ierror /= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'DRAWCGM_PRB1 - Fatal error!'
    write ( *, '(a,i6)' )  '  GETCTB returned IERROR = ', ierror
    stop
  end if

  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 ( )
!
!  DEBUG
!
  call setctb ( 4 )
!
!  Call the test routines.
!
  call test01

  if ( pause ) then
    c = pause_input ( )
  end if

  call test02

  if ( pause ) then
    c = pause_input ( )
  end if

  call test03

  if ( pause ) then
    c = pause_input ( )
  end if

  call test04

  if ( pause ) then
    c = pause_input ( )
  end if

  do itable = 1, 5

    call test05 ( itable )

    if ( pause ) then
      c = pause_input ( )
    end if

  end do

  call test06

  if ( pause ) then
    c = pause_input ( )
  end if

  call test07

  if ( pause ) then
    c = pause_input ( )
  end if

  call test08

  if ( pause ) then
    c = pause_input ( )
  end if
!
!  Terminate graphics.
!
  call grfcls
!
!  Say goodbye.
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'DRAWCGM_PRB1'
  write ( *, '(a)' ) '  Normal end of execution.'

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

  stop
end
subroutine getdat ( input, nxdim, nydim )

!*****************************************************************************80
!
!! GETDAT sets some data for the tests.
!
  implicit none

  integer nxdim
  integer nydim

  integer i
  real input(nxdim,nydim)
  integer j

  do i = 1, nxdim
    do j = 1, nydim
      input(i,j) = 0.5E+00 * real ( i + j ) / real ( nxdim )
    end do
  end do

  return
end
subroutine test01

!*****************************************************************************80
!
!! TEST01 uses linear interpolation to "stretch" cell array data.
!
  implicit none

  integer, parameter :: nxbig = 300
  integer, parameter :: nxsmall = 10
  integer, parameter :: nybig = 300
  integer, parameter :: nysmall = 10

  real input(nxsmall,nysmall)
  integer ipixel(nxbig,nybig)
  integer maxclr
  integer minclr
  real pixel(nxbig,nybig)
  real xlabel
  real xmax
  real xmaxcb
  real xmin
  real xmincb
  real ylabel
  real ymax
  real ymin

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST01'
  write ( *, '(a)' ) '  Use linear interpolation to stretch cell data.'
!
!  Get the data.
!
  call getdat ( input, nxsmall, nysmall )
!
!  Tweak a data point out of range, to test the
!  range check functionality of RTOINT.
!
  input(nxsmall/2,nysmall/2) = - 0.1
!
!  Use linear interpolation to stretch the data.
!
  call rmat_expand_linear ( input, nxsmall, nysmall, pixel, nxbig, nybig )
!
!  Map the data to integer values.
!
  minclr = 20
  maxclr = 247

  call rtoint ( pixel, ipixel, nxbig, nybig, 0.0, 1.0, minclr, maxclr )
!
!  Draw the data.
!
  xmin = 0.1
  ymin = 0.2
  xmax = 0.7
  ymax = 0.8

  call drawit ( ipixel, nxbig, nybig, xmin, ymin, xmax, ymax )
!
!  Vertical color bar.
!
  xmaxcb = 0.88
  xmincb = 0.78

  call vrtcbr ( xmincb, ymin, xmaxcb, ymax, minclr, maxclr, '1e-7', '1e+3', &
    1, 0.03 )
!
!  Label the plot.
!
  xlabel = 0.1
  ylabel = 0.93

  call label ( xlabel, ylabel, 'Linear stretch', 1, 0.03 )

  return
end
subroutine test02

!*****************************************************************************80
!
!! TEST02 uses cubic spline interpolation to "stretch" cell array data.
!
  implicit none

  integer, parameter :: nxbig = 300
  integer, parameter :: nxsmall = 10
  integer, parameter :: nybig = 300
  integer, parameter :: nysmall = 10

  real input(nxsmall,nysmall)
  integer ipixel(nxbig,nybig)
  integer maxclr
  integer minclr
  real pixel(nxbig,nybig)
  real temp(nxsmall,nysmall)
  real xlabel
  real xmax
  real xmaxcb
  real xmin
  real xmincb
  real ylabel
  real ymax
  real ymin

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST02'
  write ( *, '(a)' ) '  Use spline interpolation to stretch cell data.'
!
!  Get the data.
!
  call getdat ( input, nxsmall, nysmall )
!
!  Stretch the data by spline interpolation, and draw it again.
!
  call newfrm ( )
!
!  Label the plot.
!
  xlabel = 0.1
  ylabel = 0.93

  call label ( xlabel, ylabel, 'Spline stretch', 1, 0.03 )

  call strspl ( input, temp, nxsmall, nysmall, pixel, nxbig, nybig )

  maxclr = 247
  minclr = 20

  call rtoint ( pixel, ipixel, nxbig, nybig, 0.0, 1.0, minclr, maxclr )

  xmin = 0.1
  ymin = 0.2
  xmax = 0.7
  ymax = 0.8

  call drawit ( ipixel, nxbig, nybig, xmin, ymin, xmax, ymax )

  xmincb = 0.78
  xmaxcb = 0.88

  call vrtcbr ( xmincb, ymin, xmaxcb, ymax, minclr, maxclr, '1e-7', '1e+3', &
    1, 0.03 )

  return
end
subroutine test03

!*****************************************************************************80
!
!! TEST03 uses IMGMSK to mask a portion of the data.
!
  implicit none

  integer, parameter :: nxsmall = 10
  integer, parameter :: nysmall = 10
  integer, parameter :: nxbig = 300
  integer, parameter :: nybig = 300
  integer, parameter :: nxmask = 3
  integer, parameter :: nymask = 3

  real input(nxsmall,nysmall)
  integer ipixel(nxbig,nybig)
  integer maxclr
  integer mfield(nxmask,nymask)
  integer minclr
  real pixel(nxbig,nybig)
  real xlabel
  real xmax
  real xmin
  real ylabel
  real ymax
  real ymin

  data mfield / 1,1,1,1,0,0,1,1,1 /

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST03'
  write ( *, '(a)' ) '  Use a mask on the cell data.'
!
!  Get the data.
!
  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 ( )
!
!  Label the plot.
!
  xlabel = 0.1
  ylabel = 0.93

  call label ( xlabel, ylabel, 'Mask and window Frame', 1, 0.03 )

  call rmat_expand_linear ( input, nxsmall, nysmall, pixel, nxbig, nybig )

  minclr = 20
  maxclr = 247

  call rtoint ( pixel, ipixel, nxbig, nybig, 0.0, 1.0, minclr, maxclr )

  call imgmsk ( mfield, nxmask, nymask, ipixel, nxbig, nybig )

  xmin = 0.1
  ymin = 0.2
  xmax = 0.7
  ymax = 0.8

  call drawit ( ipixel, nxbig, nybig, xmin, ymin, xmax, ymax )

  call winfrm ( )

  return
end
subroutine test04

!*****************************************************************************80
!
!! TEST04 demonstrates horizontal and vertical flips.
!
  implicit none

  integer, parameter :: nxmed = 150
  integer, parameter :: nxsmall = 10
  integer, parameter :: nymed = 150
  integer, parameter :: nysmall = 10

  integer i
  real input(nxsmall,nysmall)
  integer ismimg1(nxmed,nymed)
  integer ismimg2(nxmed,nymed)
  integer ismimg3(nxmed,nymed)
  integer j
  integer maxclr
  integer minclr
  real smimg(nxmed,nymed)
  real xlabel
  real, parameter :: xmnmed1= 0.1
  real, parameter :: xmnmed2= 0.4
  real, parameter :: xmnmed3= 0.1
  real, parameter :: xmnmed4= 0.45
  real, parameter :: xmxmed1=0.4
  real, parameter :: xmxmed2=0.7
  real, parameter :: xmxmed3=0.4
  real, parameter :: xmxmed4=0.75
  real ylabel
  real, parameter :: ymnmed1=0.5
  real, parameter :: ymnmed2=0.5
  real, parameter :: ymnmed3=0.2
  real, parameter :: ymnmed4=0.15
  real, parameter :: ymxmed1 = 0.8
  real, parameter :: ymxmed2 = 0.8
  real, parameter :: ymxmed3 = 0.5
  real, parameter :: ymxmed4 = 0.45

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST04'
  write ( *, '(a)' ) '  Demonstrate horizontal and vertical flips'
  write ( *, '(a)' ) '  on cell data.'
!
!  Get the data.
!
  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 ( )
!
!  Label the plot.
!
  xlabel = 0.1
  ylabel = 0.93

  call label ( xlabel, ylabel, 'Copy, Flips, and interpolation', 1, 0.03 )

  call rmat_expand_linear ( input, nxsmall, nysmall, smimg, nxmed, nymed )

  minclr = 20
  maxclr = 247

  call rtoint ( smimg, ismimg1, nxmed, nymed, 0.0, 1.0, minclr, maxclr )

  ismimg2 = ismimg1

  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 test05 ( itable )

!*****************************************************************************80
!
!! TEST05 exhibits a color table.
!
  implicit none

  integer itable
  real xlabel
  real, parameter :: xmaxhb = 0.8
  real xmaxpt
  real, parameter :: xminhb = 0.1
  real xminpt
  real ylabel
  real, parameter :: ymaxhb = 0.45
  real ymaxpt
  real, parameter :: yminhb = 0.2
  real yminpt

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST05'
  write ( *, '(a,i6)' ) '  Exhibit color table #', itable

  call setctb ( itable )

  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 ( )
!
!  Label the plot.
!
  xlabel = 0.1
  ylabel = 0.93

  call label ( xlabel, ylabel, 'Standard Color Bars.', 1, 0.03 )

  xminpt = 0.1
  yminpt = 0.5
  xmaxpt = 0.8
  ymaxpt = 0.9

  call pltbar ( xminpt, yminpt, xmaxpt, ymaxpt, 2, 256, 2, 3, 4 )

  call horcbr ( xminhb, yminhb, xmaxhb, ymaxhb, 2, 256, '1e-7', '1e+3', &
    1, 0.03 )

  return
end
subroutine test06

!*****************************************************************************80
!
!! TEST06 uses CGRID to draw a Cartesian grid.
!
  implicit none

  logical fill
  integer icolor
  integer nbox
  integer nx
  integer ny
  real size
  real xbox(5)
  real xhi
  real xlo
  real xval
  real ybox(5)
  real yhi
  real ylo
  real yval

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST06'
  write ( *, '(a)' ) '  Draw a Cartesian grid.'
!
!  New frame.
!
  call newfrm ( )
!
!  Draw a Cartesian grid.
!
  xlo = 0.1
  xhi = 0.9
  nx = 10
  ylo = 0.1
  yhi = 0.9
  ny = 15

  call cgrid ( xlo, xhi, nx, ylo, yhi, ny )
!
!  Choose the fill color to be used.
!
  icolor = 100
  call filclr ( icolor )
!
!  Draw a box around the picture.
!
  nbox = 4
  xbox(1) = 0.0
  ybox(1) = 0.0
  xbox(2) = 1.0
  ybox(2) = 0.0
  xbox(3) = 1.0
  ybox(3) = 1.0
  xbox(4) = 0.0
  ybox(4) = 1.0
  xbox(5) = 0.0
  ybox(5) = 0.0

  call plylin ( nbox, xbox, ybox )
!
!  Draw three circles.
!
  fill = .TRUE.

  call circle ( 0.5, 0.5, 0.25, fill )

  call circle ( 0.25, 0.75, 0.125, fill )

  call circle ( 0.75, 0.75, 0.125, fill )
!
!  Draw new circles inside the old ones, of a different color.
!
  icolor = 5
  call filclr ( icolor )

  call circle ( 0.5625, 0.5625, 0.03125, fill )

  call circle ( 0.4375, 0.5625, 0.03125, fill )

  call circle ( 0.5000, 0.40625, 0.03125, fill )
!
!  Label the plot.
!
  xval = 0.10E+00
  yval = 0.10E+00
  icolor = 2
  size = 0.075E+00
  call label ( xval, yval, 'Mortimer Mouse', icolor, size )

  return
end
subroutine test07

!*****************************************************************************80
!
!! TEST07 draws boxes using the incremental plot commands.
!
!  Test the 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.
!
  implicit none

  real, dimension ( 4 ) :: xarr1 = (/ -5.0, -5.0, 5.0, 5.0 /)
  real, dimension ( 4 ) :: xarr2 = (/ -5.0,  0.0, 5.0, 0.0 /)
  real xarr3(4)
  real xlabel
  real xmark(5)
  real yarr1(4)
  real yarr2(4)
  real yarr3(4)
  real ylabel
  real ymark(5)

  data yarr1 / -5.0,5.0,5.0,-5.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 /

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST07'
  write ( *, '(a)' ) '  Draw boxes using incremental plot commands.'

  call newfrm ( )
!
!  Label the plot.
!
  xlabel = 0.03
  ylabel = 0.93

  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 (drawn with wider lines):
!
  call linwid ( 4.0 )

  call square ( xarr3, yarr3 )

  return
end
subroutine square ( xarray, yarray )

!*****************************************************************************80
!
!! SQUARE draws a quadrilateral.
!
  implicit none

  real xarray(4)
  real yarray(4)
!
!  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) )
!
!  Return to first vertex.
!
  call drwcgm ( xarray(1), yarray(1) )

  return
end
subroutine test08

!*****************************************************************************80
!
!! TEST08 demonstrates how PUTCTB can write a color table to a file.
!
!  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)
!
  implicit none

  character( len = 20 ) filename
  integer ierror

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'TEST08'
  write ( *, '(a)' ) '  Write color table data to a file.'

  filename = 'color_out.txt'

  call putctb ( 1, 4, filename, ierror )

  if ( ierror /= 0 ) then
    write ( *, '(a,i6)' ) '  PUTCTB returned IERROR = ', ierror
  else
    write ( *, '(a)' ) '  PUTCTB wrote color data to the file ' &
      // trim ( filename )
  end if

  return
end
function pause_input ( )

!*****************************************************************************80
!
!! PAUSE_INPUT waits until an input character is entered.
!
!  Modified:
!
!    02 May 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, character PAUSE_INPUT, the character that was entered.
!
  implicit none

  integer ios
  character pause_input

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'Press RETURN to continue.'

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

  return
end