ungrib/src/ngl/w3/getgb1s.f

   1 C-----------------------------------------------------------------------
   2       SUBROUTINE GETGB1S(CBUF,NLEN,NNUM,J,JPDS,JGDS,JENS,
   3      &                   K,KPDS,KGDS,KENS,LSKIP,LGRIB,IRET)
   4 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   5 C
   6 C SUBPROGRAM: GETGB1S        FINDS A GRIB MESSAGE
   7 C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 95-10-31
   8 C
   9 C ABSTRACT: FIND A GRIB MESSAGE.
  10 C   FIND IN THE INDEX FILE A REFERENCE TO THE GRIB MESSAGE REQUESTED.
  11 C   THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP
  12 C   AND THE UNPACKED PDS AND GDS PARAMETERS.  (A REQUESTED PARAMETER
  13 C   OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.)
  14 C
  15 C PROGRAM HISTORY LOG:
  16 C   95-10-31  IREDELL
  17 C
  18 C USAGE:    CALL GETGB1S(CBUF,NLEN,NNUM,J,JPDS,JGDS,JENS,
  19 C    &                   K,KPDS,KGDS,KENS,LSKIP,LGRIB,IRET)
  20 C   INPUT ARGUMENTS:
  21 C     CBUF         CHARACTER*1 (NLEN*NNUM) BUFFER CONTAINING INDEX DATA
  22 C     NLEN         INTEGER LENGTH OF EACH INDEX RECORD IN BYTES
  23 C     NNUM         INTEGER NUMBER OF INDEX RECORDS
  24 C     J            INTEGER NUMBER OF MESSAGES TO SKIP
  25 C                  (=0 TO SEARCH FROM BEGINNING)
  26 C     JPDS         INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH
  27 C                  (=-1 FOR WILDCARD)
  28 C     JGDS         INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH
  29 C                  (ONLY SEARCHED IF JPDS(3)=255)
  30 C                  (=-1 FOR WILDCARD)
  31 C     JENS         INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH
  32 C                  (ONLY SEARCHED IF JPDS(23)=2)
  33 C                  (=-1 FOR WILDCARD)
  34 C   OUTPUT ARGUMENTS:
  35 C     K            INTEGER MESSAGE NUMBER FOUND
  36 C                  (CAN BE SAME AS J IN CALLING PROGRAM
  37 C                  IN ORDER TO FACILITATE MULTIPLE SEARCHES)
  38 C     KPDS         INTEGER (200) UNPACKED PDS PARAMETERS
  39 C     KGDS         INTEGER (200) UNPACKED GDS PARAMETERS
  40 C     KENS         INTEGER (200) UNPACKED ENSEMBLE PDS PARMS
  41 C     LSKIP        INTEGER NUMBER OF BYTES TO SKIP
  42 C     LGRIB        INTEGER NUMBER OF BYTES TO READ
  43 C     IRET         INTEGER RETURN CODE
  44 C                    0      ALL OK
  45 C                    1      REQUEST NOT FOUND
  46 C
  47 C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
  48 C   THIS SUBPROGRAM IS INTENDED FOR PRIVATE USE BY GETGB ROUTINES ONLY.
  49 C
  50 C SUBPROGRAMS CALLED:
  51 C   GBYTE          UNPACK BYTES
  52 C   FI632          UNPACK PDS
  53 C   FI633          UNPACK GDS
  54 C   PDSEUP         UNPACK PDS EXTENSION
  55 C
  56 C ATTRIBUTES:
  57 C   LANGUAGE: FORTRAN 77
  58 C   MACHINE:  CRAY, WORKSTATIONS
  59 C
  60 C$$$
  61       CHARACTER CBUF(NLEN*NNUM)
  62       INTEGER JPDS(200),JGDS(200),JENS(200)
  63       INTEGER KPDS(200),KGDS(200),KENS(200)
  64       PARAMETER(LPDS=23,LGDS=22,LENS=5)     ! ACTUAL SEARCH RANGES
  65       CHARACTER CPDS(400)*1,CGDS(400)*1
  66       INTEGER KPTR(200)
  67       INTEGER IPDSP(LPDS),JPDSP(LPDS)
  68       INTEGER IGDSP(LGDS),JGDSP(LGDS)
  69       INTEGER IENSP(LENS),JENSP(LENS)
  70 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  71 C  COMPRESS REQUEST LISTS
  72       K=J
  73       LSKIP=0
  74       LGRIB=0
  75       IRET=1
  76 C  COMPRESS PDS REQUEST
  77       LPDSP=0
  78       DO I=1,LPDS
  79         IF(JPDS(I).NE.-1) THEN
  80           LPDSP=LPDSP+1
  81           IPDSP(LPDSP)=I
  82           JPDSP(LPDSP)=JPDS(I)
  83         ENDIF
  84       ENDDO
  85 C  COMPRESS GDS REQUEST
  86       LGDSP=0
  87       IF(JPDS(3).EQ.255) THEN
  88         DO I=1,LGDS
  89           IF(JGDS(I).NE.-1) THEN
  90             LGDSP=LGDSP+1
  91             IGDSP(LGDSP)=I
  92             JGDSP(LGDSP)=JGDS(I)
  93           ENDIF
  94         ENDDO
  95       ENDIF
  96 C  COMPRESS ENS REQUEST
  97       LENSP=0
  98       IF(JPDS(23).EQ.2) THEN
  99         DO I=1,LENS
 100           IF(JENS(I).NE.-1) THEN
 101             LENSP=LENSP+1
 102             IENSP(LENSP)=I
 103             JENSP(LENSP)=JENS(I)
 104           ENDIF
 105         ENDDO
 106       ENDIF
 107 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 108 C  SEARCH FOR REQUEST
 109       DOWHILE(IRET.NE.0.AND.K.LT.NNUM)
 110         K=K+1
 111         LT=0
 112 C  SEARCH FOR PDS REQUEST
 113         IF(LPDSP.GT.0) THEN
 114           CPDS=CHAR(0)
 115           CPDS(1:28)=CBUF((K-1)*NLEN+26:(K-1)*NLEN+53)
 116           NLESS=MAX(184-NLEN,0)
 117           CPDS(29:40-NLESS)=CBUF((K-1)*NLEN+173:(K-1)*NLEN+184-NLESS)
 118           KPTR=0
 119           CALL GBYTE(CBUF,KPTR(3),(K-1)*NLEN*8+25*8,3*8)
 120           KPDS(18)=1
 121           CALL GBYTE(CPDS,KPDS(4),7*8,8)
 122           CALL FI632(CPDS,KPTR,KPDS,IRET)
 123           DO I=1,LPDSP
 124             IP=IPDSP(I)
 125             LT=LT+ABS(JPDS(IP)-KPDS(IP))
 126           ENDDO
 127         ENDIF
 128 C  SEARCH FOR GDS REQUEST
 129         IF(LT.EQ.0.AND.LGDSP.GT.0) THEN
 130           CGDS=CHAR(0)
 131           CGDS(1:42)=CBUF((K-1)*NLEN+54:(K-1)*NLEN+95)
 132           NLESS=MAX(320-NLEN,0)
 133           CGDS(43:178-NLESS)=CBUF((K-1)*NLEN+185:(K-1)*NLEN+320-NLESS)
 134           KPTR=0
 135           CALL FI633(CGDS,KPTR,KGDS,IRET)
 136           DO I=1,LGDSP
 137             IP=IGDSP(I)
 138             LT=LT+ABS(JGDS(IP)-KGDS(IP))
 139           ENDDO
 140         ENDIF
 141 C  SEARCH FOR ENS REQUEST
 142         IF(LT.EQ.0.AND.LENSP.GT.0) THEN
 143           NLESS=MAX(172-NLEN,0)
 144           CPDS(41:100-NLESS)=CBUF((K-1)*NLEN+113:(K-1)*NLEN+172-NLESS)
 145           CALL PDSEUP(KENS,KPROB,XPROB,KCLUST,KMEMBR,45,CPDS)
 146           DO I=1,LENSP
 147             IP=IENSP(I)
 148             LT=LT+ABS(JENS(IP)-KENS(IP))
 149           ENDDO
 150         ENDIF
 151 C  RETURN IF REQUEST IS FOUND
 152         IF(LT.EQ.0) THEN
 153           CALL GBYTE(CBUF,LSKIP,(K-1)*NLEN*8,4*8)
 154           CALL GBYTE(CBUF,LGRIB,(K-1)*NLEN*8+20*8,4*8)
 155           IF(LPDSP.EQ.0) THEN
 156             CPDS=CHAR(0)
 157             CPDS(1:28)=CBUF((K-1)*NLEN+26:(K-1)*NLEN+53)
 158             NLESS=MAX(184-NLEN,0)
 159             CPDS(29:40-NLESS)=CBUF((K-1)*NLEN+173:(K-1)*NLEN+184-NLESS)
 160             KPTR=0
 161             CALL GBYTE(CBUF,KPTR(3),(K-1)*NLEN*8+25*8,3*8)
 162             KPDS(18)=1
 163             CALL GBYTE(CPDS,KPDS(4),7*8,8)
 164             CALL FI632(CPDS,KPTR,KPDS,IRET)
 165           ENDIF
 166           IF(LGDSP.EQ.0) THEN
 167             CGDS=CHAR(0)
 168             CGDS(1:42)=CBUF((K-1)*NLEN+54:(K-1)*NLEN+95)
 169             NLESS=MAX(320-NLEN,0)
 170             CGDS(43:178-NLESS)=CBUF((K-1)*NLEN+185:(K-1)*NLEN+320-NLESS)
 171             KPTR=0
 172             CALL FI633(CGDS,KPTR,KGDS,IRET)
 173           ENDIF
 174           IF(KPDS(23).EQ.2.AND.LENSP.EQ.0) THEN
 175             NLESS=MAX(172-NLEN,0)
 176             CPDS(41:100-NLESS)=CBUF((K-1)*NLEN+113:(K-1)*NLEN+172-NLESS)
 177             CALL PDSEUP(KENS,KPROB,XPROB,KCLUST,KMEMBR,45,CPDS)
 178           ENDIF
 179           IRET=0
 180         ENDIF
 181       ENDDO
 182 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 183       RETURN
 184       END