var/external/bufr/closmg.f

   1       SUBROUTINE CLOSMG(LUNIN)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    CLOSMG
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT
   9 C   ABS(LUNIN) HAS BEEN OPENED FOR OUTPUT OPERATIONS.  IT CLOSES A BUFR
  10 C   MESSAGE PREVIOUSLY OPENED BY EITHER BUFR ARCHIVE LIBRARY
  11 C   SUBROUTINES OPENMG OR OPENMB AND WRITES IT TO THE UNIT ABS(LUNIN).
  12 C   SINCE OPENMG AND OPENMB NORMALLY CALL THIS INTERNALLY, IT IS NOT
  13 C   CALLED TOO OFTEN FROM AN APPLICATION PROGRAM.
  14 C
  15 C PROGRAM HISTORY LOG:
  16 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  17 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  18 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  19 C                           ROUTINE "BORT"
  20 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  21 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  22 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  23 C                           BUFR FILES UNDER THE MPI)
  24 C 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  25 C                           10,000 TO 20,000 BYTES
  26 C 2003-05-19  J. WOOLLEN -- CORRECTED A PROBLEM INTRODUCED IN A
  27 C                           PREVIOUS (MAY 2002) IMPLEMENTATION WHICH
  28 C                           PREVENTED THE DUMP CENTER TIME AND
  29 C                           INTITIATION TIME MESSAGES FROM BEING
  30 C                           WRITTEN OUT (THIS AFFECTED APPLICATION
  31 C                           PROGRAM BUFR_DUMPMD, IF IT WERE RECOMPILED,
  32 C                           IN THE DATA DUMPING PROCESS)
  33 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  34 C                           INTERDEPENDENCIES
  35 C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED
  36 C                           DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
  37 C                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
  38 C                           TERMINATES ABNORMALLY
  39 C 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  40 C                           20,000 TO 50,000 BYTES
  41 C 2005-05-26  D. KEYSER  -- ALLOWS OVERRIDE OF PREVIOUS LOGIC THAT HAD
  42 C                           ALWAYS WRITTEN OUT MESSAGE NUMBERS 1 AND 2
  43 C                           EVEN WHEN THEY CONTAINED ZERO SUBSETS
  44 C                           (ASSUMED THESE ARE DUMMIES, CONTAINING ONLY
  45 C                           CENTER AND DUMP TIME) (NO OTHER EMPTY
  46 C                           MESSAGES WERE WRITTEN OUT), DONE BY PASSING
  47 C                           IN A NEGATIVE UNIT NUMBER ARGUMENT THE
  48 C                           FIRST TIME THIS ROUTINE IS CALLED BY AN
  49 C                           APPLICATION PROGRAM (ALL EMPTY MESSAGES ARE
  50 C                           SKIPPED) (ASSUMES DUMMY MESSAGES ARE NOT IN
  51 C                           INPUT FILE), NOTE: THIS REMAINS SET FOR THE
  52 C                           PARTICULAR FILE BEING WRITTEN TO EACH TIME
  53 C                           CLOSMG IS CALLED, REGARDLESS OF THE SIGN OF
  54 C                           THE UNIT NUMBER - THIS IS NECESSARY BECAUSE
  55 C                           THIS ROUTINE IS CALLED BY OTHER BUFRLIB
  56 C                           ROUTINES WHICH ALWAYS PASS IN A POSITIVE
  57 C                           UNIT NUMBER (THE APPLICATION PROGRAM SHOULD
  58 C                           ALWAYS CALL CLOSMG WITH A NEGATIVE UNIT
  59 C                           NUMBER IMMEDIATELY AFTER CALLING OPENBF FOR
  60 C                           THIS OUTPUT FILE IF THE INTENTION IS TO
  61 C                           NOT WRITE ANY EMPTY MESSAGES)
  62 C
  63 C USAGE:    CALL CLOSMG (LUNIN)
  64 C   INPUT ARGUMENT LIST:
  65 C     LUNIN    - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER
  66 C                FOR BUFR FILE
  67 C                  - IF LUNIN IS GREATER THAN ZERO, THEN MESSAGE NUMBER
  68 C                    1 OR 2 IS WRITTEN OUT EVEN IF THE NUMBER OF
  69 C                    SUBSETS WRITTEN INTO THE MESSAGE IS ZERO (THIS
  70 C                    ALLOWS "DUMMY" MESSAGES CONTAINING DUMP CENTER AND
  71 C                    INITIATION TIME TO BE COPIED), MESSAGE NUMBERS 3
  72 C                    AND HIGHER ARE NOT WRITTEN OUT IF THEY CONTAIN
  73 C                    ZERO SUBSETS
  74 C                  - IF LUNIN IS LESS THAN ZERO, THEN NO MESSAGES WITH
  75 C                    ZERO SUBSETS WRITTEN INTO THEM ARE WRITTEN OUT
  76 C                    FOR A PARTICULAR FILE BOTH IN THIS CALL AND IN ALL
  77 C                    SUBSEQUENT CALLS TO THIS ROUTINE BY AN APPLICATION
  78 C                    PROGRAM
  79 C
  80 C REMARKS:
  81 C    THIS ROUTINE CALLS:        BORT     MSGWRT   STATUS   WRCMPS
  82 C                               WTSTAT
  83 C    THIS ROUTINE IS CALLED BY: CLOSBF   MAKESTAB OPENMB   OPENMG
  84 C                               WRITSA
  85 C                               Also called by application programs.
  86 C
  87 C ATTRIBUTES:
  88 C   LANGUAGE: FORTRAN 77
  89 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  90 C
  91 C$$$
  92
  93       INCLUDE 'bufrlib.prm'
  94
  95       COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
  96      .                MBAY(MXMSGLD4,NFILES)
  97       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
  98      .                INODE(NFILES),IDATE(NFILES)
  99
 100       DIMENSION MSGLIM(NFILES)
 101
 102       DATA MSGLIM/NFILES*3/
 103
 104       SAVE MSGLIM
 105
 106 C-----------------------------------------------------------------------
 107 C-----------------------------------------------------------------------
 108
 109 C  CHECK THE FILE STATUS
 110 C  ---------------------
 111
 112       LUNIT = ABS(LUNIN)
 113       CALL STATUS(LUNIT,LUN,IL,IM)
 114       IF(LUNIT.NE.LUNIN) MSGLIM(LUN) = 0
 115       IF(IL.EQ.0) GOTO 900
 116       IF(IL.LT.0) GOTO 901
 117       IF(IM.NE.0) THEN
 118          IF(NSUB(LUN).GT.0) THEN
 119             CALL MSGWRT(LUNIT,MBAY(1,LUN),MBYT(LUN))
 120          ELSE IF(NSUB(LUN).EQ.0.AND.NMSG(LUN).LT.MSGLIM(LUN)) THEN
 121             CALL MSGWRT(LUNIT,MBAY(1,LUN),MBYT(LUN))
 122          ELSE IF(NSUB(LUN).LT.0) THEN
 123             CALL WRCMPS(-LUNIT)
 124          ENDIF
 125       ENDIF
 126       CALL WTSTAT(LUNIT,LUN,IL,0)
 127
 128 C  EXITS
 129 C  -----
 130
 131       RETURN
 132 900   CALL BORT('BUFRLIB: CLOSMG - OUTPUT BUFR FILE IS CLOSED, IT '//
 133      . 'MUST BE OPEN FOR OUTPUT')
 134 901   CALL BORT('BUFRLIB: CLOSMG - OUTPUT BUFR FILE IS OPEN FOR '//
 135      . 'INPUT, IT MUST BE OPEN FOR OUTPUT')
 136       END