home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / fortran / mslang / fort_bmp / bmpread.for < prev    next >
Text File  |  1993-07-14  |  9KB  |  202 lines
  1.       subroutine bmpread(filename,biBitCount,ncol,nrow,nclr,rgb,data,
  2.      $                   error)
  3.       implicit none
  4.  
  5. c*****************************************************************************
  6. c*                                                                           *
  7. c*     (C) Copyright 1993 by Enlightened Solutions. All rights reserved.     *
  8. c*                                                                           *
  9. c*                           Enlightened Solutions                           *
  10. c*                           1503 Linda Rosa Avenue                          *
  11. c*                           Los Angeles, CA  90041-2210                     *
  12. c*                           Phone: 213-255-3932                             *
  13. c*                           CIS ID: 70704,3067                              *
  14. c*                                                                           *
  15. c*    This software is distributed free-of-charge, but is NOT released to    *
  16. c*    the public domain. If you make any changes, please do so on a copy,    *
  17. c*    and include the originals in any distribution, with copyright notices  *
  18. c*    intact.                                                                *
  19. c*                                                                           *
  20. c*****************************************************************************
  21.  
  22. c     This subroutine reads a Windows Bitmap v3.0 graphic file. Note that
  23. c  "v3.0" does not refer to Windows 3.0, but rather Bitmap 3.0, as described
  24. c  in the file BMP30FMT.TXT. Bitmap v3.0 files are compatible with Windows
  25. c  3.x. Compressed (RLE) bitmap formats are not supported. This subroutine
  26. c  has been succesfully compiled under MS FORTRAN v5.1 and MS Powerstation
  27. c  FORTRAN (32 bit), although the Powerstation compiler will issue a warning
  28. c  that the [huge] attribute of the "data" array will be ignored, which is ok.
  29.  
  30. c     The required inputs and return values are described below. The other
  31. c  variables in the bitmap header (as described in BMP30FMT.TXT) are seldom
  32. c  needed or used, but could be returned if desired.
  33. c
  34. c  filename - Character*(*), input. The name of the bitmap file to be read,
  35. c             including path if necessary. If the file doesn't exist, the
  36. c             subroutine displays an informational message, sets "error" 
  37. c             = .true., and returns.
  38. c  biBitCount - Integer*2, output. The number of bits/pixel of the "data" 
  39. c               array. Valid values are 1,4,8, and 24 (representing maximum 
  40. c               colors of 2,16,256, and 16.8 million, respectively).
  41. c  ncol - Integer*4, output. Number of pixels in the horizontal direction.
  42. c  nrow - Integer*4, output. Number of pixels in the vertical direction.
  43. c  nclr - Integer*4, output. Number of colors in palette.
  44. c  rgb - Byte(3,*), output. An array to hold the red, green, and blue 
  45. c        components of the "nclr" colors of the palette. *EXCEPTION* It
  46. c        would be impractical to specify 16.8 million color palette for a 
  47. c        24 bit image, therefore these images specify the colors directly 
  48. c        by the data itself, i.e. the three bytes of data specify the red, 
  49. c        green, and blue components of that particular pixel. In this case, 
  50. c        array "rgb" is returned unaltered.
  51. c  data - [huge]byte(*), output. An array to hold the data for the bitmap. 
  52. c         "biBitCount" specifies how many bits/pixel. The array is one-dimen-
  53. c         sional here, but may be two (or more) dimensions in the calling 
  54. c         program. The first pixel in this array will correspond to the
  55. c         lower left corner of the image. If you prefer a different orienta-
  56. c         tion, then make this array 2D here, and alter the read statement
  57. c         to suit yourself. 
  58. c  error - Logical*4, output. If an error occurred, usually during opening
  59. c          or reading the file, "error" is set to .true., an informational
  60. c          message is displayed, and control is returned to the calling 
  61. c          program.
  62.  
  63. c  Bitmap File-Header variables. See "BMP30FMT.TXT" for more info.
  64.       
  65.       character*2 bfType
  66.       integer*4 bfSize,bfOffBits
  67.       integer*2 bfReserved1,bfReserved2
  68.  
  69. c  Bitmap Info-Header variables. See "BMP30FMT.TXT" for more info.
  70.       
  71.       integer*2 biPlanes,biBitCount
  72.       integer*4 biSize,biWidth,biHeight,biCompression,biSizeImage
  73.       integer*4 biXPelsPerMeter,biYPelsPerMeter,biClrUsed,biClrImportant
  74.  
  75. c  RGBQuad variables. See "BMP30FMT.TXT" for more info.
  76.       
  77.       byte rgb(3,*),rgbReserved
  78.  
  79. c  Other passed and local variables.
  80.       
  81.       byte data[huge](*),buffer(4)
  82.       integer*2 getlen,nbytes_read,nbuf
  83.       integer*4 ncol_bytes,ncol,nrow,nclr,ioerr,iu,i,j,j0
  84.       logical*4 error,open,exist
  85.       character*(*) filename
  86. c---------------------------------------------------------------------------
  87.  
  88.       error = .false.
  89.  
  90. c  Make sure file exists.
  91.  
  92.       inquire(file=filename,exist=exist)
  93.       if(.not.exist)  then
  94.        write(*,522)  filename(1:getlen(filename))
  95. 522    format(/,' BMPREAD - ',a,' does not exist.',/)
  96.        error = .true.
  97.        return
  98.       endif
  99.  
  100. c  Find available unit # and open file.
  101.  
  102.       iu = 0
  103.       open = .true.
  104.       do while (open)
  105.        iu = iu + 1
  106.        inquire(unit=iu,opened=open)
  107.       enddo
  108.       open(iu,file=filename,status='old',form='binary',mode='read',
  109.      $     iostat=ioerr,err=98)
  110.  
  111. c  Read BitmapFileHeader
  112.       
  113.       read(iu,iostat=ioerr,err=98)  bfType,bfSize,bfReserved1,
  114.      $                              bfReserved2,bfOffBits
  115.  
  116. c  Read BitmapInfoHeader
  117.       
  118.       read(iu,iostat=ioerr,err=98)  biSize,biWidth,biHeight,biPlanes,
  119.      $                              biBitCount,biCompression,
  120.      $                              biSizeImage,biXPelsPerMeter,
  121.      $                              biYPelsPerMeter,biClrUsed,
  122.      $                              biClrImportant
  123.       
  124.       if(biCompression.ne.0)  then
  125.        write(*,'(/,'' BMPREAD - Compressed bitmaps not supported.'',/)')
  126.        error = .true.
  127.        return
  128.       endif
  129.  
  130.       ncol = biWidth
  131.       nrow = biHeight
  132.       nclr = 2**biBitCount
  133.       ncol_bytes = ncol*biBitCount/8
  134.  
  135. c  Read color table. The bitmap file stores the red, green, blue triplet
  136. c  as blue, green, red; hence the descending counter in the read statement
  137. c  in order that array rgb be true to its name. 
  138.  
  139.       if(biBitCount.lt.24)  then
  140.        read(iu,iostat=ioerr,err=98)  
  141.      $                        ((rgb(j,i),j=3,1,-1),rgbReserved,i=1,nclr)
  142.        nbytes_read = 54 + 4*nclr
  143.       else
  144.        nbytes_read = 54
  145.       endif
  146.  
  147. c  Advance to the beginning of the image data. Chances are that 
  148. c  bfOffBits = nbytes_read, and this read statement will not execute. 
  149. c  "buffer(1)" is NOT a typo.
  150.  
  151.       read(iu,iostat=ioerr,err=98) (buffer(1),i=1,bfOffBits-nbytes_read)
  152.  
  153. c  Read data. Note that this program does not expand 1 or 4 bit/pixel
  154. c  values to occupy one byte. The user is left to do that themselves.
  155. c  For 24 bit/pixel data, array "data" contains successive red, green,
  156. c  blue bytes. Since each scanline (row) must end at a 4-byte boundary,
  157. c  read the padded bytes at the end of each row, if necessary. Note that
  158. c  the only reason there is a different read statment for the nbuf.eq.0 
  159. c  case is that it's faster.
  160.  
  161.       nbuf = mod(4 - mod(ncol_bytes,4),4)
  162.       if(nbuf.ne.0)  then
  163.        do 2 i = 1,nrow
  164.         j0 = (i - 1)*ncol_bytes + 1
  165.         read(iu,iostat=ioerr,err=98)  (data(j),j=j0,j0+ncol_bytes-1),
  166.      $                                (buffer(j),j=1,nbuf)
  167. 2      continue
  168.       else
  169.        read(iu,iostat=ioerr,err=98)  (data(j),j=1,ncol_bytes*nrow)
  170.       endif
  171.       close(iu)
  172.       return
  173.  
  174. c  If here, there was an open or read error. Inform, and return with 
  175. c  error = .true..
  176.  
  177. 98    error = .true.
  178.       if(ioerr.eq.-1)  then
  179.        write(*,222)  filename(1:getlen(filename))
  180. 222    format(/,' BMPREAD - End-of-file encountered reading ',a,/)
  181.       else if(ioerr.gt.0)  then 
  182.        write(*,322)  ioerr,filename(1:getlen(filename))
  183. 322    format(/,' BMPREAD - Error #',i5,' opening or reading ',a,/)
  184.       endif
  185.       
  186.       close(iu)
  187.       return
  188.       end
  189. c****************************************************************************      
  190.       integer*2 function getlen(word)
  191.       integer*2 ic
  192.       character*(*) word
  193.  
  194.       getlen = len(word) + 1
  195. 11    getlen = getlen - 1
  196.       if(getlen.eq.0)  return
  197.       ic = ichar(word(getlen:getlen))
  198.       if(ic.eq.32 .or. ic.eq.0)  go to 11
  199.  
  200.       return
  201.       end
  202.