subroutine bitchr75 ( c, pattern ) ! !******************************************************************************* ! !! BITCHR75 returns a 7 by 5 bit pattern for a given character. ! ! ! Modified: ! ! 28 May 1999 ! ! 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 ! ! Comment: ! ! The data statements used here were generated by FONT_DATA. ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, a character whose bit pattern is desired. ! ! Output, integer PATTERN(7,5), the bit pattern for the character, ! which will be all 0's if the character is not available. ! implicit none ! integer bits(7,5,68) character c integer i integer indx integer ipoint(0:255) integer j integer k integer 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 ) ! !******************************************************************************* ! !! CH_CAP capitalizes a single character. ! ! ! Modified: ! ! 19 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character C, the character to capitalize. ! implicit none ! character c integer itemp ! itemp = ichar ( c ) if ( 97 <= itemp .and. itemp <= 122 ) then c = char ( itemp - 32 ) end if return end subroutine font_data ( bits, ipoint, maxchar, maxcol, maxrow, nchar ) ! !******************************************************************************* ! !! FONT_DATA prints out a FORTRAN DATA version of a simple bit map font. ! ! ! Modified: ! ! 17 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer BITS(MAXROW,MAXCOL,MAXCHAR). The J-th character ! read in is described in the entries BITS(*,*,J). ! ! Input, integer 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 MAXCHAR, the maximum number of characters that ! the user has set aside storage for. ! ! Input, integer MAXCOL, MAXROW, the maximum number of columns ! and rows of pixels that an individual character is allowed to use. ! ! Input, integer NCHAR, the number of characters stored. ! implicit none ! integer maxchar integer maxcol integer maxrow ! integer bits(maxrow,maxcol,maxchar) character ( len = 6 ) c1 character ( len = 6 ) c2 character ( len = 6 ) c3 integer i integer ilo integer ipoint(0:255) integer j integer k integer lenc integer 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, 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, '(i6)' ) maxrow write ( c2, '(i6)' ) maxcol write ( c3, '(i6)' ) nchar text = 'integer bits(' // c1 // ',' // c2 // ',' // c3 // ')' call s_blanks_delete ( text ) write ( *, '(2x,a)' ) trim ( text ) do k = 1, nchar write ( *, '(a)' ) ' ' write ( c1, '(i6)' ) k write ( c2, '(i6)' ) maxrow write ( c3, '(i6)' ) 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 ) ! !******************************************************************************* ! !! FONT_PRINT prints out a text version of a simple bit map font. ! ! ! Modified: ! ! 15 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer BITS(MAXROW,MAXCOL,MAXCHAR). The J-th character ! read in is described in the entries BITS(*,*,J). ! ! Input, integer 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 MAXCHAR, the maximum number of characters that ! the user has set aside storage for. ! ! Input, integer MAXCOL, MAXROW, the maximum number of columns ! and rows of pixels that an individual character is allowed to use. ! implicit none ! integer maxchar integer maxcol integer maxrow ! integer bits(maxrow,maxcol,maxchar) integer i integer indx integer ipoint(0:255) integer irow integer 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,i6)' ) '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 ) ! !******************************************************************************* ! !! FONT_READ reads simple ASCII data defining a bit map font. ! ! ! Examples: ! ! 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) ! ! Modified: ! ! 12 April 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer BITS(MAXROW,MAXCOL,MAXCHAR). The J-th character ! read in is described in the entries BITS(*,*,J). ! ! Output, integer IERROR, error flag. ! 0, no error occurred. ! nonzero, an error occurred. ! ! Input, integer 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 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 MAXCHAR, the maximum number of characters that ! the user has set aside storage for. ! ! Input, integer MAXCOL, MAXROW, the maximum number of columns ! and rows of pixels that an individual character is allowed to use. ! ! Output, integer NCHAR, the number of distinct characters that ! were defined by the input file. ! implicit none ! integer maxchar integer maxcol integer maxrow ! integer bits(maxrow,maxcol,maxchar) character chr logical debug logical done integer i integer ichr integer icol integer ierror integer inunit integer ios integer ipoint(0:255) integer irow integer j integer k integer lenc integer nchar integer ntext character ( len = 80 ) text ! ! Initialize. ! ierror = 0 debug = .false. done = .true. nchar = 0 ntext = 0 ipoint(0:maxchar) = 0 do i = 1, maxrow do j = 1, maxcol do k = 1, maxchar bits(i,j,k) = 0 end do end do end do ! ! 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. exit 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 nchar = nchar + 1 chr = text(1:1) ichr = ichar ( chr ) ipoint(ichr) = nchar irow = 0 done = .false. else ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FONT_READ - Fatal error!' write ( *, '(a)' ) ' Bad line!' write ( *, '(a)' ) ' Expecting a single nonblank character.' write ( *, '(a,i6)' ) ' Line number is ', ntext write ( *, '(a,i6)' ) ' 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,i6)' ) ' Text lines ', ntext write ( *, '(a,i6)' ) ' Character definitions: ', nchar end if return end subroutine getint ( done, ierror, inunit, ival, string ) ! !******************************************************************************* ! !! 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. ! ! 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 IERROR, error flag. ! 0, no error occurred. ! 1, an error occurred while trying to read the integer. ! ! Input, integer INUNIT, the FORTRAN unit from which to read. ! ! Output, integer IVAL, the integer that was read. ! ! Input/output, character ( len = * ) STRING, the text of the most recently ! read line of the file. ! implicit none ! logical done integer i integer ierror integer inunit integer ios integer ival 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 read ( word, '(i10)' ) ival return end subroutine get_unit ( iunit ) ! !******************************************************************************* ! !! GET_UNIT returns a free FORTRAN unit number. ! ! ! Discussion: ! ! A "free" FORTRAN unit number is an integer 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. ! ! Modified: ! ! 02 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer IUNIT. ! ! If IUNIT = 0, then no free FORTRAN unit could be found, although ! all 99 units were checked (except for units 5 and 6). ! ! Otherwise, IUNIT is an integer 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. ! implicit none ! integer i integer ios integer iunit logical lopen iunit = 0 do i = 1, 99 if ( i /= 5 .and. i /= 6 ) 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 ivec_to_s ( n, ivec, s ) ! !******************************************************************************* ! !! IVEC_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. ! ! Modified: ! ! 29 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of integers. ! ! Input, integer IVEC(N), the integers. ! ! Output, character ( len = * ) S, a string of 4 * N characters ! representing the integer information. ! implicit none ! integer n ! integer i integer ilo integer ivec(n) character ( len = * ) s ! do i = 1, n ilo = 4 * ( i - 1 ) + 1 write ( s(ilo:ilo+3), '(a4)' ) ivec(i) end do return end subroutine pbm_check_data ( b, ierror, ncol, nrow ) ! !******************************************************************************* ! !! PBM_CHECK_DATA checks bit data. ! ! ! Modified: ! ! 28 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer B(NROW,NCOL), contains the bit data. ! ! Output, integer IERROR, error flag. ! 0, no error detected. ! 1, the data is illegal. ! ! Input, integer NCOL, NROW, the number of rows and columns of data. ! implicit none ! integer ncol integer nrow ! integer b(nrow,ncol) integer i integer ierror integer 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,i6,a,i6,a,i6)' ) ' B(', i, ',', j, ')=', b(i,j) return end if end do end do return end subroutine pbma_read ( filename, ierror, maxb, nrow, ncol, b ) ! !******************************************************************************* ! !! 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 ! ! Modified: ! ! 07 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILENAME, the name of the file from which ! the data should be read. ! ! Output, integer 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 MAXB, the number of entries available in B. ! If MAXB is smaller than NROW*NCOL, then the data will not be read. ! ! Output, integer NROW, NCOL, the number of rows and columns of data. ! ! Output, integer 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 maxb ! integer b(maxb) logical debug logical done character ( len = * ) filename integer i integer ierror integer input_unit integer ios integer j integer k integer ncol integer none integer nrow integer nzero logical s_eqi character ( len = 70 ) string ! debug = .false. ierror = 0 ncol = 0 none = 0 nrow = 0 nzero = 0 ! ! Open the file. ! call get_unit ( input_unit ) open ( unit = input_unit, file = filename, 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 first line of data, which must begin with the magic number. ! read ( input_unit, '(a)', iostat = ios ) string if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMA_READ - Fatal error!' write ( *, '(a)' ) ' End or error while reading file.' ierror = 2 return end if if ( .not. s_eqi ( string(1:2), 'P1' ) ) then ierror = 3 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMA_READ - Fatal error.' write ( *, '(a)' ) ' First two bytes are not magic number "P1".' write ( *, '(a)' ) ' First two bytes are: ' // string(1:2) write ( *, '(a, 2i6)' ) ' ASCII codes: ', ichar ( string(1:1) ), & ichar ( string(2:2) ) return end if string(1:2) = ' ' ! ! Chop out any comments. ! i = index ( string, '#' ) if ( i /= 0 ) then string(i:) = ' ' end if ! ! Now search for NCOL and NROW. ! done = .TRUE. call getint ( done, ierror, input_unit, ncol, string ) if ( ierror /= 0 ) then close ( unit = input_unit ) ierror = 4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMA_READ - Fatal error!' write ( *, '(a)' ) ' Problem reading NCOL.' return end if call getint ( done, ierror, input_unit, nrow, string ) if ( ierror /= 0 ) then ierror = 4 close ( unit = input_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMA_READ - Fatal error!' write ( *, '(a)' ) ' Problem reading NROW.' return end if ! ! Check that there is enough room. ! if ( nrow * ncol > maxb ) then ierror = 7 close ( unit = input_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMA_READ - Fatal error!' write ( *, '(a,i6)' ) ' Needed NROW*NCOL = ', nrow * ncol write ( *, '(a,i6)' ) ' Available MAXB = ', maxb return end if ! ! Now read the bits. ! k = 0 do i = 1, nrow do j = 1, ncol k = ( j - 1 ) * nrow + i call getint ( done, ierror, input_unit, b(k), string ) if ( b(k) == 0 ) then nzero = nzero + 1 else none = none + 1 end if if ( ierror /= 0 ) then ierror = 5 close ( unit = input_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMA_READ - Fatal error!' write ( *, '(a)' ) ' Problem reading bit data.' return end if end do end do ! ! Close the file. ! close ( unit = input_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,i6)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i6)' ) ' Number of data columns NCOL = ', ncol write ( *, '(a,i6)' ) ' Number of 0 bits = ', nzero write ( *, '(a,i6)' ) ' Number of 1 bits = ', none end if return end subroutine pbma_write ( filename, ierror, nrow, ncol, b ) ! !******************************************************************************* ! !! 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.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 ! ! Modified: ! ! 07 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILENAME, the name of the file to which ! the data should be written. ! ! Output, integer IERROR, an error flag. ! 0, no error. ! 1, the data was illegal. ! 2, the file could not be opened. ! ! Input, integer NROW, NCOL, the number of rows and columns of data. ! ! Input, integer B(NROW,NCOL), contains the bit value of each pixel, ! which should be 0 or 1. ! implicit none ! integer ncol integer nrow ! integer b(nrow,ncol) logical debug character ( len = * ) filename integer i integer ierror integer ios integer j integer jhi integer jlo character ( len = 2 ) magic integer nzero integer none integer output_unit ! debug = .false. 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)' ) '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 = filename, 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)' ) '# ASCII PBM file created by 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 ) ! ! 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)' ) 'PBMA_WRITE - Note:' write ( *, '(a)' ) ' The data was checked and written.' write ( *, '(a,i6)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i6)' ) ' Number of data columns NCOL = ', ncol write ( *, '(a,i6)' ) ' Number of 0 bits = ', nzero write ( *, '(a,i6)' ) ' Number of 1 bits = ', none end if return end subroutine pbmb_read ( filename, ierror, maxb, nrow, ncol, b ) ! !******************************************************************************* ! !! 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. ! ! Modified: ! ! 09 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILENAME, the name of the file from which ! the data should be read. ! ! Output, integer 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 MAXB, the number of entries available in B. ! If MAXB is smaller than NROW*NCOL, then the data will not be read. ! ! Output, integer NROW, NCOL, the number of rows and columns of data. ! ! Output, integer 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 maxb ! integer b(maxb) logical debug character ( len = * ) filename integer i integer ierror integer indx integer input_unit integer ios integer istring(17) integer ival integer j integer k integer last integer nchar integer nchar2 integer ncol integer none integer nrow integer nval integer nzero integer record integer record_length character ( len = 68 ) string ! debug = .false. 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 ( input_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 = input_unit, file = filename, 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 ( input_unit, rec = record ) istring(i) end do if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMB_READ - About to convert integers to characters.' end if call ivec_to_s ( nval, istring, string ) 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,i6,i6)' ) ' 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_i ( string, ncol, ierror, last ) call s_chop ( string, 1, last ) nchar = nchar - last call s_to_i ( 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 ( nrow * ncol > maxb ) then ierror = 7 close ( unit = input_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PBMB_READ - Fatal error!' write ( *, '(a,i6)' ) ' Needed NROW*NCOL = ', nrow * ncol write ( *, '(a,i6)' ) ' 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 ( input_unit, rec = record ) istring(1) call ivec_to_s ( 1, istring, string(nchar+1:nchar+4) ) 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 = input_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)' ) 'PPMB_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,i6)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i6)' ) ' Number of data columns NCOL = ', ncol write ( *, '(a,i6)' ) ' Number of 0 bits = ', nzero write ( *, '(a,i6)' ) ' Number of 1 bits = ', none end if return end subroutine pbmb_write ( filename, ierror, nrow, ncol, b ) ! !******************************************************************************* ! !! 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. ! ! Modified: ! ! 09 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILENAME, the name of the file to which ! the data should be written. ! ! Output, integer IERROR, an error flag. ! 0, no error. ! 1, the data was illegal. ! 2, the file could not be opened. ! ! Input, integer NROW, NCOL, the number of rows and columns of data. ! ! Input, integer B(NROW,NCOL), contains the bit value of each pixel, ! which should be 0 or 1. ! implicit none ! integer ncol integer nrow ! integer b(nrow,ncol) logical debug character ( len = * ) filename integer i integer ierror integer ios integer ival integer istring(17) integer j integer k integer l integer nchar integer none integer nval integer nzero integer output_unit integer record integer record_length character ( len = 68 ) string ! debug = .false. 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 = filename, 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_ivec ( string(1:nchar), nval, istring ) do l = 1, nval record = record + 1 write ( output_unit, rec = record ) istring(l) end do string = ' ' nchar = 0 end if end do end do ! ! If K > 0, we have a partial result to turn into the last character. ! if ( k > 0 ) then nchar = nchar + 1 string(nchar:nchar) = char(ival) end if ! ! If NCHAR > 0, then we have a partial line to print out. ! if ( nchar > 0 ) then call s_to_ivec ( string(1:nchar), nval, istring ) do i = 1, nval record = record + 1 write ( output_unit, rec = record ) istring(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,i6)' ) ' Number of words written = ', record write ( *, '(a,i6)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i6)' ) ' Number of data columns NCOL = ', ncol write ( *, '(a,i6)' ) ' Number of 0 bits = ', nzero write ( *, '(a,i6)' ) ' Number of 1 bits = ', none end if return end subroutine pgm_check_data ( g, ierror, maxcol, ncol, nrow ) ! !******************************************************************************* ! !! PGM_CHECK_DATA checks gray data. ! ! ! Modified: ! ! 28 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer G(NROW,NCOL), contains the gray data. ! ! Output, integer IERROR, error flag. ! 0, no error detected. ! 1, the data is illegal. ! ! Input, integer MAXCOL, the maximum gray value. ! ! Input, integer NCOL, NROW, the number of rows and columns of data. ! implicit none ! integer ncol integer nrow ! integer g(nrow,ncol) integer i integer ierror integer j integer maxcol integer maxcol2 ! ierror = 0 maxcol2 = g(1,1) do i = 1, nrow do j = 1, ncol maxcol2 = max ( maxcol2, g(i,j) ) if ( g(i,j) < 0 ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGM_CHECK_DATA - Fatal error!' write ( *, '(a)' ) ' All gray values must be at least 0.' write ( *, '(a,i6,a,i6,a,i6)' ) ' G(', i, ',', j, ')=', g(i,j) return else if ( g(i,j) > maxcol ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGM_CHECK_DATA - Fatal error!' write ( *, '(a)' ) ' All gray values must be less than MAXCOL.' write ( *, '(a,i6)' ) ' MAXCOL = ', maxcol write ( *, '(a,i6,a,i6,a,i6)' ) ' G(', i, ',', j, ')=', g(i,j) return end if end do end do if ( maxcol2 /= maxcol ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGM_CHECK_DATA - Warning!' write ( *, '(a,i6)' ) ' Supposedly, MAXCOL = ', maxcol write ( *, '(a,i6)' ) ' but the maximum actually is ', maxcol2 end if return end subroutine pgma_read ( filename, ierror, maxcol, maxg, nrow, ncol, g ) ! !******************************************************************************* ! !! 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 ! ! Modified: ! ! 09 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILENAME, the name of the file from which ! the data should be read. ! ! Output, integer 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 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 MAXCOL, the maximum gray value. ! ! Input, integer MAXG, the number of entries available in B. ! If MAXG is smaller than NROW*NCOL, then the data will not be read. ! ! Output, integer NROW, NCOL, the number of rows and columns of data. ! ! Output, integer 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 maxg ! logical debug logical done character ( len = * ) filename integer g(maxg) integer i integer ierror integer input_unit integer ios integer j integer k integer maxcol integer ncol integer nrow logical s_eqi character ( len = 70 ) string ! debug = .false. ierror = 0 maxcol = 0 ncol = 0 nrow = 0 ! ! Open the file. ! call get_unit ( input_unit ) open ( unit = input_unit, file = filename, 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 first line of data, which must begin with the magic number. ! read ( input_unit, '(a)', iostat = ios ) string if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMA_READ - Fatal error!' write ( *, '(a)' ) ' End or error while reading file.' ierror = 2 return end if if ( .not. s_eqi ( string(1:2), 'P2' ) ) then ierror = 3 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMA_READ - Fatal error.' write ( *, '(a)' ) ' First two bytes are not magic number "P2".' write ( *, '(a)' ) ' First two bytes are: ' // string(1:2) write ( *, '(a,2i6)' ) ' ASCII codes: ', ichar ( string(1:1) ), & ichar ( string(2:2) ) return end if string(1:2) = ' ' ! ! Chop out any comments. ! i = index ( string, '#' ) if ( i /= 0 ) then string(i:) = ' ' end if ! ! Now search for NCOL, NROW, and MAXCOL. ! done = .TRUE. call getint ( done, ierror, input_unit, ncol, string ) if ( ierror /= 0 ) then close ( unit = input_unit ) ierror = 4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMA_READ - Fatal error!' write ( *, '(a)' ) ' Problem reading NCOL.' return end if call getint ( done, ierror, input_unit, nrow, string ) if ( ierror /= 0 ) then ierror = 4 close ( unit = input_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMA_READ - Fatal error!' write ( *, '(a)' ) ' Problem reading NROW.' return end if call getint ( done, ierror, input_unit, maxcol, string ) if ( ierror /= 0 ) then ierror = 4 close ( unit = input_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMA_READ - Fatal error!' write ( *, '(a)' ) ' Problem reading MAXCOL.' return end if ! ! Check that there is enough room. ! if ( nrow * ncol > maxg ) then ierror = 7 close ( unit = input_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMA_READ - Fatal error!' write ( *, '(a,i6)' ) ' Needed NROW*NCOL = ', nrow * ncol write ( *, '(a,i6)' ) ' Available MAXG = ', maxg return end if ! ! Now read the gray data. ! k = 0 do i = 1, nrow do j = 1, ncol k = ( j - 1 ) * nrow + i call getint ( done, ierror, input_unit, g(k), string ) if ( ierror /= 0 ) then ierror = 5 close ( unit = input_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMA_READ - Fatal error!' write ( *, '(a)' ) ' Problem reading gray data.' return end if end do end do ! ! Close the file. ! close ( unit = input_unit ) ! ! Check the data. ! call pgm_check_data ( g, ierror, maxcol, 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,i6)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i6)' ) ' Number of data columns NCOL = ', ncol write ( *, '(a,i6)' ) ' Maximum color value MAXCOL = ', maxcol end if return end subroutine pgma_write ( filename, ierror, nrow, ncol, g ) ! !******************************************************************************* ! !! 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.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 ! ! Modified: ! ! 07 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILENAME, the name of the file to which ! the data should be written. ! ! Output, integer IERROR, an error flag. ! 0, no error. ! 1, the data was illegal. ! 2, the file could not be opened. ! ! Input, integer NROW, NCOL, the number of rows and columns of data. ! ! Input, integer G(NROW,NCOL), contains the gray value of each pixel. ! These should be positive. ! implicit none ! integer ncol integer nrow ! logical debug character ( len = * ) filename integer g(nrow,ncol) integer i integer ierror integer ios integer j integer jhi integer jlo character ( len = 2 ) magic integer maxcol integer output_unit ! debug = .false. ierror = 0 ! ! Compute the maximum gray value. ! maxcol = g(1,1) do i = 1, nrow do j = 1, ncol maxcol = max ( maxcol, g(i,j) ) end do end do ! ! 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 = filename, 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)' ) '# ASCII PGM file created by 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,i6)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i6)' ) ' Number of data columns NCOL = ', ncol write ( *, '(a,i6)' ) ' Maximum color value MAXCOL = ', maxcol end if return end subroutine pgmb_read ( filename, ierror, maxcol, maxg, nrow, ncol, g ) ! !******************************************************************************* ! !! 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 ! ! Modified: ! ! 07 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILENAME, the name of the file to be read. ! ! Output, integer 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 MAXCOL, the maximum gray value. ! ! Input, integer MAXG, the number of entries available in B. ! If MAXG is smaller than NROW*NCOL, then the data will not be read. ! ! Output, integer NROW, NCOL, the number of rows and columns of data. ! ! Output, integer 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 maxg ! logical debug character ( len = * ) filename integer g(maxg) integer i integer ierror integer input_unit integer ios integer istring(17) integer ival integer j integer k integer last character ( len = 2 ) magic integer maxcol integer nchar integer nchar2 integer ncol integer nrow integer nval integer record integer record_length character ( len = 68 ) string ! debug = .false. 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 ( input_unit ) ! ! For the SGI: ! record_length = 4 ! ! For the DEC Alpha: ! ! record_length = 1 open ( unit = input_unit, file = filename, 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 ( input_unit, rec = record ) istring(i) end do call ivec_to_s ( nval, istring, string ) 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: ' // string(1:2) write ( *, '(a,2i6)' ) ' 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_i ( string, ncol, ierror, last ) call s_chop ( string, 1, last ) nchar = nchar - last call s_to_i ( string, nrow, ierror, last ) call s_chop ( string, 1, last ) nchar = nchar - last call s_to_i ( 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 ( nrow * ncol > maxg ) then ierror = 7 close ( unit = input_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMB_READ - Fatal error!' write ( *, '(a,i6)' ) ' Needed NROW*NCOL = ', nrow * ncol write ( *, '(a,i6)' ) ' 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 ( input_unit, rec = record ) istring(1) call ivec_to_s ( 1, istring, string(nchar+1:nchar+4) ) 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 = input_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,i6)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i6)' ) ' Number of data columns NCOL = ', ncol write ( *, '(a,i6)' ) ' Maximum color value MAXCOL = ', maxcol end if return end subroutine pgmb_write ( filename, ierror, nrow, ncol, g ) ! !******************************************************************************* ! !! 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. ! ! Modified: ! ! 09 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILENAME, the name of the file to which ! the data should be written. ! ! Output, integer IERROR, an error flag. ! 0, no error. ! 1, the data was illegal. ! 2, the file could not be opened. ! ! Input, integer NROW, NCOL, the number of rows and columns of data. ! ! Input, integer G(NROW,NCOL), contains the gray value of each pixel. ! These should be between 0 and 255. ! implicit none ! integer ncol integer nrow ! logical debug character ( len = * ) filename integer g(nrow,ncol) integer i integer ierror integer ios integer istring(17) integer j integer l integer maxcol integer nchar integer nval integer output_unit integer record integer record_length character ( len = 68 ) string ! debug = .false. ierror = 0 ! ! Compute the maximum gray value. ! maxcol = g(1,1) do i = 1, nrow do j = 1, ncol maxcol = max ( maxcol, g(i,j) ) end do end do ! ! Make sure no gray value is above 255. ! if ( maxcol > 255 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PGMB_WRITE - Fatal error!' write ( *, '(a)' ) ' The gray data exceeds 255.' 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 = filename, 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_ivec ( string(1:nchar), nval, istring ) do l = 1, nval record = record + 1 write ( output_unit, rec = record ) istring(l) end do string = ' ' nchar = 0 end if nchar = nchar + 1 string(nchar:nchar) = char ( g(i,j) ) end do end do if ( nchar > 0 ) then call s_to_ivec ( string(1:nchar), nval, istring ) do l = 1, nval record = record + 1 write ( output_unit, rec = record ) istring(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,i6)' ) ' Number of words = ', record write ( *, '(a,i6)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i6)' ) ' Number of data columns NCOL = ', ncol write ( *, '(a,i6)' ) ' Maximum color value MAXCOL = ', maxcol end if return end function r_pi ( ) ! !******************************************************************************* ! !! R_PI returns the value of pi. ! ! ! Modified: ! ! 04 December 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real R_PI, the value of pi. ! implicit none ! real r_pi ! r_pi = 3.14159265358979323846264338327950288419716939937510E+00 return end subroutine ppm_check_data ( r, g, b, ierror, maxcol, ncol, nrow ) ! !******************************************************************************* ! !! PPM_CHECK_DATA checks pixel data. ! ! ! Modified: ! ! 28 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer R(NROW,NCOL), G(NROW,NCOL), B(NROW,NCOL), contains the ! RGB pixel data. ! ! Output, integer IERROR, error flag. ! 0, no error detected. ! 1, the data is illegal. ! ! Input, integer MAXCOL, the maximum value. ! ! Input, integer NCOL, NROW, the number of rows and columns of data. ! implicit none ! integer ncol integer nrow ! integer b(nrow,ncol) integer g(nrow,ncol) integer i integer ierror integer j integer maxcol integer r(nrow,ncol) ! ierror = 0 ! ! Make sure no color is negative nor greater than MAXCOL. ! do i = 1, nrow do j = 1, ncol if ( r(i,j) < 0 .or. g(i,j) < 0 .or. b(i,j) < 0 ) then ierror = 1 return end if if ( r(i,j) > maxcol .or. g(i,j) > maxcol .or. b(i,j) > maxcol ) then ierror = 1 return end if end do end do return end subroutine ppma_read ( filename, ierror, maxcol, maxp, nrow, ncol, r, g, b ) ! !******************************************************************************* ! !! 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 ! ! Modified: ! ! 07 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILENAME, the name of the file from which ! the data should be read. ! ! Output, integer 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 MAXCOL, the maximum pixel color value. ! ! Input, integer 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 NROW, NCOL, the number of rows and columns of data. ! ! Output, integer 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 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 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 maxp ! integer b(maxp) logical debug logical done character ( len = * ) filename integer g(maxp) integer i integer ierror integer input_unit integer ios integer j integer k integer maxcol integer ncol integer nrow integer r(maxp) logical s_eqi character ( len = 70 ) string ! debug = .false. ierror = 0 maxcol = 0 ncol = 0 nrow = 0 ! ! Open the file. ! call get_unit ( input_unit ) open ( unit = input_unit, file = filename, 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 ( input_unit, '(a)', iostat = ios ) string 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 ( string(1:2), '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: ' // string(1:2) write ( *, '(a,2i6)' ) ' ASCII codes: ', ichar ( string(1:1) ), & ichar ( string(2:2) ) return end if string(1:2) = ' ' ! ! Chop out any comments. ! i = index ( string, '#' ) if ( i /= 0 ) then string(i:) = ' ' end if ! ! Now search for NCOL, NROW, and MAXCOL. ! done = .TRUE. call getint ( done, ierror, input_unit, ncol, string ) if ( ierror /= 0 ) then close ( unit = input_unit ) ierror = 4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMA_READ - Fatal error!' write ( *, '(a)' ) ' Problem reading NCOL.' return end if call getint ( done, ierror, input_unit, nrow, string ) if ( ierror /= 0 ) then ierror = 4 close ( unit = input_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMA_READ - Fatal error!' write ( *, '(a)' ) ' Problem reading NROW.' return end if call getint ( done, ierror, input_unit, maxcol, string ) if ( ierror /= 0 ) then ierror = 4 close ( unit = input_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMA_READ - Fatal error!' write ( *, '(a)' ) ' Problem reading MAXCOL.' return end if ! ! Check that there is enough room. ! if ( nrow * ncol > maxp ) then ierror = 7 close ( unit = input_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMA_READ - Fatal error!' write ( *, '(a,i6)' ) ' Needed NROW*NCOL = ', nrow * ncol write ( *, '(a,i6)' ) ' 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, input_unit, r(k), string ) if ( ierror /= 0 ) then ierror = 5 close ( unit = input_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMA_READ - Fatal error!' write ( *, '(a)' ) ' Problem reading R data.' return end if call getint ( done, ierror, input_unit, g(k), string ) if ( ierror /= 0 ) then ierror = 5 close ( unit = input_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMA_READ - Fatal error!' write ( *, '(a)' ) ' Problem reading G data.' return end if call getint ( done, ierror, input_unit, b(k), string ) if ( ierror /= 0 ) then ierror = 5 close ( unit = input_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 = input_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,i6)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i6)' ) ' Number of data columns NCOL = ', ncol write ( *, '(a,i6)' ) ' Maximum color value MAXCOL = ', maxcol end if return end subroutine ppma_write ( filename, ierror, nrow, ncol, r, g, b ) ! !******************************************************************************* ! !! 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.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 ! ! Modified: ! ! 07 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILENAME, the name of the file to which ! the data should be written. ! ! Output, integer IERROR, an error flag. ! 0, no error. ! 1, the data was illegal. ! 2, the file could not be opened. ! ! Input, integer NROW, NCOL, the number of rows and columns of data. ! ! Input, integer 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 ncol integer nrow ! integer b(nrow,ncol) logical debug character ( len = * ) filename integer g(nrow,ncol) integer i integer ierror integer ios integer j integer jhi integer jlo character ( len = 2 ) magic integer maxcol integer output_unit integer r(nrow,ncol) ! debug = .false. ierror = 0 ! ! Compute the maximum color value. ! maxcol = r(1,1) do i = 1, nrow do j = 1, ncol maxcol = max ( maxcol, r(i,j) ) maxcol = max ( maxcol, g(i,j) ) maxcol = max ( maxcol, b(i,j) ) end do end do ! ! 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 = filename, 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)' ) '# ASCII PPM file created by 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,i6)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i6)' ) ' Number of data columns NCOL = ', ncol write ( *, '(a,i6)' ) ' Maximum color value MAXCOL = ', maxcol end if return end subroutine ppmb_read ( filename, ierror, maxcol, maxg, nrow, ncol, r, g, b ) ! !******************************************************************************* ! !! 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 ! ! Modified: ! ! 07 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILENAME, the name of the file to be read. ! ! Output, integer 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 MAXCOL, the maximum pixel value. ! ! Input, integer 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 NROW, NCOL, the number of rows and columns of data. ! ! Output, integer 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 maxg ! integer b(maxg) logical debug character ( len = * ) filename integer g(maxg) integer i integer ierror integer input_unit integer ios integer istring(17) integer ival integer j integer k integer last character ( len = 2 ) magic integer maxcol integer nchar integer nchar2 integer ncol integer nrow integer nval integer r(maxg) integer record integer record_length character ( len = 68 ) string ! debug = .false. 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 ( input_unit ) ! ! For the SGI: ! record_length = 4 ! ! For the DEC Alpha: ! ! record_length = 1 open ( unit = input_unit, file = filename, 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 ( input_unit, rec = record ) istring(i) end do call ivec_to_s ( nval, istring, string ) 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,2i6)' ) ' 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_i ( string, ncol, ierror, last ) call s_chop ( string, 1, last ) nchar = nchar - last call s_to_i ( string, nrow, ierror, last ) call s_chop ( string, 1, last ) nchar = nchar - last call s_to_i ( 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 ( nrow * ncol > maxg ) then ierror = 7 close ( unit = input_unit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMB_READ - Fatal error!' write ( *, '(a,i6)' ) ' Needed NROW*NCOL = ', nrow * ncol write ( *, '(a,i6)' ) ' 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 ( input_unit, rec = record ) istring(1) call ivec_to_s ( 1, istring, string(nchar+1:nchar+4) ) 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 ( input_unit, rec = record ) istring(1) call ivec_to_s ( 1, istring, string(nchar+1:nchar+4) ) 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 ( input_unit, rec = record ) istring(1) call ivec_to_s ( 1, istring, string(nchar+1:nchar+4) ) 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 = input_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,i6)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i6)' ) ' Number of data columns NCOL = ', ncol write ( *, '(a,i6)' ) ' Maximum color value MAXCOL = ', maxcol end if return end subroutine ppmb_write ( filename, ierror, nrow, ncol, r, g, b ) ! !******************************************************************************* ! !! 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. ! ! Modified: ! ! 07 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILENAME, the name of the file to which ! the data should be written. ! ! Output, integer IERROR, an error flag. ! 0, no error. ! 1, the data was illegal. ! 2, the file could not be opened. ! ! Input, integer NROW, NCOL, the number of rows and columns of data. ! ! Input, integer 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 ncol integer nrow ! integer b(nrow,ncol) logical debug character ( len = * ) filename integer g(nrow,ncol) integer i integer ierror integer ios integer istring(17) integer j integer l integer maxcol integer nchar integer nval integer output_unit integer r(nrow,ncol) integer record integer record_length character ( len = 68 ) string ! debug = .false. ierror = 0 ! ! Compute the maximum color value. ! maxcol = r(1,1) do i = 1, nrow do j = 1, ncol maxcol = max ( maxcol, r(i,j) ) maxcol = max ( maxcol, g(i,j) ) maxcol = max ( maxcol, b(i,j) ) end do end do ! ! Check that no color data exceeds 255. ! if ( maxcol > 255 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPMB_WRITE - Fatal error!' write ( *, '(a)' ) ' The color data exceeds 255!' 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 = filename, 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_ivec ( string(1:nchar), nval, istring ) do l = 1, nval record = record + 1 write ( output_unit, rec = record ) istring(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_ivec ( string(1:nchar), nval, istring ) do l = 1, nval record = record + 1 write ( output_unit, rec = record ) istring(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_ivec ( string(1:nchar), nval, istring ) do l = 1, nval record = record + 1 write ( output_unit, rec = record ) istring(l) end do string = ' ' nchar = 0 end if nchar = nchar + 1 string(nchar:nchar) = char ( b(i,j) ) end do end do if ( nchar > 0 ) then call s_to_ivec ( string(1:nchar), nval, istring ) do l = 1, nval record = record + 1 write ( output_unit, rec = record ) istring(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,i6)' ) ' Number of words = ', record write ( *, '(a,i6)' ) ' Number of data rows NROW = ', nrow write ( *, '(a,i6)' ) ' Number of data columns NCOL = ', ncol write ( *, '(a,i6)' ) ' Maximum color value MAXCOL = ', maxcol end if return end subroutine rt_to_xy ( r, t, x, y ) ! !******************************************************************************* ! !! RT_TO_XY converts polar coordinates to XY coordinates. ! ! ! Modified: ! ! 12 April 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real R, T, the radius and angle (in radians). ! ! Output, real X, Y, the Cartesian coordinates. ! implicit none ! real r real t real x real y ! x = r * cos ( t ) y = r * sin ( t ) return end subroutine s_blanks_delete ( s ) ! !******************************************************************************* ! !! 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. ! ! Modified: ! ! 26 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! implicit none ! integer i integer 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 ) ! !******************************************************************************* ! !! 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! ' ! ! Modified: ! ! 06 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! ! Input, integer ILO, IHI, the locations of the first and last ! characters to be removed. ! implicit none ! integer ihi integer ihi2 integer ilo integer ilo2 integer lens character ( len = * ) s ! lens = len ( s ) ilo2 = max ( ilo, 1 ) ihi2 = min ( ihi, lens ) if ( ilo2 > ihi2 ) 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 ) ! !******************************************************************************* ! !! S_EQI is a case insensitive comparison of two strings for equality. ! ! ! Examples: ! ! S_EQI ( 'Anjana', 'ANJANA' ) is .TRUE. ! ! 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 i integer len1 integer len2 integer 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_i ( s, ival, ierror, last ) ! !******************************************************************************* ! !! S_TO_I reads an integer value from a string. ! ! ! Modified: ! ! 28 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string to be examined. ! ! Output, integer IVAL, the integer value read from the string. ! If blank, then IVAL will be returned 0. ! ! Output, integer IERROR, an error flag. ! 0, no error. ! 1, an error occurred. ! ! Output, integer LAST, the last character that was ! part of the representation of IVAL. ! implicit none ! character c integer i integer ierror integer isgn integer istate integer ival integer last integer 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 ( i >= lens ) 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_ivec ( s, n, ivec ) ! !******************************************************************************* ! !! S_TO_IVEC converts an string of characters into an array of integers. ! ! ! 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. ! ! 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 N, the number of integers read from the string. ! ! Output, integer IVEC(*), an array of N integers which contains ! the information from S. ! implicit none ! integer from integer frompos integer ihi integer ilo integer ivec(*) integer j integer, parameter :: length = 8 integer n integer nchar logical, parameter :: reverse_order = .true. character ( len = * ) s integer to integer 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_order ) then topos = length * ( j - ilo ) else topos = length * ( ilo + 3 - j ) end if call mvbits ( from, frompos, length, to, topos ) end do ivec(n) = to end do return end subroutine timestamp ( ) ! !******************************************************************************* ! !! TIMESTAMP prints the current YMDHMS date as a time stamp. ! ! ! Example: ! ! May 31 2001 9:45:54.872 AM ! ! Modified: ! ! 31 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none ! character ( len = 8 ) ampm integer d character ( len = 8 ) date integer h integer m integer mm character ( len = 9 ), parameter, dimension(12) :: month = (/ & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' /) integer n integer s character ( len = 10 ) time integer values(8) integer y character ( len = 5 ) zone ! call date_and_time ( date, time, zone, values ) y = values(1) m = values(2) d = values(3) h = values(5) n = values(6) s = values(7) mm = values(8) if ( h < 12 ) then ampm = 'AM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Noon' else ampm = 'PM' end if else h = h - 12 if ( h < 12 ) then ampm = 'PM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Midnight' else ampm = 'AM' end if end if end if write ( *, '(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 ) ! !******************************************************************************* ! !! WORD_NEXT_RD "reads" words from a string, one at a time. ! ! ! 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 ilo integer lenl character ( len = * ) line integer, 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 10 continue ! ! ...LINE(NEXT:LENL) is blank. Return with WORD=' ', and DONE=TRUE. ! if ( ilo > lenl ) 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) == ' ' .or. line(ilo:ilo) == TAB ) then ilo = ilo + 1 go to 10 end if ! ! 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 20 continue if ( next > lenl ) then word = line(ilo:next-1) return end if if ( line(next:next) /= ' ' .and. line(next:next) /= TAB ) then next = next + 1 go to 20 end if word = line(ilo:next-1) return end