subroutine ch_cap ( c ) !*****************************************************************************80 ! !! CH_CAP capitalizes a single character. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 19 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character C, the character to capitalize. ! implicit none character c integer itemp itemp = ichar ( c ) if ( 97 <= itemp .and. itemp <= 122 ) then c = char ( itemp - 32 ) end if return end subroutine get_prob_num ( prob_num ) !*****************************************************************************80 ! !! GET_PROB_NUM returns the number of test problems. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 10 June 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer PROB_NUM, the number of test problems. ! implicit none integer prob_num prob_num = 11 return end subroutine i4_swap ( i, j ) !*****************************************************************************80 ! !! I4_SWAP swaps two I4's. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 30 November 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer I, J. On output, the values of I and ! J have been interchanged. ! implicit none integer i integer j integer k k = i i = j j = k return end subroutine p00_dat ( prob, x, y, ndata ) !*****************************************************************************80 ! !! P00_DAT returns the data vector for problems of data vector type. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 10 June 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer PROB, the number of the desired test problem. ! ! Output, real ( kind = 8 ) X(NDATA), the abscissa data. ! ! Output, real ( kind = 8 ) Y(NDATA), the ordinate data. ! ! Input, integer NDATA, the number of data points, as specified by P00_NDATA. ! implicit none integer ndata integer prob real ( kind = 8 ) x(ndata) real ( kind = 8 ) y(ndata) if ( prob == 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'P00_DAT - Fatal error!' write ( *, '(a)' ) ' This problem is not a data vector type!' else if ( prob == 2 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'P00_DAT - Fatal error!' write ( *, '(a)' ) ' This problem is not a data vector type!' else if ( prob == 3 ) then call p03_dat ( x, y, ndata ) else if ( prob == 4 ) then call p04_dat ( x, y, ndata ) else if ( prob == 5 ) then call p05_dat ( x, y, ndata ) else if ( prob == 6 ) then call p06_dat ( x, y, ndata ) else if ( prob == 7 ) then call p07_dat ( x, y, ndata ) else if ( prob == 8 ) then call p08_dat ( x, y, ndata ) else if ( prob == 9 ) then call p09_dat ( x, y, ndata ) else if ( prob == 10 ) then call p10_dat ( x, y, ndata ) else if ( prob == 11 ) then call p11_dat ( x, y, ndata ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'P00_DAT - Fatal error!' write ( *, '(a,i6)' ) ' Illegal problem number = ', prob stop end if return end function p00_fun ( prob, x ) !*****************************************************************************80 ! !! P00_FUN evaluates the function for any problem. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 10 June 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer PROB, the number of the desired test problem. ! ! Input, real ( kind = 8 ) X, the point at which the function ! is to be evaluated. ! ! Output, real ( kind = 8 ) P00_FUN, the value of the function at X. ! implicit none integer prob real ( kind = 8 ) p00_fun real ( kind = 8 ) p01_fun real ( kind = 8 ) p02_fun real ( kind = 8 ) x if ( prob == 1 ) then p00_fun = p01_fun ( x ) else if ( prob == 2 ) then p00_fun = p02_fun ( x ) else if ( prob == 3 ) then p00_fun = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'P00_FUN - Fatal error!' write ( *, '(a)' ) ' This problem is not functional!' else if ( prob == 4 ) then p00_fun = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'P00_FUN - Fatal error!' write ( *, '(a)' ) ' This problem is not functional!' else if ( prob == 5 ) then p00_fun = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'P00_FUN - Fatal error!' write ( *, '(a)' ) ' This problem is not functional!' else if ( prob == 6 ) then p00_fun = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'P00_FUN - Fatal error!' write ( *, '(a)' ) ' This problem is not functional!' else if ( prob == 7 ) then p00_fun = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'P00_FUN - Fatal error!' write ( *, '(a)' ) ' This problem is not functional!' else if ( prob == 8 ) then p00_fun = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'P00_FUN - Fatal error!' write ( *, '(a)' ) ' This problem is not functional!' else if ( prob == 9 ) then p00_fun = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'P00_FUN - Fatal error!' write ( *, '(a)' ) ' This problem is not functional!' else if ( prob == 10 ) then p00_fun = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'P00_FUN - Fatal error!' write ( *, '(a)' ) ' This problem is not functional!' else if ( prob == 11 ) then p00_fun = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'P00_FUN - Fatal error!' write ( *, '(a)' ) ' This problem is not functional!' else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'P00_FUN - Fatal error!' write ( *, '(a,i6)' ) ' Illegal problem number = ', prob p00_fun = 0.0D+00 stop end if return end subroutine p00_lim ( prob, a, b ) !*****************************************************************************80 ! !! P00_LIM returns the limits of the approximation interval for any problem. ! ! Discussion: ! ! If the problem is defined by a set of data points, then A and B ! will simply be the minimum and maximum data abscissas. ! ! If the problem is defined by a function, then A and B are the ! minimum and maximum abscissas in an interval of interest. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 10 June 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer PROB, the number of the desired test problem. ! ! Output, real ( kind = 8 ) A, B, the lower and upper limits of ! the approximation interval. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b integer prob if ( prob == 1 ) then call p01_lim ( a, b ) else if ( prob == 2 ) then call p02_lim ( a, b ) else if ( prob == 3 ) then call p03_lim ( a, b ) else if ( prob == 4 ) then call p04_lim ( a, b ) else if ( prob == 5 ) then call p05_lim ( a, b ) else if ( prob == 6 ) then call p06_lim ( a, b ) else if ( prob == 7 ) then call p07_lim ( a, b ) else if ( prob == 8 ) then call p08_lim ( a, b ) else if ( prob == 9 ) then call p09_lim ( a, b ) else if ( prob == 10 ) then call p10_lim ( a, b ) else if ( prob == 11 ) then call p11_lim ( a, b ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'P00_LIM - Fatal error!' write ( *, '(a,i6)' ) ' Illegal problem number = ', prob stop end if return end subroutine p00_ndata ( prob, ndata ) !*****************************************************************************80 ! !! P00_NDATA returns the dimension of the data vector for any problem. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 10 June 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NDATA, the dimension of the data vector. ! If the problem is not of data vector type, then NDATA is ! returned as 0. ! ! Output, integer NDATA, the dimension of the data vector. ! implicit none integer prob integer ndata if ( prob == 1 ) then ndata = 0 else if ( prob == 2 ) then ndata = 0 else if ( prob == 3 ) then call p03_ndata ( ndata ) else if ( prob == 4 ) then call p04_ndata ( ndata ) else if ( prob == 5 ) then call p05_ndata ( ndata ) else if ( prob == 6 ) then call p06_ndata ( ndata ) else if ( prob == 7 ) then call p07_ndata ( ndata ) else if ( prob == 8 ) then call p08_ndata ( ndata ) else if ( prob == 9 ) then call p09_ndata ( ndata ) else if ( prob == 10 ) then call p10_ndata ( ndata ) else if ( prob == 11 ) then call p11_ndata ( ndata ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'P00_NDATA - Fatal error!' write ( *, '(a,i6)' ) ' Illegal problem number = ', prob stop end if return end subroutine p00_period ( prob, iperiod ) !*****************************************************************************80 ! !! P00_PERIOD returns the periodicity of any problem. ! ! Discussion: ! ! If the data is periodic, then it will be assumed that the approximation ! interval is exactly equal to one or more periods of the data. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 10 June 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer PROB, the number of the desired test problem. ! ! Output, integer IPERIOD, the periodicity of the data. ! 0, the data is not known to be periodic. ! 1, the data is periodic. ! implicit none integer iperiod integer prob if ( prob == 1 ) then iperiod = 0 else if ( prob == 2 ) then iperiod = 0 else if ( prob == 3 ) then iperiod = 0 else if ( prob == 4 ) then iperiod = 0 else if ( prob == 5 ) then iperiod = 0 else if ( prob == 6 ) then iperiod = 0 else if ( prob == 7 ) then iperiod = 0 else if ( prob == 8 ) then iperiod = 0 else if ( prob == 9 ) then iperiod = 0 else if ( prob == 10 ) then iperiod = 0 else if ( prob == 11 ) then iperiod = 0 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'P00_PERIOD - Fatal error!' write ( *, '(a,i6)' ) ' Illegal problem number = ', prob stop end if return end subroutine p00_story ( prob ) !*****************************************************************************80 ! !! P00_STORY prints the "story" for any problem. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 19 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none integer prob if ( prob == 1 ) then call p01_story ( ) else if ( prob == 2 ) then call p02_story ( ) else if ( prob == 3 ) then call p03_story ( ) else if ( prob == 4 ) then call p04_story ( ) else if ( prob == 5 ) then call p05_story ( ) else if ( prob == 6 ) then call p06_story ( ) else if ( prob == 7 ) then call p07_story ( ) else if ( prob == 8 ) then call p08_story ( ) else if ( prob == 9 ) then call p09_story ( ) else if ( prob == 10 ) then call p10_story ( ) else if ( prob == 11 ) then call p11_story ( ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'P00_STORY - Fatal error!' write ( *, '(a)' ) ' Unexpected input value of PROB.' stop end if return end subroutine p00_title ( prob, title ) !*****************************************************************************80 ! !! P00_TITLE returns the title of any problem. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 10 June 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer PROB, the number of the desired test problem. ! ! Output, character ( len = * ) TITLE, the title of the problem. ! implicit none integer prob character ( len = * ) title if ( prob == 1 ) then call p01_title ( title ) else if ( prob == 2 ) then call p02_title ( title ) else if ( prob == 3 ) then call p03_title ( title ) else if ( prob == 4 ) then call p04_title ( title ) else if ( prob == 5 ) then call p05_title ( title ) else if ( prob == 6 ) then call p06_title ( title ) else if ( prob == 7 ) then call p07_title ( title ) else if ( prob == 8 ) then call p08_title ( title ) else if ( prob == 9 ) then call p09_title ( title ) else if ( prob == 10 ) then call p10_title ( title ) else if ( prob == 11 ) then call p11_title ( title ) else title = ' ' write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'P00_TITLE - Fatal error!' write ( *, '(a,i6)' ) ' Illegal problem number = ', prob stop end if return end subroutine p00_type ( prob, type ) !*****************************************************************************80 ! !! P00_TYPE returns the type of any problem. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 10 June 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer PROB, the number of the desired test problem. ! ! Output, integer TYPE, the type of the problem. ! 0, the problem data is available through a function call. ! 1, the problem data is available as a data vector. ! implicit none integer prob integer type if ( prob == 1 ) then call p01_type ( type ) else if ( prob == 2 ) then call p02_type ( type ) else if ( prob == 3 ) then call p03_type ( type ) else if ( prob == 4 ) then call p04_type ( type ) else if ( prob == 5 ) then call p05_type ( type ) else if ( prob == 6 ) then call p06_type ( type ) else if ( prob == 7 ) then call p07_type ( type ) else if ( prob == 8 ) then call p08_type ( type ) else if ( prob == 9 ) then call p09_type ( type ) else if ( prob == 10 ) then call p10_type ( type ) else if ( prob == 11 ) then call p11_type ( type ) else type = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'P00_TYPE - Fatal error!' write ( *, '(a,i6)' ) ' Illegal problem number = ', prob stop end if return end function p01_fun ( x ) !*****************************************************************************80 ! !! P01_FUN evaluates the function for problem 1. ! ! Discussion: ! ! This is a famous example, due to Runge. If equally spaced ! abscissas are used, the sequence of interpolating polynomials Pn(X) ! diverges, in the sense that the max norm of the difference ! between Pn(X) and F(X) becomes arbitrarily large as N increases. ! ! Dimension: ! ! N = 1 ! ! Interval: ! ! -5 <= X <= 5 ! ! Function: ! ! 1 / ( X * X + 1 ) ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 08 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the point at which the function ! is to be evaluated. ! ! Output, real ( kind = 8 ) P01_FUN, the value of the function at X. ! implicit none real ( kind = 8 ) p01_fun real ( kind = 8 ) x p01_fun = 1.0D+00 / ( x * x + 1.0D+00 ) return end subroutine p01_lim ( a, b ) !*****************************************************************************80 ! !! P01_LIM returns the limits of the approximation interval for problem 1. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 03 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) A, B, the limits of the interval ! of approximation. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b a = -5.0D+00 b = 5.0D+00 return end subroutine p01_story ( ) !*****************************************************************************80 ! !! P01_STORY prints the "story" for problem 1. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 19 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' This is a famous example, due to Runge. If equally spaced' write ( *, '(a)' ) & ' abscissas are used, the sequence of interpolating polynomials Pn(X)' write ( *, '(a)' ) & ' diverges, in the sense that the max norm of the difference' write ( *, '(a)' ) & ' between Pn(X) and F(X) becomes arbitrarily large as N increases.' return end subroutine p01_title ( title ) !*****************************************************************************80 ! !! P01_TITLE returns the title of problem 1. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 08 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, character ( len = * ) TITLE, the title of the problem. ! implicit none character ( len = * ) title title = 'Runge example, 1 / ( x * x + 1 ), [-5,5]' return end subroutine p01_type ( type ) !*****************************************************************************80 ! !! P01_TYPE returns the type of problem 1. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 20 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer TYPE, the type of the problem. ! 0, the problem data is available through a function call. ! 1, the problem data is available as a data vector. ! implicit none integer type type = 0 return end function p02_fun ( x ) !*****************************************************************************80 ! !! P02_FUN evaluates the function for problem 2. ! ! Discussion: ! ! This example is due to Bernstein. If equally spaced ! abscissas are used, the sequence of interpolating polynomials Pn(X) ! only converges to F(X) at -1, 0, and 1. ! ! Dimension: ! ! N = 1 ! ! Interval: ! ! -1 <= X <= 1 ! ! Function: ! ! ABS ( X ) ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 08 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the point at which the function ! is to be evaluated. ! ! Output, real ( kind = 8 ) P02_FUN, the value of the function at X. ! implicit none real ( kind = 8 ) p02_fun real ( kind = 8 ) x p02_fun = abs ( x ) return end subroutine p02_lim ( a, b ) !*****************************************************************************80 ! !! P02_LIM returns the limits of the approximation interval for problem 2. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 03 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) A, B, the limits of the interval ! of approximation. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b a = -1.0D+00 b = 1.0D+00 return end subroutine p02_story ( ) !*****************************************************************************80 ! !! P02_STORY prints the "story" for problem 2. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 19 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' This example is due to Bernstein.' write ( *, '(a)' ) & ' If equally spaced abscissas are used, the sequence of interpolating' write ( *, '(a)' ) & ' polynomials Pn(X) only converges to F(X) at -1, 0, and 1.' return end subroutine p02_title ( title ) !*****************************************************************************80 ! !! P02_TITLE returns the title of problem 2. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 08 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, character ( len = * ) TITLE, the title of the problem. ! implicit none character ( len = * ) title title = 'Bernstein example, abs ( x ), [-1,1]' return end subroutine p02_type ( type ) !*****************************************************************************80 ! !! P02_TYPE returns the type of problem 2. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 20 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer TYPE, the type of the problem. ! 0, the problem data is available through a function call. ! 1, the problem data is available as a data vector. ! implicit none integer type type = 0 return end subroutine p03_dat ( x, y, ndata ) !*****************************************************************************80 ! !! P03_DAT returns the data vector for problem 3. ! ! Discussion: ! ! The X data is measured in days, and the Y data represents the ! observed position of Mars in a heliocentric coordinate system. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 24 June 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Samuel Conte, Carl deBoor, ! Elementary Numerical Analysis, ! McGraw Hill, 1972, page 217. ! ! Parameters: ! ! Output, real ( kind = 8 ) X(NDATA), the abscissa data. ! ! Output, real ( kind = 8 ) Y(NDATA), the ordinate data. ! ! Input, integer NDATA, the dimension of the data vector. ! implicit none integer ndata real ( kind = 8 ) x(ndata) real ( kind = 8 ) y(ndata) x(1:ndata) = (/ & 1250.5D+00, 1260.5D+00, 1270.5D+00, 1280.5D+00, 1290.5D+00, & 1300.5D+00, 1310.5D+00, 1320.5D+00, 1330.5D+00, 1340.5D+00 /) y(1:ndata) = (/ & 1.39140D+00, 1.37696D+00, 1.34783D+00, 1.30456D+00, 1.24787D+00, & 1.17862D+00, 1.09776D+00, 1.00636D+00, 0.90553D+00, 0.79642D+00 /) return end subroutine p03_lim ( a, b ) !*****************************************************************************80 ! !! P03_LIM returns the limits of the approximation interval for problem 3. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 03 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) A, B, the limits of the interval ! of approximation. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b a = 1250.5D+00 b = 1340.5D+00 return end subroutine p03_ndata ( ndata ) !*****************************************************************************80 ! !! P03_NDATA returns the dimension of the data vector for problem 3. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 09 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer NDATA, the dimension of the data vector. ! implicit none integer ndata ndata = 10 return end subroutine p03_story ( ) !*****************************************************************************80 ! !! P03_STORY prints the "story" for problem 3. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 19 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' This example is due to deBoor.' write ( *, '(a)' ) & ' For this example, X is measured in days,' write ( *, '(a)' ) & ' and Y records the observed position of Mars in a heliocentric' write ( *, '(a)' ) & ' coordinate system.' return end subroutine p03_title ( title ) !*****************************************************************************80 ! !! P03_TITLE returns the title of problem 3. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 09 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, character ( len = * ) TITLE, the title of the problem. ! implicit none character ( len = * ) title title = 'DeBoor example, Mars position, data vector' return end subroutine p03_type ( type ) !*****************************************************************************80 ! !! P03_TYPE returns the type of problem 3. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 20 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer TYPE, the type of the problem. ! 0, the problem data is available through a function call. ! 1, the problem data is available as a data vector. ! implicit none integer type type = 1 return end subroutine p04_dat ( x, y, ndata ) !*****************************************************************************80 ! !! P04_DAT returns the data vector for problem 4. ! ! Discussion: ! ! The data lies roughly along a straight line. Polynomial ! interpolation is inappropriate. Instead, a least squares ! approximation should be sought, of the form: ! ! F(X) = A + B * X ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 09 December 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Samuel Conte, Carl deBoor, ! Elementary Numerical Analysis, ! McGraw Hill, 1972, page 217. ! ! Parameters: ! ! Output, real ( kind = 8 ) X(NDATA), the abscissa data. ! ! Output, real ( kind = 8 ) Y(NDATA), the ordinate data. ! ! Input, integer NDATA, the dimension of the data vector. ! implicit none integer ndata real ( kind = 8 ) x(ndata) real ( kind = 8 ) y(ndata) x(1:ndata) = (/ & 1.0D+00, 2.0D+00, 3.0D+00, 4.0D+00, 5.0D+00, & 6.0D+00, 7.0D+00, 8.0D+00, 9.0D+00, 10.0D+00, & 11.0D+00 /) y(1:ndata) = (/ & 0.00D+00, 0.60D+00, 1.77D+00, 1.92D+00, 3.31D+00, & 3.52D+00, 4.59D+00, 5.31D+00, 5.79D+00, 7.06D+00, & 7.17D+00 /) return end subroutine p04_lim ( a, b ) !*****************************************************************************80 ! !! P04_LIM returns the limits of the approximation interval for problem 4. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 03 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) A, B, the limits of the interval ! of approximation. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b a = 1.0D+00 b = 11.0D+00 return end subroutine p04_ndata ( ndata ) !*****************************************************************************80 ! !! P04_NDATA returns the dimension of the data vector for problem 4. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 09 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer NDATA, the dimension of the data vector. ! implicit none integer ndata ndata = 11 return end subroutine p04_story ( ) !*****************************************************************************80 ! !! P04_STORY prints the "story" for problem 4. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 19 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' This example is due to deBoor.' write ( *, '(a)' ) & ' The data lies roughly along a straight line. Polynomial' write ( *, '(a)' ) & ' interpolation is inappropriate. Instead, a least squares' write ( *, '(a)' ) & ' approximation should be sought, of the form:' write ( *, '(a)' ) & ' F(X) = A + B * X' return end subroutine p04_title ( title ) !*****************************************************************************80 ! !! P04_TITLE returns the title of problem 4. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 09 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, character ( len = * ) TITLE, the title of the problem. ! implicit none character ( len = * ) title title = 'DeBoor example, roughly linear data' return end subroutine p04_type ( type ) !*****************************************************************************80 ! !! P04_TYPE returns the type of problem 4. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 20 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer TYPE, the type of the problem. ! 0, the problem data is available through a function call. ! 1, the problem data is available as a data vector. ! implicit none integer type type = 1 return end subroutine p05_dat ( x, y, ndata ) !*****************************************************************************80 ! !! P05_DAT returns the data vector for problem 5. ! ! Discussion: ! ! The data is all zero except for a single value of 1 in the center. ! This data set is interesting because an interpolation method that ! is "local" will produce an interpolating curve that is exactly ! zero over most of the outlying intervals, whereas a nonlocal ! interpolation method may produce a curve that "wiggles" over the ! entire interpolation interval. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 09 December 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) X(NDATA), the abscissa data. ! ! Output, real ( kind = 8 ) Y(NDATA), the ordinate data. ! ! Input, integer NDATA, the dimension of the data vector. ! implicit none integer ndata real ( kind = 8 ) x(ndata) real ( kind = 8 ) y(ndata) x(1:ndata) = (/ & 0.0D+00, 1.0D+00, 2.0D+00, 3.0D+00, 4.0D+00, & 5.0D+00, 6.0D+00, 7.0D+00, 8.0D+00, 9.0D+00, & 10.0D+00 /) y(1:ndata) = (/ & 0.0D+00, 0.0D+00, 0.0D+00, 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, 0.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00 /) return end subroutine p05_lim ( a, b ) !*****************************************************************************80 ! !! P05_LIM returns the limits of the approximation interval for problem 5. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 03 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) A, B, the limits of the interval ! of approximation. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b a = 0.0D+00 b = 10.0D+00 return end subroutine p05_ndata ( ndata ) !*****************************************************************************80 ! !! P05_NDATA returns the dimension of the data vector for problem 5. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 02 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer NDATA, the dimension of the data vector. ! implicit none integer ndata ndata = 11 return end subroutine p05_story ( ) !*****************************************************************************80 ! !! P05_STORY prints the "story" for problem 5. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 19 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' The data is all zero except for a single value of 1 in the center.' write ( *, '(a)' ) & ' This data set is interesting because an interpolation method that' write ( *, '(a)' ) & ' is "local" will produce an interpolating curve that is exactly' write ( *, '(a)' ) & ' zero over most of the outlying intervals, whereas a nonlocal' write ( *, '(a)' ) & ' interpolation method may produce a curve that "wiggles" over the' write ( *, '(a)' ) & ' entire interpolation interval.' return end subroutine p05_title ( title ) !*****************************************************************************80 ! !! P05_TITLE returns the title of problem 5. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 02 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, character ( len = * ) TITLE, the title of the problem. ! implicit none character ( len = * ) title title = 'The pulse data, 0 0 0 0 0 1 0 0 0 0 0' return end subroutine p05_type ( type ) !*****************************************************************************80 ! !! P05_TYPE returns the type of problem 5. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 20 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer TYPE, the type of the problem. ! 0, the problem data is available through a function call. ! 1, the problem data is available as a data vector. ! implicit none integer type type = 1 return end subroutine p06_dat ( x, y, ndata ) !*****************************************************************************80 ! !! P06_DAT returns the data vector for problem 6. ! ! Discussion: ! ! Theoretically, the data is a step, 0 to the left of 5, and 1 ! to the right. To keep things simple, the data is defined ! to be 0 up to 5 - RADIUS, 1/2 at 5, 1 at 5 + RADIUS and beyond, ! with RADIUS set to a "small" value, currently 0.01. ! Some interpolation methods will violently overreact to this ! jump. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 02 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) X(NDATA), the abscissa data. ! ! Output, real ( kind = 8 ) Y(NDATA), the ordinate data. ! ! Input, integer NDATA, the dimension of the data vector. ! implicit none integer ndata real ( kind = 8 ), parameter :: radius = 0.01D+00 real ( kind = 8 ) x(ndata) real ( kind = 8 ) y(ndata) x(1:ndata) = (/ & 0.0D+00, 1.0D+00, 2.0D+00, 3.0D+00, 4.0D+00, & 5.0D+00 - radius, 5.0D+00, 5.0D+00 + radius, 6.0D+00, 7.0D+00, & 8.0D+00, 9.0D+00, 10.0D+00 /) y(1:ndata) = (/ & 0.0D+00, 0.0D+00, 0.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 0.5D+00, 1.0D+00, 1.0D+00, 1.0D+00, & 1.0D+00, 1.0D+00, 1.0D+00 /) return end subroutine p06_lim ( a, b ) !*****************************************************************************80 ! !! P06_LIM returns the limits of the approximation interval for problem 6. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 03 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) A, B, the limits of the interval ! of approximation. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b a = 0.0D+00 b = 10.0D+00 return end subroutine p06_ndata ( ndata ) !*****************************************************************************80 ! !! P06_NDATA returns the dimension of the data vector for problem 6. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 02 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer NDATA, the dimension of the data vector. ! implicit none integer ndata ndata = 13 return end subroutine p06_story ( ) !*****************************************************************************80 ! !! P06_STORY prints the "story" for problem 6. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 19 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' Theoretically, the data is a step, 0 to the left of 5, and 1' write ( *, '(a)' ) & ' to the right. To keep things simple, the data is defined' write ( *, '(a)' ) & ' to be 0 up to 5 - RADIUS, 1/2 at 5, 1 at 5 + RADIUS and beyond,' write ( *, '(a)' ) & ' with RADIUS set to a "small" value, currently 0.01.' write ( *, '(a)' ) & ' Some interpolation methods will violently overreact to this jump.' return end subroutine p06_title ( title ) !*****************************************************************************80 ! !! P06_TITLE returns the title of problem 6. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 02 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, character ( len = * ) TITLE, the title of the problem. ! implicit none character ( len = * ) title title = 'The jump data, 0 0 0 0 0 1/2 1 1 1 1 1' return end subroutine p06_type ( type ) !*****************************************************************************80 ! !! P06_TYPE returns the type of problem 6. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 20 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer TYPE, the type of the problem. ! 0, the problem data is available through a function call. ! 1, the problem data is available as a data vector. ! implicit none integer type type = 1 return end subroutine p07_dat ( x, y, ndata ) !*****************************************************************************80 ! !! P07_DAT returns the data vector for problem 7. ! ! Discussion: ! ! This example is due to deBoor. ! This data represents a property of titanium as a function of temperature. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 03 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Carl deBoor, ! A Practical Guide to Splines, ! Springer Verlag. ! ! Parameters: ! ! Output, real ( kind = 8 ) X(NDATA), the abscissa data. ! ! Output, real ( kind = 8 ) Y(NDATA), the ordinate data. ! ! Input, integer NDATA, the dimension of the data vector. ! implicit none integer ndata real ( kind = 8 ) x(ndata) real ( kind = 8 ) y(ndata) x(1:49) = (/ & 595.0D+00, & 605.0D+00, 615.0D+00, 625.0D+00, 635.0D+00, 645.0D+00, & 655.0D+00, 665.0D+00, 675.0D+00, 685.0D+00, 695.0D+00, & 705.0D+00, 715.0D+00, 725.0D+00, 735.0D+00, 745.0D+00, & 755.0D+00, 765.0D+00, 775.0D+00, 785.0D+00, 795.0D+00, & 805.0D+00, 815.0D+00, 825.0D+00, 835.0D+00, 845.0D+00, & 855.0D+00, 865.0D+00, 875.0D+00, 885.0D+00, 895.0D+00, & 905.0D+00, 915.0D+00, 925.0D+00, 935.0D+00, 945.0D+00, & 955.0D+00, 965.0D+00, 975.0D+00, 985.0D+00, 995.0D+00, & 1005.0D+00, 1015.0D+00, 1025.0D+00, 1035.0D+00, 1045.0D+00, & 1055.0D+00, 1065.0D+00, 1075.0D+00 /) y(1:49) = (/ & 0.644D+00, & 0.622D+00, 0.638D+00, 0.649D+00, 0.652D+00, 0.639D+00, & 0.646D+00, 0.657D+00, 0.652D+00, 0.655D+00, 0.644D+00, & 0.663D+00, 0.663D+00, 0.668D+00, 0.676D+00, 0.676D+00, & 0.686D+00, 0.679D+00, 0.678D+00, 0.683D+00, 0.694D+00, & 0.699D+00, 0.710D+00, 0.730D+00, 0.763D+00, 0.812D+00, & 0.907D+00, 1.044D+00, 1.336D+00, 1.881D+00, 2.169D+00, & 2.075D+00, 1.598D+00, 1.211D+00, 0.916D+00, 0.746D+00, & 0.672D+00, 0.627D+00, 0.615D+00, 0.607D+00, 0.606D+00, & 0.609D+00, 0.603D+00, 0.601D+00, 0.603D+00, 0.601D+00, & 0.611D+00, 0.601D+00, 0.608D+00 /) return end subroutine p07_lim ( a, b ) !*****************************************************************************80 ! !! P07_LIM returns the limits of the approximation interval for problem 7. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 03 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) A, B, the limits of the interval ! of approximation. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b a = 595.0D+00 b = 1075.0D+00 return end subroutine p07_ndata ( ndata ) !*****************************************************************************80 ! !! P07_NDATA returns the dimension of the data vector for problem 7. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 03 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer NDATA, the dimension of the data vector. ! implicit none integer ndata ndata = 49 return end subroutine p07_story ( ) !*****************************************************************************80 ! !! P07_STORY prints the "story" for problem 7. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 19 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' This example is due to deBoor.' write ( *, '(a)' ) & ' This data represents a property of titanium as a function of temperature.' return end subroutine p07_title ( title ) !*****************************************************************************80 ! !! P07_TITLE returns the title of problem 7. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 03 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, character ( len = * ) TITLE, the title of the problem. ! implicit none character ( len = * ) title title = 'DeBoor''s Titanium Property' return end subroutine p07_type ( type ) !*****************************************************************************80 ! !! P07_TYPE returns the type of problem 7. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 20 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer TYPE, the type of the problem. ! 0, the problem data is available through a function call. ! 1, the problem data is available as a data vector. ! implicit none integer type type = 1 return end subroutine p08_dat ( x, y, ndata ) !*****************************************************************************80 ! !! P08_DAT returns the data vector for problem 8. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 05 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) X(NDATA), the abscissa data. ! ! Output, real ( kind = 8 ) Y(NDATA), the ordinate data. ! ! Input, integer NDATA, the dimension of the data vector. ! implicit none integer ndata integer i integer j integer n integer, parameter :: num_int = 5 real ( kind = 8 ) x(ndata) real ( kind = 8 ) y(ndata) n = 1 x(n) = 0.0D+00 y(n) = 0.0D+00 do i = 1, num_int do j = 1, i n = n + 1 x(n) = real ( i - 1, kind = 8 ) + 0.5D+00 * real ( j, kind = 8 ) & / real ( i, kind = 8 ) y(n) = real ( j, kind = 8 ) / real ( i, kind = 8 ) end do do j = 1, i n = n + 1 x(n) = real ( i - 1, kind = 8 ) + 0.5D+00 & + 0.5D+00 * real ( j, kind = 8 ) / real ( i, kind = 8 ) y(n) = 1.0D+00 - real ( j, kind = 8 ) / real ( i, kind = 8 ) end do end do return end subroutine p08_lim ( a, b ) !*****************************************************************************80 ! !! P08_LIM returns the limits of the approximation interval for problem 8. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 05 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) A, B, the limits of the interval ! of approximation. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b integer, parameter :: num_int = 5 a = 0.0D+00 b = real ( num_int, kind = 8 ) return end subroutine p08_ndata ( ndata ) !*****************************************************************************80 ! !! P08_NDATA returns the dimension of the data vector for problem 8. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 05 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer NDATA, the dimension of the data vector. ! implicit none integer ndata integer, parameter :: num_int = 5 ndata = 1 + num_int * ( num_int + 1 ) return end subroutine p08_story ( ) !*****************************************************************************80 ! !! P08_STORY prints the "story" for problem 8. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 19 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' This is a data vector.' return end subroutine p08_title ( title ) !*****************************************************************************80 ! !! P08_TITLE returns the title of problem 8. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 05 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, character ( len = * ) TITLE, the title of the problem. ! implicit none character ( len = * ) title title = 'The Sawtooth' return end subroutine p08_type ( type ) !*****************************************************************************80 ! !! P08_TYPE returns the type of problem 8. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 20 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer TYPE, the type of the problem. ! 0, the problem data is available through a function call. ! 1, the problem data is available as a data vector. ! implicit none integer type type = 1 return end subroutine p09_dat ( x, y, ndata ) !*****************************************************************************80 ! !! P09_DAT returns the data vector for problem 9. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 05 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) X(NDATA), the abscissa data. ! ! Output, real ( kind = 8 ) Y(NDATA), the ordinate data. ! ! Input, integer NDATA, the dimension of the data vector. ! implicit none integer ndata real ( kind = 8 ) x(ndata) real ( kind = 8 ) y(ndata) x(1:9) = (/ 0.0D+00, 0.1D+00, 0.2D+00, 0.3D+00, 0.4D+00, & 0.5D+00, 0.6D+00, 0.8D+00, 1.0D+00 /) y(1:9) = (/ 0.0D+00, 0.9D+00, 0.95D+00, 0.9D+00, 0.1D+00, & 0.05D+00, 0.05D+00, 0.2D+00, 1.0D+00 /) return end subroutine p09_lim ( a, b ) !*****************************************************************************80 ! !! P09_LIM returns the limits of the approximation interval for problem 9. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 05 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) A, B, the limits of the interval ! of approximation. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b a = 0.0D+00 b = 1.0D+00 return end subroutine p09_ndata ( ndata ) !*****************************************************************************80 ! !! P09_NDATA returns the dimension of the data vector for problem 9. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 05 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer NDATA, the dimension of the data vector. ! implicit none integer ndata ndata = 9 return end subroutine p09_story ( ) !*****************************************************************************80 ! !! P09_STORY prints the "story" for problem 9. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 19 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' This is a data vector.' return end subroutine p09_title ( title ) !*****************************************************************************80 ! !! P09_TITLE returns the title of problem 9. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 05 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, character ( len = * ) TITLE, the title of the problem. ! implicit none character ( len = * ) title title = 'Concavity test' return end subroutine p09_type ( type ) !*****************************************************************************80 ! !! P09_TYPE returns the type of problem 9. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 20 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer TYPE, the type of the problem. ! 0, the problem data is available through a function call. ! 1, the problem data is available as a data vector. ! implicit none integer type type = 1 return end subroutine p10_dat ( x, y, ndata ) !*****************************************************************************80 ! !! P10_DAT returns the data vector for problem 10. ! ! Discussion: ! ! This example is due to Pierre Blais. ! Data is only available over the interval [0, 238], but extrapolation ! is to be used to extend the approximate function to a maximum argument ! of 1023. The behavior of the extrapolated curve is of great interest. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 10 June 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) X(NDATA), the abscissa data. ! ! Output, real ( kind = 8 ) Y(NDATA), the ordinate data. ! ! Input, integer NDATA, the dimension of the data vector. ! implicit none integer ndata real ( kind = 8 ) x(ndata) real ( kind = 8 ) y(ndata) x(1:12) = (/ & 0.0D+00, 71.0D+00, 104.0D+00, 135.0D+00, 145.0D+00, & 160.0D+00, 181.0D+00, 193.0D+00, 205.0D+00, 215.0D+00, & 225.0D+00, 238.0D+00 /) y(1:12) = (/ & 0.0000D+00, 7.7554D+00, 19.7062D+00, 35.53786D+00, 42.91537D+00, & 54.7752D+00, 66.75865D+00, 78.49286D+00, 89.76833D+00, 101.746D+00, & 113.4824D+00, 135.4566D+00 /) return end subroutine p10_lim ( a, b ) !*****************************************************************************80 ! !! P10_LIM returns the limits of the approximation interval for problem 10. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 10 June 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) A, B, the limits of the interval ! of approximation. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b a = 0.0D+00 b = 1023.0D+00 return end subroutine p10_ndata ( ndata ) !*****************************************************************************80 ! !! P10_NDATA returns the dimension of the data vector for problem 10. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 10 June 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer NDATA, the dimension of the data vector. ! implicit none integer ndata ndata = 12 return end subroutine p10_story ( ) !*****************************************************************************80 ! !! P10_STORY prints the "story" for problem 10. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 19 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' This example is due to Pierre Blais.' write ( *, '(a)' ) & ' Data is only available over the interval [0, 238], but extrapolation' write ( *, '(a)' ) & ' is to be used to extend the approximate function to a maximum argument' write ( *, '(a)' ) & ' of 1023. The behavior of the extrapolated curve is of great interest.' return end subroutine p10_title ( title ) !*****************************************************************************80 ! !! P10_TITLE returns the title of problem 10. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 10 June 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, character ( len = * ) TITLE, the title of the problem. ! implicit none character ( len = * ) title title = 'Extrapolation test.' return end subroutine p10_type ( type ) !*****************************************************************************80 ! !! P10_TYPE returns the type of problem 10. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 10 June 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer TYPE, the type of the problem. ! 0, the problem data is available through a function call. ! 1, the problem data is available as a data vector. ! implicit none integer type type = 1 return end subroutine p11_dat ( x, y, ndata ) !*****************************************************************************80 ! !! P11_DAT returns the data vector for problem 11. ! ! Discussion: ! ! This example is due to Max Waldmeier. ! This data represents a measure of sunspot activity over the ! years 1700 to 1960. The X value is the year, and the Y value ! is a measure of the sunspot activity, which is usually, but ! not always, an integer. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 10 June 2006 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Max Waldmeier, ! The Sunspot-Activity in the Years 1610-1960, ! Shulthess, Zurich, 1961. ! ! Parameters: ! ! Output, real ( kind = 8 ) X(NDATA), the abscissa data. ! ! Output, real ( kind = 8 ) Y(NDATA), the ordinate data. ! ! Input, integer NDATA, the dimension of the data vector. ! implicit none integer ndata integer i real ( kind = 8 ) x(ndata) real ( kind = 8 ) y(ndata) do i = 1, 261 x(i) = real ( 1699 + i, kind = 8 ) end do y(1:261) = (/ & 5.0D+00, 11.0D+00, 16.0D+00, 23.0D+00, 36.0D+00, & 58.0D+00, 29.0D+00, 20.0D+00, 10.0D+00, 8.0D+00, & 3.0D+00, 0.0D+00, 0.0D+00, 2.0D+00, 11.0D+00, & 27.0D+00, 47.0D+00, 63.0D+00, 60.0D+00, 39.0D+00, & 28.0D+00, 26.0D+00, 22.0D+00, 11.0D+00, 21.0D+00, & 40.0D+00, 78.0D+00, 122.0D+00, 103.0D+00, 73.0D+00, & 47.0D+00, 35.0D+00, 11.0D+00, 5.0D+00, 16.0D+00, & 34.0D+00, 70.0D+00, 81.0D+00, 111.0D+00, 101.0D+00, & 73.0D+00, 40.0D+00, 20.0D+00, 16.0D+00, 5.0D+00, & 11.0D+00, 22.0D+00, 40.0D+00, 60.0D+00, 80.9D+00, & 83.4D+00, 47.7D+00, 47.8D+00, 30.7D+00, 12.2D+00, & 9.6D+00, 10.2D+00, 32.4D+00, 47.6D+00, 54.0D+00, & 62.9D+00, 85.9D+00, 61.2D+00, 45.1D+00, 36.4D+00, & 20.9D+00, 11.4D+00, 37.8D+00, 69.8D+00, 106.1D+00, & 100.8D+00, 81.6D+00, 66.5D+00, 34.8D+00, 30.6D+00, & 7.0D+00, 19.8D+00, 92.5D+00, 154.4D+00, 125.9D+00, & 84.8D+00, 68.1D+00, 38.5D+00, 22.8D+00, 10.2D+00, & 24.1D+00, 82.9D+00, 132.0D+00, 130.9D+00, 118.1D+00, & 89.9D+00, 66.6D+00, 60.0D+00, 46.9D+00, 41.0D+00, & 21.3D+00, 16.0D+00, 6.4D+00, 4.1D+00, 6.8D+00, & 14.5D+00, 34.0D+00, 45.0D+00, 43.1D+00, 47.5D+00, & 42.2D+00, 28.1D+00, 10.1D+00, 8.1D+00, 2.5D+00, & 0.0D+00, 1.4D+00, 5.0D+00, 12.2D+00, 13.9D+00, & 35.4D+00, 45.8D+00, 41.1D+00, 30.1D+00, 23.9D+00, & 15.6D+00, 6.6D+00, 4.0D+00, 1.8D+00, 8.5D+00, & 16.6D+00, 36.3D+00, 49.6D+00, 64.2D+00, 67.0D+00, & 70.9D+00, 47.8D+00, 27.5D+00, 8.5D+00, 13.2D+00, & 56.9D+00, 121.5D+00, 138.3D+00, 103.2D+00, 85.7D+00, & 64.6D+00, 36.7D+00, 24.2D+00, 10.7D+00, 15.0D+00, & 40.1D+00, 61.5D+00, 98.5D+00, 124.7D+00, 96.3D+00, & 66.6D+00, 64.5D+00, 54.1D+00, 39.0D+00, 20.6D+00, & 6.7D+00, 4.3D+00, 22.7D+00, 54.8D+00, 93.8D+00, & 95.8D+00, 77.2D+00, 59.1D+00, 44.0D+00, 47.0D+00, & 30.5D+00, 16.3D+00, 7.3D+00, 37.6D+00, 74.0D+00, & 139.0D+00, 111.2D+00, 101.6D+00, 66.2D+00, 44.7D+00, & 17.0D+00, 11.3D+00, 12.4D+00, 3.4D+00, 6.0D+00, & 32.3D+00, 54.3D+00, 59.7D+00, 63.7D+00, 63.5D+00, & 52.2D+00, 25.4D+00, 13.1D+00, 6.8D+00, 6.3D+00, & 7.1D+00, 35.6D+00, 73.0D+00, 85.1D+00, 78.0D+00, & 64.0D+00, 41.8D+00, 26.2D+00, 26.7D+00, 12.1D+00, & 9.5D+00, 2.7D+00, 5.0D+00, 24.4D+00, 42.0D+00, & 63.5D+00, 53.8D+00, 62.0D+00, 48.5D+00, 43.9D+00, & 18.6D+00, 5.7D+00, 3.6D+00, 1.4D+00, 9.6D+00, & 47.4D+00, 57.1D+00, 103.9D+00, 80.6D+00, 63.6D+00, & 37.6D+00, 26.1D+00, 14.2D+00, 5.8D+00, 16.7D+00, & 44.3D+00, 63.9D+00, 69.0D+00, 77.8D+00, 64.9D+00, & 35.7D+00, 21.2D+00, 11.1D+00, 5.7D+00, 8.7D+00, & 36.1D+00, 79.7D+00, 114.4D+00, 109.6D+00, 88.8D+00, & 67.8D+00, 47.5D+00, 30.6D+00, 16.3D+00, 9.6D+00, & 33.2D+00, 92.6D+00, 151.6D+00, 136.3D+00, 134.7D+00, & 83.9D+00, 69.4D+00, 31.5D+00, 13.9D+00, 4.4D+00, & 38.0D+00, 141.7D+00, 190.2D+00, 184.8D+00, 159.0D+00, & 112.3D+00 /) return end subroutine p11_lim ( a, b ) !*****************************************************************************80 ! !! P11_LIM returns the limits of the approximation interval for problem 11. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 10 June 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) A, B, the limits of the interval ! of approximation. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b a = 1700.0D+00 b = 1960.0D+00 return end subroutine p11_ndata ( ndata ) !*****************************************************************************80 ! !! P11_NDATA returns the dimension of the data vector for problem 11. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 10 June 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer NDATA, the dimension of the data vector. ! implicit none integer ndata ndata = 261 return end subroutine p11_story ( ) !*****************************************************************************80 ! !! P11_STORY prints the "story" for problem 11. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 19 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' This example is due to Max Waldmeier.' write ( *, '(a)' ) & ' This data represents a measure of sunspot activity over the' write ( *, '(a)' ) & ' years 1700 to 1960. The X value is the year, and the Y value' write ( *, '(a)' ) & ' is a measure of the sunspot activity, which is usually, but' write ( *, '(a)' ) & ' not always, an integer.' return end subroutine p11_title ( title ) !*****************************************************************************80 ! !! P11_TITLE returns the title of problem 11. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 10 June 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, character ( len = * ) TITLE, the title of the problem. ! implicit none character ( len = * ) title title = 'Sunspot Data, 1700-1960.' return end subroutine p11_type ( type ) !*****************************************************************************80 ! !! P11_TYPE returns the type of problem 11. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 10 June 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer TYPE, the type of the problem. ! 0, the problem data is available through a function call. ! 1, the problem data is available as a data vector. ! implicit none integer type type = 1 return end function point_inside_box_2d ( x1, y1, x2, y2, x, y ) !*****************************************************************************80 ! !! POINT_INSIDE_BOX_2D determines if a point is inside a box in 2D. ! ! Discussion: ! ! A "box" is defined by its "left down" corner and its ! "right up" corner, and all the points between. It is ! assumed that the sides of the box align with coordinate directions. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 01 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X1, Y1, X2, Y2, the two corners of the box. ! ! Input, real ( kind = 8 ) X, Y, the point to be checked. ! ! Output, logical POINT_INSIDE_BOX_2D, is .TRUE. if (X,Y) is inside the ! box, or on its boundary, and .FALSE. otherwise. ! implicit none logical point_inside_box_2d real ( kind = 8 ) x real ( kind = 8 ) x1 real ( kind = 8 ) x2 real ( kind = 8 ) y real ( kind = 8 ) y1 real ( kind = 8 ) y2 if ( x1 <= x .and. x <= x2 .and. & y1 <= y .and. y <= y2 ) then point_inside_box_2d = .true. else point_inside_box_2d = .false. end if return end subroutine ps_color_line ( action, r, g, b ) !*****************************************************************************80 ! !! PS_COLOR_LINE handles the line color. ! ! Discussion: ! ! By calling this routine, you can temporarily set the line color, ! draw some lines, and then restore it to whatever it was. ! ! An earlier version of this routine did not use the SAVE command for ! the stack arrrays, meaning the stored data was lost. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 19 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) ACTION, the desired action. ! 'SET', set the line color to RGB. ! 'GET', set RGB to the current line color. ! 'PUSH', push a value onto the RGB stack. ! 'POP', pop the RGB stack. ! ! Input, real ( kind = 8 ) R, G, B, the RGB values for the new line color. ! implicit none integer, parameter :: nstack = 10 character ( len = * ) action real ( kind = 8 ) b real ( kind = 8 ) b_old real ( kind = 8 ), save, dimension ( nstack) :: b_stack real ( kind = 8 ) g real ( kind = 8 ) g_old real ( kind = 8 ), save, dimension ( nstack) :: g_stack integer, save :: istack = 0 real ( kind = 8 ) r real ( kind = 8 ) r_old real ( kind = 8 ), save, dimension ( nstack) :: r_stack logical s_eqi if ( s_eqi ( action, 'SET' ) ) then call ps_color_line_set ( r, g, b ) else if ( s_eqi ( action, 'GET' ) ) then call ps_setting_real ( 'GET', 'LINE_RED', r ) call ps_setting_real ( 'GET', 'LINE_GREEN', g ) call ps_setting_real ( 'GET', 'LINE_BLUE', b ) else if ( s_eqi ( action, 'POP' ) ) then if ( 0 < istack ) then r = r_stack(istack) g = g_stack(istack) b = b_stack(istack) istack = istack - 1 end if call ps_color_line_set ( r, g, b ) else if ( s_eqi ( action, 'PUSH' ) ) then call ps_setting_real ( 'GET', 'LINE_RED', r_old ) call ps_setting_real ( 'GET', 'LINE_GREEN', g_old ) call ps_setting_real ( 'GET', 'LINE_BLUE', b_old ) if ( istack <= nstack ) then istack = istack + 1 r_stack(istack) = r_old g_stack(istack) = g_old b_stack(istack) = b_old end if call ps_color_line_set ( r, g, b ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_COLOR_LINE - Fatal error!' write ( *, '(a)' ) ' Unexpected ACTION.' stop end if return end subroutine ps_color_line_set ( r, g, b ) !*****************************************************************************80 ! !! PS_COLOR_LINE_SET sets the line color. ! ! Discussion: ! ! By calling this routine, you guarantee that a check will be made ! of the current line color. If the current and new line colors are ! the same, then we skip the extraneous action of setting the color. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 19 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) R, G, B, the RGB values for the new line color. ! implicit none real ( kind = 8 ) b real ( kind = 8 ) b_old real ( kind = 8 ) g real ( kind = 8 ) g_old real ( kind = 8 ) r real ( kind = 8 ) r_old integer state integer unit ! ! Check the state. ! call ps_setting_int ( 'GET', 'STATE', state ) if ( state < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_COLOR_LINE_SET - Fatal error!' write ( *, '(a,i9)' ) ' PostScript state is ', state write ( *, '(a)' ) ' A PostScript state of at least 1 is required.' return end if ! ! Get the current colors. ! call ps_setting_real ( 'GET', 'LINE_RED', r_old ) call ps_setting_real ( 'GET', 'LINE_GREEN', g_old ) call ps_setting_real ( 'GET', 'LINE_BLUE', b_old ) ! ! If any color has changed, we need to reset them. ! if ( r_old /= r .or. g_old /= g .or. b_old /= b ) then call ps_setting_int ( 'GET', 'UNIT', unit ) call ps_comment ( 'Set RGB line color.' ) write ( unit, '(3f7.4,a)' ) r, g, b, ' setrgbcolor' call ps_setting_real ( 'SET', 'LINE_RED', r ) call ps_setting_real ( 'SET', 'LINE_GREEN', g ) call ps_setting_real ( 'SET', 'LINE_BLUE', b ) end if return end subroutine ps_comment ( string ) !*****************************************************************************80 ! !! PS_COMMENT inserts a comment into the PostScript file. ! ! Discussion: ! ! A comment begins with a percent sign in column 1. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 24 April 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Henry McGilton, Mary Campione, ! PostScript by Example, ! Addison-Wesley, ! ISBN: 0-201-63228-4 ! ! Parameters: ! ! Input, character ( len = * ) STRING, the comment. ! implicit none character ( len = * ) string integer unit ! ! Get the unit number. ! call ps_setting_int ( 'GET', 'UNIT', unit ) ! ! Write the comment. ! if ( len_trim ( string ) == 0 ) then write ( unit, '(a)' ) '%' else write ( unit, '(a)' ) '%' write ( unit, '(a2,a)' ) '% ', trim ( string ) write ( unit, '(a)' ) '%' end if return end subroutine ps_default ( ) !*****************************************************************************80 ! !! PS_DEFAULT sets the internal settings to their default values ! ! Discussion: ! ! Certain variables are not reset, including the number of pages, ! the unit number, the internal state, and variables relating to ! the size and shape of the region. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 24 January 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Henry McGilton, Mary Campione, ! PostScript by Example, ! Addison-Wesley, ! ISBN: 0-201-63228-4 ! ! Parameters: ! ! None ! implicit none real ( kind = 8 ) fill_blue real ( kind = 8 ) fill_green real ( kind = 8 ) fill_red real ( kind = 8 ) font_size real ( kind = 8 ) line_blue real ( kind = 8 ) line_green real ( kind = 8 ) line_red integer line_width integer marker_size line_width = 1 marker_size = 5 call ps_setting_int ( 'SET', 'LINE_WIDTH', line_width ) call ps_setting_int ( 'SET', 'MARKER_SIZE', marker_size ) fill_blue = 0.7D+00 fill_green = 0.7D+00 fill_red = 0.7D+00 font_size = 0.1D+00 line_blue = 0.0D+00 line_green = 0.0D+00 line_red = 0.0D+00 call ps_setting_real ( 'SET', 'FILL_BLUE', fill_blue ) call ps_setting_real ( 'SET', 'FILL_GREEN', fill_green ) call ps_setting_real ( 'SET', 'FILL_RED', fill_red ) call ps_setting_real ( 'SET', 'FONT_SIZE', font_size ) call ps_setting_real ( 'SET', 'LINE_BLUE', line_blue ) call ps_setting_real ( 'SET', 'LINE_GREEN', line_green ) call ps_setting_real ( 'SET', 'LINE_RED', line_red ) return end subroutine ps_file_close ( unit ) !*****************************************************************************80 ! !! PS_FILE_CLOSE closes a PostScript file. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 29 May 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Henry McGilton, Mary Campione, ! PostScript by Example, ! Addison-Wesley, ! ISBN: 0-201-63228-4 ! ! Parameters: ! ! Input, integer UNIT, the FORTRAN unit to which output was written. ! implicit none integer state integer unit ! ! Determine if the PostScript state is acceptable. ! call ps_setting_int ( 'GET', 'STATE', state ) if ( state < 1 .or. 4 < state ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_FILE_CLOSE - Fatal error!' write ( *, '(a,i9)' ) ' PostScript state is ', state write ( *, '(a)' ) ' PostScript state 1, 2, 3 or 4 is required.' return end if close ( unit = unit ) state = 0 call ps_setting_int ( 'SET', 'STATE', state ) unit = 0 call ps_setting_int ( 'SET', 'UNIT', unit ) return end subroutine ps_file_head ( file_name ) !*****************************************************************************80 ! !! PS_FILE_HEAD writes header information to a PostScript file. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 14 April 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Henry McGilton, Mary Campione, ! PostScript by Example, ! Addison-Wesley, ! ISBN: 0-201-63228-4 ! ! Parameters: ! ! Input, character ( len = * ) FILE_NAME, the name of the output file. ! implicit none character ( len = 8 ) date character ( len = * ) file_name real ( kind = 8 ) line_blue real ( kind = 8 ) line_green real ( kind = 8 ) line_red integer margin integer pagexmax integer pagexmin integer pageymax integer pageymin integer plotxmax integer plotxmin integer plotymax integer plotymin integer state integer unit ! ! Determine if the PostScript state is acceptable. ! call ps_setting_int ( 'GET', 'STATE', state ) if ( state /= 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_FILE_HEAD - Fatal error!' write ( *, '(a,i9)' ) ' PostScript state is ', state write ( *, '(a)' ) ' PostScript state 1 is required.' return end if ! ! Initialization ! call ps_default ( ) ! ! Compute the scale factor. ! pagexmax = 612 pagexmin = 0 pageymax = 792 pageymin = 0 margin = 36 plotxmax = pagexmax - margin plotxmin = pagexmin + margin plotymax = pageymax - margin plotymin = pageymin + margin ! ! Get the unit number. ! call ps_setting_int ( 'GET', 'UNIT', unit ) call date_and_time ( date ) ! ! Write the prolog. ! write ( unit, '(a)' ) '%!PS-Adobe-1.0' write ( unit, '(a)' ) '%%Creator: ps_write.f90' write ( unit, '(a)' ) '%%Title: ' // trim ( file_name ) write ( unit, '(a)' ) '%%CreationDate: ' // trim ( date ) write ( unit, '(a)' ) '%%Pages: (atend)' write ( unit, '(a,4i6)' ) '%%BoundingBox:', plotxmin, plotymin, plotxmax, & plotymax write ( unit, '(a)' ) '%%Document-Fonts: Times-Roman' write ( unit, '(a)' ) '%%LanguageLevel: 1' write ( unit, '(a)' ) '%%EndComments' write ( unit, '(a)' ) '%%BeginProlog' write ( unit, '(a)' ) '/inch {72 mul} def' write ( unit, '(a)' ) '%%EndProlog' ! ! Set the font. ! call ps_comment ( 'Set the font:' ) write ( unit, '(a)' ) '/Times-Roman findfont' write ( unit, '(a)' ) '1.00 inch scalefont' write ( unit, '(a)' ) 'setfont' ! ! Set the line color. ! line_red = 0.0D+00 line_green = 0.0D+00 line_blue = 0.0D+00 call ps_color_line ( 'SET', line_red, line_green, line_blue ) ! ! Reset the state. ! state = 2 call ps_setting_int ( 'SET', 'STATE', state ) return end subroutine ps_file_open ( file_name, unit, ierror ) !*****************************************************************************80 ! !! PS_FILE_OPEN opens a new version of a PostScript file with a given name. ! ! Discussion: ! ! If a file of the given name already exists, it is deleted. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 29 June 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Henry McGilton, Mary Campione, ! PostScript by Example, ! Addison-Wesley, ! ISBN: 0-201-63228-4 ! ! Parameters: ! ! Input, integer UNIT, the FORTRAN unit to which output should ! be written. ! ! Input, character ( len = 80 ) FILE_NAME, the name of the output file. ! ! Output, integer IERROR, error flag. ! 0, no error. ! nonzero, the file could not be created. ! implicit none character ( len = * ) file_name integer ierror integer ios integer state integer unit ! ! Determine if the PostScript state is acceptable. ! call ps_setting_int ( 'GET', 'STATE', state ) if ( state /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_FILE_OPEN - Fatal error!' write ( *, '(a,i9)' ) ' PostScript state is ', state write ( *, '(a)' ) ' PostScript state 0 is required.' write ( *, '(a)' ) ' Call PS_FILE_CLOSE first!' return end if ierror = 0 ! ! Now create a new empty file of the given name. ! open ( unit = unit, file = file_name, status = 'replace', iostat = ios ) if ( ios /= 0 ) then ierror = ios return end if state = 1 call ps_setting_int ( 'SET', 'STATE', state ) call ps_setting_int ( 'SET', 'UNIT', unit ) return end subroutine ps_file_tail ( ) !*****************************************************************************80 ! !! PS_FILE_TAIL writes trailer information to a PostScript file. ! ! Discussion: ! ! Looks like that penultimate 'end' line is not wanted, so ! I commented it out. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 05 March 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Henry McGilton, Mary Campione, ! PostScript by Example, ! Addison-Wesley, ! ISBN: 0-201-63228-4 ! ! Parameters: ! ! None ! implicit none integer num_pages integer state integer unit ! ! Determine if the PostScript state is acceptable. ! call ps_setting_int ( 'GET', 'STATE', state ) if ( state == 3 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_FILE_TAIL - Warning!' write ( *, '(a)' ) ' A page was open. It is being forced closed.' state = 2 call ps_setting_int ( 'SET', 'STATE', state ) end if if ( state /= 2 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_FILE_TAIL - Fatal error!' write ( *, '(a,i9)' ) ' PostScript state is ', state write ( *, '(a)' ) ' PostScript state 2 is required.' return end if ! ! Get the unit number. ! call ps_setting_int ( 'GET', 'UNIT', unit ) ! ! Retrieve the number of pages. ! call ps_setting_int ( 'GET', 'NUM_PAGES', num_pages ) ! ! Write the epilog. ! write ( unit, '(a)' ) '%%Trailer' write ( unit, '(a,i6)' ) '%%Pages: ', num_pages ! write ( unit, '(a)' ) 'end' write ( unit, '(a)' ) '%%EOF' ! ! Zero out the number of pages. ! num_pages = 0 call ps_setting_int ( 'SET', 'NUM_PAGES', num_pages ) ! ! Reset the state. ! state = 4 call ps_setting_int ( 'SET', 'STATE', state ) return end subroutine ps_grid_cartesian ( xmin, xmax, nx, ymin, ymax, ny ) !*****************************************************************************80 ! !! PS_GRID_CARTESIAN draws a cartesian grid. ! ! Discussion: ! ! The current point is not modified by this call. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 29 May 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Henry McGilton, Mary Campione, ! PostScript by Example, ! Addison-Wesley, ! ISBN: 0-201-63228-4 ! ! Parameters: ! ! Input, real ( kind = 8 ) XMIN, XMAX, the minimum and maximum values ! at which X grid lines should be drawn. ! ! Input, integer NX, the number of X grid lines. ! If NX is not positive, no X grid lines are drawn. ! If NX is 1, a single grid line is drawn midway. ! ! Input, real ( kind = 8 ) YMIN, YMAX, the minimum and maximum values ! at which Y grid lines should be drawn. ! ! Input, integer NY, the number of Y grid lines. ! If NY is not positive, no Y grid lines are drawn. ! If NY is 1, a single grid line is drawn midway. ! implicit none real ( kind = 8 ) alpha integer i integer nx integer ny integer plotxmin2 integer plotymin2 integer px integer py integer state integer unit real ( kind = 8 ) x real ( kind = 8 ) xmax real ( kind = 8 ) xmin real ( kind = 8 ) xmin2 real ( kind = 8 ) y real ( kind = 8 ) ymax real ( kind = 8 ) ymin real ( kind = 8 ) ymin2 ! ! At least one of NX and NY must be positive. ! if ( nx < 1 .and. ny < 1 ) then return end if ! ! Determine if the PostScript state is acceptable. ! call ps_setting_int ( 'GET', 'STATE', state ) if ( state /= 3 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_GRID_CARTESIAN - Fatal error!' write ( *, '(a,i9)' ) ' PostScript state is ', state write ( *, '(a)' ) ' PostScript state 3 is required.' return end if ! ! Get the unit number. ! call ps_setting_int ( 'GET', 'UNIT', unit ) ! ! Get settings. ! alpha = 0.0D+00 xmin2 = 0.0D+00 ymin2 = 0.0D+00 call ps_setting_int ( 'GET', 'PXMIN', plotxmin2 ) call ps_setting_int ( 'GET', 'PYMIN', plotymin2 ) call ps_setting_real ( 'GET', 'ALPHA', alpha ) call ps_setting_real ( 'GET', 'XMIN', xmin2 ) call ps_setting_real ( 'GET', 'YMIN', ymin2 ) ! ! Draw the vertical (X) grid lines. ! do i = 1, nx if ( 1 < nx ) then x = ( real ( nx - i, kind = 8 ) * xmin & + real ( i - 1, kind = 8 ) * xmax ) & / real ( nx - 1, kind = 8 ) else if ( nx == 1 ) then x = 0.5D+00 * ( xmin + xmax ) end if px = plotxmin2 + nint ( alpha * ( x - xmin2 ) ) write ( unit, '(a)' ) 'newpath' py = plotymin2 + nint ( alpha * ( ymin - ymin2 ) ) write ( unit, '(2i6,a)' ) px, py, ' moveto' py = plotymin2 + nint ( alpha * ( ymax - ymin2 ) ) write ( unit, '(2i6,a)' ) px, py, ' lineto' write ( unit, '(a)' ) 'stroke' end do ! ! Draw the horizontal (Y) grid lines. ! do i = 1, ny if ( 1 < ny ) then y = ( real ( ny - i, kind = 8 ) * ymin & + real ( i - 1, kind = 8 ) * ymax ) & / real ( ny - 1, kind = 8 ) else if ( ny == 1 ) then y = 0.5D+00 * ( ymin + ymax ) end if py = plotymin2 + nint ( alpha * ( y - ymin2 ) ) write ( unit, '(a)' ) 'newpath' px = plotxmin2 + nint ( alpha * ( xmin - xmin2 ) ) write ( unit, '(2i6,a)' ) px, py, ' moveto' px = plotxmin2 + nint ( alpha * ( xmax - xmin2 ) ) write ( unit, '(2i6,a)' ) px, py, ' lineto' write ( unit, '(a)' ) 'stroke' end do return end subroutine ps_line_closed ( npoint, x, y ) !*****************************************************************************80 ! !! PS_LINE_CLOSED adds the graph of a closed line to a PostScript file. ! ! Discussion: ! ! A "closed" line is one in which the last point is connected back ! to the first one. ! ! The current point is set to the first (and logically last) point ! in the list. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 28 August 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Henry McGilton, Mary Campione, ! PostScript by Example, ! Addison-Wesley, ! ISBN: 0-201-63228-4 ! ! Parameters: ! ! Input, integer NPOINT, the number of points in the line. ! ! Input, real ( kind = 8 ) X(NPOINT), Y(NPOINT), the X and Y components ! of the points. ! implicit none integer npoint real ( kind = 8 ) alpha integer i integer plotxmin2 integer plotymin2 integer px integer py integer state integer unit real ( kind = 8 ) x(npoint) real ( kind = 8 ) xmin real ( kind = 8 ) y(npoint) real ( kind = 8 ) ymin ! ! Refuse to handle fewer than 2 points. ! if ( npoint < 2 ) then return end if ! ! Determine if the PostScript state is acceptable. ! call ps_setting_int ( 'GET', 'STATE', state ) if ( state /= 3 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_LINE_CLOSED - Fatal error!' write ( *, '(a,i9)' ) ' PostScript state is ', state write ( *, '(a)' ) ' PostScript state 3 is required.' return end if ! ! Get settings. ! call ps_setting_int ( 'GET', 'PXMIN', plotxmin2 ) call ps_setting_int ( 'GET', 'PYMIN', plotymin2 ) call ps_setting_int ( 'GET', 'UNIT', unit ) call ps_setting_real ( 'GET', 'ALPHA', alpha ) call ps_setting_real ( 'GET', 'XMIN', xmin ) call ps_setting_real ( 'GET', 'YMIN', ymin ) ! ! Draw lines. ! write ( unit, '(a)' ) 'newpath' px = plotxmin2 + nint ( alpha * ( x(1) - xmin ) ) py = plotymin2 + nint ( alpha * ( y(1) - ymin ) ) write ( unit, '(2i6,a)' ) px, py, ' moveto' do i = 2, npoint px = plotxmin2 + nint ( alpha * ( x(i) - xmin ) ) py = plotymin2 + nint ( alpha * ( y(i) - ymin ) ) write ( unit, '(2i6,a)' ) px, py, ' lineto' end do ! ! Add the final extra segment to the initial point. ! px = plotxmin2 + nint ( alpha * ( x(1) - xmin ) ) py = plotymin2 + nint ( alpha * ( y(1) - ymin ) ) write ( unit, '(2i6,a)' ) px, py, ' lineto' ! ! Draw the line. ! write ( unit, '(a)' ) 'stroke' call ps_setting_real ( 'SET', 'XCUR', x(1) ) call ps_setting_real ( 'SET', 'YCUR', y(1) ) return end subroutine ps_line_open ( npoint, x, y ) !*****************************************************************************80 ! !! PS_LINE_OPEN adds the graph of a line to a PostScript file. ! ! Discussion: ! ! The current point is set to the last point in the list. ! ! This routine does not perform clipping, although it wouldn't be ! hard to add. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 28 August 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Henry McGilton, Mary Campione, ! PostScript by Example, ! Addison-Wesley, ! ISBN: 0-201-63228-4 ! ! Parameters: ! ! Input, integer NPOINT, the number of points in the line. ! ! Input, real ( kind = 8 ) X(NPOINT), Y(NPOINT), the X and Y ! components of the points. ! implicit none integer npoint real ( kind = 8 ) alpha integer i integer plotxmin2 integer plotymin2 integer px integer py integer state integer unit real ( kind = 8 ) x(npoint) real ( kind = 8 ) xmin real ( kind = 8 ) y(npoint) real ( kind = 8 ) ymin ! ! Refuse to handle fewer than 2 points. ! if ( npoint < 2 ) then return end if ! ! Determine if the PostScript state is acceptable. ! call ps_setting_int ( 'GET', 'STATE', state ) if ( state /= 3 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_LINE - Fatal error!' write ( *, '(a,i9)' ) ' PostScript state is ', state write ( *, '(a)' ) ' PostScript state 3 is required.' return end if ! ! Get settings. ! call ps_setting_int ( 'GET', 'PXMIN', plotxmin2 ) call ps_setting_int ( 'GET', 'PYMIN', plotymin2 ) call ps_setting_int ( 'GET', 'UNIT', unit ) call ps_setting_real ( 'GET', 'ALPHA', alpha ) call ps_setting_real ( 'GET', 'XMIN', xmin ) call ps_setting_real ( 'GET', 'YMIN', ymin ) ! ! Draw lines. ! write ( unit, '(a)' ) 'newpath' px = plotxmin2 + nint ( alpha * ( x(1) - xmin ) ) py = plotymin2 + nint ( alpha * ( y(1) - ymin ) ) write ( unit, '(2i6,a)' ) px, py, ' moveto' do i = 2, npoint px = plotxmin2 + nint ( alpha * ( x(i) - xmin ) ) py = plotymin2 + nint ( alpha * ( y(i) - ymin ) ) write ( unit, '(2i6,a)' ) px, py, ' lineto' end do ! ! Draw the line. ! write ( unit, '(a)' ) 'stroke' call ps_setting_real ( 'SET', 'XCUR', x(npoint) ) call ps_setting_real ( 'SET', 'YCUR', y(npoint) ) return end subroutine ps_mark_circle ( x, y ) !*****************************************************************************80 ! !! PS_MARK_CIRCLE marks a point with a small open circle. ! ! Discussion: ! ! The current point is set to the center of the circle. ! ! The circle is drawn with the current RGB line colors. ! ! The circle is drawn the current marker size. ! ! If the point is outside the region, the command is ignored. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 01 May 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Henry McGilton, Mary Campione, ! PostScript by Example, ! Addison-Wesley, ! ISBN: 0-201-63228-4 ! ! Parameters: ! ! Input, real ( kind = 8 ) X, Y, the coordinates of the point to mark. ! implicit none real ( kind = 8 ) alpha integer marker_size integer plotxmin2 integer plotymin2 logical point_inside_box_2d integer pxcen integer pycen integer state integer unit real ( kind = 8 ) x real ( kind = 8 ) xmax real ( kind = 8 ) xmin real ( kind = 8 ) y real ( kind = 8 ) ymax real ( kind = 8 ) ymin ! ! Determine if the PostScript state is acceptable. ! call ps_setting_int ( 'GET', 'STATE', state ) if ( state /= 3 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_MARK_CIRCLE - Fatal error!' write ( *, '(a,i9)' ) ' PostScript state is ', state write ( *, '(a)' ) ' PostScript state 3 is required.' return end if ! ! Get settings. ! call ps_setting_int ( 'GET', 'MARKER_SIZE', marker_size ) call ps_setting_int ( 'GET', 'PXMIN', plotxmin2 ) call ps_setting_int ( 'GET', 'PYMIN', plotymin2 ) call ps_setting_int ( 'GET', 'UNIT', unit ) call ps_setting_real ( 'GET', 'ALPHA', alpha ) call ps_setting_real ( 'GET', 'XMIN', xmin ) call ps_setting_real ( 'GET', 'XMAX', xmax ) call ps_setting_real ( 'GET', 'YMIN', ymin ) call ps_setting_real ( 'GET', 'YMAX', ymax ) ! ! If the point is outside the plot box, don't draw it. ! if ( .not. point_inside_box_2d ( xmin, ymin, xmax, ymax, x, y ) ) then return end if write ( unit, '(a)' ) 'newpath' pxcen = plotxmin2 + nint ( alpha * ( x - xmin ) ) pycen = plotymin2 + nint ( alpha * ( y - ymin ) ) write ( unit, '(3i6,a)' ) pxcen, pycen, marker_size, & ' 0 360 arc closepath stroke' call ps_setting_real ( 'SET', 'XCUR', x ) call ps_setting_real ( 'SET', 'YCUR', y ) return end subroutine ps_page_head ( xmin, ymin, xmax, ymax ) !*****************************************************************************80 ! !! PS_PAGE_HEAD writes header information on a new page. ! ! Discussion: ! ! I think an earlier version of this code, which wrote ! "%% Page:" rather than "%%Page:" may have caused problems ! for some interpreters. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 22 February 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Henry McGilton, Mary Campione, ! PostScript by Example, ! Addison-Wesley, ! ISBN: 0-201-63228-4 ! ! Parameters: ! ! Input, real ( kind = 8 ) XMIN, YMIN, XMAX, YMAX, the minimum and maximum X ! and Y values of the data to be drawn on this page. ! implicit none real ( kind = 8 ) alpha integer num_pages integer state real ( kind = 8 ) line_blue real ( kind = 8 ) line_green real ( kind = 8 ) line_red integer margin integer pagexmax integer pagexmin integer pageymax integer pageymin integer plotxmax integer plotxmin integer plotxmin2 integer plotymax integer plotymin integer plotymin2 integer unit real ( kind = 8 ) xcur real ( kind = 8 ) xmax real ( kind = 8 ) xmax2 real ( kind = 8 ) xmin real ( kind = 8 ) xmin2 real ( kind = 8 ) xvec(4) real ( kind = 8 ) ycur real ( kind = 8 ) ymax real ( kind = 8 ) ymax2 real ( kind = 8 ) ymin real ( kind = 8 ) ymin2 real ( kind = 8 ) yvec(4) ! ! Determine if the PostScript state is acceptable. ! call ps_setting_int ( 'GET', 'STATE', state ) if ( state == 3 ) then state = 2 call ps_setting_int ( 'SET', 'STATE', state ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_PAGE_HEAD - Warning!' write ( *, '(a)' ) ' The current open page is forced closed.' end if if ( state /= 2 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_PAGE_HEAD - Fatal error!' write ( *, '(a,i9)' ) ' PostScript state is ', state write ( *, '(a)' ) ' PostScript state 2 is required.' return end if ! ! Get settings. ! call ps_setting_int ( 'GET', 'NUM_PAGES', num_pages ) num_pages = num_pages + 1 call ps_setting_int ( 'SET', 'NUM_PAGES', num_pages ) call ps_setting_int ( 'GET', 'UNIT', unit ) write ( unit, '(a,i6,i6)' ) '%%Page: ', num_pages, num_pages write ( unit, '(a)' ) 'save' ! ! Reset the state. ! state = 3 call ps_setting_int ( 'SET', 'STATE', state ) ! ! Determine and store parameters. ! if ( xmax == xmin ) then xmax2 = xmax + 1.0D+00 xmin2 = xmax - 1.0D+00 else xmax2 = xmax xmin2 = xmin end if if ( ymax == ymin ) then ymax2 = ymax + 1.0D+00 ymin2 = ymax - 1.0D+00 else ymax2 = ymax ymin2 = ymin end if ! ! Set the value of "current point". ! xcur = xmin ycur = ymin ! ! Set the conversion factors. ! pagexmax = 612 pagexmin = 0 pageymax = 792 pageymin = 0 margin = 36 plotxmax = pagexmax - margin plotxmin = pagexmin + margin plotymax = pageymax - margin plotymin = pageymin + margin alpha = min ( real ( plotxmax - plotxmin, kind = 8 ) / ( xmax2 - xmin2 ), & real ( plotymax - plotymin, kind = 8 ) / ( ymax2 - ymin2 ) ) ! ! Adjust PLOTXMIN and PLOTYMIN to center the image. ! plotxmin2 = nint ( 0.5D+00 * & ( real ( plotxmin + plotxmax, kind = 8 ) - alpha * ( xmax2 - xmin2 ) ) ) plotymin2 = nint ( 0.5D+00 * & ( real ( plotymin + plotymax, kind = 8 ) - alpha * ( ymax2 - ymin2 ) ) ) ! ! Store data. ! call ps_setting_int ( 'SET', 'PXMIN', plotxmin2 ) call ps_setting_int ( 'SET', 'PYMIN', plotymin2 ) call ps_setting_real ( 'SET', 'ALPHA', alpha ) call ps_setting_real ( 'SET', 'XCUR', xcur ) call ps_setting_real ( 'SET', 'XMIN', xmin ) call ps_setting_real ( 'SET', 'XMAX', xmax ) call ps_setting_real ( 'SET', 'YCUR', ycur ) call ps_setting_real ( 'SET', 'YMIN', ymin ) call ps_setting_real ( 'SET', 'YMAX', ymax ) ! ! Draw a gray border around the page. ! line_red = 0.9D+00 line_green = 0.9D+00 line_blue = 0.9D+00 call ps_color_line ( 'PUSH', line_red, line_green, line_blue ) call ps_comment ( 'Draw a gray border around the page.' ) xvec(1:4) = (/ xmin, xmax, xmax, xmin /) yvec(1:4) = (/ ymin, ymin, ymax, ymax /) call ps_line_closed ( 4, xvec, yvec ) call ps_color_line ( 'POP', line_red, line_green, line_blue ) return end subroutine ps_page_tail ( ) !*****************************************************************************80 ! !! PS_PAGE_TAIL writes tail information at the end of a page. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 28 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Henry McGilton, Mary Campione, ! PostScript by Example, ! Addison-Wesley, ! ISBN: 0-201-63228-4 ! ! Parameters: ! ! None ! implicit none integer state integer unit ! ! Determine if the PostScript state is acceptable. ! call ps_setting_int ( 'GET', 'STATE', state ) if ( state /= 3 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_PAGE_TAIL - Fatal error!' write ( *, '(a,i9)' ) ' PostScript state is ', state write ( *, '(a)' ) ' PostScript state 3 is required.' return end if ! ! Get settings. ! call ps_setting_int ( 'GET', 'UNIT', unit ) write ( unit, '(a)' ) 'restore showpage' call ps_comment ( 'End of page' ) ! ! Reset the state. ! state = 2 call ps_setting_int ( 'SET', 'STATE', state ) return end subroutine ps_setting_int ( action, variable, value ) !*****************************************************************************80 ! !! PS_SETTING_INT sets, gets, or prints integer internal PS_WRITE parameters. ! ! Discussion: ! ! Normally, the user does not call this routine. It is a utility ! used by the package. ! ! I'd like a more sophisticated pop and push. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 14 April 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Henry McGilton, Mary Campione, ! PostScript by Example, ! Addison-Wesley, ! ISBN: 0-201-63228-4 ! ! Parameters: ! ! Input, character ( len = * ) ACTION, the desired action: ! 'GET' to get the current value of VARIABLE, or ! 'POP' to return the current value and set a new value; ! 'SET' to set a new value of VARIABLE, or ! 'PUSH' to return the current value and set a new value; ! 'PRINT' to print the current value of VARIABLE. ! ! Input, character ( len = * ) VARIABLE, the variable to get or set: ! 'LINE_WIDTH', the line width. ! 0 is the very thinnest line possible, ! 1 is more usual, 2 is thicker, and so on. ! 'MARKER_SIZE', the size of marker circles and disks, in PostScript points; ! 'NUM_PAGES', the number of pages begun or completed; ! 'PXMIN', the location of the left hand margin of the region ! in PostScript points; ! 'PYMIN', the location of the lower margin of the region ! in PostScript points; ! 'STATE', the current internal state, ! 0, file not open, ! 1, file open, no header written, no page open, ! 2, file open, header written, no page open, ! 3, file open, header written, page open. ! 4, file open, header written, trailer written. ! 'UNIT', the FORTRAN output unit associated with the PostScript file. ! ! Input/output, integer VALUE. ! If ACTION = 'GET', then VALUE is an output quantity, and is the ! current internal value of the variable. ! ! If ACTION = 'SET', then VALUE is an input quantity, and the ! current internal value of the variable is set to this value. ! ! If ACTION = 'PRINT', then VALUE is ignored. ! implicit none character ( len = * ) action integer, save :: line_width = 1 integer, save :: marker_size = 0 integer, save :: num_pages = 0 integer, save :: pxmin = 0 integer, save :: pymin = 0 integer, save :: state = 0 integer, save :: unit = 0 integer value character ( len = * ) variable if ( variable == 'LINE_WIDTH' ) then if ( action == 'GET' ) then value = line_width else if ( action == 'PRINT' ) then write ( *, '(a,i9)' ) 'Line width, LINE_WIDTH = ', line_width else if ( action == 'SET' ) then line_width = value else if ( action == 'POP' ) then call i4_swap ( line_width, value ) else if ( action == 'PUSH' ) then call i4_swap ( line_width, value ) end if else if ( variable == 'MARKER_SIZE' ) then if ( action == 'GET' ) then value = marker_size else if ( action == 'PRINT' ) then write ( *, '(a,i9)' ) 'Marker size, MARKER_SIZE = ', marker_size else if ( action == 'SET' ) then marker_size = value else if ( action == 'POP' ) then call i4_swap ( marker_size, value ) else if ( action == 'PUSH' ) then call i4_swap ( marker_size, value ) end if else if ( variable == 'NUM_PAGES' ) then if ( action == 'GET' ) then value = num_pages else if ( action == 'PRINT' ) then write ( *, '(a,i9)' ) 'Number of pages, NUM_PAGES = ', num_pages else if ( action == 'SET' ) then num_pages = value end if else if ( variable == 'PXMIN' ) then if ( action == 'GET' ) then value = pxmin else if ( action == 'PRINT' ) then write ( *, '(a,i9)' ) 'PostScript minimum X point, PXMIN = ', pxmin else if ( action == 'SET' ) then pxmin = value else if ( action == 'POP' ) then call i4_swap ( pxmin, value ) else if ( action == 'PUSH' ) then call i4_swap ( pxmin, value ) end if else if ( variable == 'PYMIN' ) then if ( action == 'GET' ) then value = pymin else if ( action == 'PRINT' ) then write ( *, '(a,i9)' ) 'PostScript minimum Y point, PYMIN = ', pymin else if ( action == 'SET' ) then pymin = value else if ( action == 'POP' ) then call i4_swap ( pymin, value ) else if ( action == 'PUSH' ) then call i4_swap ( pymin, value ) end if else if ( variable == 'STATE' ) then if ( action == 'GET' ) then value = state else if ( action == 'PRINT' ) then write ( *, '(a,i9)' ) 'Current internal state, STATE = ', state else if ( action == 'SET' ) then state = value else if ( action == 'POP' ) then call i4_swap ( state, value ) else if ( action == 'PUSH' ) then call i4_swap ( state, value ) end if else if ( variable == 'UNIT' ) then if ( action == 'GET' ) then value = unit else if ( action == 'PRINT' ) then write ( *, '(a,i9)' ) 'Current FORTRAN unit, UNIT = ', unit else if ( action == 'SET' ) then unit = value else if ( action == 'POP' ) then call i4_swap ( unit, value ) else if ( action == 'PUSH' ) then call i4_swap ( unit, value ) end if end if return end subroutine ps_setting_real ( action, variable, value ) !*****************************************************************************80 ! !! PS_SETTING_REAL sets, gets, or prints real internal PS_WRITE parameters. ! ! Discussion: ! ! I'd like a more sophisticated pop and push. ! ! This routine has been revised to print an error message and stop ! if the ACTION or VARIABLE is unexpected. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 19 May 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Henry McGilton and Mary Campione, ! PostScript by Example, ! Addison-Wesley, ! ISBN: 0-201-63228-4 ! ! Parameters: ! ! Input, character ( len = * ) ACTION, is either: ! 'GET' to get the current value, or ! 'POP' to return the current value and set a new one; ! 'PRINT' to print the current value, or ! 'SET' to set the current value or ! 'PUSH' to set a new value and return the current one. ! ! Input, character ( len = * ) VARIABLE, the variable to get or set: ! 'ALPHA', the scale factor from XY user space to PostScript points; ! 'FILL_BLUE', the intensity of the blue fill color, between 0.0 and 1.0. ! 'FILL_GREEN', the intensity of the green fill color, between 0.0 and 1.0. ! 'FILL_RED', the intensity of the red fill color, between 0.0 and 1.0. ! 'FONT_SIZE', the font size, in inches. ! 'LINE_BLUE', the blue component of the line color, between 0.0 and 1.0. ! 'LINE_GREEN', the green component of the line color, between 0.0 and 1.0. ! 'LINE_RED', the red component of the line color, between 0.0 and 1.0. ! 'XCUR', the current X location. ! 'XMAX', maximum X value of the data. ! 'XMIN', minimum X value of the data. ! 'YCUR', the current Y location. ! 'YMAX', maximum Y value of the data. ! 'YMIN', minimum Y value of the data. ! ! Input/output, real ( kind = 8 ) VALUE. ! If ACTION = 'GET', then VALUE is an output quantity, and is the ! current internal value of the variable. ! ! If ACTION = 'SET', then VALUE is an input quantity, and the ! current internal value of the variable is set to this value. ! ! If ACTION = 'PRINT', then VALUE is ignored. ! implicit none character ( len = * ) action real ( kind = 8 ), save :: alpha = 0.0D+00 real ( kind = 8 ), save :: fill_blue = 0.7D+00 real ( kind = 8 ), save :: fill_green = 0.7D+00 real ( kind = 8 ), save :: fill_red = 0.7D+00 real ( kind = 8 ), save :: font_size = 0.1D+00 real ( kind = 8 ), save :: line_blue = 0.0D+00 real ( kind = 8 ), save :: line_green = 0.0D+00 real ( kind = 8 ), save :: line_red = 0.0D+00 real ( kind = 8 ) value character ( len = * ) variable real ( kind = 8 ), save :: xcur = 0.0D+00 real ( kind = 8 ), save :: xmax = 1.0D+00 real ( kind = 8 ), save :: xmin = 0.0D+00 real ( kind = 8 ), save :: ycur = 0.0D+00 real ( kind = 8 ), save :: ymax = 0.0D+00 real ( kind = 8 ), save :: ymin = 0.0D+00 if ( variable == 'ALPHA' ) then if ( action == 'GET' ) then value = alpha else if ( action == 'PRINT' ) then write ( *, '(a,g14.6)' ) 'Scale factor from user to PS, ALPHA = ', alpha else if ( action == 'SET' ) then alpha = value else if ( action == 'POP' ) then call r8_swap ( alpha, value ) else if ( action == 'PUSH' ) then call r8_swap ( alpha, value ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_SETTING_REAL - Fatal error' write ( *, '(a)' ) ' Unexpected action!' stop end if else if ( variable == 'FILL_BLUE' ) then if ( action == 'GET' ) then value = fill_blue else if ( action == 'PRINT' ) then write ( *, '(a,g14.6)' ) 'Blue fill RGB value, FILL_BLUE = ', fill_blue else if ( action == 'SET' ) then fill_blue = value else if ( action == 'POP' ) then call r8_swap ( fill_blue, value ) else if ( action == 'PUSH' ) then call r8_swap ( fill_blue, value ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_SETTING_REAL - Fatal error' write ( *, '(a)' ) ' Unexpected action!' stop end if else if ( variable == 'FILL_GREEN' ) then if ( action == 'GET' ) then value = fill_green else if ( action == 'PRINT' ) then write ( *, '(a,g14.6)' ) 'Green fill RGB value, FILL_GREEN = ', fill_green else if ( action == 'SET' ) then fill_green = value else if ( action == 'POP' ) then call r8_swap ( fill_green, value ) else if ( action == 'PUSH' ) then call r8_swap ( fill_green, value ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_SETTING_REAL - Fatal error' write ( *, '(a)' ) ' Unexpected action!' stop end if else if ( variable == 'FILL_RED' ) then if ( action == 'GET' ) then value = fill_red else if ( action == 'PRINT' ) then write ( *, '(a,g14.6)' ) 'RED fill RGB value, FILL_RED = ', fill_red else if ( action == 'SET' ) then fill_red = value else if ( action == 'POP' ) then call r8_swap ( fill_red, value ) else if ( action == 'PUSH' ) then call r8_swap ( fill_red, value ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_SETTING_REAL - Fatal error' write ( *, '(a)' ) ' Unexpected action!' stop end if else if ( variable == 'FONT_SIZE' ) then if ( action == 'GET' ) then value = font_size else if ( action == 'PRINT' ) then write ( *, '(a,g14.6)' ) 'Font size, FONT_SIZE = ', font_size else if ( action == 'SET' ) then font_size = value else if ( action == 'POP' ) then call r8_swap ( font_size, value ) else if ( action == 'PUSH' ) then call r8_swap ( font_size, value ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_SETTING_REAL - Fatal error' write ( *, '(a)' ) ' Unexpected action!' stop end if else if ( variable == 'LINE_BLUE' ) then if ( action == 'GET' ) then value = line_blue else if ( action == 'PRINT' ) then write ( *, '(a,g14.6)' ) 'Blue line RGB value, LINE_BLUE = ', line_blue else if ( action == 'SET' ) then line_blue = value else if ( action == 'POP' ) then call r8_swap ( line_blue, value ) else if ( action == 'PUSH' ) then call r8_swap ( line_blue, value ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_SETTING_REAL - Fatal error' write ( *, '(a)' ) ' Unexpected action!' stop end if else if ( variable == 'LINE_GREEN' ) then if ( action == 'GET' ) then value = line_green else if ( action == 'PRINT' ) then write ( *, '(a,g14.6)' ) 'Green line RGB value, LINE_GREEN = ', line_green else if ( action == 'SET' ) then line_green = value else if ( action == 'POP' ) then call r8_swap ( line_green, value ) else if ( action == 'PUSH' ) then call r8_swap ( line_green, value ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_SETTING_REAL - Fatal error' write ( *, '(a)' ) ' Unexpected action!' stop end if else if ( variable == 'LINE_RED' ) then if ( action == 'GET' ) then value = line_red else if ( action == 'PRINT' ) then write ( *, '(a,g14.6)' ) 'Red line RGB value, LINE_RED = ', line_red else if ( action == 'SET' ) then line_red = value else if ( action == 'POP' ) then call r8_swap ( line_red, value ) else if ( action == 'PUSH' ) then call r8_swap ( line_red, value ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_SETTING_REAL - Fatal error' write ( *, '(a)' ) ' Unexpected action!' stop end if else if ( variable == 'XCUR' ) then if ( action == 'GET' ) then value = xcur else if ( action == 'PRINT' ) then write ( *, '(a,g14.6)' ) 'Current X location, XCUR = ', xcur else if ( action == 'SET' ) then xcur = value else if ( action == 'POP' ) then call r8_swap ( xcur, value ) else if ( action == 'PUSH' ) then call r8_swap ( xcur, value ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_SETTING_REAL - Fatal error' write ( *, '(a)' ) ' Unexpected action!' stop end if else if ( variable == 'XMAX' ) then if ( action == 'GET' ) then value = xmax else if ( action == 'PRINT' ) then write ( *, '(a,g14.6)' ) 'Maximum X value, XMAX = ', xmax else if ( action == 'SET' ) then xmax = value else if ( action == 'POP' ) then call r8_swap ( xmax, value ) else if ( action == 'PUSH' ) then call r8_swap ( xmax, value ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_SETTING_REAL - Fatal error' write ( *, '(a)' ) ' Unexpected action!' stop end if else if ( variable == 'XMIN' ) then if ( action == 'GET' ) then value = xmin else if ( action == 'PRINT' ) then write ( *, '(a,g14.6)' ) 'Minimum X value, XMIN = ', xmin else if ( action == 'SET' ) then xmin = value else if ( action == 'POP' ) then call r8_swap ( xmin, value ) else if ( action == 'PUSH' ) then call r8_swap ( xmin, value ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_SETTING_REAL - Fatal error' write ( *, '(a)' ) ' Unexpected action!' stop end if else if ( variable == 'YCUR' ) then if ( action == 'GET' ) then value = ycur else if ( action == 'PRINT' ) then write ( *, '(a,g14.6)' ) 'Current Y location, YCUR = ', ycur else if ( action == 'SET' ) then ycur = value else if ( action == 'POP' ) then call r8_swap ( ycur, value ) else if ( action == 'PUSH' ) then call r8_swap ( ycur, value ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_SETTING_REAL - Fatal error' write ( *, '(a)' ) ' Unexpected action!' stop end if else if ( variable == 'YMAX' ) then if ( action == 'GET' ) then value = ymax else if ( action == 'PRINT' ) then write ( *, '(a,g14.6)' ) 'Maximum Y value, YMAX = ', ymax else if ( action == 'SET' ) then ymax = value else if ( action == 'POP' ) then call r8_swap ( ymax, value ) else if ( action == 'PUSH' ) then call r8_swap ( ymax, value ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_SETTING_REAL - Fatal error' write ( *, '(a)' ) ' Unexpected action!' stop end if else if ( variable == 'YMIN' ) then if ( action == 'GET' ) then value = ymin else if ( action == 'PRINT' ) then write ( *, '(a,g14.6)' ) 'Minimum Y value, YMIN = ', ymin else if ( action == 'SET' ) then ymin = value else if ( action == 'POP' ) then call r8_swap ( ymin, value ) else if ( action == 'PUSH' ) then call r8_swap ( ymin, value ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_SETTING_REAL - Fatal error' write ( *, '(a)' ) ' Unexpected action!' stop end if else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PS_SETTING_REAL - Fatal error' write ( *, '(a)' ) ' Unexpected variable!' stop end if return end subroutine r8_swap ( x, y ) !*****************************************************************************80 ! !! R8_SWAP swaps two R8's. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 01 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, real ( kind = 8 ) X, Y. On output, the values of X and ! Y have been interchanged. ! implicit none real ( kind = 8 ) x real ( kind = 8 ) y real ( kind = 8 ) z z = x x = y y = z return end subroutine r8vec2_print ( n, a1, a2, title ) !*****************************************************************************80 ! !! R8VEC2_PRINT prints a pair of R8VEC's. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 14 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components of the vector. ! ! Input, real ( kind = 8 ) A1(N), A2(N), the vectors to be printed. ! ! Input, character ( len = * ) TITLE, a title to be printed first. ! TITLE may be blank. ! implicit none integer n real ( kind = 8 ) a1(n) real ( kind = 8 ) a2(n) integer i character ( len = * ) title if ( title /= ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, n write ( *, '(i6,2g14.6)' ) i, a1(i), a2(i) end do return end function s_eqi ( s1, s2 ) !*****************************************************************************80 ! !! S_EQI is a case insensitive comparison of two strings for equality. ! ! Example: ! ! S_EQI ( 'Anjana', 'ANJANA' ) is .TRUE. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, S2, the strings to compare. ! ! Output, logical S_EQI, the result of the comparison. ! implicit none character c1 character c2 integer i integer len1 integer len2 integer lenc logical s_eqi character ( len = * ) s1 character ( len = * ) s2 len1 = len ( s1 ) len2 = len ( s2 ) lenc = min ( len1, len2 ) s_eqi = .false. do i = 1, lenc c1 = s1(i:i) c2 = s2(i:i) call ch_cap ( c1 ) call ch_cap ( c2 ) if ( c1 /= c2 ) then return end if end do do i = lenc + 1, len1 if ( s1(i:i) /= ' ' ) then return end if end do do i = lenc + 1, len2 if ( s2(i:i) /= ' ' ) then return end if end do s_eqi = .true. return end subroutine timestamp ( ) !*****************************************************************************80 ! !! TIMESTAMP prints the current YMDHMS date as a time stamp. ! ! Example: ! ! 31 May 2001 9:45:54.872 AM ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 06 August 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none character ( len = 8 ) ampm integer d integer h integer m integer mm character ( len = 9 ), parameter, dimension(12) :: month = (/ & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' /) integer n integer s integer values(8) integer y call date_and_time ( values = values ) y = values(1) m = values(2) d = values(3) h = values(5) n = values(6) s = values(7) mm = values(8) if ( h < 12 ) then ampm = 'AM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Noon' else ampm = 'PM' end if else h = h - 12 if ( h < 12 ) then ampm = 'PM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Midnight' else ampm = 'AM' end if end if end if write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm ) return end subroutine timestring ( string ) !*****************************************************************************80 ! !! TIMESTRING writes the current YMDHMS date into a string. ! ! Example: ! ! STRING = 'May 31 2001 9:45:54.872 AM' ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 15 March 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, character ( len = * ) STRING, contains the date information. ! A character length of 40 should always be sufficient. ! implicit none character ( len = 8 ) ampm integer d character ( len = 8 ) date integer h integer m integer mm character ( len = 9 ), parameter, dimension(12) :: month = (/ & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' /) integer n integer s character ( len = * ) string character ( len = 10 ) time integer values(8) integer y character ( len = 5 ) zone call date_and_time ( date, time, zone, values ) y = values(1) m = values(2) d = values(3) h = values(5) n = values(6) s = values(7) mm = values(8) if ( h < 12 ) then ampm = 'AM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Noon' else ampm = 'PM' end if else h = h - 12 if ( h < 12 ) then ampm = 'PM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Midnight' else ampm = 'AM' end if end if end if write ( string, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm ) return end