ungrib/src/ngl/w3/pdsens.f

   1 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   2 C                .      .    .                                       .
   3 C SUBPROGRAM:    PDSENS.F    PACKS GRIB PDS EXTENSION 41- FOR ENSEMBLE
   4 C   PRGMMR: RICHARD WOBUS    ORG: W/NP20     DATE: 98-09-28
   5 C
   6 C ABSTRACT: PACKS BRIB PDS EXTENSION STARTING ON BYTE 41 FOR ENSEMBLE
   7 C       FORECAST PRODUCTS. FOR FORMAT OF PDS EXTENSION, SEE NMC OFFICE NOTE 38
   8 C
   9 C PROGRAM HISTORY LOG:
  10 C   95-03-14  ZOLTAN TOTH AND MARK IREDELL
  11 C   95-10-31  IREDELL     REMOVED SAVES AND PRINTS
  12 C   98-09-28  WOBUS       CORRECTED MEMBER ENTRY, BLANK ALL UNUSED FIELDS
  13 C
  14 C USAGE:    CALL PDSENS.F(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,MSGA)
  15 C   INPUT ARGUMENT LIST:
  16 C     KENS(5)  - BYTES 41-45 (GENERAL SECTION, ALWAYS PRESENT.)
  17 C     KPROB(2) - BYTES 46-47 (PROBABILITY SECTION, PRESENT ONLY IF NEEDE
  18 C     XPROB(2) - BYTES 48-51&52-55 (PROBABILITY SECTION, IF NEEDED.)
  19 C     KCLUST(16)-BYTES 61-76 (CLUSTERING SECTION, IF NEEDED.)
  20 C     KMEMBR(80)-BYTES 77-86 (CLUSTER MEMBERSHIP SECTION, IF NEEDED.)
  21 C     ILAST    - LAST BYTE TO BE PACKED (IF GREATER OR EQUAL TO FIRST BY
  22 C                IN ANY OF FOUR SECTIONS ABOVE, WHOLE SECTION IS PACKED.
  23 C
  24 C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
  25 C     MSGA     - FULL PDS SECTION, INCLUDING NEW ENSEMBLE EXTENSION
  26 C
  27 C REMARKS: USE PDSEUP.F FOR UNPACKING PDS ENSEMBLE EXTENSION.
  28 C   SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
  29 C
  30 C ATTRIBUTES:
  31 C   LANGUAGE: FORTRAN 77
  32 C   MACHINE:  CRAY, WORKSTATIONS
  33 C
  34 C$$$
  35 C       TESTING GRIB EXTENSION 41- PACKER AND UNPACKER SUBROUTINES
  36 C
  37 CFPP$ NOCONCUR R
  38           SUBROUTINE PDSENS(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,MSGA)
  39           INTEGER KENS(5),KPROB(2),KCLUST(16),KMEMBR(80)
  40       DIMENSION XPROB(2)
  41           CHARACTER*1 MSGA(100)
  42           IF(ILAST.LT.41) THEN
  43           GO TO 333
  44           ENDIF
  45 C       PACKING IS DONE IN FOUR SECTIONS ENDING AT BYTE IL
  46           IF(ILAST.GE.41) IL=45
  47           IF(ILAST.GE.46) IL=55
  48           IF(ILAST.GE.61) IL=76
  49           IF(ILAST.GE.77) IL=86
  50           do i=42,il
  51             CALL SBYTE(MSGA, 0, i*8, 8)
  52           enddo
  53 C       CHANGING THE NUMBER OF BYTES (FIRST THREE BYTES IN PDS)
  54           CALL SBYTE(MSGA, IL, 0,24)
  55 C       PACKING FIRST SECTION (GENERAL INTORMATION SECTION)
  56       IF(IL.GE.45) CALL SBYTES(MSGA,KENS,40*8,8,0,5)
  57 C       PACKING 2ND SECTION (PROBABILITY SECTION)
  58       IF(IL.GE.55) THEN
  59           CALL SBYTES(MSGA,KPROB,45*8,8,0,2)
  60           CALL W3FI01(LW)
  61           CALL W3FI76(XPROB(1),IEXP,IMANT,8*LW)
  62           CALL SBYTE(MSGA,IEXP,47*8,8)
  63           CALL SBYTE(MSGA,IMANT,48*8,24)
  64           CALL W3FI76(XPROB(2),IEXP,IMANT,8*LW)
  65           CALL SBYTE(MSGA,IEXP,51*8,8)
  66           CALL SBYTE(MSGA,IMANT,52*8,24)
  67       ENDIF
  68 C       PACKING 3RD SECTION (CLUSTERING INFORMATION)
  69       IF(IL.GE.76) CALL SBYTES(MSGA,KCLUST,60*8,8,0,16)
  70 C       PACKING 4TH SECTION (CLUSTER MEMBERSHIP)
  71       IF(IL.GE.86) CALL SBYTES(MSGA,KMEMBR,76*8,1,0,80)
  72 C
  73  333  CONTINUE
  74           RETURN
  75           END