var/external/bufr/msgwrt.f

   1       SUBROUTINE MSGWRT(LUNIT,MESG,MGBYT)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    MSGWRT
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE PERFORMS SOME FINAL CHECKS ON AN OUTPUT
   9 C  BUFR MESSAGE (E.G., CONFIRMING THAT EACH SECTION OF THE MESSAGE HAS
  10 C  AN EVEN NUMBER OF BYTES WHEN NECESSARY, "STANDARDIZING" THE MESSAGE
  11 C  IF REQUESTED VIA A PREVIOUS CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE
  12 C  STDMSG, ETC.), AND THEN PREPARES THE MESSAGE FOR FINAL OUTPUT TO
  13 C  LOGICAL UNIT LUNIT (E.G., ADDING THE STRING "7777" TO THE LAST FOUR
  14 C  BYTES OF THE MESSAGE, APPENDING ZEROED-OUT BYTES UP TO A SUBSEQUENT
  15 C  MACHINE WORD BOUNDARY, ETC.).  IT THEN WRITES OUT THE FINISHED
  16 C  MESSAGE TO LOGICAL UNIT LUNIT AND ALSO STORES A COPY OF IT WITHIN
  17 C  COMMON /BUFRMG/ FOR POSSIBLE LATER RETRIEVAL VIA BUFR ARCHIVE
  18 C  LIBRARY SUBROUTINE WRITSA.
  19 C
  20 C PROGRAM HISTORY LOG:
  21 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  22 C 1997-07-29  J. WOOLLEN -- MODIFIED TO UPDATE THE CURRENT BUFR VERSION
  23 C                           WRITTEN IN SECTION 0 FROM 2 TO 3
  24 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  25 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  26 C                           ROUTINE "BORT"
  27 C 1998-11-24  J. WOOLLEN -- MODIFIED TO ZERO OUT THE PADDING BYTES
  28 C                           WRITTEN AT THE END OF SECTION 4
  29 C 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  30 C                           10,000 TO 20,000 BYTES
  31 C 2003-11-04  J. ATOR    -- DON'T WRITE TO LUNIT IF OPENED AS A NULL
  32 C                           FILE BY OPENBF {NULL(LUN) = 1 IN NEW
  33 C                           COMMON BLOCK /NULBFR/} (WAS IN DECODER
  34 C                           VERSION); ADDED DOCUMENTATION
  35 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  36 C                           INTERDEPENDENCIES
  37 C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY
  38 C                           DOCUMENTATION; OUTPUTS MORE COMPLETE
  39 C                           DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
  40 C                           ABNORMALLY
  41 C 2004-08-18  J. ATOR    -- IMPROVED DOCUMENTATION; ADDED LOGIC TO CALL
  42 C                           STNDRD IF REQUESTED VIA COMMON /MSGSTD/;
  43 C                           ADDED LOGIC TO CALL OVRBS1 IF NECESSARY;
  44 C                           MAXIMUM MESSAGE LENGTH INCREASED FROM
  45 C                           20,000 TO 50,000 BYTES
  46 C 2005-11-29  J. ATOR    -- USE GETLENS, IUPBS01, PADMSG, PKBS1 AND
  47 C                           NMWRD; ADDED LOGIC TO CALL PKBS1 AND/OR
  48 C                           CNVED4 WHEN NECESSARY
  49 C 2009-03-23  J. ATOR    -- USE IDXMSG AND ERRWRT; ADD CALL TO ATRCPT;
  50 C                           ALLOW STANDARDIZING VIA COMMON /MSGSTD/
  51 C                           EVEN IF DATA IS COMPRESSED; WORK ON LOCAL
  52 C                           COPY OF INPUT MESSAGE
  53 C 2012-09-15  J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE;
  54 C                           CALL NEW ROUTINE BLOCKS FOR FILE BLOCKING
  55 C                           AND NEW C ROUTINE CWRBUFR TO WRITE BUFR
  56 C                           MESSAGE TO DISK FILE
  57 C
  58 C USAGE:    CALL MSGWRT (LUNIT, MESG, MGBYT)
  59 C   INPUT ARGUMENT LIST:
  60 C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  61 C     MESG     - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR
  62 C                MESSAGE TO OUTPUT TO LUNIT
  63 C     MGBYT    - INTEGER: LENGTH OF BUFR MESSAGE IN BYTES
  64 C
  65 C   OUTPUT FILES:
  66 C     UNIT "LUNIT" - BUFR FILE
  67 C
  68 C REMARKS:
  69 C    THIS ROUTINE CALLS:        ATRCPT   BORT     CNVED4   ERRWRT
  70 C                               GETLENS  IDXMSG   IUPB     IUPBS01
  71 C                               NMWRD    PADMSG   PKB      PKBS1
  72 C                               PKC      STATUS   STNDRD   BLOCKS
  73 C                               CWRBUFR
  74 C    THIS ROUTINE IS CALLED BY: CLOSMG   COPYBF   COPYMG   CPYMEM
  75 C                               CPYUPD   MSGUPD   WRCMPS   WRDXTB
  76 C                               Normally not called by any application
  77 C                               programs.
  78 C
  79 C ATTRIBUTES:
  80 C   LANGUAGE: FORTRAN 77
  81 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  82 C
  83 C$$$
  84
  85       INCLUDE 'bufrlib.prm'
  86
  87       PARAMETER (MXCOD=15)
  88
  89       COMMON /BUFRMG/ MSGLEN,MSGTXT(MXMSGLD4)
  90       COMMON /NULBFR/ NULL(NFILES)
  91       COMMON /QUIET / IPRT
  92       COMMON /MSGSTD/ CSMF
  93       COMMON /S01CM/  NS01V,CMNEM(MXS01V),IVMNEM(MXS01V)
  94       COMMON /TNKRCP/ ITRYR,ITRMO,ITRDY,ITRHR,ITRMI,CTRT
  95
  96       CHARACTER*128 ERRSTR
  97
  98       CHARACTER*8 CMNEM
  99       CHARACTER*4 BUFR,SEVN
 100       CHARACTER*1 CSMF
 101       CHARACTER*1 CTRT
 102       DIMENSION   MESG(*)
 103       DIMENSION   MBAY(MXMSGLD4),MSGNEW(MXMSGLD4)
 104       DIMENSION   IEC0(2)
 105
 106       DATA BUFR/'BUFR'/
 107       DATA SEVN/'7777'/
 108
 109 C-----------------------------------------------------------------------
 110 C-----------------------------------------------------------------------
 111
 112 C     MAKE A LOCAL COPY OF THE INPUT MESSAGE FOR USE WITHIN THIS
 113 C     SUBROUTINE, SINCE CALLS TO ANY OR ALL OF THE SUBROUTINES STNDRD,
 114 C     CNVED4, PKBS1, ATRCPT, ETC. MAY END UP MODIFYING THE MESSAGE
 115 C     BEFORE IT FINALLY GETS WRITTEN OUT TO LUNIT.
 116
 117       MBYT = MGBYT
 118
 119       IEC0(1) = MESG(1)
 120       IEC0(2) = MESG(2)
 121       IBIT = 32
 122       CALL PKB(MBYT,24,IEC0,IBIT)
 123
 124       DO II = 1, NMWRD(IEC0)
 125         MBAY(II) = MESG(II)
 126       ENDDO
 127
 128 C     OVERWRITE ANY VALUES WITHIN SECTION 0 OR SECTION 1 THAT WERE
 129 C     REQUESTED VIA PREVIOUS CALLS TO BUFR ARCHIVE LIBRARY SUBROUTINE
 130 C     PKVS01.  IF A REQUEST WAS MADE TO CHANGE THE BUFR EDITION NUMBER
 131 C     TO 4, THEN ACTUALLY CONVERT THE MESSAGE AS WELL.
 132
 133       IF(NS01V.GT.0) THEN
 134         DO I=1,NS01V
 135           IF(CMNEM(I).EQ.'BEN') THEN
 136             IF(IVMNEM(I).EQ.4) THEN
 137
 138 C             INSTALL SECTION 0 BYTE COUNT FOR USE BY SUBROUTINE CNVED4.
 139
 140               IBIT = 32
 141               CALL PKB(MBYT,24,MBAY,IBIT)
 142
 143               CALL CNVED4(MBAY,MXMSGLD4,MSGNEW)
 144
 145 C             COMPUTE MBYT FOR THE NEW EDITION 4 MESSAGE.
 146
 147               MBYT = IUPBS01(MSGNEW,'LENM')
 148
 149 C             COPY THE MSGNEW ARRAY BACK INTO MBAY.
 150
 151               DO II = 1, NMWRD(MSGNEW)
 152                 MBAY(II) = MSGNEW(II)
 153               ENDDO
 154             ENDIF
 155           ELSE
 156
 157 C           OVERWRITE THE REQUESTED VALUE.
 158
 159             CALL PKBS1(IVMNEM(I),MBAY,CMNEM(I))
 160           ENDIF
 161         ENDDO
 162       ENDIF
 163
 164 C     "STANDARDIZE" THE MESSAGE IF REQUESTED VIA COMMON /MSGSTD/.
 165 C     HOWEVER, WE DO NOT WANT TO DO THIS IF THE MESSAGE CONTAINS BUFR
 166 C     TABLE (DX) INFORMATION, IN WHICH CASE IT IS ALREADY "STANDARD".
 167
 168       IF ( ( CSMF.EQ.'Y' ) .AND. ( IDXMSG(MBAY).NE.1 ) )  THEN
 169
 170 C       INSTALL SECTION 0 BYTE COUNT AND SECTION 5 '7777' INTO THE
 171 C       ORIGINAL MESSAGE.  THIS IS NECESSARY BECAUSE SUBROUTINE STNDRD
 172 C       REQUIRES A COMPLETE AND WELL-FORMED BUFR MESSAGE AS ITS INPUT.
 173
 174         IBIT = 32
 175         CALL PKB(MBYT,24,MBAY,IBIT)
 176         IBIT = (MBYT-4)*8
 177         CALL PKC(SEVN,4,MBAY,IBIT)
 178
 179         CALL STNDRD(LUNIT,MBAY,MXMSGLD4,MSGNEW)
 180
 181 C       COMPUTE MBYT FOR THE NEW "STANDARDIZED" MESSAGE.
 182
 183         MBYT = IUPBS01(MSGNEW,'LENM')
 184
 185 C       COPY THE MSGNEW ARRAY BACK INTO MBAY.
 186
 187         DO II = 1, NMWRD(MSGNEW)
 188           MBAY(II) = MSGNEW(II)
 189         ENDDO
 190       ENDIF
 191
 192 C     APPEND THE TANK RECEIPT TIME TO SECTION 1 IF REQUESTED VIA
 193 C     COMMON /TNKRCP/, UNLESS THE MESSAGE CONTAINS BUFR TABLE (DX)
 194 C     INFORMATION.
 195
 196       IF ( ( CTRT.EQ.'Y' ) .AND. ( IDXMSG(MBAY).NE.1 ) ) THEN
 197
 198 C       INSTALL SECTION 0 BYTE COUNT FOR USE BY SUBROUTINE ATRCPT.
 199
 200         IBIT = 32
 201         CALL PKB(MBYT,24,MBAY,IBIT)
 202
 203         CALL ATRCPT(MBAY,MXMSGLD4,MSGNEW)
 204
 205 C       COMPUTE MBYT FOR THE REVISED MESSAGE.
 206
 207         MBYT = IUPBS01(MSGNEW,'LENM')
 208
 209 C       COPY THE MSGNEW ARRAY BACK INTO MBAY.
 210
 211         DO II = 1, NMWRD(MSGNEW)
 212           MBAY(II) = MSGNEW(II)
 213         ENDDO
 214       ENDIF
 215
 216 C     GET THE SECTION LENGTHS.
 217
 218       CALL GETLENS(MBAY,4,LEN0,LEN1,LEN2,LEN3,LEN4,L5)
 219
 220 C     DEPENDING ON THE EDITION NUMBER OF THE MESSAGE, WE NEED TO ENSURE
 221 C     THAT EACH SECTION WITHIN THE MESSAGE HAS AN EVEN NUMBER OF BYTES.
 222
 223       IF(IUPBS01(MBAY,'BEN').LT.4) THEN
 224         IF(MOD(LEN1,2).NE.0) GOTO 901
 225         IF(MOD(LEN2,2).NE.0) GOTO 902
 226         IF(MOD(LEN3,2).NE.0) GOTO 903
 227         IF(MOD(LEN4,2).NE.0) THEN
 228
 229 C          PAD SECTION 4 WITH AN ADDITIONAL BYTE
 230 C          THAT IS ZEROED OUT.
 231
 232            IAD4 = LEN0+LEN1+LEN2+LEN3
 233            IAD5 = IAD4+LEN4
 234            IBIT = IAD4*8
 235            LEN4 = LEN4+1
 236            CALL PKB(LEN4,24,MBAY,IBIT)
 237            IBIT = IAD5*8
 238            CALL PKB(0,8,MBAY,IBIT)
 239            MBYT = MBYT+1
 240         ENDIF
 241       ENDIF
 242
 243 C  WRITE SECTION 0 BYTE COUNT AND SECTION 5
 244 C  ----------------------------------------
 245
 246       IBIT = 0
 247       CALL PKC(BUFR, 4,MBAY,IBIT)
 248       CALL PKB(MBYT,24,MBAY,IBIT)
 249
 250       KBIT = (MBYT-4)*8
 251       CALL PKC(SEVN, 4,MBAY,KBIT)
 252
 253 C  ZERO OUT THE EXTRA BYTES WHICH WILL BE WRITTEN
 254 C  ----------------------------------------------
 255
 256 C     I.E. SINCE THE BUFR MESSAGE IS STORED WITHIN THE INTEGER ARRAY
 257 C     MBAY(*) (RATHER THAN WITHIN A CHARACTER ARRAY), WE NEED TO MAKE
 258 C     SURE THAT THE "7777" IS FOLLOWED BY ZEROED-OUT BYTES UP TO THE
 259 C     BOUNDARY OF THE LAST MACHINE WORD THAT WILL BE WRITTEN OUT.
 260
 261       CALL PADMSG(MBAY,MXMSGLD4,NPBYT)
 262
 263 C  WRITE THE MESSAGE PLUS PADDING TO A WORD BOUNDARY IF NULL(LUN) = 0
 264 C  ------------------------------------------------------------------
 265
 266       MWRD = NMWRD(MBAY)
 267       CALL STATUS(LUNIT,LUN,IL,IM)
 268       IF(NULL(LUN).EQ.0) then
 269          CALL BLOCKS(MBAY,MWRD)
 270          call cwrbufr(lun,mbay,mwrd)
 271       ENDIF
 272
 273       IF(IPRT.GE.2) THEN
 274       CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
 275       WRITE ( UNIT=ERRSTR, FMT='(A,I4,A,I7)')
 276      .  'BUFRLIB: MSGWRT: LUNIT =', LUNIT, ', BYTES =', MBYT+NPBYT
 277       CALL ERRWRT(ERRSTR)
 278       CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
 279       CALL ERRWRT(' ')
 280       ENDIF
 281
 282 C  SAVE A MEMORY COPY OF THIS MESSAGE, UNLESS IT'S A DX MESSAGE
 283 C  ------------------------------------------------------------
 284
 285       IF(IDXMSG(MBAY).NE.1) THEN
 286
 287 C        STORE A COPY OF THIS MESSAGE WITHIN COMMON /BUFRMG/,
 288 C        FOR POSSIBLE LATER RETRIEVAL DURING THE NEXT CALL TO
 289 C        SUBROUTINE WRITSA.
 290
 291          MSGLEN = MWRD
 292          DO I=1,MSGLEN
 293            MSGTXT(I) = MBAY(I)
 294          ENDDO
 295       ENDIF
 296
 297 C  EXITS
 298 C  -----
 299
 300       RETURN
 301 901   CALL BORT
 302      . ('BUFRLIB: MSGWRT - LENGTH OF SECTION 1 IS NOT A MULTIPLE OF 2')
 303 902   CALL BORT
 304      . ('BUFRLIB: MSGWRT - LENGTH OF SECTION 2 IS NOT A MULTIPLE OF 2')
 305 903   CALL BORT
 306      . ('BUFRLIB: MSGWRT - LENGTH OF SECTION 3 IS NOT A MULTIPLE OF 2')
 307       END