var/external/bufr/msgupd.f

   1       SUBROUTINE MSGUPD(LUNIT,LUN)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    MSGUPD
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE PACKS UP THE CURRENT SUBSET WITHIN MEMORY
   9 C  (ARRAY IBAY IN COMMON BLOCK /BITBUF/) AND THEN TRIES TO ADD IT TO
  10 C  THE BUFR MESSAGE THAT IS CURRENTLY OPEN WITHIN MEMORY FOR LUNIT
  11 C  (ARRAY MBAY IN COMMON BLOCK /BITBUF/).  IF THE SUBSET WILL NOT FIT
  12 C  INTO THE CURRENTLY OPEN MESSAGE, THEN THAT MESSAGE IS FLUSHED TO
  13 C  LUNIT AND A NEW ONE IS CREATED IN ORDER TO HOLD THE CURRENT SUBSET.
  14 C  IF THE SUBSET IS LARGER THAN AN EMPTY MESSAGE, THE SUBSET IS
  15 C  DISCARDED AND A DIAGNOSTIC IS PRINTED.
  16 C
  17 C PROGRAM HISTORY LOG:
  18 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  19 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  20 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  21 C                           ROUTINE "BORT"
  22 C 1998-12-14  J. WOOLLEN -- NO LONGER CALLS BORT IF A SUBSET IS LARGER
  23 C                           THAN A MESSAGE, JUST DISCARDS THE SUBSET
  24 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  25 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  26 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  27 C                           BUFR FILES UNDER THE MPI)
  28 C 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  29 C                           10,000 TO 20,000 BYTES
  30 C 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
  31 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  32 C                           INTERDEPENDENCIES
  33 C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY
  34 C                           DOCUMENTATION
  35 C 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  36 C                           20,000 TO 50,000 BYTES
  37 C 2009-03-23  J. ATOR    -- USE MSGFULL AND ERRWRT
  38 C
  39 C USAGE:    CALL MSGUPD (LUNIT, LUN)
  40 C   INPUT ARGUMENT LIST:
  41 C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  42 C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  43 C                (ASSOCIATED WITH FILE CONNECTED TO LOGICAL UNIT LUNIT)
  44 C
  45 C REMARKS:
  46 C    THIS ROUTINE CALLS:        ERRWRT   IUPB     MSGFULL  MSGINI
  47 C                               MSGWRT   MVB      PAD      PKB
  48 C                               USRTPL
  49 C    THIS ROUTINE IS CALLED BY: WRITSA   WRITSB
  50 C                               Normally not called by any application
  51 C                               programs.
  52 C
  53 C ATTRIBUTES:
  54 C   LANGUAGE: FORTRAN 77
  55 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  56 C
  57 C$$$
  58
  59       INCLUDE 'bufrlib.prm'
  60
  61       COMMON /MSGPTR/ NBY0,NBY1,NBY2,NBY3,NBY4,NBY5
  62       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
  63      .                INODE(NFILES),IDATE(NFILES)
  64       COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
  65      .                MBAY(MXMSGLD4,NFILES)
  66       COMMON /QUIET / IPRT
  67
  68       LOGICAL MSGFULL
  69
  70       CHARACTER*128 ERRSTR
  71
  72 C-----------------------------------------------------------------------
  73 C-----------------------------------------------------------------------
  74
  75 C  PAD THE SUBSET BUFFER
  76 C  ---------------------
  77
  78       CALL PAD(IBAY,IBIT,IBYT,8)
  79
  80 C  SEE IF THE NEW SUBSET FITS
  81 C  --------------------------
  82
  83       IF(MSGFULL(MBYT(LUN),IBYT,MAXBYT)) THEN
  84 c  .... NO it does not fit
  85          CALL MSGWRT(LUNIT,MBAY(1,LUN),MBYT(LUN))
  86          CALL MSGINI(LUN)
  87       ENDIF
  88
  89       IF(MSGFULL(MBYT(LUN),IBYT,MAXBYT)) GOTO 900
  90
  91 C  SET A BYTE COUNT AND TRANSFER THE SUBSET BUFFER INTO THE MESSAGE
  92 C  ----------------------------------------------------------------
  93
  94       LBIT = 0
  95       CALL PKB(IBYT,16,IBAY,LBIT)
  96
  97 C     Note that we want to append the data for this subset to the end
  98 C     of Section 4, but the value in MBYT(LUN) already includes the
  99 C     length of Section 5 (i.e. 4 bytes).  Therefore, we need to begin
 100 C     writing at the point 3 bytes prior to the byte currently pointed
 101 C     to by MBYT(LUN).
 102
 103       CALL MVB(IBAY,1,MBAY(1,LUN),MBYT(LUN)-3,IBYT)
 104
 105 C  UPDATE THE SUBSET AND BYTE COUNTERS
 106 C  --------------------------------------
 107
 108       MBYT(LUN)   = MBYT(LUN)   + IBYT
 109       NSUB(LUN)   = NSUB(LUN)   + 1
 110
 111       LBIT = (NBY0+NBY1+NBY2+4)*8
 112       CALL PKB(NSUB(LUN),16,MBAY(1,LUN),LBIT)
 113
 114       LBYT = NBY0+NBY1+NBY2+NBY3
 115       NBYT = IUPB(MBAY(1,LUN),LBYT+1,24)
 116       LBIT = LBYT*8
 117       CALL PKB(NBYT+IBYT,24,MBAY(1,LUN),LBIT)
 118
 119 C  RESET THE USER ARRAYS AND EXIT NORMALLY
 120 C  ---------------------------------------
 121
 122       CALL USRTPL(LUN,1,1)
 123       GOTO 100
 124
 125 C  ON ENCOUTERING OVERLARGE SUBSETS, EXIT GRACEFULLY (SUBSET DISCARDED)
 126 C  --------------------------------------------------------------------
 127
 128 900   IF(IPRT.GE.0) THEN
 129       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 130       WRITE ( UNIT=ERRSTR, FMT='(A,A,I7,A)')
 131      . 'BUFRLIB: MSGUPD - SUBSET LONGER THAN ANY POSSIBLE MESSAGE ',
 132      . '{MAXIMUM MESSAGE LENGTH = ', MAXBYT, '}'
 133       CALL ERRWRT(ERRSTR)
 134       CALL ERRWRT('>>>>>>>OVERLARGE SUBSET DISCARDED FROM FILE<<<<<<<<')
 135       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 136       CALL ERRWRT(' ')
 137       ENDIF
 138
 139 C  EXIT
 140 C  ----
 141
 142 100   RETURN
 143       END