hwrf-baseline-20120103-1354/ungrib/src/ngl/g2/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,rmin4
  57       real(8) :: rmin,rmax
  58       integer(4) :: iref
  59       integer :: ifld(width*height)
  60       integer,parameter :: zero=0
  61       integer :: enc_png
  62       character(len=1),allocatable :: ctemp(:)
  63 #ifdef USE_PNG
  64
  65       ndpts=width*height
  66       bscale=2.0**real(-idrstmpl(2))
  67       dscale=10.0**real(idrstmpl(3))
  68 !
  69 !  Find max and min values in the data
  70 !
  71       rmax=fld(1)
  72       rmin=fld(1)
  73       do j=2,ndpts
  74         if (fld(j).gt.rmax) rmax=fld(j)
  75         if (fld(j).lt.rmin) rmin=fld(j)
  76       enddo
  77       maxdif=nint((rmax-rmin)*dscale*bscale)
  78 !
  79 !  If max and min values are not equal, pack up field.
  80 !  If they are equal, we have a constant field, and the reference
  81 !  value (rmin) is the value for each point in the field and
  82 !  set nbits to 0.
  83 !
  84       if (rmin.ne.rmax .AND. maxdif.ne.0) then
  85         !
  86         !  Determine which algorithm to use based on user-supplied
  87         !  binary scale factor and number of bits.
  88         !
  89         if (idrstmpl(2).eq.0) then
  90            !
  91            !  No binary scaling and calculate minimum number of
  92            !  bits in which the data will fit.
  93            !
  94            imin=nint(rmin*dscale)
  95            imax=nint(rmax*dscale)
  96            maxdif=imax-imin
  97            temp=alog(real(maxdif+1))/alog(2.0)
  98            nbits=ceiling(temp)
  99            rmin=real(imin)
 100            !   scale data
 101            do j=1,ndpts
 102              ifld(j)=nint(fld(j)*dscale)-imin
 103            enddo
 104         else
 105            !
 106            !  Use binary scaling factor and calculate minimum number of
 107            !  bits in which the data will fit.
 108            !
 109            rmin=rmin*dscale
 110            rmax=rmax*dscale
 111            maxdif=nint((rmax-rmin)*bscale)
 112            temp=alog(real(maxdif+1))/alog(2.0)
 113            nbits=ceiling(temp)
 114            !   scale data
 115            do j=1,ndpts
 116              ifld(j)=nint(((fld(j)*dscale)-rmin)*bscale)
 117            enddo
 118         endif
 119         !
 120         !  Pack data into full octets, then do PNG encode.
 121         !  and calculate the length of the packed data in bytes
 122         !
 123         if (nbits.le.8) then
 124             nbits=8
 125         elseif (nbits.le.16) then
 126             nbits=16
 127         elseif (nbits.le.24) then
 128             nbits=24
 129         else
 130             nbits=32
 131         endif
 132         nbytes=(nbits/8)*ndpts
 133         allocate(ctemp(nbytes))
 134         call sbytes(ctemp,ifld,0,nbits,0,ndpts)
 135         !
 136         !  Encode data into PNG Format.
 137         !
 138         lcpack=enc_png(ctemp,width,height,nbits,cpack)
 139         if (lcpack.le.0) then
 140            print *,'pngpack: ERROR Encoding PNG = ',lcpack
 141         endif
 142         deallocate(ctemp)
 143
 144       else
 145         nbits=0
 146         lcpack=0
 147       endif
 148
 149 !
 150 !  Fill in ref value and number of bits in Template 5.0
 151 !
 152       rmin4=rmin
 153       call mkieee(rmin4,ref,1)   ! ensure reference value is IEEE format
 154 !      call gbyte(ref,idrstmpl(1),0,32)
 155       iref=transfer(ref,iref)
 156       idrstmpl(1)=iref
 157       idrstmpl(4)=nbits
 158       idrstmpl(5)=0         ! original data were reals
 159
 160
 161 #endif /* USE_PNG */
 162       return
 163       end