pkc.f

Go to the documentation of this file.

C> @file
C> @brief Encode a character string within an integer array.

C> This subroutine encodes a character string within a specified
C> number of bits of an integer array, starting at the bit
C> immediately after a specified bit within the array.
C>
C> @author J. Woollen
C> @date 1994-01-06
C>
C> @param[in] CHR      - character*(*): String to be encoded
C> @param[in] NCHR     - integer: Number of bytes of IBAY within
C>                       which to encode CHR (i.e. the number of
C>                       characters in CHR)
C> @param[out] IBAY    - integer(*): Array containing encoded CHR
C> @param[in,out] IBIT - integer: Bit pointer within IBAY
C>                       - On input, IBIT points to the bit within
C>                         IBAY after which to begin encoding CHR.
C>                       - On output, IBIT points to the last bit
C>                         of IBAY which contains the encoded CHR.
C>
C> @remarks
C> - This subroutine is the logical inverse of subroutine upc().
C> - On input, there is no requirement that IBIT must point to the first
C>   bit of a byte within IBAY.  Correspondingly, on output there is no
C>   guarantee that the NCHR characters of CHR will be aligned on byte
C>   boundaries when encoded within IBAY.
C>
C> <b>Program history log:</b>
C> - 1994-01-06  J. Woollen -- Original author
C> - 1998-07-08  J. Woollen -- Replaced call to Cray library routine ABORT
C>                             with call to new internal routine bort()
C> - 2003-11-04  J. Woollen -- Modified to be endian-independent
C> - 2003-11-04  J. Ator    -- Added documentation
C> - 2003-11-04  S. Bender  -- Added remarks and routine interdependencies
C> - 2003-11-04  D. Keyser  -- Unified/portable for WRF; added history
C>                             documentation; outputs more complete
C>                             diagnostic info when routine terminates
C>                             abnormally; use bort2() instead of bort()
C> - 2004-08-18  J. Ator    -- Modified to be compatible with writlc()
C>
      SUBROUTINE pkc(CHR,NCHR,IBAY,IBIT)

      COMMON /charac/ iascii,iatoe(0:255),ietoa(0:255)
      COMMON /hrdwrd/ nbytw,nbitw,iord(8)

      CHARACTER*(*) chr
      CHARACTER*1   cval(8)
      dimension     ibay(*),ival(2)
      equivalence(cval,ival)

C----------------------------------------------------------------------
C----------------------------------------------------------------------

      lb = iord(nbytw)

C     LB now points to the "low-order" (i.e. least significant) byte
C     within a machine word.

      ival(1) = 0
      nbit = 8

      DO i=1,nchr
      IF(i.LE.len(chr)) THEN
         cval(lb) = chr(i:i)
      ELSE
         cval(lb) = ' '
      ENDIF

C     If the machine is EBCDIC, then translate character CVAL(LB) from
C     EBCDIC to ASCII.

      IF(iascii.EQ.0) CALL ipkm(cval(lb),1,ietoa(iupm(cval(lb),8)))

      nwd  = ibit/nbitw + 1
      nbt  = mod(ibit,nbitw)
      int = ishft(ival(1),nbitw-nbit)
      int = ishft(int,-nbt)
      msk = ishft(  -1,nbitw-nbit)
      msk = ishft(msk,-nbt)
      ibay(nwd) = irev(ior(iand(irev(ibay(nwd)),not(msk)),int))
      IF(nbt+nbit.GT.nbitw) THEN

C        This character will not fit within the current word (i.e.
C        array member) of IBAY, because there are less than 8 bits of
C        space left.  Store as many bits as will fit within the current
C        word and then store the remaining bits within the next word.

         int = ishft(ival(1),2*nbitw-(nbt+nbit))
         msk = ishft(  -1,2*nbitw-(nbt+nbit))
         ibay(nwd+1) = irev(ior(iand(irev(ibay(nwd+1)),not(msk)),int))
      ENDIF
      ibit = ibit + nbit
      ENDDO

C  EXITS
C  -----

      RETURN
      END