external/io_grib2/g2lib/pngpack.F

   1       subroutine pngpack(fld,width,height,idrstmpl,cpack,lcpack)
   2 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
   3 !                .      .    .                                       .
   4 ! SUBPROGRAM:    pngpack
   5 !   PRGMMR: Gilbert          ORG: W/NP11    DATE: 2002-12-21
   6 !
   7 ! ABSTRACT: This subroutine packs up a data field into PNG image format.
   8 !   After the data field is scaled, and the reference value is subtracted out,
   9 !   it is treated as a grayscale image and passed to a PNG encoder.
  10 !   It also fills in GRIB2 Data Representation Template 5.41 or 5.40010 with the
  11 !   appropriate values.
  12 !
  13 ! PROGRAM HISTORY LOG:
  14 ! 2002-12-21  Gilbert
  15 !
  16 ! USAGE:    CALL pngpack(fld,width,height,idrstmpl,cpack,lcpack)
  17 !   INPUT ARGUMENT LIST:
  18 !     fld()    - Contains the data values to pack
  19 !     width    - number of points in the x direction
  20 !     height   - number of points in the y direction
  21 !     idrstmpl - Contains the array of values for Data Representation
  22 !                Template 5.41 or 5.40010
  23 !                (1) = Reference value - ignored on input
  24 !                (2) = Binary Scale Factor
  25 !                (3) = Decimal Scale Factor
  26 !                (4) = number of bits for each data value - ignored on input
  27 !                (5) = Original field type - currently ignored on input
  28 !                      Data values assumed to be reals.
  29 !
  30 !   OUTPUT ARGUMENT LIST:
  31 !     idrstmpl - Contains the array of values for Data Representation
  32 !                Template 5.41 or 5.40010
  33 !                (1) = Reference value - set by pngpack routine.
  34 !                (2) = Binary Scale Factor - unchanged from input
  35 !                (3) = Decimal Scale Factor - unchanged from input
  36 !                (4) = Number of bits containing each grayscale pixel value
  37 !                (5) = Original field type - currently set = 0 on output.
  38 !                      Data values assumed to be reals.
  39 !     cpack    - The packed data field (character*1 array)
  40 !     lcpack   - length of packed field cpack().
  41 !
  42 ! REMARKS: None
  43 !
  44 ! ATTRIBUTES:
  45 !   LANGUAGE: XL Fortran 90
  46 !   MACHINE:  IBM SP
  47 !
  48 !$$$
  49
  50       integer,intent(in) :: width,height
  51       real,intent(in) :: fld(width*height)
  52       character(len=1),intent(out) :: cpack(*)
  53       integer,intent(inout) :: idrstmpl(*)
  54       integer,intent(out) :: lcpack
  55
  56       real(4) :: ref
  57       integer(4) :: iref
  58       integer :: ifld(width*height)
  59       integer,parameter :: zero=0
  60       integer :: enc_png
  61       character(len=1),allocatable :: ctemp(:)
  62
  63       ndpts=width*height
  64       bscale=2.0**real(-idrstmpl(2))
  65       dscale=10.0**real(idrstmpl(3))
  66 !
  67 !  Find max and min values in the data
  68 !
  69       rmax=fld(1)
  70       rmin=fld(1)
  71       do j=2,ndpts
  72         if (fld(j).gt.rmax) rmax=fld(j)
  73         if (fld(j).lt.rmin) rmin=fld(j)
  74       enddo
  75       maxdif=nint((rmax-rmin)*dscale*bscale)
  76 !
  77 !  If max and min values are not equal, pack up field.
  78 !  If they are equal, we have a constant field, and the reference
  79 !  value (rmin) is the value for each point in the field and
  80 !  set nbits to 0.
  81 !
  82       if (rmin.ne.rmax .AND. maxdif.ne.0) then
  83         !
  84         !  Determine which algorithm to use based on user-supplied
  85         !  binary scale factor and number of bits.
  86         !
  87         if (idrstmpl(2).eq.0) then
  88            !
  89            !  No binary scaling and calculate minimum number of
  90            !  bits in which the data will fit.
  91            !
  92            imin=nint(rmin*dscale)
  93            imax=nint(rmax*dscale)
  94            maxdif=imax-imin
  95            temp=alog(real(maxdif+1))/alog(2.0)
  96            nbits=ceiling(temp)
  97            rmin=real(imin)
  98            !   scale data
  99            do j=1,ndpts
 100              ifld(j)=nint(fld(j)*dscale)-imin
 101            enddo
 102         else
 103            !
 104            !  Use binary scaling factor and calculate minimum number of
 105            !  bits in which the data will fit.
 106            !
 107            rmin=rmin*dscale
 108            rmax=rmax*dscale
 109            maxdif=nint((rmax-rmin)*bscale)
 110            temp=alog(real(maxdif+1))/alog(2.0)
 111            nbits=ceiling(temp)
 112            !   scale data
 113            do j=1,ndpts
 114              ifld(j)=nint(((fld(j)*dscale)-rmin)*bscale)
 115            enddo
 116         endif
 117         !
 118         !  Pack data into full octets, then do PNG encode.
 119         !  and calculate the length of the packed data in bytes
 120         !
 121         if (nbits.le.8) then
 122             nbits=8
 123         elseif (nbits.le.16) then
 124             nbits=16
 125         elseif (nbits.le.24) then
 126             nbits=24
 127         else
 128             nbits=32
 129         endif
 130         nbytes=(nbits/8)*ndpts
 131         allocate(ctemp(nbytes))
 132         call g2lib_sbytes(ctemp,ifld,0,nbits,0,ndpts)
 133         !
 134         !  Encode data into PNG Format.
 135         !
 136         lcpack=enc_png(ctemp,width,height,nbits,cpack)
 137         if (lcpack.le.0) then
 138            print *,'pngpack: ERROR Encoding PNG = ',lcpack
 139         endif
 140         deallocate(ctemp)
 141
 142       else
 143         nbits=0
 144         lcpack=0
 145       endif
 146
 147 !
 148 !  Fill in ref value and number of bits in Template 5.0
 149 !
 150       call mkieee(rmin,ref,1)   ! ensure reference value is IEEE format
 151 !      call g2lib_gbyte(ref,idrstmpl(1),0,32)
 152       iref=transfer(ref,iref)
 153       idrstmpl(1)=iref
 154       idrstmpl(4)=nbits
 155       idrstmpl(5)=0         ! original data were reals
 156
 157       return
 158       end