var/external/bufr/cnved4.f

   1         SUBROUTINE CNVED4(MSGIN,LMSGOT,MSGOT)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    CNVED4
   6 C   PRGMMR: ATOR             ORG: NP12       DATE: 2005-11-29
   7 C
   8 C ABSTRACT: THIS SUBROUTINE READS AN INPUT BUFR MESSAGE ENCODED USING
   9 C   BUFR EDITION 3 AND OUTPUTS AN EQUIVALENT BUFR MESSAGE ENCODED USING
  10 C   BUFR EDITION 4.  THE OUTPUT MESSAGE WILL BE SLIGHTLY LONGER THAN THE
  11 C   INPUT MESSAGE, SO THE USER MUST ALLOW FOR ENOUGH SPACE WITHIN THE
  12 C   MSGOT ARRAY.  NOTE THAT MSGIN AND MSGOT MUST BE SEPARATE ARRAYS.
  13 C
  14 C PROGRAM HISTORY LOG:
  15 C 2005-11-29  J. ATOR    -- ORIGINAL AUTHOR
  16 C 2009-08-12  J. ATOR    -- ALLOW SILENT RETURN (INSTEAD OF BORT RETURN)
  17 C                           IF MSGIN IS ALREADY ENCODED USING EDITION 4
  18 C
  19 C USAGE:    CALL CNVED4 (MSGIN, LMSGOT, MSGOT)
  20 C   INPUT ARGUMENT LIST:
  21 C     MSGIN    - INTEGER: *-WORD ARRAY CONTAINING BUFR MESSAGE ENCODED
  22 C                USING BUFR EDITION 3
  23 C     LMSGOT   - INTEGER: DIMENSIONED SIZE (IN INTEGER WORDS) OF MSGOT;
  24 C                USED BY THE SUBROUTINE TO ENSURE THAT IT DOES NOT
  25 C                OVERFLOW THE MSGOT ARRAY
  26 C
  27 C   OUTPUT ARGUMENT LIST:
  28 C     MSGOT    - INTEGER: *-WORD ARRAY CONTAINING INPUT BUFR MESSAGE
  29 C                NOW ENCODED USING BUFR EDITION 4
  30 C
  31 C REMARKS:
  32 C    MSGIN AND MSGOT MUST BE SEPARATE ARRAYS.
  33 C
  34 C    THIS ROUTINE CALLS:        BORT     GETLENS  IUPBS01  MVB
  35 C                               NMWRD    PKB
  36 C    THIS ROUTINE IS CALLED BY: MSGWRT
  37 C                               Also called by application programs.
  38 C
  39 C ATTRIBUTES:
  40 C   LANGUAGE: FORTRAN 77
  41 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  42 C
  43 C$$$
  44
  45         DIMENSION MSGIN(*), MSGOT(*)
  46
  47         COMMON /HRDWRD/ NBYTW,NBITW,IORD(8)
  48
  49 C-----------------------------------------------------------------------
  50 C-----------------------------------------------------------------------
  51
  52         IF(IUPBS01(MSGIN,'BEN').EQ.4) THEN
  53
  54 C         The input message is already encoded using edition 4, so just
  55 C         copy it from MSGIN to MSGOT and then return.
  56
  57           NMW = NMWRD(MSGIN)
  58           IF(NMW.GT.LMSGOT) GOTO 900
  59           DO I = 1, NMW
  60             MSGOT(I) = MSGIN(I)
  61           ENDDO
  62           RETURN
  63         ENDIF
  64
  65 C       Get some section lengths and addresses from the input message.
  66
  67         CALL GETLENS(MSGIN,3,LEN0,LEN1,LEN2,LEN3,L4,L5)
  68
  69         IAD2 = LEN0 + LEN1
  70         IAD4 = IAD2 + LEN2 + LEN3
  71
  72         LENM = IUPBS01(MSGIN,'LENM')
  73
  74 C       Check for overflow of the output array.  Note that the new
  75 C       edition 4 message will be a total of 3 bytes longer than the
  76 C       input message (i.e. 4 more bytes in Section 1, but 1 fewer
  77 C       byte in Section 3).
  78
  79         LENMOT = LENM + 3
  80         IF(LENMOT.GT.(LMSGOT*NBYTW)) GOTO 900
  81
  82         LEN1OT = LEN1 + 4
  83         LEN3OT = LEN3 - 1
  84
  85 C       Write Section 0 of the new message into the output array.
  86
  87         CALL MVB ( MSGIN, 1, MSGOT, 1, 4 )
  88         IBIT = 32
  89         CALL PKB ( LENMOT, 24, MSGOT, IBIT )
  90         CALL PKB ( 4, 8, MSGOT, IBIT )
  91
  92 C       Write Section 1 of the new message into the output array.
  93
  94         CALL PKB ( LEN1OT, 24, MSGOT, IBIT )
  95         CALL PKB ( IUPBS01(MSGIN,'BMT'), 8, MSGOT, IBIT )
  96         CALL PKB ( IUPBS01(MSGIN,'OGCE'), 16, MSGOT, IBIT )
  97         CALL PKB ( IUPBS01(MSGIN,'GSES'), 16, MSGOT, IBIT )
  98         CALL PKB ( IUPBS01(MSGIN,'USN'), 8, MSGOT, IBIT )
  99         CALL PKB ( IUPBS01(MSGIN,'ISC2')*128, 8, MSGOT, IBIT )
 100         CALL PKB ( IUPBS01(MSGIN,'MTYP'), 8, MSGOT, IBIT )
 101
 102 C       Set a default of 255 for the international subcategory.
 103
 104         CALL PKB ( 255, 8, MSGOT, IBIT )
 105         CALL PKB ( IUPBS01(MSGIN,'MSBT'), 8, MSGOT, IBIT )
 106         CALL PKB ( IUPBS01(MSGIN,'MTV'), 8, MSGOT, IBIT )
 107         CALL PKB ( IUPBS01(MSGIN,'MTVL'), 8, MSGOT, IBIT )
 108         CALL PKB ( IUPBS01(MSGIN,'YEAR'), 16, MSGOT, IBIT )
 109         CALL PKB ( IUPBS01(MSGIN,'MNTH'), 8, MSGOT, IBIT )
 110         CALL PKB ( IUPBS01(MSGIN,'DAYS'), 8, MSGOT, IBIT )
 111         CALL PKB ( IUPBS01(MSGIN,'HOUR'), 8, MSGOT, IBIT )
 112         CALL PKB ( IUPBS01(MSGIN,'MINU'), 8, MSGOT, IBIT )
 113
 114 C       Set a default of 0 for the second.
 115
 116         CALL PKB ( 0, 8, MSGOT, IBIT )
 117
 118 C       Copy Section 2 (if it exists) through the next-to-last byte
 119 C       of Section 3 from the input array to the output array.
 120
 121         CALL MVB ( MSGIN, IAD2+1, MSGOT, (IBIT/8)+1, LEN2+LEN3-1 )
 122
 123 C       Store the length of the new Section 3.
 124
 125         IBIT = ( LEN0 + LEN1OT + LEN2 ) * 8
 126         CALL PKB ( LEN3OT, 24, MSGOT, IBIT )
 127
 128 C       Copy Section 4 and Section 5 from the input array to the
 129 C       output array.
 130
 131         IBIT = IBIT + ( LEN3OT * 8 ) - 24
 132         CALL MVB ( MSGIN, IAD4+1, MSGOT, (IBIT/8)+1, LENM-IAD4 )
 133
 134         RETURN
 135 900     CALL BORT('BUFRLIB: CNVED4 - OVERFLOW OF OUTPUT (EDITION 4) '//
 136      .    'MESSAGE ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY')
 137         END