program drawcgm_prb1
!
!*******************************************************************************
!
!! DRAWCGM_PRB1 is a sample calling program for DRAWCGM.
!
  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 ( *, * ) ' '
  write ( *, * ) 'DRAWCGM_PRB1'
  write ( *, * ) '  Sample problems for DRAWCGM.'
!
!  Specify the output device.
!
  dev = 'ps'
  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,a)' ) '  Graphics output goes to the file ', 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 ( *, * ) ' '
    write ( *, * ) 'DRAWCGM_PRB1 - Fatal error!'
    write ( *, * )  '  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 ( *, * ) ' '
  write ( *, * ) 'DRAWCGM_PRB1'
  write ( *, * ) '  Normal end of execution.'

  stop
end
subroutine getdat ( input, nxdim, nydim )
!
!*******************************************************************************
!
!! 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.5 * real ( i + j ) / real ( nxdim )
    end do
  end do

  return
end
subroutine test01
!
!*******************************************************************************
!
!! 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 ( *, * ) ' '
  write ( *, * ) 'TEST01'
  write ( *, * ) '  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
!
!*******************************************************************************
!
!! 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 ( *, * ) ' '
  write ( *, * ) 'TEST02'
  write ( *, * ) '  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
!
!*******************************************************************************
!
!! 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 ( *, * ) ' '
  write ( *, * ) 'TEST03'
  write ( *, * ) '  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
!
!*******************************************************************************
!
!! 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 ( *, * ) ' '
  write ( *, * ) 'TEST04'
  write ( *, * ) '  Demonstrate horizontal and vertical flips'
  write ( *, * ) '  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 )
!
!*******************************************************************************
!
!! 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 ( *, * ) ' '
  write ( *, * ) 'TEST05'
  write ( *, * ) '  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
!
!*******************************************************************************
!
!! 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 ( *, * ) ' '
  write ( *, * ) 'TEST06'
  write ( *, * ) '  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
!
!*******************************************************************************
!
!! 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 xarr2(4)
  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 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 /
!
  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 )
!
!*******************************************************************************
!
!! 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
!
!*******************************************************************************
!
!! 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 ( )
!
!*******************************************************************************
!
!! 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