wrfv2_fire/var/external/bufr/rewnbf.inc

   1       SUBROUTINE REWNBF (LUNIT, ISR)
   2
   3 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 !
   5 ! SUBPROGRAM:    REWNBF
   6 !   PRGMMR: WOOLLEN          ORG: NP20       DATE: 2003-11-04
   7 !
   8 ! ABSTRACT: THIS SUBROUTINE, DEPENDING ON THE VALUE OF ISR, WILL
   9 !   EITHER:
  10 !        1) STORE THE CURRENT PARAMETERS ASSOCIATED WITH A BUFR FILE
  11 !   CONNECTED TO LUNIT (READ/WRITE POINTERS, ETC.), SET THE FILE STATUS
  12 !   TO READ, THEN REWIND THE BUFR FILE AND POSITION IT SUCH THAT THE
  13 !   NEXT BUFR MESSAGE READ WILL BE THE FIRST MESSAGE IN THE FILE
  14 !   CONTAINING ACTUAL SUBSETS WITH DATA; OR
  15 !        2) RESTORE THE BUFR FILE CONNECTED TO LUNIT TO THE PARAMETERS
  16 !   IT HAD PRIOR TO 1) ABOVE USING THE INFORMATION SAVED IN 1) ABOVE.
  17 !
  18 !   THIS ALLOWS INFORMATION TO BE EXTRACTED FROM A PARTICULAR SUBSET IN
  19 !   A BUFR FILE WHICH IS IN THE MIDST OF BEING READ FROM OR WRITTEN TO
  20 !   BY AN APPLICATION PROGRAM.  NOTE THAT FOR A PARTICULAR BUFR FILE 1)
  21 !   ABOVE MUST PRECEDE 2) ABOVE.  AN APPLICATION PROGRAM MIGHT FIRST
  22 !   CALL THIS SUBROUTINE WITH ISR = 0, THEN CALL EITHER BUFR ARCHIVE
  23 !   LIBRARY SUBROUTINE RDMGSB OR UFBINX TO GET INFO FROM A SUBSET, THEN
  24 !   CALL THIS ROUTINE AGAIN WITH ISR = 1 TO RESTORE THE POINTERS IN THE
  25 !   BUFR FILE TO THEIR ORIGINAL LOCATION.  ALSO, BUFR ARCHIVE LIBRARY
  26 !   SUBROUTINE UFBTAB WILL CALL THIS ROUTINE IF THE BUFR FILE IT IS
  27 !   ACTING UPON IS ALREADY OPEN FOR INPUT OR OUTPUT.
  28 !
  29 ! PROGRAM HISTORY LOG:
  30 ! 2003-11-04  J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN VERIFICATION
  31 !                           VERSION BUT MAY HAVE BEEN IN THE PRODUCTION
  32 !                           VERSION AT ONE TIME AND THEN REMOVED)
  33 ! 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED
  34 !                           DOCUMENTATION; OUTPUTS MORE COMPLETE
  35 !                           DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
  36 !                           ABNORMALLY
  37 ! 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  38 !                           20,000 TO 50,000 BYTES
  39 !
  40 ! USAGE:    CALL REWNBF (LUNIT, ISR)
  41 !   INPUT ARGUMENT LIST:
  42 !     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  43 !     ISR      - INTEGER: SWITCH:
  44 !                       0 = store current parameters associated with
  45 !                           BUFR file, set file status to read, rewind
  46 !                           file such that next message read is first
  47 !                           message containing subset data
  48 !                       1 = restore BUFR file with parameters saved
  49 !                           from the previous call to this routine with
  50 !                           ISR=0
  51 !
  52 !   INPUT FILES:
  53 !     UNIT "LUNIT" - BUFR FILE
  54 !
  55 ! REMARKS:
  56 !    THIS ROUTINE CALLS:        BORT     I4DY     RDMSGW   STATUS
  57 !                               WTSTAT
  58 !    THIS ROUTINE IS CALLED BY: UFBINX   UFBTAB
  59 !                               Also called by application programs.
  60 !
  61 ! ATTRIBUTES:
  62 !   LANGUAGE: FORTRAN 77
  63 !   MACHINE:  PORTABLE TO ALL PLATFORMS
  64 !
  65 !$$$
  66
  67       INCLUDE 'bufrlib.prm'
  68
  69       COMMON / MSGCWD / NMSG (NFILES), NSUB (NFILES), MSUB (NFILES),    &
  70       INODE (NFILES), IDATE (NFILES)
  71       COMMON / BITBUF / MAXBYT, IBIT, IBAY (MXMSGLD4), MBYT (NFILES),   &
  72       MBAY (MXMSGLD4, NFILES)
  73       COMMON / BUFRSR / JUNN, JILL, JIMM, JBIT, JBYT, JMSG, JSUB, KSUB, &
  74       JNOD, JDAT, JSR (NFILES), JBAY (MXMSGLD4)
  75
  76       CHARACTER(128) BORT_STR
  77
  78       DIMENSION MESG (MXMSGLD4)
  79
  80 !-----------------------------------------------------------------------
  81 !-----------------------------------------------------------------------
  82
  83 !  TRY TO TRAP BAD CALL PROBLEMS
  84 !  -----------------------------
  85
  86       IF (ISR.EQ.0) THEN
  87          CALL STATUS (LUNIT, LUN, IL, IM)
  88          IF (JSR (LUN) .NE.0) GOTO 900
  89          IF (IL.EQ.0) GOTO 901
  90       ELSEIF (ISR.EQ.1) THEN
  91          LUN = JUNN
  92          IF (JSR (JUNN) .NE.1) GOTO 902
  93       ELSE
  94          GOTO 903
  95       ENDIF
  96
  97 !  STORE FILE PARAMETERS AND SET FOR READING
  98 !  -----------------------------------------
  99
 100       IF (ISR.EQ.0) THEN
 101          JUNN = LUN
 102          JILL = IL
 103          JIMM = IM
 104          JBIT = IBIT
 105          JBYT = MBYT (LUN)
 106          JMSG = NMSG (LUN)
 107          JSUB = NSUB (LUN)
 108          KSUB = MSUB (LUN)
 109          JNOD = INODE (LUN)
 110          JDAT = IDATE (LUN)
 111          DO I = 1, JBYT
 112          JBAY (I) = MBAY (I, LUN)
 113          ENDDO
 114          CALL WTSTAT (LUNIT, LUN, - 1, 0)
 115       ENDIF
 116
 117 !  REWIND THE FILE AND POSITION AFTER THE DICTIONARY
 118 !  -------------------------------------------------
 119
 120       REWIND LUNIT
 121     1 CALL RDMSGW (LUNIT, MESG, IER)
 122       IF (IER.EQ. - 1) GOTO 2
 123       IF (IER.EQ. - 2) GOTO 904
 124       IF (IUPBS01 (MESG, 'MTYP') .EQ.11) GOTO 1
 125     2 BACKSPACE LUNIT
 126
 127 !  RESTORE FILE PARAMETERS AND POSITION IT TO WHERE IT WAS SAVED
 128 !  -------------------------------------------------------------
 129
 130       IF (ISR.EQ.1) THEN
 131          LUN = JUNN
 132          IL = JILL
 133          IM = JIMM
 134          IBIT = JBIT
 135          MBYT (LUN) = JBYT
 136          NMSG (LUN) = JMSG
 137          NSUB (LUN) = JSUB
 138          MSUB (LUN) = KSUB
 139          INODE (LUN) = JNOD
 140          IDATE (LUN) = I4DY (JDAT)
 141          DO I = 1, JBYT
 142          MBAY (I, LUN) = JBAY (I)
 143          ENDDO
 144          DO IMSG = 1, JMSG
 145          READ (LUNIT, ERR = 905, END = 906)
 146          ENDDO
 147          CALL WTSTAT (LUNIT, LUN, IL, IM)
 148       ENDIF
 149
 150       JSR (LUN) = MOD (JSR (LUN) + 1, 2)
 151
 152 !  EXITS
 153 !  -----
 154
 155       RETURN
 156   900 WRITE (BORT_STR, '("BUFRLIB: REWNBF - ATTEMPING TO SAVE '//'PARAME&
 157      &TERS FOR FILE FOR WHICH THEY HAVE ALREADY BEEN SAVED '//'(AND NOT &
 158      &YET RESTORED) (UNIT",I3,")")') LUNIT
 159       CALL BORT (BORT_STR)
 160   901 WRITE (BORT_STR, '("BUFRLIB: REWNBF - ATTEMPING TO SAVE '//       &
 161       'PARAMETERS FOR BUFR FILE WHICH IS NOT OPENED FOR EITHER INPUT'// &
 162       ' OR OUTPUT) (UNIT",I3,")")') LUNIT
 163       CALL BORT (BORT_STR)
 164   902 WRITE (BORT_STR, '("BUFRLIB: REWNBF - ATTEMPING TO RESTORE '//    &
 165       'PARAMETERS TO BUFR FILE WHICH WERE NEVER SAVED (UNIT",I3,")")')  &
 166       LUNIT
 167       CALL BORT (BORT_STR)
 168   903 WRITE (BORT_STR, '("BUFRLIB: REWNBF - SAVE/RESTORE SWITCH (INPUT '&
 169      &//'ARGUMENT ISR) IS NOT ZERO OR ONE (HERE =",I4,") (UNIT",I3,")")'&
 170      &)
 171       CALL BORT (BORT_STR)
 172   904 WRITE (BORT_STR, '("BUFRLIB: REWNBF - ERROR READING A DICTIONARY '&
 173      &//'MESSAGE AFTER REWIND OF BUFR FILE IN UNIT",I4,")")') LUNIT
 174       CALL BORT (BORT_STR)
 175   905 WRITE (BORT_STR, '("BUFRLIB: REWNBF - ERROR READING MSG (RECORD) '&
 176      &//'NO.",I5," IN ATTEMPT TO REPOSITION BUFR FILE IN UNIT",I3," TO'/&
 177      &/' ORIGINAL MSG NO.",I5)') IMSG, LUNIT, JMSG
 178       CALL BORT (BORT_STR)
 179   906 WRITE (BORT_STR, '("BUFRLIB: REWNBF - HIT END OF FILE BEFORE '//  &
 180       'REPOSITIONING BUFR FILE IN UNIT",I3," TO ORIGINAL MESSAGE '//    &
 181       'NO.",I5)') LUNIT, JMSG
 182       CALL BORT (BORT_STR)
 183       END SUBROUTINE REWNBF