var/external/bufr/pkc.f

   1       SUBROUTINE PKC(CHR,NCHR,IBAY,IBIT)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    PKC
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE PACKS A CHARACTER STRING (CHR) CONTAINING
   9 C   NCHR CHARACTERS INTO NCHR BYTES OF AN INTEGER ARRAY (IBAY),
  10 C   STARTING WITH BIT (IBIT+1).  ON OUTPUT, IBIT IS UPDATED TO POINT TO
  11 C   THE LAST BIT THAT WAS PACKED.  NOTE THAT THERE IS NO GUARANTEE THAT
  12 C   THE NCHR CHARACTERS WILL BE ALIGNED ON BYTE BOUNDARIES WHEN PACKED
  13 C   WITHIN IBAY.
  14 C
  15 C PROGRAM HISTORY LOG:
  16 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  17 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  18 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  19 C                           ROUTINE "BORT"
  20 C 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
  21 C 2003-11-04  J. WOOLLEN -- BIG-ENDIAN/LITTLE-ENDIAN INDEPENDENT (WAS
  22 C                           IN DECODER VERSION)
  23 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  24 C                           INTERDEPENDENCIES
  25 C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY
  26 C                           DOCUMENTATION; OUTPUTS MORE COMPLETE
  27 C                           DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
  28 C                           ABNORMALLY; CHANGED CALL FROM BORT TO BORT2
  29 C 2004-08-18  J. ATOR    -- MODIFIED TO BE COMPATIBLE WITH WRITLC
  30 C
  31 C USAGE:    CALL PKC (CHR, NCHR, IBAY, IBIT)
  32 C   INPUT ARGUMENT LIST:
  33 C     CHR      - CHARACTER*(*): CHARACTER STRING TO BE PACKED
  34 C     NCHR     - INTEGER: NUMBER OF BYTES OF IBAY WITHIN WHICH TO PACK
  35 C                CHR (I.E., THE NUMBER OF CHARACTERS IN CHR)
  36 C     IBIT     - INTEGER: BIT POINTER WITHIN IBAY INDICATING BIT AFTER
  37 C                WHICH TO START PACKING
  38 C
  39 C   OUTPUT ARGUMENT LIST:
  40 C     IBAY     - INTEGER: *-WORD PACKED BINARY ARRAY NOW CONTAINING
  41 C                PACKED CHR
  42 C     IBIT     - INTEGER: BIT POINTER WITHIN IBAY INDICATING LAST BIT
  43 C                THAT WAS PACKED
  44 C
  45 C REMARKS:
  46 C    THIS SUBROUTINE IS THE INVERSE OF BUFR ARCHIVE LIBRARY ROUTINE
  47 C    UPC.
  48 C
  49 C    THIS ROUTINE CALLS:        IPKM     IREV     IUPM
  50 C    THIS ROUTINE IS CALLED BY: CMSGINI  DXMINI   MSGINI   MSGWRT
  51 C                               STNDRD   WRCMPS   WRDXTB   WRITLC
  52 C                               WRTREE
  53 C                               Normally not called by any application
  54 C                               programs.
  55 C
  56 C ATTRIBUTES:
  57 C   LANGUAGE: FORTRAN 77
  58 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  59 C
  60 C$$$
  61
  62       COMMON /CHARAC/ IASCII,IATOE(0:255),IETOA(0:255)
  63       COMMON /HRDWRD/ NBYTW,NBITW,IORD(8)
  64
  65       CHARACTER*(*) CHR
  66       CHARACTER*1   CVAL(8)
  67       DIMENSION     IBAY(*),IVAL(2)
  68       EQUIVALENCE   (CVAL,IVAL)
  69
  70 C----------------------------------------------------------------------
  71 C----------------------------------------------------------------------
  72
  73       LB = IORD(NBYTW)
  74
  75 C     LB now points to the "low-order" (i.e. least significant) byte
  76 C     within a machine word.
  77
  78       IVAL(1) = 0
  79       NBIT = 8
  80
  81       DO I=1,NCHR
  82       IF(I.LE.LEN(CHR)) THEN
  83          CVAL(LB) = CHR(I:I)
  84       ELSE
  85          CVAL(LB) = ' '
  86       ENDIF
  87
  88 C     If the machine is EBCDIC, then translate character CVAL(LB) from
  89 C     EBCDIC to ASCII.
  90
  91       IF(IASCII.EQ.0) CALL IPKM(CVAL(LB),1,IETOA(IUPM(CVAL(LB),8)))
  92
  93       NWD  = IBIT/NBITW + 1
  94       NBT  = MOD(IBIT,NBITW)
  95       INT = ISHFT(IVAL(1),NBITW-NBIT)
  96       INT = ISHFT(INT,-NBT)
  97       MSK = ISHFT(  -1,NBITW-NBIT)
  98       MSK = ISHFT(MSK,-NBT)
  99       IBAY(NWD) = IREV(IOR(IAND(IREV(IBAY(NWD)),NOT(MSK)),INT))
 100       IF(NBT+NBIT.GT.NBITW) THEN
 101
 102 C        This character will not fit within the current word (i.e.
 103 C        array member) of IBAY, because there are less than 8 bits of
 104 C        space left.  Store as many bits as will fit within the current
 105 C        word and then store the remaining bits within the next word.
 106
 107          INT = ISHFT(IVAL(1),2*NBITW-(NBT+NBIT))
 108          MSK = ISHFT(  -1,2*NBITW-(NBT+NBIT))
 109          IBAY(NWD+1) = IREV(IOR(IAND(IREV(IBAY(NWD+1)),NOT(MSK)),INT))
 110       ENDIF
 111       IBIT = IBIT + NBIT
 112       ENDDO
 113
 114 C  EXITS
 115 C  -----
 116
 117       RETURN
 118       END