wrfv2_fire/var/external/bufr/readsb.inc

   1       SUBROUTINE READSB(LUNIT,IRET)
   2
   3 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 !
   5 ! SUBPROGRAM:    READSB
   6 !   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 !
   8 ! ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT
   9 !   LUNIT HAS BEEN OPENED FOR INPUT OPERATIONS.  IT READS A SUBSET FROM
  10 !   A BUFR MESSAGE INTO INTERNAL SUBSET ARRAYS.  THE BUFR MESSAGE MUST
  11 !   HAVE BEEN PREVIOUSLY READ FROM UNIT LUNIT USING BUFR ARCHIVE
  12 !   LIBRARY SUBROUTINE READMG OR READERME AND MAY BE EITHER COMPRESSED
  13 !   OR UNCOMPRESSED.
  14 !
  15 ! PROGRAM HISTORY LOG:
  16 ! 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  17 ! 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  18 !                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  19 !                           ROUTINE "BORT"
  20 ! 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  21 !                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  22 !                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  23 !                           BUFR FILES UNDER THE MPI)
  24 ! 2000-09-19  J. WOOLLEN -- ADDED CALL TO NEW ROUTINE RDCMPS ALLOWING
  25 !                           SUBSETS TO NOW BE DECODED FROM COMPRESSED
  26 !                           BUFR MESSAGES; MAXIMUM MESSAGE LENGTH
  27 !                           INCREASED FROM 10,000 TO 20,000 BYTES
  28 ! 2002-05-14  J. WOOLLEN -- CORRECTED ERROR RELATING TO CERTAIN
  29 !                           FOREIGN FILE TYPES; REMOVED OLD CRAY
  30 !                           COMPILER DIRECTIVES
  31 ! 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  32 !                           INTERDEPENDENCIES
  33 ! 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED
  34 !                           DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
  35 !                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
  36 !                           TERMINATES ABNORMALLY
  37 ! 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  38 !                           20,000 TO 50,000 BYTES
  39 !
  40 ! USAGE:    CALL READSB (LUNIT, IRET)
  41 !   INPUT ARGUMENT LIST:
  42 !     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  43 !
  44 !   OUTPUT ARGUMENT LIST:
  45 !     IRET     - INTEGER: RETURN CODE:
  46 !                       0 = normal return
  47 !                      -1 = there are no more subsets in the BUFR
  48 !                           message
  49 !
  50 ! REMARKS:
  51 !    THIS ROUTINE CALLS:        BORT     RDCMPS   RDTREE   STATUS
  52 !                               UPB
  53 !    THIS ROUTINE IS CALLED BY: COPYSB   IREADSB  RDMEMS   READNS
  54 !                               RDMSGB   UFBINX   UFBPOS
  55 !                               Also called by application programs.
  56 !
  57 ! ATTRIBUTES:
  58 !   LANGUAGE: FORTRAN 77
  59 !   MACHINE:  PORTABLE TO ALL PLATFORMS
  60 !
  61 !$$$
  62
  63       INCLUDE 'bufrlib.prm'
  64
  65       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), &
  66                       INODE(NFILES),IDATE(NFILES)
  67       COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), &
  68                       MBAY(MXMSGLD4,NFILES)
  69       COMMON /UNPTYP/ MSGUNP(NFILES)
  70
  71       CHARACTER*128 BORT_STR
  72
  73 !-----------------------------------------------------------------------
  74 !-----------------------------------------------------------------------
  75
  76       IRET = 0
  77
  78 !  CHECK THE FILE STATUS
  79 !  ---------------------
  80
  81       CALL STATUS(LUNIT,LUN,IL,IM)
  82       IF(IL.EQ.0) GOTO 900
  83       IF(IL.GT.0) GOTO 901
  84       IF(IM.EQ.0) THEN
  85          IRET = -1
  86          GOTO 100
  87       ENDIF
  88
  89 !  SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE
  90 !  ---------------------------------------------
  91
  92       IF(NSUB(LUN).EQ.MSUB(LUN)) THEN
  93          IRET = -1
  94          GOTO 100
  95       ELSE
  96          NSUB(LUN) = NSUB(LUN) + 1
  97       ENDIF
  98
  99 !  READ THE NEXT SUBSET AND RESET THE POINTERS
 100 !  -------------------------------------------
 101
 102       IF(MSGUNP(LUN).EQ.0) THEN
 103          IBIT = MBYT(LUN)*8
 104          CALL UPB(NBYT,16,MBAY(1,LUN),IBIT)
 105          CALL RDTREE(LUN)
 106          MBYT(LUN) = MBYT(LUN) + NBYT
 107       ELSEIF(MSGUNP(LUN).EQ.1) THEN
 108 !  .... message with "standard" Section 3
 109          IBIT = MBYT(LUN)
 110          CALL RDTREE(LUN)
 111          MBYT(LUN) = IBIT
 112       ELSEIF(MSGUNP(LUN).EQ.2) THEN
 113 !  .... compressed message
 114          CALL RDCMPS(LUN)
 115       ELSE
 116          GOTO 902
 117       ENDIF
 118
 119 !  EXITS
 120 !  -----
 121
 122 100   RETURN
 123 900   CALL BORT('BUFRLIB: READSB - INPUT BUFR FILE IS CLOSED, IT MUST'// &
 124        ' BE OPEN FOR INPUT')
 125 901   CALL BORT('BUFRLIB: READSB - INPUT BUFR FILE IS OPEN FOR OUTPUT'// &
 126        ', IT MUST BE OPEN FOR INPUT')
 127 902   WRITE(BORT_STR,'("BUFRLIB: READSB - MESSAGE UNPACK TYPE",I3,"IS'// &
 128        ' NOT RECOGNIZED")') MSGUNP
 129       CALL BORT(BORT_STR)
 130       END SUBROUTINE READSB