hwrf-baseline-20120103-1354/ungrib/src/ngl/w3/w3fi73.f

   1       SUBROUTINE W3FI73 (IBFLAG,IBMAP,IBLEN,BMS,LENBMS,IER)
   2 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   3 C                .      .    .                                       .
   4 C SUBPROGRAM:  W3FI73        CONSTRUCT GRIB BIT MAP SECTION (BMS)
   5 C   PRGMMR: FARLEY           ORG: NMC421      DATE:92-11-16
   6 C
   7 C ABSTRACT: THIS SUBROUTINE CONSTRUCTS A GRIB BIT MAP SECTION.
   8 C
   9 C PROGRAM HISTORY LOG:
  10 C   92-07-01  M. FARLEY      ORIGINAL AUTHOR
  11 C   94-02-14  CAVANAUGH      RECODED
  12 C   95-10-31  IREDELL        REMOVED SAVES AND PRINTS
  13 C
  14 C USAGE:    CALL W3FI73 (IBFLAG, IBMAP, IBLEN, BMS, LENBMS, IER)
  15 C   INPUT ARGUMENT LIST:
  16 C     IBFLAG      - 0, IF BIT MAP SUPPLIED BY USER
  17 C                 - #, NUMBER OF PREDEFINED CENTER BIT MAP
  18 C     IBMAP       - INTEGER ARRAY CONTAINING USER BIT MAP
  19 C     IBLEN       - LENGTH OF BIT MAP
  20 C
  21 C   OUTPUT ARGUMENT LIST:
  22 C     BMS       - COMPLETED GRIB BIT MAP SECTION
  23 C     LENBMS    - LENGTH OF BIT MAP SECTION
  24 C     IER       - 0 NORMAL EXIT, 8 = IBMAP VALUES ARE ALL ZERO
  25 C
  26 C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
  27 C
  28 C ATTRIBUTES:
  29 C   LANGUAGE: IBM370 VS FORTRAN 77, CRAY CFT77 FORTRAN
  30 C   MACHINE:  HDS, CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256
  31 C
  32 C$$$
  33 C
  34       INTEGER       IBMAP(*)
  35       INTEGER       LENBMS
  36       INTEGER       IBLEN
  37       INTEGER       IBFLAG
  38 C
  39       CHARACTER*1   BMS   (*)
  40 C
  41       IER   = 0
  42 C
  43 C
  44       IZ  = 0
  45       DO 20 I = 1, IBLEN
  46           IF (IBMAP(I).EQ.0) IZ  = IZ + 1
  47    20 CONTINUE
  48       IF (IZ.EQ.IBLEN) THEN
  49 C
  50 C                         AT THIS POINT ALL BIT MAP POSITIONS ARE ZERO
  51 C
  52               IER = 8
  53               RETURN
  54       END IF
  55 C
  56 C                          BIT MAP IS A COMBINATION OF ONES AND ZEROS
  57 C                          OR      BIT MAP ALL ONES
  58 C
  59 C                     CONSTRUCT BIT MAP FIELD OF BIT MAP SECTION
  60 C
  61       CALL SBYTES (BMS,IBMAP,48,1,0,IBLEN)
  62 C
  63       IF (MOD(IBLEN,16).NE.0) THEN
  64           NLEFT  = 16 - MOD(IBLEN,16)
  65       ELSE
  66           NLEFT  = 0
  67       END IF
  68 C
  69       NUM  = 6 + (IBLEN+NLEFT) / 8
  70 C
  71 C
  72 C                          CONSTRUCT BMS FROM COLLECTED DATA
  73 C
  74 C                          SIZE INTO FIRST THREE BYTES
  75       CALL SBYTE (BMS,NUM,0,24)
  76 C                          NUMBER OF FILL BITS INTO BYTE 4
  77       CALL SBYTE (BMS,NLEFT,24,8)
  78 C                          OCTET 5-6 TO CONTAIN INFO FROM IBFLAG
  79       CALL SBYTE (BMS,IBFLAG,32,16)
  80 C
  81 C                          BIT MAP MAY BE ALL ONES OR A COMBINATION
  82 C                          OF ONES AND ZEROS
  83 C
  84 C                          ACTUAL BITS OF BIT MAP PLACED ALL READY
  85 C
  86 C                          INSTALL FILL POSITIONS IF NEEDED
  87       IF (NLEFT.NE.0) THEN
  88           NLEFT  = 16 - NLEFT
  89 C                          ZERO FILL POSITIONS
  90           CALL SBYTE (BMS,0,IBLEN+48,NLEFT)
  91       END IF
  92 C
  93 C     STORE NUM IN LENBMS  (LENGTH OF BMS SECTION)
  94 C
  95       LENBMS = NUM
  96 C     PRINT *,'W3FI73 - BMS LEN =',NUM,LENBMS
  97 C
  98       RETURN
  99       END