var/external/bufr/atrcpt.f

   1         SUBROUTINE ATRCPT(MSGIN,LMSGOT,MSGOT)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    ATRCPT
   6 C   PRGMMR: ATOR             ORG: NP12       DATE: 2009-03-23
   7 C
   8 C ABSTRACT: THIS SUBROUTINE READS AN INPUT BUFR MESSAGE, APPENDS THE
   9 C   TANK RECEIPT TIME TO SECTION 1, AND WRITES THE RESULT TO A NEW BUFR
  10 C   MESSAGE FOR OUTPUT.  THE TANK RECEIPT TIME MUST HAVE BEEN SPECIFIED
  11 C   VIA A PREVIOUS CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE STRCPT.  THE
  12 C   OUTPUT MESSAGE WILL BE SLIGHTLY LONGER THAN THE INPUT MESSAGE, SO
  13 C   THE USER MUST ALLOW FOR ENOUGH SPACE WITHIN THE OUTPUT ARRAY.
  14 C
  15 C PROGRAM HISTORY LOG:
  16 C 2009-03-23  J. ATOR    -- ORIGINAL AUTHOR
  17 C
  18 C USAGE:    CALL ATRCPT (MSGIN, LMSGOT, MSGOT)
  19 C   INPUT ARGUMENT LIST:
  20 C     MSGIN    - INTEGER: *-WORD ARRAY CONTAINING BUFR MESSAGE
  21 C     LMSGOT   - INTEGER: DIMENSIONED SIZE (IN INTEGER WORDS) OF MSGOT;
  22 C                USED BY THE SUBROUTINE TO ENSURE THAT IT DOES NOT
  23 C                OVERFLOW THE MSGOT ARRAY
  24 C
  25 C   OUTPUT ARGUMENT LIST:
  26 C     MSGOT    - INTEGER: *-WORD ARRAY CONTAINING INPUT BUFR MESSAGE
  27 C                WITH TANK RECEIPT TIME APPENDED TO SECTION 1
  28 C
  29 C REMARKS:
  30 C    MSGIN AND MSGOT MUST BE SEPARATE ARRAYS.
  31 C
  32 C    THIS ROUTINE CALLS:        BORT     GETLENS  IUPBS01  MVB
  33 C                               PKB
  34 C    THIS ROUTINE IS CALLED BY: MSGWRT
  35 C                               Also called by application programs.
  36 C
  37 C ATTRIBUTES:
  38 C   LANGUAGE: FORTRAN 77
  39 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  40 C
  41 C$$$
  42
  43         DIMENSION MSGIN(*), MSGOT(*)
  44
  45         COMMON /HRDWRD/ NBYTW,NBITW,IORD(8)
  46         COMMON /TNKRCP/ ITRYR,ITRMO,ITRDY,ITRHR,ITRMI,CTRT
  47
  48         CHARACTER*1 CTRT
  49
  50 C-----------------------------------------------------------------------
  51 C-----------------------------------------------------------------------
  52
  53 C       Get some section lengths and addresses from the input message.
  54
  55         CALL GETLENS(MSGIN,1,LEN0,LEN1,L2,L3,L4,L5)
  56
  57         IAD1 = LEN0
  58         IAD2 = IAD1 + LEN1
  59
  60         LENM = IUPBS01(MSGIN,'LENM')
  61
  62 C       Check for overflow of the output array.  Note that the new
  63 C       message will be 6 bytes longer than the input message.
  64
  65         LENMOT = LENM + 6
  66         IF(LENMOT.GT.(LMSGOT*NBYTW)) GOTO 900
  67
  68         LEN1OT = LEN1 + 6
  69
  70 C       Write Section 0 of the new message into the output array.
  71
  72         CALL MVB ( MSGIN, 1, MSGOT, 1, 4 )
  73         IBIT = 32
  74         CALL PKB ( LENMOT, 24, MSGOT, IBIT )
  75         CALL MVB ( MSGIN, 8, MSGOT, 8, 1 )
  76
  77 C       Store the length of the new Section 1.
  78
  79         IBIT = IAD1*8
  80         CALL PKB ( LEN1OT, 24, MSGOT, IBIT )
  81
  82 C       Copy the remainder of Section 1 from the input array to the
  83 C       output array.
  84
  85         CALL MVB ( MSGIN, IAD1+4, MSGOT, (IBIT/8)+1, LEN1-3 )
  86
  87 C       Append the tank receipt time data to the new Section 1.
  88
  89         IBIT = IAD2*8
  90         CALL PKB ( ITRYR, 16, MSGOT, IBIT )
  91         CALL PKB ( ITRMO,  8, MSGOT, IBIT )
  92         CALL PKB ( ITRDY,  8, MSGOT, IBIT )
  93         CALL PKB ( ITRHR,  8, MSGOT, IBIT )
  94         CALL PKB ( ITRMI,  8, MSGOT, IBIT )
  95
  96 C       Copy Sections 2, 3, 4 and 5 from the input array to the
  97 C       output array.
  98
  99         CALL MVB ( MSGIN, IAD2+1, MSGOT, (IBIT/8)+1, LENM-IAD2 )
 100
 101         RETURN
 102 900     CALL BORT('BUFRLIB: ATRCPT - OVERFLOW OF OUTPUT MESSAGE '//
 103      .    'ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY')
 104         END