var/external/bufr/openbf.f

   1       SUBROUTINE OPENBF(LUNIT,IO,LUNDX)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    OPENBF
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE NORMALLY (I.E. EXCEPT WHEN INPUT ARGUMENT
   9 C   IO IS 'QUIET') IDENTIFIES A NEW LOGICAL UNIT TO THE BUFR ARCHIVE
  10 C   LIBRARY SOFTWARE FOR INPUT OR OUTPUT OPERATIONS.  HOWEVER, THE
  11 C   FIRST TIME IT IS CALLED, IT ALSO FIGURES OUT SOME IMPORTANT
  12 C   INFORMATION ABOUT THE LOCAL MACHINE ON WHICH THE SOFTWARE IS BEING
  13 C   RUN (VIA A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE WRDLEN), AND IT
  14 C   ALSO INITIALIZES ARRAYS IN MANY BUFR ARCHIVE LIBRARY COMMON BLOCKS
  15 C   (VIA A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE BFRINI). UP TO 32
  16 C   LOGICAL UNITS CAN BE CONNECTED TO THE BUFR ARCHIVE LIBRARY SOFTWARE
  17 C   AT ANY ONE TIME.
  18 C
  19 C   NOTE: IF IO IS PASSED IN AS 'QUIET', THEN OPENBF PERFORMS ONLY ONE
  20 C   FUNCTION - IT SIMPLY SETS THE "DEGREE OF PRINTOUT" SWITCH IPRT (IN
  21 C   COMMON BLOCK /QUIET/) TO THE VALUE OF INPUT ARGUMENT LUNDX,
  22 C   OVERRIDING ITS PREVIOUS VALUE.  A DEFAULT IPRT VALUE OF 0 (I.E.
  23 C   "LIMITED PRINTOUT") IS SET DURING THE FIRST CALL TO THIS ROUTINE,
  24 C   BUT THIS OR ANY OTHER IPRT VALUE MAY BE SET AND RESET AS OFTEN AS
  25 C   DESIRED VIA SUCCESSIVE CALLS TO OPENBF WITH IO = 'QUIET'.
  26 C   IN ALL SUCH CASES, OPENBF SIMPLY (RE)SETS IPRT AND THEN RETURNS
  27 C   WITHOUT ACTUALLY OPENING ANY FILES.  THE DEGREE OF PRINTOUT
  28 C   INCREASES AS IPRT INCREASES FROM "-1" TO "0" TO "1" TO "2".
  29 C
  30 C PROGRAM HISTORY LOG:
  31 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  32 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  33 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  34 C                           ROUTINE "BORT"
  35 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  36 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  37 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  38 C                           BUFR FILES UNDER THE MPI)
  39 C 2003-11-04  J. ATOR    -- ADDED IO='NUL' OPTION IN ORDER TO PREVENT
  40 C                           LATER WRITING TO BUFR FILE IN LUNIT (WAS IN
  41 C                           DECODER VERSION); ADDED DOCUMENTATION
  42 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  43 C                           INTERDEPENDENCIES
  44 C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY
  45 C                           DOCUMENTATION; OUTPUTS MORE COMPLETE
  46 C                           DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
  47 C                           ABNORMALLY, UNUSUAL THINGS HAPPEN OR FOR
  48 C                           INFORMATIONAL PURPOSES
  49 C 2004-08-18  J. ATOR    -- ADDED SAVE FOR IFIRST FLAG AND IO="NODX"
  50 C                           OPTION
  51 C 2005-11-29  J. ATOR    -- ADDED COMMON /MSGFMT/ AND ICHKSTR CALL
  52 C 2009-03-23  J. ATOR    -- ADDED IO='SEC3' OPTION; REMOVED CALL TO
  53 C                           POSAPN; CLARIFIED COMMENTS; USE ERRWRT
  54 C 2010-05-11  J. ATOR    -- ADDED COMMON /STCODE/
  55 C 2012-06-18  J. ATOR    -- ADDED IO='INUL' OPTION
  56 C 2012-09-15  J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE;
  57 C                           USE INQUIRE TO OBTAIN THE FILENAME;
  58 C                           CALL C ROUTINES OPENRB, OPENWB, AND
  59 C                           OPENAB TO CONNECT BUFR FILES TO C;
  60 C                           ADDED IO TYPE 'INX' TO ENABLE OPEN AND
  61 C                           CLOSE FOR C FILE WITHOUT CLOSING FORTRAN
  62 C                           FILE; ADD IO TYPE 'FIRST' TO SUPPORT CALLS
  63 C                           TO BFRINI AND WRDLEN PRIOR TO USER RESET
  64 C                           OF BUFRLIB PARAMETERS FOUND IN NEW ROUTINES
  65 C                           SETBMISS AND SETBLOCK
  66 C
  67 C USAGE:    CALL OPENBF (LUNIT, IO, LUNDX)
  68 C   INPUT ARGUMENT LIST:
  69 C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  70 C                (UNLESS IO IS 'QUIET', THEN A DUMMY)
  71 C     IO       - CHARACTER*(*): FLAG INDICATING HOW LUNIT IS TO BE
  72 C                USED BY THE SOFTWARE:
  73 C                    'IN' = input operations with table processing
  74 C                   'INX' = input  operations w/o table processing
  75 C                   'OUX' = output operations w/o table processing
  76 C                   'OUT' = output operations with table processing
  77 C                  'SEC3' = same as 'IN', except use Section 3 of input
  78 C                           messages for decoding rather than dictionary
  79 C                           table information from LUNDX; in this case
  80 C                           LUNDX is ignored, and user must provide
  81 C                           appropriate BUFR master tables within
  82 C                           directory specified by a subsequent call
  83 C                           to subroutine MTINFO
  84 C                  'NODX' = same as 'OUT', except don't write dictionary
  85 C                           (i.e. DX) table messages to LUNIT
  86 C                   'APN' = same as 'NODX', except begin writing at end
  87 C                           of file ("append")
  88 C                   'APX' = same as 'APN', except backspace before
  89 C                           appending
  90 C                   'NUL' = same as 'OUT', except don't write any
  91 C                           messages whatsoever to LUNIT (e.g. when
  92 C                           subroutine WRITSA is to be used)
  93 C                  'INUL' = same as 'IN', except don't read any
  94 C                           messages whatsoever from LUNIT (e.g. when
  95 C                           subroutine READERME is to be used)
  96 C                 'QUIET' = LUNIT is ignored, this is an indicator
  97 C                           that the value for IPRT in COMMON block
  98 C                           /QUIET/ is being reset (see LUNDX)
  99 C                 'FIRST' = calls bfrini and wrdlen as a prelude to user
 100 c                           resetting of bufrlib parameters such as
 101 c                           missing value or output block type
 102 C     LUNDX    - INTEGER: IF IO IS NOT 'QUIET':
 103 C                            FORTRAN logical unit number containing
 104 C                            dictionary table information to be used in
 105 C                            reading/writing from/to LUNIT (depending
 106 C                            on the case); may be set equal to LUNIT if
 107 C                            dictionary table information is already
 108 C                            embedded in LUNIT
 109 C                         IF IO IS 'QUIET':
 110 C                            Indicator for degree of printout:
 111 C                              -1 = NO printout except for ABORT
 112 C                                   messages
 113 C                               0 = LIMITED printout (default)
 114 C                               1 = ALL warning messages are printed
 115 C                                   out
 116 C                               2 = ALL warning AND informational
 117 C                                   messages are printed out
 118 C                            (Note: this does not change until OPENBF
 119 C                                   is again called with IO equal to
 120 C                                   'QUIET')
 121 C
 122 C   INPUT FILES:
 123 C     UNIT "LUNIT" - BUFR FILE
 124 C
 125 C REMARKS:
 126 C    THIS ROUTINE CALLS:        BFRINI   BORT     DXINIT   ERRWRT
 127 C                               POSAPX   READDX   STATUS   WRDLEN
 128 C                               WRITDX   WTSTAT   OPENRB   OPENWB
 129 C                               OPENAB
 130 C    THIS ROUTINE IS CALLED BY: COPYBF   GETBMISS MESGBC   MESGBF
 131 C                               RDMGSB   UFBINX   UFBMEM   UFBMEX
 132 C                               UFBTAB   SETBMISS SETBLOCK
 133 C                               Also called by application programs.
 134 C
 135 C ATTRIBUTES:
 136 C   LANGUAGE: FORTRAN 77
 137 C   MACHINE:  PORTABLE TO ALL PLATFORMS
 138 C
 139 C$$$
 140
 141       INCLUDE 'bufrlib.prm'
 142
 143       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
 144      .                INODE(NFILES),IDATE(NFILES)
 145       COMMON /STBFR / IOLUN(NFILES),IOMSG(NFILES)
 146       COMMON /NULBFR/ NULL(NFILES)
 147       COMMON /SC3BFR/ ISC3(NFILES),TAMNEM(NFILES)
 148       COMMON /LUSHR/  LUS(NFILES)
 149       COMMON /STCODE/ ISCODES(NFILES)
 150       COMMON /QUIET / IPRT
 151
 152       CHARACTER*(*) IO
 153       CHARACTER*255 filename,fileacc
 154       CHARACTER*128 BORT_STR,ERRSTR
 155       CHARACTER*28  CPRINT(0:3)
 156       CHARACTER*8   TAMNEM
 157       CHARACTER*1   BSTR(4)
 158
 159       DATA IFIRST/0/
 160       DATA          CPRINT/
 161      . ' (only ABORTs)              ',
 162      . ' (limited - default)        ',
 163      . ' (all warnings)             ',
 164      . ' (all warning+informational)'/
 165
 166       SAVE IFIRST
 167
 168 C-----------------------------------------------------------------------
 169 C-----------------------------------------------------------------------
 170
 171 C     If this is the first call to this subroutine, initialize
 172 C     IPRT in /QUIET/ as 0 (limited printout - except for abort
 173 C     messages)
 174
 175       IF(IFIRST.EQ.0) IPRT = 0
 176
 177       IF(IO.EQ.'QUIET') THEN
 178 c  .... override previous IPRT value (printout indicator)
 179          IF(LUNDX.LT.-1)  LUNDX = -1
 180          IF(LUNDX.GT. 2)  LUNDX =  2
 181          IF(LUNDX.GE.0) THEN
 182       CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
 183       WRITE ( UNIT=ERRSTR, FMT='(A,I3,A,A,I3,A)' )
 184      . 'BUFRLIB: OPENBF - DEGREE OF MESSAGE PRINT INDICATOR '//
 185      . 'CHNGED FROM',IPRT,CPRINT(IPRT+1),' TO',LUNDX,CPRINT(LUNDX+1)
 186       CALL ERRWRT(ERRSTR)
 187       CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
 188       CALL ERRWRT(' ')
 189          ENDIF
 190          IPRT = LUNDX
 191       ENDIF
 192
 193       IF(IFIRST.EQ.0) THEN
 194
 195 C        If this is the first call to this subroutine, then call WRDLEN
 196 C        to figure out some important information about the local
 197 C        machine and call BFRINI to initialize some global variables.
 198
 199 C        NOTE: WRDLEN must be called prior to calling BFRINI!
 200
 201          CALL WRDLEN
 202          CALL BFRINI
 203          IFIRST = 1
 204       ENDIF
 205
 206       IF(IO.EQ.'FIRST') GOTO 100
 207       IF(IO.EQ.'QUIET') GOTO 100
 208
 209 C  SEE IF A FILE CAN BE OPENED
 210 C  ---------------------------
 211
 212       CALL STATUS(LUNIT,LUN,IL,IM)
 213       IF(LUN.EQ.0) GOTO 900
 214       IF(IL .NE.0) GOTO 901
 215       NULL(LUN) = 0
 216       ISC3(LUN) = 0
 217       ISCODES(LUN) = 0
 218       LUS(LUN) = 0
 219
 220 C  USE INQUIRE TO OBTAIN THE FILENAME ASSOCIATED WITH UNIT LUNIT
 221 C  -------------------------------------------------------------
 222
 223       IF (IO.NE.'NUL' .AND. IO.NE.'INUL') THEN
 224          inquire(lunit,access=fileacc)
 225          if(fileacc=='UNDEFINED') open(lunit)
 226          inquire(lunit,name=filename)
 227          filename=trim(filename)//char(0)
 228       ENDIF
 229
 230 C  SET INITIAL OPEN DEFAULTS (CLEAR OUT A MSG CONTROL WORD PARTITION)
 231 C  ------------------------------------------------------------------
 232
 233       NMSG (LUN) = 0
 234       NSUB (LUN) = 0
 235       MSUB (LUN) = 0
 236       INODE(LUN) = 0
 237       IDATE(LUN) = 0
 238
 239 C  DECIDE HOW TO OPEN THE FILE AND SETUP THE DICTIONARY
 240 C  ----------------------------------------------------
 241
 242       IF(IO.EQ.'IN') THEN
 243          call openrb(lun,filename)
 244          CALL WTSTAT(LUNIT,LUN,-1,0)
 245          CALL READDX(LUNIT,LUN,LUNDX)
 246       ELSE IF(IO.EQ.'INUL') THEN
 247          CALL WTSTAT(LUNIT,LUN,-1,0)
 248          IF(LUNIT.NE.LUNDX) CALL READDX(LUNIT,LUN,LUNDX)
 249          NULL(LUN) = 1
 250       ELSE IF(IO.EQ.'NUL') THEN
 251          CALL WTSTAT(LUNIT,LUN, 1,0)
 252          IF(LUNIT.NE.LUNDX) CALL READDX(LUNIT,LUN,LUNDX)
 253          NULL(LUN) = 1
 254       ELSE IF(IO.EQ.'INX') THEN
 255          call openrb(lun,filename)
 256          CALL WTSTAT(LUNIT,LUN,-1,0)
 257          NULL(LUN) = 1
 258       ELSE IF(IO.EQ.'OUX') THEN
 259          call openwb(lun,filename)
 260          CALL WTSTAT(LUNIT,LUN, 1,0)
 261       ELSE IF(IO.EQ.'SEC3') THEN
 262          call openrb(lun,filename)
 263          CALL WTSTAT(LUNIT,LUN,-1,0)
 264          ISC3(LUN) = 1
 265       ELSE IF(IO.EQ.'OUT') THEN
 266          call openwb(lun,filename)
 267          CALL WTSTAT(LUNIT,LUN, 1,0)
 268          CALL WRITDX(LUNIT,LUN,LUNDX)
 269       ELSE IF(IO.EQ.'NODX') THEN
 270          call openwb(lun,filename)
 271          CALL WTSTAT(LUNIT,LUN, 1,0)
 272          CALL READDX(LUNIT,LUN,LUNDX)
 273       ELSE IF(IO.EQ.'APN' .OR. IO.EQ.'APX') THEN
 274          call openab(lun,filename)
 275          CALL WTSTAT(LUNIT,LUN, 1,0)
 276          IF(LUNIT.NE.LUNDX) CALL READDX(LUNIT,LUN,LUNDX)
 277          CALL POSAPX(LUNIT)
 278       ELSE
 279          GOTO 904
 280       ENDIF
 281
 282       GOTO 100
 283
 284 C     FILE OPENED FOR INPUT IS EMPTY - LET READMG OR READERME GIVE
 285 C     THE BAD NEWS LATER
 286
 287 200   REWIND LUNIT
 288       IF(IPRT.GE.0) THEN
 289       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 290       WRITE ( UNIT=ERRSTR, FMT='(A,I3,A)' )
 291      .  'BUFRLIB: OPENBF - INPUT BUFR FILE IN UNIT ', LUNIT,
 292      .  ' IS EMPTY'
 293       CALL ERRWRT(ERRSTR)
 294       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 295       CALL ERRWRT(' ')
 296       ENDIF
 297       CALL WTSTAT(LUNIT,LUN,-1,0)
 298
 299 C  INITIALIZE THE DICTIONARY TABLE PARTITION
 300 C  -----------------------------------------
 301
 302       CALL DXINIT(LUN,0)
 303
 304 C  EXITS
 305 C  -----
 306
 307 100   RETURN
 308 900   WRITE(BORT_STR,'("BUFRLIB: OPENBF - THERE ARE ALREADY",I3,'//
 309      . '" BUFR FILES OPENED, CANNOT OPEN FILE CONNECTED TO UNIT",I4)')
 310      . NFILES,LUNIT
 311       CALL BORT(BORT_STR)
 312 901   WRITE(BORT_STR,'("BUFRLIB: OPENBF - THE FILE CONNECTED TO UNIT"'//
 313      . ',I5," IS ALREADY OPEN")') LUNIT
 314       CALL BORT(BORT_STR)
 315 904   CALL BORT('BUFRLIB: OPENBF - SECOND (INPUT) ARGUMENT MUST BE'//
 316      . ' "IN", "OUT", "NODX", "NUL", "APN", "APX", "SEC3"'//
 317      . ' OR "QUIET"')
 318       END