ungrib/src/ngl/w3/pdseup.f

   1 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   2 C                .      .    .                                       .
   3 C SUBPROGRAM:    PDSEUP.F    UNPACKS GRIB PDS EXTENSION 41- FOR ENSEMBLE
   4 C   PRGMMR: RICHARD WOBUS    ORG: W/NP20     DATE: 98-09-28
   5 C
   6 C ABSTRACT: UNPACKS GRIB 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 EXTRACTION
  13 C
  14 C USAGE:    CALL PDSENS.F(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,MSGA)
  15 C   INPUT ARGUMENT LIST:
  16 C     ILAST    - LAST BYTE TO BE UNPACKED (IF GREATER/EQUAL TO FIRST BYT
  17 C                IN ANY OF FOUR SECTIONS BELOW, WHOLE SECTION IS PACKED.
  18 C     MSGA     - FULL PDS SECTION, INCLUDING NEW ENSEMBLE EXTENSION
  19 C
  20 C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
  21 C     KENS(5)  - BYTES 41-45 (GENERAL SECTION, ALWAYS PRESENT.)
  22 C     KPROB(2) - BYTES 46-47 (PROBABILITY SECTION, PRESENT ONLY IF NEEDE
  23 C     XPROB(2) - BYTES 48-51&52-55 (PROBABILITY SECTION, IF NEEDED.)
  24 C     KCLUST(16)-BYTES 61-76 (CLUSTERING SECTION, IF NEEDED.)
  25 C     KMEMBR(80)-BYTES 77-86 (CLUSTER MEMBERSHIP SECTION, IF NEEDED.)
  26 C
  27 C REMARKS: USE PDSENS.F FOR PACKING PDS ENSEMBLE EXTENSION.
  28 C   SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
  29 C
  30 C ATTRIBUTES:
  31 C   LANGUAGE: CF77 FORTRAN
  32 C   MACHINE:  CRAY, WORKSTATIONS
  33 C
  34 C$$$
  35 C
  36           SUBROUTINE PDSEUP(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,MSGA)
  37           INTEGER KENS(5),KPROB(2),KCLUST(16),KMEMBR(80)
  38           DIMENSION XPROB(2)
  39           INTEGER KREF
  40           CHARACTER*1 MSGA(100)
  41           REAL REFNCE
  42           CHARACTER*1 CKREF(8)
  43           EQUIVALENCE   (CKREF(1),KREF,REFNCE)
  44 C       CHECKING TOTAL NUMBER OF BYTES IN PDS (IBYTES)
  45           CALL GBYTE(MSGA, IBYTES, 0,24)
  46           IF(ILAST.GT.IBYTES) THEN
  47 C         ILAST=IBYTES
  48           GO TO 333
  49           ENDIF
  50           IF(ILAST.LT.41) THEN
  51           GO TO 333
  52           ENDIF
  53 C       UNPACKING FIRST SECTION (GENERAL INFORMATION)
  54       CALL GBYTES(MSGA,KENS,40*8,8,0,5)
  55 C       UNPACKING 2ND SECTION (PROBABILITY SECTION)
  56       IF(ILAST.GE.46) THEN
  57       CALL GBYTES(MSGA,KPROB,45*8,8,0,2)
  58 C
  59 C
  60       CALL GBYTE (MSGA,KREF,47*8,32)
  61       CALL W3FI01(LW)
  62       IF (LW.EQ.4) THEN
  63         CALL GBYTE (CKREF,JSGN,0,1)
  64         CALL GBYTE (CKREF,JEXP,1,7)
  65         CALL GBYTE (CKREF,IFR,8,24)
  66       ELSE
  67         CALL GBYTE (CKREF,JSGN,32,1)
  68         CALL GBYTE (CKREF,JEXP,33,7)
  69         CALL GBYTE (CKREF,IFR,40,24)
  70       ENDIF
  71       IF (IFR.EQ.0) THEN
  72           REFNCE  = 0.0
  73       ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN
  74           REFNCE  = 0.0
  75       ELSE
  76           REFNCE  = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6)
  77           IF (JSGN.NE.0) REFNCE = - REFNCE
  78       END IF
  79           XPROB(1)=REFNCE
  80 C
  81       CALL GBYTE (MSGA,KREF,51*8,32)
  82       CALL W3FI01(LW)
  83       IF (LW.EQ.4) THEN
  84         CALL GBYTE (CKREF,JSGN,0,1)
  85         CALL GBYTE (CKREF,JEXP,1,7)
  86         CALL GBYTE (CKREF,IFR,8,24)
  87       ELSE
  88         CALL GBYTE (CKREF,JSGN,32,1)
  89         CALL GBYTE (CKREF,JEXP,33,7)
  90         CALL GBYTE (CKREF,IFR,40,24)
  91       ENDIF
  92       IF (IFR.EQ.0) THEN
  93           REFNCE  = 0.0
  94       ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN
  95           REFNCE  = 0.0
  96       ELSE
  97           REFNCE  = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6)
  98           IF (JSGN.NE.0) REFNCE = - REFNCE
  99       END IF
 100           XPROB(2)=REFNCE
 101           ENDIF
 102 C
 103 C       UNPACKING 3RD SECTION (CLUSTERING INFORMATION)
 104       IF(ILAST.GE.61) CALL GBYTES(MSGA,KCLUST,60*8,8,0,16)
 105 C       UNPACKING 4TH SECTION (CLUSTERMEMBERSHIP INFORMATION)
 106       IF(ILAST.GE.77) CALL GBYTES(MSGA,KMEMBR,76*8,1,0,80)
 107 C
 108  333  CONTINUE
 109           RETURN
 110           END