subroutine bitchr75 ( c, pattern ) !*****************************************************************************80 ! !! BITCHR75 returns a 7 by 5 bit pattern for a given character. ! ! Examples: ! ! C = 'A' ! ! PATTERN = ! ! 0 0 1 0 0 ! 0 1 0 1 0 ! 1 1 0 1 1 ! 1 0 0 0 1 ! 1 1 1 1 1 ! 1 0 0 0 1 ! 1 0 0 0 1 ! ! The data statements used here were generated by FONT_DATA. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 28 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, a character whose bit pattern is desired. ! ! Output, integer ( kind = 4 ) PATTERN(7,5), the bit pattern for the ! character, which will be all 0's if the character is not available. ! implicit none integer ( kind = 4 ) bits(7,5,68) character c integer ( kind = 4 ) i integer ( kind = 4 ) indx integer ( kind = 4 ) ipoint(0:255) integer ( kind = 4 ) j integer ( kind = 4 ) k integer ( kind = 4 ) pattern(7,5) data ( ipoint(i), i = 0, 255 ) / & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, & 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, & 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, & 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 65, 66, 67, 68, 0, & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 / data ((bits(i,j, 1), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0, & 1, 1, 1, 1, 1, 0, 1, & 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0 / data ((bits(i,j, 2), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 0, 0, 0, 0, 0, & 1, 1, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0, & 1, 1, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0 / data ((bits(i,j, 3), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 1, 0, 1, 0, 0, & 0, 1, 1, 1, 1, 1, 0, & 0, 0, 1, 0, 1, 0, 0, & 0, 1, 1, 1, 1, 1, 0, & 0, 0, 1, 0, 1, 0, 0 / data ((bits(i,j, 4), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 1, 0, 0, 0, 0, & 0, 1, 0, 1, 0, 1, 0, & 1, 1, 1, 1, 1, 1, 1, & 0, 1, 0, 1, 0, 1, 0, & 0, 0, 0, 0, 1, 0, 0 / data ((bits(i,j, 5), i = 1, 7 ), j = 1, 5 ) / & 0, 1, 1, 0, 0, 1, 0, & 0, 1, 1, 0, 1, 0, 0, & 0, 0, 0, 1, 0, 0, 0, & 0, 0, 1, 0, 1, 1, 0, & 0, 1, 0, 0, 1, 1, 0 / data ((bits(i,j, 6), i = 1, 7 ), j = 1, 5 ) / & 0, 1, 1, 0, 1, 1, 0, & 1, 0, 0, 1, 0, 0, 1, & 1, 0, 0, 0, 1, 0, 1, & 0, 1, 0, 0, 0, 1, 0, & 0, 0, 0, 0, 1, 0, 1 / data ((bits(i,j, 7), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0, & 0, 1, 0, 0, 0, 0, 0, & 1, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0 / data ((bits(i,j, 8), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 1, 1, 1, 0, 0, & 0, 1, 0, 0, 0, 1, 0, & 1, 0, 0, 0, 0, 0, 1, & 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0 / data ((bits(i,j, 9), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0, & 1, 0, 0, 0, 0, 0, 1, & 0, 1, 0, 0, 0, 1, 0, & 0, 0, 1, 1, 1, 0, 0 / data ((bits(i,j, 10), i = 1, 7 ), j = 1, 5 ) / & 0, 1, 0, 0, 0, 0, 0, & 0, 0, 1, 0, 0, 0, 0, & 1, 1, 0, 0, 0, 0, 0, & 0, 0, 1, 0, 0, 0, 0, & 0, 1, 0, 0, 0, 0, 0 / data ((bits(i,j, 11), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 0, 1, 0, 0, 0, & 0, 0, 0, 1, 0, 0, 0, & 0, 1, 1, 1, 1, 1, 0, & 0, 0, 0, 1, 0, 0, 0, & 0, 0, 0, 1, 0, 0, 0 / data ((bits(i,j, 12), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 1, 1, & 0, 0, 0, 0, 0, 1, 0, & 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0 / data ((bits(i,j, 13), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 1, 0, 0, 0, & 0, 0, 0, 1, 0, 0, 0, & 0, 0, 0, 1, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0 / data ((bits(i,j, 14), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 1, 1, & 0, 0, 0, 0, 0, 1, 1, & 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0 / data ((bits(i,j, 15), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 0, 0, 0, 1, 1, & 0, 0, 0, 0, 1, 0, 0, & 0, 0, 0, 1, 0, 0, 0, & 0, 0, 1, 0, 0, 0, 0, & 1, 1, 0, 0, 0, 0, 0 / data ((bits(i,j, 16), i = 1, 7 ), j = 1, 5 ) / & 0, 1, 1, 1, 1, 1, 0, & 1, 0, 0, 0, 1, 0, 1, & 1, 0, 0, 1, 0, 0, 1, & 1, 0, 1, 0, 0, 0, 1, & 0, 1, 1, 1, 1, 1, 0 / data ((bits(i,j, 17), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 0, 0, 0, 0, 0, & 0, 1, 0, 0, 0, 0, 0, & 1, 1, 1, 1, 1, 1, 1, & 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0 / data ((bits(i,j, 18), i = 1, 7 ), j = 1, 5 ) / & 0, 1, 0, 0, 0, 0, 1, & 1, 0, 0, 0, 0, 1, 1, & 1, 0, 0, 0, 1, 0, 1, & 0, 1, 0, 1, 0, 0, 1, & 0, 0, 1, 0, 0, 0, 1 / data ((bits(i,j, 19), i = 1, 7 ), j = 1, 5 ) / & 0, 1, 0, 0, 0, 1, 0, & 1, 0, 0, 0, 0, 0, 1, & 1, 0, 0, 1, 0, 0, 1, & 1, 0, 0, 1, 0, 0, 1, & 0, 1, 1, 1, 1, 1, 0 / data ((bits(i,j, 20), i = 1, 7 ), j = 1, 5 ) / & 1, 1, 1, 1, 0, 0, 0, & 0, 0, 0, 1, 0, 0, 0, & 0, 0, 0, 1, 0, 0, 0, & 0, 0, 0, 1, 0, 0, 0, & 1, 1, 1, 1, 1, 1, 1 / data ((bits(i,j, 21), i = 1, 7 ), j = 1, 5 ) / & 1, 1, 1, 0, 0, 1, 0, & 1, 0, 0, 1, 0, 0, 1, & 1, 0, 0, 1, 0, 0, 1, & 1, 0, 0, 1, 0, 0, 1, & 1, 0, 0, 0, 1, 1, 0 / data ((bits(i,j, 22), i = 1, 7 ), j = 1, 5 ) / & 0, 1, 1, 1, 1, 1, 1, & 1, 0, 0, 1, 0, 0, 1, & 0, 0, 0, 1, 0, 0, 1, & 0, 0, 0, 1, 0, 0, 1, & 0, 0, 0, 0, 1, 1, 0 / data ((bits(i,j, 23), i = 1, 7 ), j = 1, 5 ) / & 1, 0, 0, 0, 0, 0, 0, & 1, 0, 0, 0, 0, 0, 0, & 1, 0, 0, 1, 1, 1, 1, & 1, 0, 1, 0, 0, 0, 0, & 1, 1, 0, 0, 0, 0, 0 / data ((bits(i,j, 24), i = 1, 7 ), j = 1, 5 ) / & 0, 1, 1, 0, 1, 1, 0, & 1, 0, 0, 1, 0, 0, 1, & 1, 0, 0, 1, 0, 0, 1, & 1, 0, 0, 1, 0, 0, 1, & 0, 1, 1, 0, 1, 1, 0 / data ((bits(i,j, 25), i = 1, 7 ), j = 1, 5 ) / & 0, 1, 1, 0, 0, 1, 0, & 1, 0, 0, 1, 0, 0, 1, & 1, 0, 0, 1, 0, 0, 1, & 1, 0, 0, 1, 0, 0, 1, & 0, 1, 1, 1, 1, 1, 0 / data ((bits(i,j, 26), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 1, 0, 1, 0, & 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0 / data ((bits(i,j, 27), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 1, & 0, 0, 0, 1, 0, 1, 0, & 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0 / data ((bits(i,j, 28), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 0, 1, 0, 0, 0, & 0, 0, 1, 0, 1, 0, 0, & 0, 1, 0, 0, 0, 1, 0, & 1, 0, 0, 0, 0, 0, 1, & 0, 0, 0, 0, 0, 0, 0 / data ((bits(i,j, 29), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 1, 0, 1, 0, 0, & 0, 0, 1, 0, 1, 0, 0, & 0, 0, 1, 0, 1, 0, 0, & 0, 0, 1, 0, 1, 0, 0, & 0, 0, 1, 0, 1, 0, 0 / data ((bits(i,j, 30), i = 1, 7 ), j = 1, 5 ) / & 1, 0, 0, 0, 0, 0, 1, & 0, 1, 0, 0, 0, 1, 0, & 0, 0, 1, 0, 1, 0, 0, & 0, 0, 0, 1, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0 / data ((bits(i,j, 31), i = 1, 7 ), j = 1, 5 ) / & 0, 1, 0, 0, 0, 0, 0, & 1, 0, 0, 0, 0, 0, 0, & 1, 0, 0, 1, 1, 0, 1, & 1, 0, 1, 0, 0, 0, 0, & 0, 1, 0, 0, 0, 0, 0 / data ((bits(i,j, 32), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 1, 1, 1, 1, 0, & 0, 1, 0, 1, 0, 0, 1, & 0, 1, 1, 0, 1, 0, 1, & 0, 1, 1, 0, 1, 0, 0, & 0, 0, 1, 1, 1, 0, 0 / data ((bits(i,j, 33), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 1, 1, 1, 1, 1, & 0, 1, 1, 0, 1, 0, 0, & 1, 0, 0, 0, 1, 0, 0, & 0, 1, 1, 0, 1, 0, 0, & 0, 0, 1, 1, 1, 1, 1 / data ((bits(i,j, 34), i = 1, 7 ), j = 1, 5 ) / & 1, 1, 1, 1, 1, 1, 1, & 1, 0, 0, 1, 0, 0, 1, & 1, 0, 0, 1, 0, 0, 1, & 1, 0, 0, 1, 0, 0, 1, & 0, 1, 1, 0, 1, 1, 0 / data ((bits(i,j, 35), i = 1, 7 ), j = 1, 5 ) / & 0, 1, 1, 1, 1, 1, 0, & 1, 0, 0, 0, 0, 0, 1, & 1, 0, 0, 0, 0, 0, 1, & 1, 0, 0, 0, 0, 0, 1, & 0, 1, 0, 0, 0, 1, 0 / data ((bits(i,j, 36), i = 1, 7 ), j = 1, 5 ) / & 1, 1, 1, 1, 1, 1, 1, & 1, 0, 0, 0, 0, 0, 1, & 1, 0, 0, 0, 0, 0, 1, & 1, 0, 0, 0, 0, 0, 1, & 0, 1, 1, 1, 1, 1, 0 / data ((bits(i,j, 37), i = 1, 7 ), j = 1, 5 ) / & 1, 1, 1, 1, 1, 1, 1, & 1, 0, 0, 1, 0, 0, 1, & 1, 0, 0, 1, 0, 0, 1, & 1, 0, 0, 1, 0, 0, 1, & 1, 0, 0, 0, 0, 0, 1 / data ((bits(i,j, 38), i = 1, 7 ), j = 1, 5 ) / & 1, 1, 1, 1, 1, 1, 1, & 1, 0, 0, 1, 0, 0, 0, & 1, 0, 0, 1, 0, 0, 0, & 1, 0, 0, 1, 0, 0, 0, & 1, 0, 0, 0, 0, 0, 0 / data ((bits(i,j, 39), i = 1, 7 ), j = 1, 5 ) / & 0, 1, 1, 1, 1, 1, 0, & 1, 0, 0, 0, 0, 0, 1, & 1, 0, 0, 0, 0, 0, 1, & 1, 0, 0, 0, 1, 0, 1, & 0, 1, 0, 0, 1, 1, 0 / data ((bits(i,j, 40), i = 1, 7 ), j = 1, 5 ) / & 1, 1, 1, 1, 1, 1, 1, & 0, 0, 0, 1, 0, 0, 0, & 0, 0, 0, 1, 0, 0, 0, & 0, 0, 0, 1, 0, 0, 0, & 1, 1, 1, 1, 1, 1, 1 / data ((bits(i,j, 41), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 0, 0, 0, 0, 0, & 1, 0, 0, 0, 0, 0, 1, & 1, 1, 1, 1, 1, 1, 1, & 1, 0, 0, 0, 0, 0, 1, & 0, 0, 0, 0, 0, 0, 0 / data ((bits(i,j, 42), i = 1, 7 ), j = 1, 5 ) / & 1, 0, 0, 0, 0, 1, 0, & 1, 0, 0, 0, 0, 0, 1, & 1, 1, 1, 1, 1, 1, 0, & 1, 0, 0, 0, 0, 0, 0, & 1, 0, 0, 0, 0, 0, 0 / data ((bits(i,j, 43), i = 1, 7 ), j = 1, 5 ) / & 1, 1, 1, 1, 1, 1, 1, & 0, 0, 0, 0, 0, 0, 0, & 0, 0, 1, 0, 1, 0, 0, & 0, 1, 0, 0, 0, 1, 0, & 1, 0, 0, 0, 0, 0, 1 / data ((bits(i,j, 44), i = 1, 7 ), j = 1, 5 ) / & 1, 1, 1, 1, 1, 1, 1, & 0, 0, 0, 0, 0, 0, 1, & 0, 0, 0, 0, 0, 0, 1, & 0, 0, 0, 0, 0, 0, 1, & 0, 0, 0, 0, 0, 0, 1 / data ((bits(i,j, 45), i = 1, 7 ), j = 1, 5 ) / & 1, 1, 1, 1, 1, 1, 1, & 1, 1, 0, 0, 0, 0, 0, & 0, 0, 1, 1, 0, 0, 0, & 1, 1, 0, 0, 0, 0, 0, & 1, 1, 1, 1, 1, 1, 1 / data ((bits(i,j, 46), i = 1, 7 ), j = 1, 5 ) / & 1, 1, 1, 1, 1, 1, 1, & 1, 1, 0, 0, 0, 0, 0, & 0, 0, 1, 1, 1, 0, 0, & 0, 0, 0, 0, 0, 1, 1, & 1, 1, 1, 1, 1, 1, 1 / data ((bits(i,j, 47), i = 1, 7 ), j = 1, 5 ) / & 0, 1, 1, 1, 1, 1, 0, & 1, 0, 0, 0, 0, 0, 1, & 1, 0, 0, 0, 0, 0, 1, & 1, 0, 0, 0, 0, 0, 1, & 0, 1, 1, 1, 1, 1, 0 / data ((bits(i,j, 48), i = 1, 7 ), j = 1, 5 ) / & 1, 1, 1, 1, 1, 1, 1, & 1, 0, 0, 1, 0, 0, 0, & 1, 0, 0, 1, 0, 0, 0, & 1, 0, 0, 1, 0, 0, 0, & 0, 1, 1, 0, 0, 0, 0 / data ((bits(i,j, 49), i = 1, 7 ), j = 1, 5 ) / & 0, 1, 1, 1, 1, 1, 0, & 1, 0, 0, 0, 0, 0, 1, & 1, 0, 0, 0, 1, 0, 1, & 1, 0, 0, 0, 0, 1, 0, & 0, 1, 1, 1, 1, 0, 1 / data ((bits(i,j, 50), i = 1, 7 ), j = 1, 5 ) / & 1, 1, 1, 1, 1, 1, 1, & 1, 0, 0, 1, 0, 0, 0, & 1, 0, 0, 1, 1, 0, 0, & 1, 0, 0, 1, 0, 1, 0, & 0, 1, 1, 0, 0, 0, 1 / data ((bits(i,j, 51), i = 1, 7 ), j = 1, 5 ) / & 0, 1, 1, 0, 0, 1, 0, & 1, 0, 0, 1, 0, 0, 1, & 1, 0, 0, 1, 0, 0, 1, & 1, 0, 0, 1, 0, 0, 1, & 0, 1, 0, 0, 1, 1, 0 / data ((bits(i,j, 52), i = 1, 7 ), j = 1, 5 ) / & 1, 0, 0, 0, 0, 0, 0, & 1, 0, 0, 0, 0, 0, 0, & 1, 1, 1, 1, 1, 1, 1, & 1, 0, 0, 0, 0, 0, 0, & 1, 0, 0, 0, 0, 0, 0 / data ((bits(i,j, 53), i = 1, 7 ), j = 1, 5 ) / & 1, 1, 1, 1, 1, 1, 0, & 0, 0, 0, 0, 0, 0, 1, & 0, 0, 0, 0, 0, 0, 1, & 0, 0, 0, 0, 0, 0, 1, & 1, 1, 1, 1, 1, 1, 0 / data ((bits(i,j, 54), i = 1, 7 ), j = 1, 5 ) / & 1, 1, 1, 0, 0, 0, 0, & 0, 0, 0, 1, 1, 1, 0, & 0, 0, 0, 0, 0, 0, 1, & 0, 0, 0, 1, 1, 1, 0, & 1, 1, 1, 0, 0, 0, 0 / data ((bits(i,j, 55), i = 1, 7 ), j = 1, 5 ) / & 1, 1, 1, 1, 1, 0, 0, & 0, 0, 0, 0, 1, 1, 1, & 0, 0, 1, 1, 1, 1, 0, & 0, 0, 0, 0, 1, 1, 1, & 1, 1, 1, 1, 1, 0, 0 / data ((bits(i,j, 56), i = 1, 7 ), j = 1, 5 ) / & 1, 1, 0, 0, 0, 1, 1, & 0, 0, 1, 0, 1, 0, 0, & 0, 0, 0, 1, 0, 0, 0, & 0, 0, 1, 0, 1, 0, 0, & 1, 1, 0, 0, 0, 1, 1 / data ((bits(i,j, 57), i = 1, 7 ), j = 1, 5 ) / & 1, 1, 0, 0, 0, 0, 0, & 0, 0, 1, 0, 0, 0, 0, & 0, 0, 0, 1, 1, 1, 1, & 0, 0, 1, 0, 0, 0, 0, & 1, 1, 0, 0, 0, 0, 0 / data ((bits(i,j, 58), i = 1, 7 ), j = 1, 5 ) / & 1, 0, 0, 0, 0, 1, 1, & 1, 0, 0, 0, 1, 0, 1, & 1, 0, 0, 1, 0, 0, 1, & 1, 0, 1, 0, 0, 0, 1, & 1, 1, 0, 0, 0, 0, 1 / data ((bits(i,j, 59), i = 1, 7 ), j = 1, 5 ) / & 1, 1, 1, 1, 1, 1, 1, & 1, 0, 0, 0, 0, 0, 1, & 1, 0, 0, 0, 0, 0, 1, & 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0 / data ((bits(i,j, 60), i = 1, 7 ), j = 1, 5 ) / & 1, 1, 0, 0, 0, 0, 0, & 0, 0, 1, 0, 0, 0, 0, & 0, 0, 0, 1, 0, 0, 0, & 0, 0, 0, 0, 1, 0, 0, & 0, 0, 0, 0, 0, 1, 1 / data ((bits(i,j, 61), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0, & 1, 0, 0, 0, 0, 0, 1, & 1, 0, 0, 0, 0, 0, 1, & 1, 1, 1, 1, 1, 1, 1 / data ((bits(i,j, 62), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 1, 0, 0, 0, 0, & 0, 1, 0, 0, 0, 0, 0, & 1, 0, 0, 0, 0, 0, 0, & 0, 1, 0, 0, 0, 0, 0, & 0, 0, 1, 0, 0, 0, 0 / data ((bits(i,j, 63), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 0, 0, 0, 0, 1, & 0, 0, 0, 0, 0, 0, 1, & 0, 0, 0, 0, 0, 0, 1, & 0, 0, 0, 0, 0, 0, 1, & 0, 0, 0, 0, 0, 0, 1 / data ((bits(i,j, 64), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 0, 0, 0, 0, 0, & 1, 0, 0, 0, 0, 0, 0, & 0, 1, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0 / data ((bits(i,j, 65), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 0, 1, 0, 0, 0, & 0, 1, 1, 0, 1, 1, 0, & 1, 0, 0, 0, 0, 0, 1, & 1, 0, 0, 0, 0, 0, 1, & 0, 0, 0, 0, 0, 0, 0 / data ((bits(i,j, 66), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0, & 1, 1, 1, 0, 1, 1, 1, & 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0 / data ((bits(i,j, 67), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 0, 0, 0, 0, 0, & 1, 0, 0, 0, 0, 0, 1, & 1, 0, 0, 0, 0, 0, 1, & 0, 1, 1, 0, 1, 1, 0, & 0, 0, 0, 1, 0, 0, 0 / data ((bits(i,j, 68), i = 1, 7 ), j = 1, 5 ) / & 0, 0, 1, 0, 0, 0, 0, & 0, 1, 0, 0, 0, 0, 0, & 0, 1, 0, 0, 0, 0, 0, & 0, 0, 1, 0, 0, 0, 0, & 0, 1, 0, 0, 0, 0, 0 / indx = ichar ( c ) k = ipoint ( indx ) if ( k == 0 ) then pattern(1:7,1:5) = 0 else pattern(1:7,1:5) = bits(1:7,1:5,k) end if return end 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 ( kind = 4 ) itemp itemp = ichar ( c ) if ( 97 <= itemp .and. itemp <= 122 ) then c = char ( itemp - 32 ) end if return end subroutine font_data ( bits, ipoint, maxchar, maxcol, maxrow, nchar ) !*****************************************************************************80 ! !! FONT_DATA prints out a FORTRAN DATA version of a simple bit map font. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 17 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) BITS(MAXROW,MAXCOL,MAXCHAR). The J-th ! character read in is described in the entries BITS(*,*,J). ! ! Input, integer ( kind = 4 ) IPOINT(0:255); IPOINT(I) contains: ! 0, if character I was not read in; ! J, if information about character I is in BITS(*,*,J). ! ! Input, integer ( kind = 4 ) MAXCHAR, the maximum number of characters that ! the user has set aside storage for. ! ! Input, integer ( kind = 4 ) MAXCOL, MAXROW, the maximum number of columns ! and rows of pixels that an individual character is allowed to use. ! ! Input, integer ( kind = 4 ) NCHAR, the number of characters stored. ! implicit none integer ( kind = 4 ) maxchar integer ( kind = 4 ) maxcol integer ( kind = 4 ) maxrow integer ( kind = 4 ) bits(maxrow,maxcol,maxchar) character ( len = 8 ) c1 character ( len = 8 ) c2 character ( len = 8 ) c3 integer ( kind = 4 ) i integer ( kind = 4 ) ilo integer ( kind = 4 ) ipoint(0:255) integer ( kind = 4 ) j integer ( kind = 4 ) k integer ( kind = 4 ) lenc integer ( kind = 4 ) nchar character ( len = 80 ) text write ( *, '(a)' ) '!' write ( *, '(a)' ) '! IPOINT(I) is:' write ( *, '(a)' ) '! 0, if character I is not here,' write ( *, '(a)' ) '! J, if character I is in BITS(*,*,J).' write ( *, '(a)' ) '!' write ( *, '(a)' ) & ' integer ( kind = 4 ), parameter, dimension (0:255) :: ipoint = (/ &' do ilo = 0, 255, 16 if ( ilo /= 240 ) then write ( *, '(2x, 16(i3,'',''), '' &'' )' ) ipoint(ilo:ilo+15) else write ( *, '(2x, 15(i3,'',''), i3, '' /)'' )' ) ipoint(ilo:ilo+15) end if end do write ( *, '(a)' ) ' ' write ( c1, '(i8)' ) maxrow write ( c2, '(i8)' ) maxcol write ( c3, '(i8)' ) nchar text = 'integer ( kind = 4 ) bits(' // c1 // ',' // c2 // ',' // c3 // ')' call s_blanks_delete ( text ) write ( *, '(2x,a)' ) trim ( text ) do k = 1, nchar write ( *, '(a)' ) ' ' write ( c1, '(i8)' ) k write ( c2, '(i8)' ) maxrow write ( c3, '(i8)' ) maxcol text = 'data ((bits(i,j,' // c1 // '), i = 1, ' // c2 // & ' ), j = 1, ' // c3 // ' ) / &' call s_blanks_delete ( text ) write ( *, '(2x,a)' ) trim ( text ) do j = 1, maxcol write ( text, '(2x, 20(i3,'','') )' ) bits(1:maxrow,j,k) lenc = len_trim ( text ) if ( j < maxcol ) then lenc = lenc + 2 text(lenc-1:lenc) = ' &' else lenc = lenc + 1 text(lenc-1:lenc) = ' /' end if write ( *, '(a)' ) text(1:lenc) end do end do return end subroutine font_print ( bits, ipoint, maxchar, maxcol, maxrow ) !*****************************************************************************80 ! !! FONT_PRINT prints out a text version of a simple bit map font. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 15 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) BITS(MAXROW,MAXCOL,MAXCHAR). The J-th ! character read in is described in the entries BITS(*,*,J). ! ! Input, integer ( kind = 4 ) IPOINT(0:255); IPOINT(I) contains: ! 0, if character I was not read in; ! J, if information about character I is in BITS(*,*,J). ! ! Input, integer ( kind = 4 ) MAXCHAR, the maximum number of characters that ! the user has set aside storage for. ! ! Input, integer ( kind = 4 ) MAXCOL, MAXROW, the maximum number of columns ! and rows of pixels that an individual character is allowed to use. ! implicit none integer ( kind = 4 ) maxchar integer ( kind = 4 ) maxcol integer ( kind = 4 ) maxrow integer ( kind = 4 ) bits(maxrow,maxcol,maxchar) integer ( kind = 4 ) i integer ( kind = 4 ) indx integer ( kind = 4 ) ipoint(0:255) integer ( kind = 4 ) irow integer ( kind = 4 ) jcol character ( len = 80 ) text do i = 0, 255 indx = ipoint(i) if ( indx /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Font entry for character ' // char(i) write ( *, '(a,i8)' ) 'ASCII number ', i write ( *, '(a)' ) ' ' do irow = 1, maxrow text = ' ' do jcol = 1, maxcol if ( bits(irow,jcol,indx) /= 0 ) then text(jcol:jcol) = 'X' end if end do write ( *, '(a)' ) text(1:maxcol) end do end if end do return end subroutine font_read ( bits, ierror, inunit, ipoint, maxchar, maxcol, maxrow, & nchar ) !*****************************************************************************80 ! !! FONT_READ reads simple ASCII data defining a bit map font. ! ! Example: ! ! The file should contain records like the following: ! ! an ASCII character; ! lines of periods "." for blanks and "X" for darks; ! a blank space. ! ! Here is a portion of a file for a 7 rows by 5 columns font: ! ! A ! ..X.. ! .X.X. ! XX.XX ! X...X ! XXXXX ! X...X ! X...X ! ! B ! XXXX. ! X...X ! X...X ! XXXX. ! X...X ! X...X ! XXXX. ! ! C ! (et cetera) ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 27 August 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ( kind = 4 ) BITS(MAXROW,MAXCOL,MAXCHAR). The J-th ! character read in is described in the entries BITS(*,*,J). ! ! Output, integer ( kind = 4 ) IERROR, error flag. ! 0, no error occurred. ! nonzero, an error occurred. ! ! Input, integer ( kind = 4 ) INUNIT, the FORTRAN unit from which the font ! data should be read. The user should have already opened the file, ! associating it with unit INUNIT. ! ! Output, integer ( kind = 4 ) IPOINT(0:255); IPOINT(I) contains: ! 0, if character I was not read in; ! J, if information about character I is in BITS(*,*,J). ! ! Input, integer ( kind = 4 ) MAXCHAR, the maximum number of characters that ! the user has set aside storage for. ! ! Input, integer ( kind = 4 ) MAXCOL, MAXROW, the maximum number of columns ! and rows of pixels that an individual character is allowed to use. ! ! Output, integer ( kind = 4 ) NCHAR, the number of distinct characters that ! were defined by the input file. ! implicit none integer ( kind = 4 ) maxchar integer ( kind = 4 ) maxcol integer ( kind = 4 ) maxrow integer ( kind = 4 ) bits(maxrow,maxcol,maxchar) character chr logical, parameter :: debug = .false. logical done integer ( kind = 4 ) i integer ( kind = 4 ) ichr integer ( kind = 4 ) icol integer ( kind = 4 ) ierror integer ( kind = 4 ) inunit integer ( kind = 4 ) ios integer ( kind = 4 ) ipoint(0:255) integer ( kind = 4 ) irow integer ( kind = 4 ) j integer ( kind = 4 ) k integer ( kind = 4 ) lenc integer ( kind = 4 ) nchar integer ( kind = 4 ) ntext character ( len = 80 ) text ! ! Initialize. ! ierror = 0 done = .true. nchar = 0 ntext = 0 ipoint(0:255) = 0 bits(1:maxrow,1:maxcol,1:maxchar) = 0 if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FONT_READ:' write ( *, '(a,i8)' ) ' Maximum number of characters in font is ', maxchar write ( *, '(a,i8)' ) ' Maximum number of columns in font is ', maxcol write ( *, '(a,i8)' ) ' Maximum number of rows in font is ', maxrow end if ! ! Read another line of text. ! do read ( inunit, '(a)', iostat = ios ) text if ( ios /= 0 ) then exit end if ntext = ntext + 1 ! ! How long is the line? ! lenc = len_trim ( text ) ! ! If the line is empty, then we're definitely done whatever character ! we were working on. ! if ( lenc == 0 ) then done = .true. cycle end if ! ! If this is the first nonblank line after one or more blanks, ! it better contain a single character. ! if ( done ) then if ( lenc == 1 ) then if ( maxchar <= nchar ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FONT_READ - Warning!' write ( *, '(a)' ) ' More font data to read, no more storage space.' exit end if nchar = nchar + 1 chr = text(1:1) ichr = ichar ( chr ) ipoint(ichr) = nchar irow = 0 done = .false. write ( *, '(i3,2x,i3,2x,a)' ) nchar, ichr, chr else ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FONT_READ - Fatal error!' write ( *, '(a)' ) ' Bad line!' write ( *, '(a)' ) ' Expecting a single nonblank character.' write ( *, '(a,i8)' ) ' Line number is ', ntext write ( *, '(a,i8)' ) ' Nonblank line length = ', lenc write ( *, '(a)' ) ' Text of line:' write ( *, '(a)' ) trim ( text ) exit end if else irow = irow + 1 if ( irow <= maxrow ) then do icol = 1, min ( lenc, maxcol ) if ( text(icol:icol) == '.' ) then bits(irow,icol,nchar) = 0 else bits(irow,icol,nchar) = 1 end if end do end if end if end do if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FONT_READ - Input file contains:' write ( *, '(a,i8)' ) ' Text lines ', ntext write ( *, '(a,i8)' ) ' Character definitions: ', nchar end if return end subroutine getint ( done, ierror, inunit, ival, string ) !*****************************************************************************80 ! !! GETINT reads an integer from a file. ! ! Discussion: ! ! The file, or at least the part read by GETINT, is assumed to ! contain nothing but integers. These integers may be separated ! by spaces, or appear on separate lines. Comments, which begin ! with "#" and extend to the end of the line, may appear anywhere. ! ! Each time GETINT is called, it tries to read the next integer ! it can find. It remembers where it was in the current line ! of text. ! ! The user should open a text file on FORTRAN unit INUNIT, ! set STRING = ' ' and DONE = TRUE. The GETINT routine will take ! care of reading in a new STRING as necessary, and extracting ! as many integers as possible from the line of text before ! reading in the next line. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 07 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, logical DONE. ! ! On input, if this is the first call, or the user has changed ! STRING, then set DONE = TRUE. ! ! On output, if there is no more data to be read from STRING, ! then DONE is TRUE. ! ! Output, integer ( kind = 4 ) IERROR, error flag. ! 0, no error occurred. ! 1, an error occurred while trying to read the integer. ! ! Input, integer ( kind = 4 ) INUNIT, the FORTRAN unit from which to read. ! ! Output, integer ( kind = 4 ) IVAL, the integer ( kind = 4 ) that was read. ! ! Input/output, character ( len = * ) STRING, the text of the most recently ! read line of the file. ! implicit none logical done integer ( kind = 4 ) i integer ( kind = 4 ) ierror integer ( kind = 4 ) inunit integer ( kind = 4 ) ios integer ( kind = 4 ) ival integer ( kind = 4 ) last character ( len = * ) string character ( len = 80 ) word do call word_next_rd ( string, word, done ) if ( .not. done ) then exit end if read ( inunit, '(a)', iostat = ios ) string if ( ios /= 0 ) then ierror = 1 return end if i = index ( string, '#' ) if ( i /= 0 ) then string(i:) = ' ' end if end do call s_to_i4 ( word, ival, ierror, last ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GETINT - Fatal error!' write ( *, '(a)' ) ' Error trying to convert string to integer.' return end if return end subroutine get_unit ( iunit ) !*****************************************************************************80 ! !! GET_UNIT returns a free FORTRAN unit number. ! ! Discussion: ! ! A "free" FORTRAN unit number is a value between 1 and 99 which ! is not currently associated with an I/O device. A free FORTRAN unit ! number is needed in order to open a file with the OPEN command. ! ! If IUNIT = 0, then no free FORTRAN unit could be found, although ! all 99 units were checked (except for units 5, 6 and 9, which ! are commonly reserved for console I/O). ! ! Otherwise, IUNIT is a value between 1 and 99, representing a ! free FORTRAN unit. Note that GET_UNIT assumes that units 5 and 6 ! are special, and will never return those values. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 18 September 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ( kind = 4 ) IUNIT, the free unit number. ! implicit none integer ( kind = 4 ) i integer ( kind = 4 ) ios integer ( kind = 4 ) iunit logical lopen iunit = 0 do i = 1, 99 if ( i /= 5 .and. i /= 6 .and. i /= 9 ) then inquire ( unit = i, opened = lopen, iostat = ios ) if ( ios == 0 ) then if ( .not. lopen ) then iunit = i return end if end if end if end do return end subroutine hexcol ( angle, r, g, b ) !*****************************************************************************80 ! !! HEXCOL returns a color on the perimeter of the color hexagon. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 13 December 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) ANGLE, the angle in the color hexagon. ! The sextants are defined by the following points: ! 0 degrees, 1, 0, 0, red; ! 60 degrees, 1, 1, 0, yellow; ! 120 degrees, 0, 1, 0, green; ! 180 degrees, 0, 1, 1, cyan; ! 240 degrees, 0, 0, 1, blue; ! 300 degrees, 1, 0, 1, magenta. ! ! Output, real ( kind = 8 ) R, G, B, RGB specifications for the color ! that lies at the given angle, on the perimeter of the color hexagon. ! One value will be 1, and one value will be 0. ! implicit none real ( kind = 8 ) angle real ( kind = 8 ) angle2 real ( kind = 8 ) b real ( kind = 8 ) g real ( kind = 8 ), parameter :: degrees_to_radians = & 3.141592653589793D+00 / 180.0D+00 real ( kind = 8 ) r angle = mod ( angle, 360.0D+00 ) if ( angle < 0.0D+00 ) then angle = angle + 360.0D+00 end if if ( angle <= 60.0D+00 ) then angle2 = degrees_to_radians * 3.0D+00 * angle / 4.0D+00 r = 1.0D+00 g = tan ( angle2 ) b = 0.0D+00 else if ( angle <= 120.0D+00 ) then angle2 = degrees_to_radians * 3.0D+00 * angle / 4.0D+00 r = cos ( angle2 ) / sin ( angle2 ) g = 1.0D+00 b = 0.0D+00 else if ( angle <= 180.0D+00 ) then angle2 = degrees_to_radians * 3.0D+00 * ( angle - 120.0D+00 ) / 4.0D+00 r = 0.0D+00 g = 1.0D+00 b = tan ( angle2 ) else if ( angle <= 240.0D+00 ) then angle2 = degrees_to_radians * 3.0D+00 * ( angle - 120.0D+00 ) / 4.0D+00 r = 0.0D+00 g = cos ( angle2 ) / sin ( angle2 ) b = 1.0D+00 else if ( angle <= 300.0D+00 ) then angle2 = degrees_to_radians * 3.0D+00 * ( angle - 240.0D+00 ) / 4.0D+00 r = tan ( angle2 ) g = 0.0D+00 b = 1.0D+00 else if ( angle <= 360.0D+00 ) then angle2 = degrees_to_radians * 3.0D+00 * ( angle - 240.0D+00 ) / 4.0D+00 r = 1.0D+00 g = 0.0D+00 b = cos ( angle2 ) / sin ( angle2 ) end if return end subroutine i4vec_to_s ( n, i4vec, s, reverse ) !*****************************************************************************80 ! !! I4VEC_TO_S converts an array of integers into a string. ! ! Discussion: ! ! This routine can be useful when trying to read character data from an ! unformatted direct access file, for instance. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the number of integers. ! ! Input, integer ( kind = 4 ) I4VEC(N), the integers. ! ! Output, character ( len = * ) S, a string of 4 * N characters ! representing the integer ( kind = 4 ) information. ! ! Input, logical REVERSE, is TRUE if the bytes in a word need to be reversed. ! implicit none integer ( kind = 4 ) n integer ( kind = 4 ) i integer ( kind = 4 ) ilo integer ( kind = 4 ) i4vec(n) integer ( kind = 4 ) j1 integer ( kind = 4 ) j2 integer ( kind = 4 ) j3 integer ( kind = 4 ) j4 logical reverse character ( len = * ) s do i = 1, n ilo = 4 * ( i - 1 ) + 1 j1 = ibits ( i4vec(i), 0, 8 ) j2 = ibits ( i4vec(i), 8, 8 ) j3 = ibits ( i4vec(i), 16, 8 ) j4 = ibits ( i4vec(i), 24, 8 ) if ( reverse ) then s(ilo:ilo+3) = & achar ( j1 ) // achar ( j2 ) // achar ( j3 ) // achar ( j4 ) else s(ilo:ilo+3) = & achar ( j4 ) // achar ( j3 ) // achar ( j2 ) // achar ( j1 ) end if end do return end subroutine pbm_check_data ( b, ierror, ncol, nrow ) !*****************************************************************************80 ! !! PBM_CHECK_DATA checks bit data. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 28 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) B(NROW,NCOL), contains the bit data. ! ! Output, integer ( kind = 4 ) IERROR, error flag. ! 0, no error detected. ! 1, the data is illegal. ! ! Input, integer ( kind = 4 ) NCOL, NROW, the number of rows and columns ! of data. ! implicit none integer ( kind = 4 ) ncol integer ( kind = 4 ) nrow integer ( kind = 4 ) b(nrow,ncol) integer ( kind = 4 ) i integer ( kind = 4 ) ierror integer ( kind = 4 ) j ierror = 0 do i = 1, nrow do j = 1, ncol if ( b(i,j) /= 0 .and. b(i,j) /= 1 ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBM_CHECK_DATA - Fatal error!' write ( *, '(a)' ) ' All bits must be 0 or 1.' write ( *, '(a,i8,a,i8,a,i8)' ) ' B(', i, ',', j, ')=', b(i,j) return end if end do end do return end subroutine pbm_example ( nrow, ncol, b ) !*****************************************************************************80 ! !! PBM_EXAMPLE sets up data for a PBM file. ! ! Discussion: ! ! The data is an image of an ellipse. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 16 December 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) NROW, NCOL, the number of rows and columns ! of data. A reasonable value is 200. ! ! Output, integer ( kind = 4 ) B(NROW,NCOL), the bit data. ! implicit none integer ( kind = 4 ) ncol integer ( kind = 4 ) nrow integer ( kind = 4 ) b(nrow,ncol) integer ( kind = 4 ) i integer ( kind = 4 ) j real ( kind = 8 ) r real ( kind = 8 ) test real ( kind = 8 ) x real ( kind = 8 ) xc real ( kind = 8 ) y real ( kind = 8 ) yc xc = real ( ncol, kind = 8 ) / 2.0D+00 yc = real ( nrow, kind = 8 ) / 2.0D+00 r = real ( min ( nrow, ncol ), kind = 8 ) / 3.0D+00 do i = 1, nrow y = real ( i, kind = 8 ) do j = 1, ncol x = real ( j, kind = 8 ) test = r - sqrt ( ( x - xc )**2 + 0.75D+00 * ( y - yc )**2 ) if ( abs ( test ) <= 3.0D+00 ) then b(i,j) = 1 else b(i,j) = 0 end if end do end do return end subroutine pbma_read ( file_name, ierror, maxb, nrow, ncol, b ) !*****************************************************************************80 ! !! PBMA_READ reads an ASCII portable bit map file. ! ! Discussion: ! ! PBM files can be viewed by XV. ! ! Programs to convert files to PBM format include: ! ! MACPTOPBM - MacPaint file. ! ! A PBM file can also be converted to other formats, by programs: ! ! PBMTOASCII - ASCII "typewriter" file ! PBMTOMACP - MacPaint file. ! PBMTOPLOT - Unix plot file. ! ! Example: ! ! P1 ! # feep.pbm ! 24 7 ! 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ! 0 1 1 1 1 0 0 1 1 1 1 0 0 1 1 1 1 0 0 1 1 1 1 0 ! 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 0 1 0 ! 0 1 1 1 0 0 0 1 1 1 0 0 0 1 1 1 0 0 0 1 1 1 1 0 ! 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 ! 0 1 0 0 0 0 0 1 1 1 1 0 0 1 1 1 1 0 0 1 0 0 0 0 ! 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 07 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILE_NAME, the name of the file from which ! the data should be read. ! ! Output, integer ( kind = 4 ) IERROR, an error flag. ! 0, no error occurred. ! 1, the file could not be opened. ! 2, end or error while reading file. ! 3, bad magic number (the first two bytes must be 'P1'). ! 4, trouble reading NROW or NCOL. ! 5, trouble reading one of the bit values. ! 6, at least one bit was not 0 or 1. ! 7, NROW*NCOL exceeds MAXB. ! ! Input, integer ( kind = 4 ) MAXB, the number of entries available in B. ! If MAXB is smaller than NROW*NCOL, then the data will not be read. ! ! Output, integer ( kind = 4 ) NROW, NCOL, the number of rows and columns ! of data. ! ! Output, integer ( kind = 4 ) B(MAXB), contains the NROW by NCOL bit data. ! The (I,J) entry is in B( (J-1)*NROW + I ), the usual ! FORTRAN indexing method. ! implicit none integer ( kind = 4 ) maxb integer ( kind = 4 ) b(maxb) logical, parameter :: debug = .false. character ( len = * ) file_name integer ( kind = 4 ) file_unit integer ( kind = 4 ) ierror integer ( kind = 4 ) ios integer ( kind = 4 ) ncol integer ( kind = 4 ) nrow ierror = 0 ncol = 0 nrow = 0 ! ! Open the file. ! call get_unit ( file_unit ) open ( unit = file_unit, file = file_name, status = 'old', & form = 'formatted', access = 'sequential', iostat = ios ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMA_READ - Fatal error!' write ( *, '(a)' ) ' Could not open the file.' ierror = 1 return end if ! ! Read the header. ! call pbma_read_header ( file_unit, nrow, ncol, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMA_READ - Fatal error!' write ( *, '(a)' ) ' Could not read the file header.' return end if ! ! Check that there is enough room. ! if ( maxb < nrow * ncol ) then ierror = 7 close ( unit = file_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMA_READ - Fatal error!' write ( *, '(a,i12)' ) ' Needed NROW*NCOL = ', nrow * ncol write ( *, '(a,i12)' ) ' Available MAXB = ', maxb return end if ! ! Read the data. ! call pbma_read_data ( file_unit, nrow, ncol, b, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMA_READ - Fatal error!' write ( *, '(a)' ) ' Could not read the file data.' return end if ! ! Close the file. ! close ( unit = file_unit ) ! ! Check the data. ! call pbm_check_data ( b, ierror, ncol, nrow ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMA_READ - Fatal error!' write ( *, '(a)' ) ' Bad data detected by PBM_CHECK_DATA.' ierror = 6 end if ! ! Report ! if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMA_READ - Note:' write ( *, '(a)' ) ' The file was read and checked.' write ( *, '(a,i8)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i8)' ) ' Number of data columns NCOL = ', ncol end if return end subroutine pbma_read_data ( file_unit, nrow, ncol, b, ierror ) !*****************************************************************************80 ! !! PBMA_READ_DATA reads the data from an ASCII PBM file. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 13 December 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) FILE_UNIT, the unit number associated ! with the file. ! ! Input, integer ( kind = 4 ) NROW, NCOL, the number of rows and columns ! of data. ! ! Output, integer ( kind = 4 ) B(NROW,NCOL), the bit data. ! ! Output, integer ( kind = 4 ) IERROR, an error flag. ! 0, no error occurred. ! nonzero, an error occurred. ! implicit none integer ( kind = 4 ) ncol integer ( kind = 4 ) nrow integer ( kind = 4 ) b(nrow,ncol) logical, parameter :: debug = .false. logical done integer ( kind = 4 ) file_unit integer ( kind = 4 ) i integer ( kind = 4 ) ierror integer ( kind = 4 ) ios integer ( kind = 4 ) j character ( len = 80 ) string done = .true. string = ' ' ! ! Now read the bits. ! do i = 1, nrow do j = 1, ncol call getint ( done, ierror, file_unit, b(i,j), string ) if ( ierror /= 0 ) then ierror = 5 close ( unit = file_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMA_READ_DATA - Fatal error!' write ( *, '(a)' ) ' Problem reading bit data.' return end if end do end do return end subroutine pbma_read_header ( file_unit, nrow, ncol, ierror ) !*****************************************************************************80 ! !! PBMA_READ_HEADER reads the header of an ASCII PBM file. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 13 December 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) FILE_UNIT, the unit number associated ! with the file. ! ! Output, integer ( kind = 4 ) NROW, NCOL, the number of rows and columns ! of data. ! ! Output, integer ( kind = 4 ) IERROR, an error flag. ! 0, no error occurred. ! nonzero, an error occurred. ! implicit none logical, parameter :: debug = .false. logical done integer ( kind = 4 ) file_unit integer ( kind = 4 ) i integer ( kind = 4 ) ierror integer ( kind = 4 ) ios character ( len = 2 ) magic integer ( kind = 4 ) ncol integer ( kind = 4 ) nrow logical s_eqi character ( len = 80 ) string ! ! Read the first line of data, which must begin with the magic number. ! read ( file_unit, '(a)', iostat = ios ) magic if ( debug ) then write ( *, '(a)' ) '"' // trim ( magic ) // '"' end if if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMA_READ_HEADER - Fatal error!' write ( *, '(a)' ) ' End or error while reading file.' ierror = 2 return end if if ( .not. s_eqi ( magic, 'P1' ) ) then ierror = 3 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMA_READ_HEADER - Fatal error.' write ( *, '(a)' ) ' First two bytes are not magic number "P1".' write ( *, '(a)' ) ' First two bytes are: ' // magic return end if ! ! Now search for NCOL and NROW. ! done = .true. string = ' ' call getint ( done, ierror, file_unit, ncol, string ) if ( ierror /= 0 ) then close ( unit = file_unit ) ierror = 4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMA_READ_HEADER - Fatal error!' write ( *, '(a)' ) ' Problem reading NCOL.' return end if call getint ( done, ierror, file_unit, nrow, string ) if ( ierror /= 0 ) then ierror = 4 close ( unit = file_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMA_READ_HEADER - Fatal error!' write ( *, '(a)' ) ' Problem reading NROW.' return end if return end subroutine pbma_write ( file_name, ierror, nrow, ncol, b ) !*****************************************************************************80 ! !! PBMA_WRITE writes an ASCII portable bit map file. ! ! Discussion: ! ! PBM files can be viewed by XV. ! ! Programs to convert files to PBM format include: ! ! MACPTOPBM - MacPaint file. ! ! A PBM file can also be converted to other formats, by programs: ! ! PBMTOASCII - ASCII "typewriter" file ! PBMTOMACP - MacPaint file. ! PBMTOPLOT - Unix plot file. ! ! Example: ! ! P1 ! # feep.pbma created by PBMLIB(PBMA_WRITE). ! 24 7 ! 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ! 0 1 1 1 1 0 0 1 1 1 1 0 0 1 1 1 1 0 0 1 1 1 1 0 ! 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 0 1 0 ! 0 1 1 1 0 0 0 1 1 1 0 0 0 1 1 1 0 0 0 1 1 1 1 0 ! 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 ! 0 1 0 0 0 0 0 1 1 1 1 0 0 1 1 1 1 0 0 1 0 0 0 0 ! 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 07 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILE_NAME, the name of the file to which ! the data should be written. ! ! Output, integer ( kind = 4 ) IERROR, an error flag. ! 0, no error. ! 1, the data was illegal. ! 2, the file could not be opened. ! ! Input, integer ( kind = 4 ) NROW, NCOL, the number of rows and columns ! of data. ! ! Input, integer ( kind = 4 ) B(NROW,NCOL), contains the bit value of each ! pixel, which should be 0 or 1. ! implicit none integer ( kind = 4 ) ncol integer ( kind = 4 ) nrow integer ( kind = 4 ) b(nrow,ncol) logical, parameter :: debug = .false. character ( len = * ) file_name integer ( kind = 4 ) i integer ( kind = 4 ) ierror integer ( kind = 4 ) ios integer ( kind = 4 ) j integer ( kind = 4 ) jhi integer ( kind = 4 ) jlo character ( len = 2 ) magic integer ( kind = 4 ) output_unit ierror = 0 ! ! Check the data. ! call pbm_check_data ( b, ierror, ncol, nrow ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMA_WRITE - Fatal error!' write ( *, '(a)' ) ' Bad data detected by PBM_CHECK_DATA.' ierror = 1 return end if ! ! Open the file. ! call get_unit ( output_unit ) open ( unit = output_unit, file = file_name, status = 'replace', & form = 'formatted', access = 'sequential', iostat = ios ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMA_WRITE - Fatal error!' write ( *, '(a)' ) ' Could not open the file.' ierror = 2 return end if ! ! Write the data. ! magic = 'P1' write ( output_unit, '(a2)' ) magic write ( output_unit, '(a)' ) '# ' // trim ( file_name ) & // ' created by PBMLIB(PBMA_WRITE).' write ( output_unit, '(i5,2x,i5)' ) ncol, nrow do i = 1, nrow do jlo = 1, ncol, 35 jhi = min ( jlo+34, ncol ) write ( output_unit, '(35i2)' ) b(i,jlo:jhi) end do end do ! ! Close the file. ! close ( unit = output_unit ) ! ! Report ! if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMA_WRITE - Note:' write ( *, '(a)' ) ' The data was checked and written.' write ( *, '(a,i8)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i8)' ) ' Number of data columns NCOL = ', ncol end if return end subroutine pbmb_read ( file_name, ierror, maxb, nrow, ncol, b ) !*****************************************************************************80 ! !! PBMB_READ reads a binary portable bit map file. ! ! Discussion: ! ! PBM files can be viewed by XV. ! ! Programs to convert files to PBM format include: ! ! MACPTOPBM - MacPaint file. ! ! A PBM file can also be converted to other formats, by programs: ! ! PBMTOASCII - ASCII "typewriter" file ! PBMTOMACP - MacPaint file. ! PBMTOPLOT - Unix plot file. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 09 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILE_NAME, the name of the file from which ! the data should be read. ! ! Output, integer ( kind = 4 ) IERROR, an error flag. ! 0, no error occurred. ! 1, the file could not be opened. ! 2, end or error while reading file. ! 3, bad magic number (the first two bytes must be 'P1'). ! 4, trouble reading NROW or NCOL. ! 5, trouble reading one of the bit values. ! 6, at least one bit was not 0 or 1. ! 7, NROW*NCOL exceeds MAXB. ! ! Input, integer ( kind = 4 ) MAXB, the number of entries available in B. ! If MAXB is smaller than NROW*NCOL, then the data will not be read. ! ! Output, integer ( kind = 4 ) NROW, NCOL, the number of rows and columns ! of data. ! ! Output, integer ( kind = 4 ) B(MAXB), contains the NROW by NCOL bit data. ! The (I,J) entry is in B( (J-1)*NROW + I ), the usual ! FORTRAN indexing method. ! implicit none integer ( kind = 4 ) maxb integer ( kind = 4 ) b(maxb) logical, parameter :: debug = .false. character ( len = * ) file_name integer ( kind = 4 ) file_unit integer ( kind = 4 ) i integer ( kind = 4 ) i4vec(17) integer ( kind = 4 ) ierror integer ( kind = 4 ) indx integer ( kind = 4 ) ios integer ( kind = 4 ) ival integer ( kind = 4 ) j integer ( kind = 4 ) k integer ( kind = 4 ) last integer ( kind = 4 ) nchar integer ( kind = 4 ) nchar2 integer ( kind = 4 ) ncol integer ( kind = 4 ) none integer ( kind = 4 ) nrow integer ( kind = 4 ) nval integer ( kind = 4 ) nzero integer ( kind = 4 ) record integer ( kind = 4 ) record_length logical, parameter :: reverse = .false. character ( len = 68 ) string ierror = 0 ncol = 0 none = 0 nrow = 0 nzero = 0 ! ! Open the file. ! ! The smallest amount of information we can write at a time is ! 1 word = 4 bytes = 32 bits. ! call get_unit ( file_unit ) if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMB_READ - About to open the input file.' end if ! ! For the SGI: ! record_length = 4 ! ! For the DEC Alpha: ! ! record_length = 1 open ( unit = file_unit, file = file_name, status = 'old', & form = 'unformatted', access = 'direct', recl = record_length, & iostat = ios ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMB_READ - Fatal error!' write ( *, '(a)' ) ' Could not open the file.' ierror = 1 return end if record = 0 ! ! Read the data. ! if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMB_READ - About to read 17 header values.' end if nval = 17 do i = 1, nval record = record + 1 read ( file_unit, rec = record ) i4vec(i) end do if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMB_READ - About to convert integers to characters.' end if call i4vec_to_s ( nval, i4vec, string, reverse ) nchar = 4 * nval ! ! The first two bytes must be the magic number 'P4'. ! if ( string(1:2) /= 'P4' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMB_READ - Fatal error!' write ( *, '(a)' ) ' First two bytes are not magic number "P4".' write ( *, '(a)' ) ' First two bytes are: ' // string(1:2) write ( *, '(a,i8,i8)' ) ' ASCII codes: ', ichar ( string(1:1) ), & ichar ( string(2:2) ) ierror = 3 return end if if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMB_READ - About to chop 2 characters from STRING.' end if call s_chop ( string, 1, 2 ) nchar = nchar - 2 ! ! Now search for NCOL and NROW. ! if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMB_READ - About to search for NCOL and NROW.' end if call s_to_i4 ( string, ncol, ierror, last ) call s_chop ( string, 1, last ) nchar = nchar - last call s_to_i4 ( string, nrow, ierror, last ) call s_chop ( string, 1, last ) nchar = nchar - last ! ! Now skip a single byte. ! call s_chop ( string, 1, 1 ) nchar = nchar - 1 ! ! Check that there is enough room. ! if ( maxb < nrow * ncol) then ierror = 7 close ( unit = file_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMB_READ - Fatal error!' write ( *, '(a,i8)' ) ' Needed NROW*NCOL = ', nrow * ncol write ( *, '(a,i8)' ) ' Available MAXB = ', maxb return end if ! ! Now each successive byte is 8 bits of data. ! if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMB_READ - About to read the main data.' end if ival = 0 k = 0 do i = 1, nrow do j = 1, ncol if ( k == 0 ) then k = 8 if ( nchar < 1 ) then record = record + 1 read ( file_unit, rec = record ) i4vec(1) call i4vec_to_s ( 1, i4vec, string(nchar+1:nchar+4), reverse ) nchar2 = 4 nchar = nchar + 4 end if ival = ichar ( string(1:1) ) call s_chop ( string, 1, 1 ) nchar = nchar - 1 end if k = k - 1 indx = ( j - 1 ) * nrow + i b(indx) = ival / 2**k if ( b(indx) == 0 ) then nzero = nzero + 1 else none = none + 1 end if ival = ival - b(indx) * 2**k end do end do ! ! Close the file. ! close ( unit = file_unit ) ! ! Check the data. ! if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMB_READ - About to check data.' end if call pbm_check_data ( b, ierror, ncol, nrow ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMB_READ - Fatal error!' write ( *, '(a)' ) ' Bad data detected by PBM_CHECK_DATA.' ierror = 6 end if ! ! Report ! if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMB_READ - Note:' write ( *, '(a)' ) ' The file was read and checked.' write ( *, '(a,i8)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i8)' ) ' Number of data columns NCOL = ', ncol write ( *, '(a,i8)' ) ' Number of 0 bits = ', nzero write ( *, '(a,i8)' ) ' Number of 1 bits = ', none end if return end subroutine pbmb_write ( file_name, ierror, nrow, ncol, b ) !*****************************************************************************80 ! !! PBMB_WRITE writes a binary portable bit map file. ! ! Discussion: ! ! PBM files can be viewed by XV. ! ! A PBM file can also be converted to other formats, by programs: ! ! PBMTOASCII - ASCII "typewriter" file ! PBMTOMACP - MacPaint file. ! PBMTOPLOT - Unix plot file. ! ! DIRECT ACCESS is used for the output file just so that we can ! avoid the internal carriage returns and things that FORTRAN ! seems to want to add. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 09 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILE_NAME, the name of the file to which ! the data should be written. ! ! Output, integer ( kind = 4 ) IERROR, an error flag. ! 0, no error. ! 1, the data was illegal. ! 2, the file could not be opened. ! ! Input, integer ( kind = 4 ) NROW, NCOL, the number of rows and columns ! of data. ! ! Input, integer ( kind = 4 ) B(NROW,NCOL), contains the bit value of each ! pixel, which should be 0 or 1. ! implicit none integer ( kind = 4 ) ncol integer ( kind = 4 ) nrow integer ( kind = 4 ) b(nrow,ncol) logical, parameter :: debug = .false. character ( len = * ) file_name integer ( kind = 4 ) i integer ( kind = 4 ) i4vec(17) integer ( kind = 4 ) ierror integer ( kind = 4 ) ios integer ( kind = 4 ) ival integer ( kind = 4 ) j integer ( kind = 4 ) k integer ( kind = 4 ) l integer ( kind = 4 ) nchar integer ( kind = 4 ) none integer ( kind = 4 ) nval integer ( kind = 4 ) nzero integer ( kind = 4 ) output_unit integer ( kind = 4 ) record integer ( kind = 4 ) record_length logical, parameter :: reverse = .false. character ( len = 68 ) string ierror = 0 none = 0 nzero = 0 ! ! Check the data. ! call pbm_check_data ( b, ierror, ncol, nrow ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMB_WRITE - Fatal error!' write ( *, '(a)' ) ' Bad data detected by PBM_CHECK_DATA.' ierror = 1 return end if ! ! Open the file. ! ! The smallest amount of information we can write at a time is ! 1 word = 4 bytes = 32 bits. ! call get_unit ( output_unit ) ! ! The appropriate value of RECL seems to be bedeviled. ! On the SGI, I used RECL = 4, meaning 4 bytes. ! record_length = 4 ! ! On the Dec Alpha, I may need to use RECL = 1. ! ! record_length = 1 open ( unit = output_unit, file = file_name, status = 'replace', & form = 'unformatted', access = 'direct', recl = record_length, & iostat = ios ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMB_WRITE - Fatal error!' write ( *, '(a)' ) ' Could not open the file.' ierror = 2 return end if ! ! Write the header. ! string = ' ' string(1:4) = 'P4 ' write ( string(5:9), '(i5)' ) ncol string(10:10) = ' ' write ( string(11:15), '(i5)' ) nrow string(16:16) = ' ' k = 0 nchar = 16 ival = 0 record = 0 do i = 1, nrow do j = 1, ncol if ( b(i,j) == 1 ) then ival = ival + 2**(7-k) end if k = k + 1 if ( k == 8 ) then k = 0 nchar = nchar + 1 string(nchar:nchar) = char(ival) ival = 0 end if if ( nchar == 68 ) then call s_to_i4vec ( string(1:nchar), nval, i4vec, reverse ) do l = 1, nval record = record + 1 write ( output_unit, rec = record ) i4vec(l) end do string = ' ' nchar = 0 end if end do end do ! ! If 0 < K, we have a partial result to turn into the last character. ! if ( 0 < k ) then nchar = nchar + 1 string(nchar:nchar) = char(ival) end if ! ! If 0 < NCHAR, then we have a partial line to print out. ! if ( 0 < nchar ) then call s_to_i4vec ( string(1:nchar), nval, i4vec, reverse ) do i = 1, nval record = record + 1 write ( output_unit, rec = record ) i4vec(i) end do end if ! ! Close the file. ! close ( unit = output_unit ) ! ! Count bits. ! do i = 1, nrow do j = 1, ncol if ( b(i,j) == 0 ) then nzero = nzero + 1 else none = none + 1 end if end do end do ! ! Report ! if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMB_WRITE - Note:' write ( *, '(a)' ) ' The data was checked and written.' write ( *, '(a,i8)' ) ' Number of words written = ', record write ( *, '(a,i8)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i8)' ) ' Number of data columns NCOL = ', ncol write ( *, '(a,i8)' ) ' Number of 0 bits = ', nzero write ( *, '(a,i8)' ) ' Number of 1 bits = ', none end if return end subroutine pgm_check_data ( g, ierror, maxcol, ncol, nrow ) !*****************************************************************************80 ! !! PGM_CHECK_DATA checks gray data. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 14 December 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) G(NROW,NCOL), contains the gray data. ! ! Output, integer ( kind = 4 ) IERROR, error flag. ! 0, no error detected. ! 1, the data is illegal. ! ! Input, integer ( kind = 4 ) MAXCOL, the maximum gray value. ! ! Input, integer ( kind = 4 ) NCOL, NROW, the number of rows and columns 1 of data. ! implicit none integer ( kind = 4 ) ncol integer ( kind = 4 ) nrow integer ( kind = 4 ) g(nrow,ncol) integer ( kind = 4 ) ierror integer ( kind = 4 ) maxcol ierror = 0 if ( minval ( g(1:nrow,1:ncol) ) < 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGM_CHECK_DATA - Fatal error!' write ( *, '(a)' ) ' At least one gray value is below 0.' ierror = 1 return end if if ( maxcol < maxval ( g(1:nrow,1:ncol) ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGM_CHECK_DATA - Fatal error!' write ( *, '(a)' ) ' At least one gray value exceeds MAXCOL.' write ( *, '(a,i12)' ) ' MAXCOL = ', maxcol ierror = 1 return end if return end subroutine pgm_example ( nrow, ncol, g ) !*****************************************************************************80 ! !! PGM_EXAMPLE sets up sample PGM data. ! ! Discussion: ! ! The data is based on three periods of a sine curve. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 16 December 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) NROW, NCOL, the number of rows and columns ! of data. A reasonable value is 200 for NROW and 600 for NCOL. ! ! Output, integer ( kind = 4 ) G(NROW,NCOL), the gray scale data. ! implicit none integer ( kind = 4 ) nrow integer ( kind = 4 ) ncol integer ( kind = 4 ) g(nrow,ncol) integer ( kind = 4 ) i integer ( kind = 4 ) j integer ( kind = 4 ), parameter :: periods = 3 real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x real ( kind = 8 ) y do i = 1, nrow y = real ( i - 1, kind = 8 ) * 2.0D+00 & / real ( nrow - 1, kind = 8 ) - 1.0D+00 do j = 1, ncol x = 2.0D+00 * pi * real ( periods * ( j - 1 ), kind = 8 ) & / real ( ncol - 1, kind = 8 ) g(i,j) = int ( 20.0D+00 * ( sin ( x ) - y + 2 ) ) end do end do return end subroutine pgma_read ( file_name, ierror, maxgray, maxg, nrow, ncol, g ) !*****************************************************************************80 ! !! PGMA_READ reads an ASCII portable gray map file. ! ! Discussion: ! ! PGM files can be viewed by XV. ! ! A PGM file can also be converted to other formats, by programs: ! ! PGMTOFITS - Flexible Image Transport System file (astronomical data) ! PGMTOFS - Usenix FaceSaver file ! PGMTOLISPM - Lisp Machine file ! PGMTOPBM - Portable Bit Map file ! ! Example: ! ! P2 ! # feep.pgm ! 24 7 ! 15 ! 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ! 0 3 3 3 3 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 15 15 15 0 ! 0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 15 0 ! 0 3 3 3 0 0 0 7 7 7 0 0 0 11 11 11 0 0 0 15 15 15 15 0 ! 0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 0 0 ! 0 3 0 0 0 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 0 0 0 0 ! 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 14 December 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILE_NAME, the name of the file from which ! the data should be read. ! ! Output, integer ( kind = 4 ) IERROR, an error flag. ! 0, no error occurred. ! 1, the file could not be opened. ! 2, end or error while reading file. ! 3, bad magic number (the first two bytes must be 'P2'). ! 4, trouble reading NROW or NCOL or MAXGRAY. ! 5, trouble reading one of the gray values. ! 6, at least one gray value was less than 0, or greater than MAXGRAY. ! 7, NROW*NCOL exceeds MAXG. ! ! Output, integer ( kind = 4 ) MAXGRAY, the maximum gray value. ! ! Input, integer ( kind = 4 ) MAXG, the number of entries available in B. ! If MAXG is smaller than NROW*NCOL, then the data will not be read. ! ! Output, integer ( kind = 4 ) NROW, NCOL, the number of rows and columns ! of data. ! ! Output, integer ( kind = 4 ) G(MAXG), contains the NROW by NCOL gray data. ! The (I,J) entry is in G( (J-1)*NROW + I ), the usual ! FORTRAN indexing method. ! implicit none integer ( kind = 4 ) maxg logical, parameter :: debug = .false. logical done character ( len = * ) file_name integer ( kind = 4 ) file_unit integer ( kind = 4 ) g(maxg) integer ( kind = 4 ) i integer ( kind = 4 ) ierror integer ( kind = 4 ) ios integer ( kind = 4 ) j integer ( kind = 4 ) k integer ( kind = 4 ) maxgray integer ( kind = 4 ) ncol integer ( kind = 4 ) nrow logical s_eqi character ( len = 80 ) string ierror = 0 ! ! Open the file. ! call get_unit ( file_unit ) open ( unit = file_unit, file = file_name, status = 'old', & form = 'formatted', access = 'sequential', iostat = ios ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMA_READ - Fatal error!' write ( *, '(a)' ) ' Could not open the file.' ierror = 1 return end if ! ! Read the header. ! call pgma_read_header ( file_unit, nrow, ncol, maxgray, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMA_READ - Fatal error!' write ( *, '(a)' ) ' Could not read the header.' return end if ! ! Check that there is enough room. ! if ( maxg < nrow * ncol ) then ierror = 7 close ( unit = file_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMA_READ - Fatal error!' write ( *, '(a,i12)' ) ' Needed NROW*NCOL = ', nrow * ncol write ( *, '(a,i12)' ) ' Available MAXG = ', maxg return end if ! ! Now read the gray data. ! call pgma_read_data ( file_unit, nrow, ncol, g, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMA_READ - Fatal error!' write ( *, '(a)' ) ' Could not read the data.' return end if ! ! Close the file. ! close ( unit = file_unit ) ! ! Check the data. ! call pgm_check_data ( g, ierror, maxgray, ncol, nrow ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMA_READ - Fatal error!' write ( *, '(a)' ) ' Bad data detected by PGM_CHECK_DATA.' ierror = 6 return end if ! ! Report ! if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMA_READ - Note:' write ( *, '(a)' ) ' The file was read and checked.' write ( *, '(a,i8)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i8)' ) ' Number of data columns NCOL = ', ncol write ( *, '(a,i8)' ) ' Maximum color value MAXGRAY = ', maxgray end if return end subroutine pgma_read_data ( file_unit, nrow, ncol, g, ierror ) !*****************************************************************************80 ! !! PGMA_READ_DATA reads the data in an ASCII portable gray map file. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 14 December 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) FILE_UNIT, the unit number associated with ! the file. ! ! Input, integer ( kind = 4 ) NROW, NCOL, the number of rows and columns ! of data. ! ! Output, integer ( kind = 4 ) G(NOW,NCOL), the gray data. ! ! Output, integer ( kind = 4 ) IERROR, an error flag. ! 0, no error occurred. ! nonzero, an error occurred. ! implicit none integer ( kind = 4 ) ncol integer ( kind = 4 ) nrow logical done integer ( kind = 4 ) file_unit integer ( kind = 4 ) g(nrow,ncol) integer ( kind = 4 ) i integer ( kind = 4 ) ierror integer ( kind = 4 ) j character ( len = 80 ) string ierror = 0 done = .true. string = ' ' ! ! Read the gray data. ! do i = 1, nrow do j = 1, ncol call getint ( done, ierror, file_unit, g(i,j), string ) if ( ierror /= 0 ) then ierror = 5 close ( unit = file_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMA_READ_DATA - Fatal error!' write ( *, '(a)' ) ' Problem reading gray data.' return end if end do end do return end subroutine pgma_read_header ( file_unit, nrow, ncol, maxgray, ierror ) !*****************************************************************************80 ! !! PGMA_READ_HEADER reads the header of an ASCII portable gray map file. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 14 December 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) FILE_UNIT, the unit number associated ! with the file. ! ! Output, integer ( kind = 4 ) NROW, NCOL, the number of rows and columns. ! ! Output, integer ( kind = 4 ) MAXGRAY, the maximum gray value. ! ! Output, integer ( kind = 4 ) IERROR, an error flag. ! 0, no error occurred. ! nonzero, an error occurred. ! implicit none logical, parameter :: debug = .false. logical done integer ( kind = 4 ) file_unit integer ( kind = 4 ) i integer ( kind = 4 ) ierror integer ( kind = 4 ) ios character ( len = 2 ) magic integer ( kind = 4 ) maxgray integer ( kind = 4 ) ncol integer ( kind = 4 ) nrow logical s_eqi character ( len = 80 ) string ierror = 0 maxgray = 0 ncol = 0 nrow = 0 ! ! Read the first line of data, which must begin with the magic number. ! read ( file_unit, '(a)', iostat = ios ) magic if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMA_READ_HEADER - Fatal error!' write ( *, '(a)' ) ' End or error while reading file.' ierror = 2 return end if if ( .not. s_eqi ( magic, 'P2' ) ) then ierror = 3 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMA_READ_HEADER - Fatal error.' write ( *, '(a)' ) ' First two bytes are not magic number "P2".' write ( *, '(a)' ) ' First two bytes are: ' // magic return end if ! ! Now search for NCOL, NROW, and MAXCOL. ! done = .TRUE. string = ' ' call getint ( done, ierror, file_unit, ncol, string ) if ( ierror /= 0 ) then close ( unit = file_unit ) ierror = 4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMA_READ_HEADER - Fatal error!' write ( *, '(a)' ) ' Problem reading NCOL.' return end if call getint ( done, ierror, file_unit, nrow, string ) if ( ierror /= 0 ) then ierror = 4 close ( unit = file_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMA_READ_HEADER - Fatal error!' write ( *, '(a)' ) ' Problem reading NROW.' return end if call getint ( done, ierror, file_unit, maxgray, string ) if ( ierror /= 0 ) then ierror = 4 close ( unit = file_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMA_READ_HEADER - Fatal error!' write ( *, '(a)' ) ' Problem reading MAXGRAY.' return end if return end subroutine pgma_write ( file_name, ierror, nrow, ncol, g ) !*****************************************************************************80 ! !! PGMA_WRITE writes an ASCII portable gray map file. ! ! Discussion: ! ! PGM files can be viewed by XV. ! ! Programs to convert other files to PGM include: ! ! FITSTOPGM - Flexible Image Transport System file. ! ! A PGM file can also be converted to other formats, by programs: ! ! PGMTOFITS - Flexible Image Transport System file (astronomical data) ! PGMTOFS - Usenix FaceSaver file ! PGMTOLISPM - Lisp Machine file ! PGMTOPBM - Portable Bit Map file ! ! Example: ! ! P2 ! # feep.pgma created by PBMLIB(PGMA_WRITE). ! 24 7 ! 15 ! 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ! 0 3 3 3 3 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 15 15 15 0 ! 0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 15 0 ! 0 3 3 3 0 0 0 7 7 7 0 0 0 11 11 11 0 0 0 15 15 15 15 0 ! 0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 0 0 ! 0 3 0 0 0 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 0 0 0 0 ! 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 07 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILE_NAME, the name of the file to which ! the data should be written. ! ! Output, integer ( kind = 4 ) IERROR, an error flag. ! 0, no error. ! 1, the data was illegal. ! 2, the file could not be opened. ! ! Input, integer ( kind = 4 ) NROW, NCOL, the number of rows and columns. ! ! Input, integer ( kind = 4 ) G(NROW,NCOL), contains the gray value of ! each pixel. These should be positive. ! implicit none integer ( kind = 4 ) ncol integer ( kind = 4 ) nrow logical, parameter :: debug = .false. character ( len = * ) file_name integer ( kind = 4 ) g(nrow,ncol) integer ( kind = 4 ) i integer ( kind = 4 ) ierror integer ( kind = 4 ) ios integer ( kind = 4 ) j integer ( kind = 4 ) jhi integer ( kind = 4 ) jlo character ( len = 2 ) magic integer ( kind = 4 ) maxcol integer ( kind = 4 ) output_unit ierror = 0 ! ! Compute the maximum gray value. ! maxcol = maxval ( g(1:nrow,1:ncol) ) ! ! Check the data. ! call pgm_check_data ( g, ierror, maxcol, ncol, nrow ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMA_WRITE - Fatal error!' write ( *, '(a)' ) ' Bad data detected by PGM_CHECK_DATA!' ierror = 1 return end if ! ! Open the file. ! call get_unit ( output_unit ) open ( unit = output_unit, file = file_name, status = 'replace', & form = 'formatted', access = 'sequential', iostat = ios ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMA_WRITE - Fatal error!' write ( *, '(a)' ) ' Could not open the file.' ierror = 2 return end if ! ! Write the data. ! magic = 'P2' write ( output_unit, '(a2)' ) magic write ( output_unit, '(a)' ) '# ' // trim ( file_name ) & // ' created by PBMLIB(PGMA_WRITE).' write ( output_unit, '(i5,2x,i5)' ) ncol, nrow write ( output_unit, '(i5)' ) maxcol do i = 1, nrow do jlo = 1, ncol, 14 jhi = min ( jlo+13, ncol ) write ( output_unit, '(14i5)' ) g(i,jlo:jhi) end do end do ! ! Close the file. ! close ( unit = output_unit ) ! ! Report ! if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMA_WRITE - Note:' write ( *, '(a)' ) ' The data was checked and written.' write ( *, '(a,i8)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i8)' ) ' Number of data columns NCOL = ', ncol write ( *, '(a,i8)' ) ' Maximum color value MAXCOL = ', maxcol end if return end subroutine pgmb_read ( file_name, ierror, maxcol, maxg, nrow, ncol, g ) !*****************************************************************************80 ! !! PGMB_READ reads a binary portable gray map file. ! ! Discussion: ! ! PGM files can be viewed by XV. ! ! A PGM file can also be converted to other formats, by programs: ! ! PGMTOFITS - Flexible Image Transport System file (astronomical data) ! PGMTOFS - Usenix FaceSaver file ! PGMTOLISPM - Lisp Machine file ! PGMTOPBM - Portable Bit Map file ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 07 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILE_NAME, the name of the file to be read. ! ! Output, integer ( kind = 4 ) IERROR, an error flag. ! 0, no error occurred. ! 1, the file could not be opened. ! 2, end or error while reading file. ! 3, bad magic number (the first two bytes must be 'P5'). ! 4, trouble reading NROW or NCOL or MAXCOL. ! 5, trouble reading one of the gray values. ! 6, at least one gray value was less than 0 or greater than MAXCOL. ! 7, NROW*NCOL exceeds MAXG. ! ! Output, integer ( kind = 4 ) MAXCOL, the maximum gray value. ! ! Input, integer ( kind = 4 ) MAXG, the number of entries available in B. ! If MAXG is smaller than NROW*NCOL, then the data will not be read. ! ! Output, integer ( kind = 4 ) NROW, NCOL, the number of rows and columns. ! ! Output, integer ( kind = 4 ) G(MAXG), contains the NROW by NCOL gray data. ! The (I,J) entry is in G( (J-1)*NROW + I ), the usual FORTRAN ! indexing method. ! implicit none integer ( kind = 4 ) maxg logical, parameter :: debug = .false. character ( len = * ) file_name integer ( kind = 4 ) file_unit integer ( kind = 4 ) g(maxg) integer ( kind = 4 ) i integer ( kind = 4 ) i4vec(17) integer ( kind = 4 ) ierror integer ( kind = 4 ) ios integer ( kind = 4 ) ival integer ( kind = 4 ) j integer ( kind = 4 ) k integer ( kind = 4 ) last character ( len = 2 ) magic integer ( kind = 4 ) maxcol integer ( kind = 4 ) nchar integer ( kind = 4 ) nchar2 integer ( kind = 4 ) ncol integer ( kind = 4 ) nrow integer ( kind = 4 ) nval integer ( kind = 4 ) record integer ( kind = 4 ) record_length logical, parameter :: reverse = .false. character ( len = 68 ) string ierror = 0 maxcol = 0 ncol = 0 nrow = 0 ! ! Open the file. ! ! The smallest amount of information we can write at a time is ! 1 word = 4 bytes = 32 bits. ! call get_unit ( file_unit ) ! ! For the SGI: ! record_length = 4 ! ! For the DEC Alpha: ! ! record_length = 1 open ( unit = file_unit, file = file_name, status = 'old', & form = 'unformatted', access = 'direct', recl = record_length, & iostat = ios ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMB_READ - Fatal error!' write ( *, '(a)' ) ' Could not open the file.' ierror = 1 return end if record = 0 ! ! Read the data. ! nval = 17 do i = 1, nval record = record + 1 read ( file_unit, rec = record ) i4vec(i) end do call i4vec_to_s ( nval, i4vec, string, reverse ) nchar = 4 * nval ! ! The first two bytes must be the magic number 'P5'. ! magic = string(1:2) if ( magic /= 'P5' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMB_READ - Fatal error!' write ( *, '(a)' ) ' First two bytes are not magic number "P5".' write ( *, '(a)' ) ' First two bytes are: ' // magic write ( *, '(a,2i8)' ) ' ASCII codes: ', ichar ( string(1:1) ), & ichar ( string(2:2) ) ierror = 3 return end if call s_chop ( string, 1, 2 ) nchar = nchar - 2 ! ! Now search for NCOL, NROW and MAXCOL. ! call s_to_i4 ( string, ncol, ierror, last ) call s_chop ( string, 1, last ) nchar = nchar - last call s_to_i4 ( string, nrow, ierror, last ) call s_chop ( string, 1, last ) nchar = nchar - last call s_to_i4 ( string, maxcol, ierror, last ) call s_chop ( string, 1, last ) nchar = nchar - last ! ! Now skip a single byte. ! call s_chop ( string, 1, 1 ) nchar = nchar - 1 ! ! Check that there is enough room. ! if ( maxg < nrow * ncol ) then ierror = 7 close ( unit = file_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMB_READ - Fatal error!' write ( *, '(a,i12)' ) ' Needed NROW*NCOL = ', nrow * ncol write ( *, '(a,i12)' ) ' Available MAXG = ', maxg return end if ! ! Now each successive byte is a gray data value. ! k = 0 do i = 1, nrow do j = 1, ncol if ( nchar < 1 ) then record = record + 1 read ( file_unit, rec = record ) i4vec(1) call i4vec_to_s ( 1, i4vec, string(nchar+1:nchar+4), reverse ) nchar2 = 4 nchar = nchar + 4 end if ival = ichar ( string(1:1) ) call s_chop ( string, 1, 1 ) nchar = nchar - 1 k = k + 1 g(k) = ival end do end do ! ! Close the file. ! close ( unit = file_unit ) ! ! Check the data. ! call pgm_check_data ( g, ierror, maxcol, ncol, nrow ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMB_READ - Fatal error!' write ( *, '(a)' ) ' Bad data detected by PGM_CHECK_DATA.' ierror = 6 return end if ! ! Report ! if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMB_READ - Note:' write ( *, '(a)' ) ' The file was read and checked.' write ( *, '(a,i8)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i8)' ) ' Number of data columns NCOL = ', ncol write ( *, '(a,i8)' ) ' Maximum color value MAXCOL = ', maxcol end if return end subroutine pgmb_write ( file_name, ierror, nrow, ncol, g ) !*****************************************************************************80 ! !! PGMB_WRITE writes a binary portable gray map file. ! ! Discussion: ! ! PGM files can be viewed by XV. ! ! A PGM file can also be converted to other formats, by programs: ! ! PGMTOFITS - Flexible Image Transport System file (astronomical data) ! PGMTOFS - Usenix FaceSaver file ! PGMTOLISPM - Lisp Machine file ! PGMTOPBM - Portable Bit Map file ! ! DIRECT ACCESS is used for the output file just so that we can ! avoid the internal carriage returns and things that FORTRAN ! seems to want to add. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 09 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILE_NAME, the name of the file to which ! the data should be written. ! ! Output, integer ( kind = 4 ) IERROR, an error flag. ! 0, no error. ! 1, the data was illegal. ! 2, the file could not be opened. ! ! Input, integer ( kind = 4 ) NROW, NCOL, the number of rows and columns. ! ! Input, integer ( kind = 4 ) G(NROW,NCOL), contains the gray value of each ! pixel. These should be between 0 and 255. ! implicit none integer ( kind = 4 ) ncol integer ( kind = 4 ) nrow logical, parameter :: debug = .false. character ( len = * ) file_name integer ( kind = 4 ) g(nrow,ncol) integer ( kind = 4 ) i integer ( kind = 4 ) i4vec(17) integer ( kind = 4 ) ierror integer ( kind = 4 ) ios integer ( kind = 4 ) j integer ( kind = 4 ) l integer ( kind = 4 ) maxcol integer ( kind = 4 ) nchar integer ( kind = 4 ) nval integer ( kind = 4 ) output_unit integer ( kind = 4 ) record integer ( kind = 4 ) record_length logical, parameter :: reverse = .false. character ( len = 68 ) string ierror = 0 ! ! Compute the maximum gray value. ! maxcol = maxval ( g(1:nrow,1:ncol) ) ! ! Make sure no gray value is above 255. ! if ( 255 < maxcol ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMB_WRITE - Fatal error!' write ( *, '(a)' ) ' The gray data exceeds 255.' write ( *, '(a,i12)' ) ' MAXCOL = ', maxcol ierror = 1 return end if ! ! Check the data. ! call pgm_check_data ( g, ierror, maxcol, ncol, nrow ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMB_WRITE - Fatal error!' write ( *, '(a)' ) ' Bad data detected by PGM_CHECK_DATA!' ierror = 1 return end if ! ! Open the file. ! ! The appropriate value of RECL seems to be bedeviled. ! On the SGI, I used RECL = 4, meaning 4 bytes. ! record_length = 4 ! ! On the Dec Alpha, I may need to use RECL = ?. ! ! record_length = 1 call get_unit ( output_unit ) open ( unit = output_unit, file = file_name, status = 'replace', & form = 'unformatted', access = 'direct', recl = record_length, & iostat = ios ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMB_WRITE - Fatal error!' write ( *, '(a)' ) ' Could not open the file.' ierror = 2 return end if record = 0 ! ! Write the data. ! string = ' ' string(1:4) = 'P5 ' write ( string(5:9), '(i5)' ) ncol string(10:11) = ' ' write ( string(12:16), '(i5)' ) nrow string(17:18) = ' ' write ( string(19:23), '(i5)' ) maxcol string(24:24) = ' ' nchar = 24 do i = 1, nrow do j = 1, ncol if ( nchar == 68 ) then call s_to_i4vec ( string(1:nchar), nval, i4vec, reverse ) do l = 1, nval record = record + 1 write ( output_unit, rec = record ) i4vec(l) end do string = ' ' nchar = 0 end if nchar = nchar + 1 string(nchar:nchar) = char ( g(i,j) ) end do end do if ( 0 < nchar ) then call s_to_i4vec ( string(1:nchar), nval, i4vec, reverse ) do l = 1, nval record = record + 1 write ( output_unit, rec = record ) i4vec(l) end do string = ' ' nchar = 0 end if ! ! Close the file. ! close ( unit = output_unit ) ! ! Report ! if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMB_WRITE - Note:' write ( *, '(a)' ) ' The data was checked and written.' write ( *, '(a,i8)' ) ' Number of words = ', record write ( *, '(a,i8)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i8)' ) ' Number of data columns NCOL = ', ncol write ( *, '(a,i8)' ) ' Maximum color value MAXCOL = ', maxcol end if return end subroutine ppm_check_data ( r, g, b, ierror, maxcol, ncol, nrow ) !*****************************************************************************80 ! !! PPM_CHECK_DATA checks pixel data. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 28 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) R(NROW,NCOL), G(NROW,NCOL), B(NROW,NCOL), ! contains the RGB pixel data. ! ! Output, integer ( kind = 4 ) IERROR, error flag. ! 0, no error detected. ! 1, the data is illegal. ! ! Input, integer ( kind = 4 ) MAXCOL, the maximum value. ! ! Input, integer ( kind = 4 ) NCOL, NROW, the number of rows and columns ! of data. ! implicit none integer ( kind = 4 ) ncol integer ( kind = 4 ) nrow integer ( kind = 4 ) b(nrow,ncol) integer ( kind = 4 ) g(nrow,ncol) integer ( kind = 4 ) i integer ( kind = 4 ) ierror integer ( kind = 4 ) j integer ( kind = 4 ) maxcol integer ( kind = 4 ) r(nrow,ncol) ierror = 0 ! ! Make sure no color is negative. ! if ( minval ( r(1:nrow,1:ncol) ) < 0 .or. & minval ( g(1:nrow,1:ncol) ) < 0 .or. & minval ( b(1:nrow,1:ncol) ) < 0 ) then ierror = 1 return end if ! ! Make sure no color is greater than MAXCOL. ! if ( maxcol < maxval ( r(1:nrow,1:ncol) ) .or. & maxcol < maxval ( g(1:nrow,1:ncol) ) .or. & maxcol < maxval ( b(1:nrow,1:ncol) ) ) then ierror = 1 return end if return end subroutine ppm_example ( nrow, ncol, r, g, b ) !*****************************************************************************80 ! !! PPM_EXAMPLE sets up sample PPM data. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 16 December 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) NROW, NCOL, the number of rows and columns ! of data. A reasonable value is 200 for NROW and 600 for NCOL. ! ! Output, integer ( kind = 4 ) R(NROW,NCOL), G(NROW,NCOL), B(NROW,NCOL), ! the RGB data. ! implicit none integer ( kind = 4 ) ncol integer ( kind = 4 ) nrow integer ( kind = 4 ) b(nrow,ncol) real ( kind = 8 ) f1 real ( kind = 8 ) f2 real ( kind = 8 ) f3 integer ( kind = 4 ) g(nrow,ncol) integer ( kind = 4 ) i integer ( kind = 4 ) j real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 integer ( kind = 4 ) r(nrow,ncol) real ( kind = 8 ) x real ( kind = 8 ) y do i = 1, nrow y = real ( nrow - i, kind = 8 ) / real ( nrow - 1, kind = 8 ) do j = 1, ncol x = real ( j - 1, kind = 8 ) / real ( ncol - 1, kind = 8 ) f1 = 4.0D+00 * ( x - 0.5D+00 )**2 f2 = sin ( pi * x ) f3 = x if ( y <= f1 ) then r(i,j) = int ( 255.0D+00 * f1 ) else r(i,j) = 50 end if if ( y <= f2 ) then g(i,j) = int ( 255.0D+00 * f2 ) else g(i,j) = 150 end if if ( y <= f3 ) then b(i,j) = int ( 255.0D+00 * f3 ) else b(i,j) = 250 end if end do end do return end subroutine ppma_read ( file_name, ierror, maxcol, maxp, nrow, ncol, r, g, b ) !*****************************************************************************80 ! !! PPMA_READ reads an ASCII portable pixel map file. ! ! Discussion: ! ! PPM files can be viewed by XV. ! ! Programs to convert files to this format include: ! ! GIFTOPPM - GIF file ! PGMTOPPM - Portable Gray Map file ! PICTTOPPM - Macintosh PICT file ! XPMTOPPM - X11 pixmap file ! ! Various programs can convert other formats to PPM format, including: ! ! BMPTOPPM - Microsoft Windows BMP file. ! ! A PPM file can also be converted to other formats, by programs: ! ! PPMTOACAD - AutoCAD file ! PPMTOGIF - GIF file ! PPMTOPGM - Portable Gray Map file ! PPMTOPICT - Macintosh PICT file ! PPMTOPUZZ - X11 puzzle file ! PPMTORGB3 - 3 Portable Gray Map files ! PPMTOXPM - X11 pixmap file ! PPMTOYUV - Abekas YUV file ! ! Example: ! ! P3 ! # feep.ppm ! 4 4 ! 15 ! 0 0 0 0 0 0 0 0 0 15 0 15 ! 0 0 0 0 15 7 0 0 0 0 0 0 ! 0 0 0 0 0 0 0 15 7 0 0 0 ! 15 0 15 0 0 0 0 0 0 0 0 0 ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 07 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILE_NAME, the name of the file from which ! the data should be read. ! ! Output, integer ( kind = 4 ) IERROR, an error flag. ! 0, no error occurred. ! 1, the file could not be opened. ! 2, end or error while reading file. ! 3, bad magic number (the first two bytes must be 'P3'). ! 4, trouble reading NROW or NCOL or MAXCOL. ! 5, trouble reading one of the pixel values. ! 6, at least one pixel value was less than 0 or greater than MAXCOL. ! 7, NROW*NCOL exceeds MAXP. ! ! Output, integer ( kind = 4 ) MAXCOL, the maximum pixel color value. ! ! Input, integer ( kind = 4 ) MAXP, the number of entries available in ! R, G and B. If MAXP is smaller than NROW*NCOL, then the data will ! not be read. ! ! Output, integer ( kind = 4 ) NROW, NCOL, the number of rows and columns ! of data. ! ! Output, integer ( kind = 4 ) R(MAXP), contains the NROW by NCOL red data. ! The (I,J) entry is in R( (J-1)*NROW + I ), the usual ! FORTRAN indexing method. ! ! Output, integer ( kind = 4 ) G(MAXP), contains the NROW by NCOL green data. ! The (I,J) entry is in G( (J-1)*NROW + I ), the usual ! FORTRAN indexing method. ! ! Output, integer ( kind = 4 ) B(MAXP), contains the NROW by NCOL blue data. ! The (I,J) entry is in B( (J-1)*NROW + I ), the usual ! FORTRAN indexing method. ! implicit none integer ( kind = 4 ) maxp integer ( kind = 4 ) b(maxp) logical, parameter :: debug = .false. logical done character ( len = * ) file_name integer ( kind = 4 ) g(maxp) integer ( kind = 4 ) i integer ( kind = 4 ) ierror integer ( kind = 4 ) file_unit integer ( kind = 4 ) ios integer ( kind = 4 ) j integer ( kind = 4 ) k character ( len = 2 ) magic integer ( kind = 4 ) maxcol integer ( kind = 4 ) ncol integer ( kind = 4 ) nrow integer ( kind = 4 ) r(maxp) logical s_eqi character ( len = 80 ) string ierror = 0 maxcol = 0 ncol = 0 nrow = 0 ! ! Open the file. ! call get_unit ( file_unit ) open ( unit = file_unit, file = file_name, status = 'old', & form = 'formatted', access = 'sequential', iostat = ios ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMA_READ - Fatal error!' write ( *, '(a)' ) ' Could not open the file.' ierror = 1 return end if ! ! Read the first line of data, which must begin with the magic number. ! read ( file_unit, '(a)', iostat = ios ) magic if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMA_READ - Fatal error!' write ( *, '(a)' ) ' End or error while reading file.' ierror = 2 return end if if ( .not. s_eqi ( magic, 'P3' ) ) then ierror = 3 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMA_READ - Fatal error.' write ( *, '(a)' ) ' First two bytes are not magic number "P3".' write ( *, '(a)' ) ' First two bytes are: ' // magic return end if ! ! Now search for NCOL, NROW, and MAXCOL. ! done = .TRUE. string = ' ' call getint ( done, ierror, file_unit, ncol, string ) if ( ierror /= 0 ) then close ( unit = file_unit ) ierror = 4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMA_READ - Fatal error!' write ( *, '(a)' ) ' Problem reading NCOL.' return end if call getint ( done, ierror, file_unit, nrow, string ) if ( ierror /= 0 ) then ierror = 4 close ( unit = file_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMA_READ - Fatal error!' write ( *, '(a)' ) ' Problem reading NROW.' return end if call getint ( done, ierror, file_unit, maxcol, string ) if ( ierror /= 0 ) then ierror = 4 close ( unit = file_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMA_READ - Fatal error!' write ( *, '(a)' ) ' Problem reading MAXCOL.' return end if ! ! Check that there is enough room. ! if ( maxp < nrow * ncol ) then ierror = 7 close ( unit = file_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMA_READ - Fatal error!' write ( *, '(a,i12)' ) ' Needed NROW*NCOL = ', nrow * ncol write ( *, '(a,i12)' ) ' Available MAXP = ', maxp return end if ! ! Now read the pixel data. ! k = 0 do i = 1, nrow do j = 1, ncol k = ( j - 1 ) * nrow + i call getint ( done, ierror, file_unit, r(k), string ) if ( ierror /= 0 ) then ierror = 5 close ( unit = file_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMA_READ - Fatal error!' write ( *, '(a)' ) ' Problem reading R data.' return end if call getint ( done, ierror, file_unit, g(k), string ) if ( ierror /= 0 ) then ierror = 5 close ( unit = file_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMA_READ - Fatal error!' write ( *, '(a)' ) ' Problem reading G data.' return end if call getint ( done, ierror, file_unit, b(k), string ) if ( ierror /= 0 ) then ierror = 5 close ( unit = file_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMA_READ - Fatal error!' write ( *, '(a)' ) ' Problem reading B data.' return end if end do end do ! ! Close the file. ! close ( unit = file_unit ) ! ! Check the data. ! call ppm_check_data ( r, g, b, ierror, maxcol, ncol, nrow ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMA_READ - Fatal error!' write ( *, '(a)' ) ' Bad data detected by PPM_CHECK_DATA.' ierror = 6 return end if ! ! Report ! if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMA_READ - Note:' write ( *, '(a)' ) ' The file was read and checked.' write ( *, '(a,i8)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i8)' ) ' Number of data columns NCOL = ', ncol write ( *, '(a,i8)' ) ' Maximum color value MAXCOL = ', maxcol end if return end subroutine ppma_write ( file_name, ierror, nrow, ncol, r, g, b ) !*****************************************************************************80 ! !! PPMA_WRITE writes an ASCII portable pixel map file. ! ! Discussion: ! ! PPM files can be viewed by XV. ! ! Programs to convert files to this format include: ! ! GIFTOPPM - GIF file ! PGMTOPPM - Portable Gray Map file ! PICTTOPPM - Macintosh PICT file ! XPMTOPPM - X11 pixmap file ! ! Various programs can convert other formats to PPM format, including: ! ! BMPTOPPM - Microsoft Windows BMP file. ! ! A PPM file can also be converted to other formats, by programs: ! ! PPMTOACAD - AutoCAD file ! PPMTOGIF - GIF file ! PPMTOPGM - Portable Gray Map file ! PPMTOPICT - Macintosh PICT file ! PPMTOPUZZ - X11 puzzle file ! PPMTORGB3 - 3 Portable Gray Map files ! PPMTOXPM - X11 pixmap file ! PPMTOYUV - Abekas YUV file ! ! Example: ! ! P3 ! # feep.ppma created by PBMLIB(PPMA_WRITE). ! 4 4 ! 15 ! 0 0 0 0 0 0 0 0 0 15 0 15 ! 0 0 0 0 15 7 0 0 0 0 0 0 ! 0 0 0 0 0 0 0 15 7 0 0 0 ! 15 0 15 0 0 0 0 0 0 0 0 0 ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 07 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILE_NAME, the name of the file to which ! the data should be written. ! ! Output, integer ( kind = 4 ) IERROR, an error flag. ! 0, no error. ! 1, the data was illegal. ! 2, the file could not be opened. ! ! Input, integer ( kind = 4 ) NROW, NCOL, the number of rows and columns. ! ! Input, integer ( kind = 4 ) R(NROW,NCOL), G(NROW,NCOL), B(NROW,NCOL), ! contain the red, green and blue values of each pixel. These should ! be positive. ! implicit none integer ( kind = 4 ) ncol integer ( kind = 4 ) nrow integer ( kind = 4 ) b(nrow,ncol) logical, parameter :: debug = .false. character ( len = * ) file_name integer ( kind = 4 ) g(nrow,ncol) integer ( kind = 4 ) i integer ( kind = 4 ) ierror integer ( kind = 4 ) ios integer ( kind = 4 ) j integer ( kind = 4 ) jhi integer ( kind = 4 ) jlo character ( len = 2 ) magic integer ( kind = 4 ) maxcol integer ( kind = 4 ) output_unit integer ( kind = 4 ) r(nrow,ncol) ierror = 0 ! ! Compute the maximum color value. ! maxcol = max ( & maxval ( r(1:nrow,1:ncol) ), & maxval ( g(1:nrow,1:ncol) ), & maxval ( b(1:nrow,1:ncol) ) ) ! ! Check the data. ! call ppm_check_data ( r, g, b, ierror, maxcol, ncol, nrow ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMA_WRITE - Fatal error!' write ( *, '(a)' ) ' Bad data detected by PPM_CHECK_DATA!' ierror = 1 return end if ! ! Open the file. ! call get_unit ( output_unit ) open ( unit = output_unit, file = file_name, status = 'replace', & form = 'formatted', access = 'sequential', iostat = ios ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMA_WRITE - Fatal error!' write ( *, '(a)' ) ' Could not open the file.' ierror = 2 return end if ! ! Write the data. ! magic = 'P3' write ( output_unit, '(a2)' ) magic write ( output_unit, '(a)' ) '# ' // trim ( file_name ) & // ' created by PPMLIB(PPMA_WRITE).' write ( output_unit, '(i5,2x,i5)' ) ncol, nrow write ( output_unit, '(i5)' ) maxcol do i = 1, nrow do jlo = 1, ncol, 4 jhi = min ( jlo + 3, ncol ) write ( output_unit, '(12i5)' ) ( r(i,j), g(i,j), b(i,j), j = jlo, jhi ) end do end do ! ! Close the file. ! close ( unit = output_unit ) ! ! Report ! if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMA_WRITE - Note:' write ( *, '(a)' ) ' The data was checked and written.' write ( *, '(a,i8)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i8)' ) ' Number of data columns NCOL = ', ncol write ( *, '(a,i8)' ) ' Maximum color value MAXCOL = ', maxcol end if return end subroutine ppmb_read ( file_name, ierror, maxcol, maxg, nrow, ncol, r, g, b ) !*****************************************************************************80 ! !! PPMB_READ reads a binary portable pixel map file. ! ! Discussion: ! ! PPM files can be viewed by XV. ! ! Programs to convert files to this format include: ! ! GIFTOPPM - GIF file ! PGMTOPPM - Portable Gray Map file ! PICTTOPPM - Macintosh PICT file ! XPMTOPPM - X11 pixmap file ! ! Various programs can convert other formats to PPM format, including: ! ! BMPTOPPM - Microsoft Windows BMP file. ! ! A PPM file can also be converted to other formats, by programs: ! ! PPMTOACAD - AutoCAD file ! PPMTOGIF - GIF file ! PPMTOPGM - Portable Gray Map file ! PPMTOPICT - Macintosh PICT file ! PPMTOPUZZ - X11 puzzle file ! PPMTORGB3 - 3 Portable Gray Map files ! PPMTOXPM - X11 pixmap file ! PPMTOYUV - Abekas YUV file ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 07 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILE_NAME, the name of the file to be read. ! ! Output, integer ( kind = 4 ) IERROR, an error flag. ! 0, no error occurred. ! 1, the file could not be opened. ! 2, end or error while reading file. ! 3, bad magic number (the first two bytes must be 'P6'). ! 4, trouble reading NROW or NCOL or MAXCOL. ! 5, trouble reading one of the pixel values. ! 6, at least one pixel value was less than 0 or greater than MAXCOL. ! 7, NROW*NCOL exceeds MAXG. ! ! Output, integer ( kind = 4 ) MAXCOL, the maximum pixel value. ! ! Input, integer ( kind = 4 ) MAXG, the number of entries available in ! R, G and B. If MAXG is smaller than NROW*NCOL, then the data will ! not be read. ! ! Output, integer ( kind = 4 ) NROW, NCOL, the number of rows and columns. ! ! Output, integer ( kind = 4 ) R(MAXG), G(MAXG), B(MAXG), contains the NROW ! by NCOL pixel data. The (I,J) entry is in entry ( (J-1)*NROW + I ), the ! usual FORTRAN indexing method. ! implicit none integer ( kind = 4 ) maxg integer ( kind = 4 ) b(maxg) logical, parameter :: debug = .false. character ( len = * ) file_name integer ( kind = 4 ) file_unit integer ( kind = 4 ) g(maxg) integer ( kind = 4 ) i integer ( kind = 4 ) i4vec(17) integer ( kind = 4 ) ierror integer ( kind = 4 ) ios integer ( kind = 4 ) ival integer ( kind = 4 ) j integer ( kind = 4 ) k integer ( kind = 4 ) last character ( len = 2 ) magic integer ( kind = 4 ) maxcol integer ( kind = 4 ) nchar integer ( kind = 4 ) nchar2 integer ( kind = 4 ) ncol integer ( kind = 4 ) nrow integer ( kind = 4 ) nval integer ( kind = 4 ) r(maxg) integer ( kind = 4 ) record integer ( kind = 4 ) record_length logical, parameter :: reverse = .false. character ( len = 68 ) string ierror = 0 maxcol = 0 ncol = 0 nrow = 0 ! ! Open the file. ! ! The smallest amount of information we can write at a time is ! 1 word = 4 bytes = 32 bits. ! call get_unit ( file_unit ) ! ! For the SGI: ! record_length = 4 ! ! For the DEC Alpha: ! ! record_length = 1 open ( unit = file_unit, file = file_name, status = 'old', & form = 'unformatted', access = 'direct', recl = record_length, & iostat = ios ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMB_READ - Fatal error!' write ( *, '(a)' ) ' Could not open the file.' ierror = 1 return end if record = 0 ! ! Read the data. ! nval = 17 do i = 1, nval record = record + 1 read ( file_unit, rec = record ) i4vec(i) end do call i4vec_to_s ( nval, i4vec, string, reverse ) nchar = 4 * nval ! ! The first two bytes must be the magic number 'P6'. ! magic = string(1:2) if ( magic /= 'P6' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMB_READ - Fatal error!' write ( *, '(a)' ) ' First two bytes are not magic number "P6".' write ( *, '(a)' ) ' First two bytes are: ' // string(1:2) write ( *, '(a,2i8)' ) ' ASCII codes: ', ichar ( string(1:1) ), & ichar ( string(2:2) ) ierror = 3 return end if call s_chop ( string, 1, 2 ) nchar = nchar - 2 ! ! Now search for NCOL, NROW and MAXCOL. ! call s_to_i4 ( string, ncol, ierror, last ) call s_chop ( string, 1, last ) nchar = nchar - last call s_to_i4 ( string, nrow, ierror, last ) call s_chop ( string, 1, last ) nchar = nchar - last call s_to_i4 ( string, maxcol, ierror, last ) call s_chop ( string, 1, last ) nchar = nchar - last ! ! Now skip a single byte. ! call s_chop ( string, 1, 1 ) nchar = nchar - 1 ! ! Check that there is enough room. ! if ( maxg < nrow * ncol ) then ierror = 7 close ( unit = file_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMB_READ - Fatal error!' write ( *, '(a,i12)' ) ' Needed NROW*NCOL = ', nrow * ncol write ( *, '(a,i12)' ) ' Available MAXG = ', maxg return end if ! ! Now each successive byte is a pixel data value. ! k = 0 do i = 1, nrow do j = 1, ncol k = k + 1 if ( nchar < 1 ) then record = record + 1 read ( file_unit, rec = record ) i4vec(1) call i4vec_to_s ( 1, i4vec, string(nchar+1:nchar+4), reverse ) nchar2 = 4 nchar = nchar + 4 end if ival = ichar ( string(1:1) ) call s_chop ( string, 1, 1 ) nchar = nchar - 1 r(k) = ival if ( nchar < 1 ) then record = record + 1 read ( file_unit, rec = record ) i4vec(1) call i4vec_to_s ( 1, i4vec, string(nchar+1:nchar+4), reverse ) nchar2 = 4 nchar = nchar + 4 end if ival = ichar ( string(1:1) ) call s_chop ( string, 1, 1 ) nchar = nchar - 1 g(k) = ival if ( nchar < 1 ) then record = record + 1 read ( file_unit, rec = record ) i4vec(1) call i4vec_to_s ( 1, i4vec, string(nchar+1:nchar+4), reverse ) nchar2 = 4 nchar = nchar + 4 end if ival = ichar ( string(1:1) ) call s_chop ( string, 1, 1 ) nchar = nchar - 1 b(k) = ival end do end do ! ! Close the file. ! close ( unit = file_unit ) ! ! Check the data. ! call ppm_check_data ( r, g, b, ierror, maxcol, ncol, nrow ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMB_READ - Fatal error!' write ( *, '(a)' ) ' Bad data detected by PPM_CHECK_DATA.' ierror = 6 return end if ! ! Report ! if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMB_READ - Note:' write ( *, '(a)' ) ' The file was read and checked.' write ( *, '(a,i8)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i8)' ) ' Number of data columns NCOL = ', ncol write ( *, '(a,i8)' ) ' Maximum color value MAXCOL = ', maxcol end if return end subroutine ppmb_write ( file_name, ierror, nrow, ncol, r, g, b ) !*****************************************************************************80 ! !! PPMB_WRITE writes a binary portable pixel map file. ! ! Discussion: ! ! PPM files can be viewed by XV. ! ! Various programs can convert other formats to PPM format, including: ! ! BMPTOPPM - Microsoft Windows BMP file. ! ! A PPM file can also be converted to other formats, by programs: ! ! PPMTOACAD - AutoCAD file ! PPMTOGIF - GIF file ! PPMTOPGM - Portable Gray Map file ! PPMTOPICT - Macintosh PICT file ! PPMTORGB3 - 3 Portable Gray Map files ! PPMTOXPM - X11 pixmap file ! PPMTOYUV - Abekas YUV file ! ! DIRECT ACCESS is used for the output file just so that we can ! avoid the internal carriage returns and things that FORTRAN ! seems to want to add. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 07 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILE_NAME, the name of the file to which ! the data should be written. ! ! Output, integer ( kind = 4 ) IERROR, an error flag. ! 0, no error. ! 1, the data was illegal. ! 2, the file could not be opened. ! ! Input, integer ( kind = 4 ) NROW, NCOL, the number of rows and columns. ! ! Input, integer ( kind = 4 ) R(NROW,NCOL), G(NROW,NCOL), B(NROW,NCOL), ! contain the red, green and blue values of each pixel. These should all ! be values between 0 and 255. ! implicit none integer ( kind = 4 ) ncol integer ( kind = 4 ) nrow integer ( kind = 4 ) b(nrow,ncol) logical, parameter :: debug = .false. character ( len = * ) file_name integer ( kind = 4 ) g(nrow,ncol) integer ( kind = 4 ) i integer ( kind = 4 ) i4vec(17) integer ( kind = 4 ) ierror integer ( kind = 4 ) ios integer ( kind = 4 ) j integer ( kind = 4 ) l integer ( kind = 4 ) maxcol integer ( kind = 4 ) nchar integer ( kind = 4 ) nval integer ( kind = 4 ) output_unit integer ( kind = 4 ) r(nrow,ncol) integer ( kind = 4 ) record integer ( kind = 4 ) record_length logical, parameter :: reverse = .false. character ( len = 68 ) string ierror = 0 ! ! Compute the maximum color value. ! maxcol = max ( & maxval ( r(1:nrow,1:ncol) ), & maxval ( g(1:nrow,1:ncol) ), & maxval ( b(1:nrow,1:ncol) ) ) ! ! Check that no color data exceeds 255. ! if ( 255 < maxcol ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMB_WRITE - Fatal error!' write ( *, '(a)' ) ' The color data exceeds 255!' write ( *, '(a,i12)' ) ' MAXCOL = ', maxcol ierror = 1 return end if ! ! Check the data. ! call ppm_check_data ( r, g, b, ierror, maxcol, ncol, nrow ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMB_WRITE - Fatal error!' write ( *, '(a)' ) ' Bad data detected by PPM_CHECK_DATA!' ierror = 1 return end if ! ! Open the file. ! ! The smallest amount of information we can write at a time is ! 1 word = 4 bytes = 32 bits. ! call get_unit ( output_unit ) ! ! For the SGI: ! record_length = 4 ! ! For the DEC Alpha: ! ! record_length = 1 open ( unit = output_unit, file = file_name, status = 'replace', & form = 'unformatted', access = 'direct', recl = record_length, & iostat = ios ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMB_WRITE - Fatal error!' write ( *, '(a)' ) ' Could not open the file.' ierror = 2 return end if record = 0 ! ! Write the data. ! string = ' ' string(1:4) = 'P6 ' write ( string(5:9), '(i5)' ) ncol string(10:11) = ' ' write ( string(12:16), '(i5)' ) nrow string(17:18) = ' ' write ( string(19:23), '(i5)' ) maxcol string(24:24) = ' ' nchar = 24 do i = 1, nrow do j = 1, ncol if ( nchar == 68 ) then call s_to_i4vec ( string(1:nchar), nval, i4vec, reverse ) do l = 1, nval record = record + 1 write ( output_unit, rec = record ) i4vec(l) end do string = ' ' nchar = 0 end if nchar = nchar + 1 string(nchar:nchar) = char ( r(i,j) ) if ( nchar == 68 ) then call s_to_i4vec ( string(1:nchar), nval, i4vec, reverse ) do l = 1, nval record = record + 1 write ( output_unit, rec = record ) i4vec(l) end do string = ' ' nchar = 0 end if nchar = nchar + 1 string(nchar:nchar) = char ( g(i,j) ) if ( nchar == 68 ) then call s_to_i4vec ( string(1:nchar), nval, i4vec, reverse ) do l = 1, nval record = record + 1 write ( output_unit, rec = record ) i4vec(l) end do string = ' ' nchar = 0 end if nchar = nchar + 1 string(nchar:nchar) = char ( b(i,j) ) end do end do if ( 0 < nchar ) then call s_to_i4vec ( string(1:nchar), nval, i4vec, reverse ) do l = 1, nval record = record + 1 write ( output_unit, rec = record ) i4vec(l) end do string = ' ' nchar = 0 end if ! ! Close the file. ! close ( unit = output_unit ) ! ! Report ! if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMB_WRITE - Note:' write ( *, '(a)' ) ' The data was checked and written.' write ( *, '(a,i8)' ) ' Number of words = ', record write ( *, '(a,i8)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i8)' ) ' Number of data columns NCOL = ', ncol write ( *, '(a,i8)' ) ' Maximum color value MAXCOL = ', maxcol end if return end subroutine rt_to_xy ( r, t, x, y ) !*****************************************************************************80 ! !! RT_TO_XY converts polar coordinates to XY coordinates. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 12 April 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) R, T, the radius and angle (in radians). ! ! Output, real ( kind = 8 ) X, Y, the Cartesian coordinates. ! implicit none real ( kind = 8 ) r real ( kind = 8 ) t real ( kind = 8 ) x real ( kind = 8 ) y x = r * cos ( t ) y = r * sin ( t ) return end subroutine s_blanks_delete ( s ) !*****************************************************************************80 ! !! S_BLANKS_DELETE replaces consecutive blanks by one blank. ! ! Discussion: ! ! The remaining characters are left justified and right padded with blanks. ! TAB characters are converted to spaces. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 26 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! implicit none integer ( kind = 4 ) i integer ( kind = 4 ) j character newchr character oldchr character ( len = * ) s character, parameter :: TAB = char ( 9 ) j = 0 newchr = ' ' do i = 1, len ( s ) oldchr = newchr newchr = s(i:i) if ( newchr == TAB ) then newchr = ' ' end if s(i:i) = ' ' if ( oldchr /= ' ' .or. newchr /= ' ' ) then j = j + 1 s(j:j) = newchr end if end do return end subroutine s_chop ( s, ilo, ihi ) !*****************************************************************************80 ! !! S_CHOP "chops out" a portion of a string, and closes up the hole. ! ! Example: ! ! S = 'Fred is not a jerk!' ! ! call s_chop ( S, 9, 12 ) ! ! S = 'Fred is a jerk! ' ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 06 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! ! Input, integer ( kind = 4 ) ILO, IHI, the locations of the first and last ! characters to be removed. ! implicit none integer ( kind = 4 ) ihi integer ( kind = 4 ) ihi2 integer ( kind = 4 ) ilo integer ( kind = 4 ) ilo2 integer ( kind = 4 ) lens character ( len = * ) s lens = len ( s ) ilo2 = max ( ilo, 1 ) ihi2 = min ( ihi, lens ) if ( ihi2 < ilo2 ) then return end if s(ilo2:lens+ilo2-ihi2-1) = s(ihi2+1:lens) s(lens+ilo2-ihi2:lens) = ' ' return end function s_eqi ( strng1, strng2 ) !*****************************************************************************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 = * ) STRNG1, STRNG2, the strings to compare. ! ! Output, logical S_EQI, the result of the comparison. ! implicit none integer ( kind = 4 ) i integer ( kind = 4 ) len1 integer ( kind = 4 ) len2 integer ( kind = 4 ) lenc logical s_eqi character s1 character s2 character ( len = * ) strng1 character ( len = * ) strng2 len1 = len ( strng1 ) len2 = len ( strng2 ) lenc = min ( len1, len2 ) s_eqi = .false. do i = 1, lenc s1 = strng1(i:i) s2 = strng2(i:i) call ch_cap ( s1 ) call ch_cap ( s2 ) if ( s1 /= s2 ) then return end if end do do i = lenc + 1, len1 if ( strng1(i:i) /= ' ' ) then return end if end do do i = lenc + 1, len2 if ( strng2(i:i) /= ' ' ) then return end if end do s_eqi = .true. return end subroutine s_to_i4 ( s, ival, ierror, last ) !*****************************************************************************80 ! !! S_TO_I4 reads an I4 from a string. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 28 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string to be examined. ! ! Output, integer ( kind = 4 ) IVAL, the value read from the string. ! If blank, then IVAL will be returned 0. ! ! Output, integer ( kind = 4 ) IERROR, an error flag. ! 0, no error. ! 1, an error occurred. ! ! Output, integer ( kind = 4 ) LAST, the last character that was ! part of the representation of IVAL. ! implicit none character c integer ( kind = 4 ) i integer ( kind = 4 ) ierror integer ( kind = 4 ) isgn integer ( kind = 4 ) istate integer ( kind = 4 ) ival integer ( kind = 4 ) last integer ( kind = 4 ) lens character ( len = * ) s ierror = 0 istate = 0 isgn = 1 ival = 0 lens = len ( s ) i = 0 do i = i + 1 c = s(i:i) if ( istate == 0 ) then if ( c == ' ' ) then else if ( c == '-' ) then istate = 1 isgn = -1 else if ( c == '+' ) then istate = 1 isgn = + 1 else if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then istate = 2 ival = ichar ( c ) - ichar ( '0' ) else ierror = 1 exit end if else if ( istate == 1 ) then if ( c == ' ' ) then else if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then istate = 2 ival = ichar ( c ) - ichar ( '0' ) else ierror = 1 exit end if else if ( istate == 2 ) then if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then ival = 10 * ival + ichar ( c ) - ichar ( '0' ) else istate = 3 end if end if ! ! Continue or exit? ! if ( istate == 3 ) then ival = isgn * ival last = i - 1 exit else if ( lens <= i ) then if ( istate == 2 ) then ival = isgn * ival last = lens else ierror = 1 last = 0 end if exit end if end do return end subroutine s_to_i4vec ( s, n, i4vec, reverse ) !*****************************************************************************80 ! !! S_TO_I4VEC converts an string of characters into an I4VEC. ! ! Discussion: ! ! This routine can be useful when trying to write character data to an ! unformatted direct access file. ! ! Depending on the internal byte ordering used on a particular machine, ! the parameter REVERSE_ORDER may need to be set TRUE or FALSE. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 29 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string of characters. ! Each set of 4 characters is assumed to represent an integer. ! ! Output, integer ( kind = 4 ) N, the number of integers read ! from the string. ! ! Output, integer ( kind = 4 ) ( kind = 4 ) I4VEC(N), the integers read ! from S. ! ! Input, logical REVERSE, is TRUE if the bytes in a word need to be ! reversed. ! implicit none integer ( kind = 4 ) from integer ( kind = 4 ) frompos integer ( kind = 4 ) ihi integer ( kind = 4 ) ilo integer ( kind = 4 ) i4vec(*) integer ( kind = 4 ) j integer ( kind = 4 ), parameter :: length = 8 integer ( kind = 4 ) n integer ( kind = 4 ) nchar logical reverse character ( len = * ) s integer ( kind = 4 ) to integer ( kind = 4 ) topos nchar = len ( s ) n = 0 frompos = 0 do ilo = 1, nchar, 4 n = n + 1 ihi = min ( ilo + 3, nchar ) to = 0 do j = ilo, ihi from = ichar ( s(j:j) ) if ( reverse ) then topos = length * ( j - ilo ) else topos = length * ( ilo + 3 - j ) end if call mvbits ( from, frompos, length, to, topos ) end do i4vec(n) = to end do return end subroutine timestamp ( ) !*****************************************************************************80 ! !! TIMESTAMP prints the current YMDHMS date as a time stamp. ! ! Example: ! ! May 31 2001 9:45:54.872 AM ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 31 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none character ( len = 8 ) ampm integer ( kind = 4 ) d character ( len = 8 ) date integer ( kind = 4 ) h integer ( kind = 4 ) m integer ( kind = 4 ) mm character ( len = 9 ), parameter, dimension(12) :: month = (/ & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' /) integer ( kind = 4 ) n integer ( kind = 4 ) s character ( len = 10 ) time integer ( kind = 4 ) values(8) integer ( kind = 4 ) 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 ( *, '(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 subroutine word_next_rd ( line, word, done ) !*****************************************************************************80 ! !! WORD_NEXT_RD "reads" words from a string, one at a time. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 18 December 2008 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) LINE, a string, presumably containing ! words separated by spaces. ! ! Output, character ( len = * ) WORD. ! ! If DONE is FALSE, ! WORD contains the "next" word read from LINE. ! Else ! WORD is blank. ! ! Input/output, logical DONE. ! ! On input, on the first call, or with a fresh value of LINE, ! set DONE to TRUE. ! Else ! leave it at the output value of the previous call. ! ! On output, if a new nonblank word was extracted from LINE ! DONE is FALSE ! ELSE ! DONE is TRUE. ! ! If DONE is TRUE, then you need to provide a new LINE of data. ! ! Local Parameters: ! ! NEXT is the next location in LINE that should be searched. ! implicit none logical done integer ( kind = 4 ) ilo integer ( kind = 4 ) lenl character ( len = * ) line integer ( kind = 4 ), save :: next = 1 character ( len = 1 ), parameter :: TAB = char(9) character ( len = * ) word lenl = len_trim ( line ) if ( done ) then next = 1 done = .false. end if ! ! Beginning at index NEXT, search LINE for the next nonblank. ! ilo = next do ! ! ...LINE(NEXT:LENL) is blank. Return with WORD=' ', and DONE=TRUE. ! if ( lenl < ilo ) then word = ' ' done = .true. next = lenl + 1 return end if ! ! ...If the current character is blank, skip to the next one. ! if ( line(ilo:ilo) /= ' ' .and. line(ilo:ilo) /= TAB ) then exit end if ilo = ilo + 1 end do ! ! To get here, ILO must be the index of the nonblank starting ! character of the next word. ! ! Now search for the LAST nonblank character. ! next = ilo + 1 do if ( lenl < next ) then word = line(ilo:next-1) return end if if ( line(next:next) == ' ' .or. line(next:next) == TAB ) then exit end if next = next + 1 end do word = line(ilo:next-1) return end