var/external/bufr/copysb.f

   1       SUBROUTINE COPYSB(LUNIN,LUNOT,IRET)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    COPYSB
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE COPIES A PACKED DATA SUBSET, INTACT, FROM
   9 C   LOGICAL UNIT LUNIN, OPENED FOR INPUT VIA A PREVIOUS CALL TO BUFR
  10 C   ARCHIVE LIBRARY SUBROUTINE OPENBF, TO LOGICAL UNIT LUNOT, OPENED
  11 C   FOR OUTPUT VIA A PREVIOUS CALL TO OPENBF.  THE BUFR MESSAGE MUST
  12 C   HAVE BEEN PREVIOUSLY READ FROM UNIT LUNIT USING BUFR ARCHIVE
  13 C   LIBRARY SUBROUTINE READMG OR READERME AND MAY BE EITHER COMPRESSED
  14 C   OR UNCOMPRESSED.  ALSO, BUFR ARCHIVE LIBRARY SUBROUTINE OPENMG OR
  15 C   OPENMB MUST HAVE BEEN PREVIOUSLY CALLED TO OPEN AND INITIALIZE A
  16 C   BUFR MESSAGE WITHIN MEMORY FOR UNIT LUNOT.  EACH CALL TO COPYSB
  17 C   ADVANCES THE POINTER TO THE BEGINNING OF THE NEXT SUBSET IN BOTH
  18 C   THE INPUT AND OUTPUT FILES, UNLESS INPUT PARAMETER LUNOT IS .LE.
  19 C   ZERO, IN WHICH CASE THE OUTPUT POINTER IS NOT ADVANCED. THE
  20 C   COMPRESSION STATUS OF THE OUTPUT SUBSET/BUFR MESSAGE WILL ALWAYS
  21 C   MATCH THAT OF THE INPUT SUBSET/BUFR MESSAGE {I.E., IF INPUT MESSAGE
  22 C   IS UNCOMPRESSED(COMPRESSED) OUTPUT MESSAGE WILL BE UNCOMPRESSED
  23 C   (COMPRESSED)}.
  24 C
  25 C PROGRAM HISTORY LOG:
  26 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  27 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  28 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  29 C                           ROUTINE "BORT"
  30 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  31 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  32 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  33 C                           BUFR FILES UNDER THE MPI)
  34 C 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  35 C                           10,000 TO 20,000 BYTES
  36 C 2002-05-14  J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES
  37 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  38 C                           INTERDEPENDENCIES
  39 C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED
  40 C                           DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
  41 C                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
  42 C                           TERMINATES ABNORMALLY
  43 C 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  44 C                           20,000 TO 50,000 BYTES
  45 C 2005-09-16  J. WOOLLEN -- NOW WRITES OUT COMPRESSED SUBSET/MESSAGE IF
  46 C                           INPUT SUBSET/MESSAGE IS COMPRESSED (BEFORE
  47 C                           COULD ONLY WRITE OUT UNCOMPRESSED SUBSET/
  48 C                           MESSAGE REGARDLESS OF COMPRESSION STATUS OF
  49 C                           INPUT SUBSET/MESSAGE)
  50 C 2009-06-26  J. ATOR    -- USE IOK2CPY
  51 C
  52 C USAGE:    CALL COPYSB  ( LUNIN, LUNOT, IRET )
  53 C   INPUT ARGUMENT LIST:
  54 C     LUNIN    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR
  55 C                FILE
  56 C     LUNOT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR
  57 C                FILE
  58 C
  59 C   OUTPUT ARGUMENT LIST:
  60 C     IRET     - INTEGER: RETURN CODE:
  61 C                       0 = normal return
  62 C                      -1 = there are no more subsets in the input
  63 C                           BUFR message
  64 C
  65 C REMARKS:
  66 C    THIS ROUTINE CALLS:        BORT     CMPMSG   CPYUPD   IOK2CPY
  67 C                               MESGBC   READSB   STATUS   UFBCPY
  68 C                               UPB      WRITSB
  69 C    THIS ROUTINE IS CALLED BY: ICOPYSB
  70 C                               Also called by application programs.
  71 C
  72 C ATTRIBUTES:
  73 C   LANGUAGE: FORTRAN 77
  74 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  75 C
  76 C$$$
  77
  78       INCLUDE 'bufrlib.prm'
  79
  80       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
  81      .                INODE(NFILES),IDATE(NFILES)
  82       COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
  83      .                MBAY(MXMSGLD4,NFILES)
  84       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
  85      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
  86      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
  87      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
  88      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
  89
  90       CHARACTER*10 TAG
  91       CHARACTER*3  TYP
  92
  93       CHARACTER*128 BORT_STR
  94
  95 C-----------------------------------------------------------------------
  96 C-----------------------------------------------------------------------
  97
  98       IRET = 0
  99
 100 C  CHECK THE FILE STATUSES
 101 C  -----------------------
 102
 103       CALL STATUS(LUNIN,LIN,IL,IM)
 104       IF(IL.EQ.0) GOTO 900
 105       IF(IL.GT.0) GOTO 901
 106       IF(IM.EQ.0) GOTO 902
 107
 108       IF(LUNOT.GT.0) THEN
 109          CALL STATUS(LUNOT,LOT,IL,IM)
 110          IF(IL.EQ.0) GOTO 903
 111          IF(IL.LT.0) GOTO 904
 112          IF(IM.EQ.0) GOTO 905
 113          IF(INODE(LIN).NE.INODE(LOT)) THEN
 114            IF( (TAG(INODE(LIN)).NE.TAG(INODE(LOT))) .OR.
 115      .        (IOK2CPY(LIN,LOT).NE.1) ) GOTO 906
 116          ENDIF
 117       ENDIF
 118
 119 C  SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE
 120 C  ---------------------------------------------
 121
 122       IF(NSUB(LIN).EQ.MSUB(LIN)) THEN
 123          IRET = -1
 124          GOTO 100
 125       ENDIF
 126
 127 C  CHECK COMPRESSION STATUS OF INPUT MESSAGE, OUTPUT MESSAGE WILL MATCH
 128 C  --------------------------------------------------------------------
 129
 130       CALL MESGBC(-LUNIN,MEST,ICMP)
 131
 132       IF(ICMP.EQ.1) THEN
 133
 134 C  -------------------------------------------------------
 135 C  THIS BRANCH IS FOR COMPRESSED INPUT/OUTPUT MESSAGES
 136 C  -------------------------------------------------------
 137 C  READ IN AND UNCOMPRESS SUBSET, THEN COPY IT TO COMPRESSED OUTPUT MSG
 138 C  --------------------------------------------------------------------
 139
 140          CALL READSB(LUNIN,IRET)
 141          IF(LUNOT.GT.0) THEN
 142             CALL UFBCPY(LUNIN,LUNOT)
 143             CALL CMPMSG('Y')
 144             CALL WRITSB(LUNOT)
 145             CALL CMPMSG('N')
 146          ENDIF
 147          GOTO 100
 148       ELSE  IF(ICMP.EQ.0) THEN
 149
 150 C  -------------------------------------------------------
 151 C  THIS BRANCH IS FOR UNCOMPRESSED INPUT/OUTPUT MESSAGES
 152 C  -------------------------------------------------------
 153 C  COPY THE SUBSET TO THE OUTPUT MESSAGE AND/OR RESET THE POINTERS
 154 C  ---------------------------------------------------------------
 155
 156          IBIT = (MBYT(LIN))*8
 157          CALL UPB(NBYT,16,MBAY(1,LIN),IBIT)
 158          IF(LUNOT.GT.0) CALL CPYUPD(LUNOT,LIN,LOT,NBYT)
 159          MBYT(LIN) = MBYT(LIN) + NBYT
 160          NSUB(LIN) = NSUB(LIN) + 1
 161       ELSE
 162          GOTO 907
 163       ENDIF
 164
 165 C  EXITS
 166 C  -----
 167
 168 100   RETURN
 169 900   CALL BORT('BUFRLIB: COPYSB - INPUT BUFR FILE IS CLOSED, IT '//
 170      . 'MUST BE OPEN FOR INPUT')
 171 901   CALL BORT('BUFRLIB: COPYSB - INPUT BUFR FILE IS OPEN FOR '//
 172      . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
 173 902   CALL BORT('BUFRLIB: COPYSB - A MESSAGE MUST BE OPEN IN INPUT '//
 174      . 'BUFR FILE, NONE ARE')
 175 903   CALL BORT('BUFRLIB: COPYSB - OUTPUT BUFR FILE IS CLOSED, IT '//
 176      . 'MUST BE OPEN FOR OUTPUT')
 177 904   CALL BORT('BUFRLIB: COPYSB - OUTPUT BUFR FILE IS OPEN FOR '//
 178      . 'INPUT, IT MUST BE OPEN FOR OUTPUT')
 179 905   CALL BORT('BUFRLIB: COPYSB - A MESSAGE MUST BE OPEN IN OUTPUT '//
 180      . 'BUFR FILE, NONE ARE')
 181 906   CALL BORT('BUFRLIB: COPYSB - INPUT AND OUTPUT BUFR FILES MUST '//
 182      . 'HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE')
 183 907   WRITE(BORT_STR,'("BUFRLIB: COPYSB - INVALID COMPRESSION '//
 184      . 'INDICATOR (ICMP=",I3," RETURNED FROM BUFR ARCHIVE LIBRARY '//
 185      . 'ROUTINE MESGBC")') ICMP
 186       CALL BORT(BORT_STR)
 187       END