wrfv2_fire/var/external/bufr/copymg.inc

   1       SUBROUTINE COPYMG (LUNIN, LUNOT)
   2
   3 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 !
   5 ! SUBPROGRAM:    COPYMG
   6 !   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 !
   8 ! ABSTRACT: THIS SUBROUTINE COPIES A BUFR MESSAGE, INTACT, FROM LOGICAL
   9 !   UNIT LUNIN, OPENED FOR INPUT VIA A PREVIOUS CALL TO BUFR ARCHIVE
  10 !   LIBRARY SUBROUTINE OPENBF, TO LOGICAL UNIT LUNOT, OPENED FOR OUTPUT
  11 !   VIA A PREVIOUS CALL TO OPENBF.  THE MESSAGE COPIED FROM LOGICAL
  12 !   UNIT LUNIN WILL BE THE ONE MOST RECENTLY READ USING BUFR ARCHIVE
  13 !   LIBRARY SUBROUTINE READMG.  THE OUTPUT FILE MUST HAVE NO CURRENTLY
  14 !   OPEN MESSAGES.  ALSO, BOTH FILES MUST HAVE BEEN OPENED TO THE BUFR
  15 !   INTERFACE WITH IDENTICAL BUFR TABLES.
  16 !
  17 ! PROGRAM HISTORY LOG:
  18 ! 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  19 ! 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  20 !                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  21 !                           ROUTINE "BORT"
  22 ! 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  23 !                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  24 !                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  25 !                           BUFR FILES UNDER THE MPI)
  26 ! 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  27 !                           10,000 TO 20,000 BYTES
  28 ! 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  29 !                           INTERDEPENDENCIES
  30 ! 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  31 !                           INCREASED FROM 15000 TO 16000 (WAS IN
  32 !                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  33 !                           WRF; ADDED DOCUMENTATION (INCLUDING
  34 !                           HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC
  35 !                           INFO WHEN ROUTINE TERMINATES ABNORMALLY
  36 ! 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  37 !                           20,000 TO 50,000 BYTES
  38 ! 2005-11-29  J. ATOR    -- USE IUPBS01
  39 !
  40 ! USAGE:    CALL COPYMG (LUNIN, LUNOT)
  41 !   INPUT ARGUMENT LIST:
  42 !     LUNIN    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR
  43 !                FILE
  44 !     LUNOT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR
  45 !                FILE
  46 !
  47 ! REMARKS:
  48 !    THIS ROUTINE CALLS:        BORT     IUPBS01  MSGWRT   NEMTBA
  49 !                               STATUS
  50 !    THIS ROUTINE IS CALLED BY: None.
  51 !                               Normally called only by application
  52 !                               programs.
  53 !
  54 ! ATTRIBUTES:
  55 !   LANGUAGE: FORTRAN 77
  56 !   MACHINE:  PORTABLE TO ALL PLATFORMS
  57 !
  58 !$$$
  59
  60       INCLUDE 'bufrlib.prm'
  61
  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 / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT (   &
  67 !     MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL),    &
  68 !     IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),&
  69 !     ISEQ (MAXJL, 2), JSEQ (MAXJL)
  70
  71 !     CHARACTER(10) TAG
  72       CHARACTER(8) SUBSET
  73 !     CHARACTER(3) TYP
  74
  75 !-----------------------------------------------------------------------
  76 !-----------------------------------------------------------------------
  77
  78 !  CHECK THE FILE STATUSES
  79 !  -----------------------
  80
  81       CALL STATUS (LUNIN, LIN, IL, IM)
  82       IF (IL.EQ.0) GOTO 900
  83       IF (IL.GT.0) GOTO 901
  84       IF (IM.EQ.0) GOTO 902
  85
  86       CALL STATUS (LUNOT, LOT, IL, IM)
  87       IF (IL.EQ.0) GOTO 903
  88       IF (IL.LT.0) GOTO 904
  89       IF (IM.NE.0) GOTO 905
  90
  91 !  MAKE SURE BOTH FILES HAVE THE SAME TABLES
  92 !  -----------------------------------------
  93
  94       SUBSET = TAG (INODE (LIN) )
  95 !  .... Given SUBSET, returns MSGT,MSTB,INOD
  96       CALL NEMTBA (LOT, SUBSET, MSGT, MSTB, INOD)
  97       IF (INODE (LIN) .NE.INOD) GOTO 906
  98
  99 !  EVERYTHING OKAY, COPY A MESSAGE
 100 !  -------------------------------
 101
 102       MBYM = IUPBS01 (MBAY (1, LIN) , 'LENM')
 103       CALL MSGWRT (LUNOT, MBAY (1, LIN), MBYM)
 104
 105 !  SET THE MESSAGE CONTROL WORDS FOR PARTITION ASSOCIATED WITH LUNOT
 106 !  -----------------------------------------------------------------
 107
 108       NMSG (LOT) = NMSG (LOT) + 1
 109       NSUB (LOT) = MSUB (LIN)
 110       IDATE (LOT) = IDATE (LIN)
 111       INODE (LOT) = INODE (LIN)
 112
 113 !  EXITS
 114 !  -----
 115
 116       RETURN
 117   900 CALL BORT ('BUFRLIB: COPYMG - INPUT BUFR FILE IS CLOSED, IT MUST'/&
 118      &/' BE OPEN FOR INPUT')
 119   901 CALL BORT ('BUFRLIB: COPYMG - INPUT BUFR FILE IS OPEN FOR '//     &
 120       'OUTPUT, IT MUST BE OPEN FOR INPUT')
 121   902 CALL BORT ('BUFRLIB: COPYMG - A MESSAGE MUST BE OPEN IN INPUT '// &
 122       'BUFR FILE, NONE ARE')
 123   903 CALL BORT ('BUFRLIB: COPYMG - OUTPUT BUFR FILE IS CLOSED, IT '//  &
 124       'MUST BE OPEN FOR OUTPUT')
 125   904 CALL BORT ('BUFRLIB: COPYMG - OUTPUT BUFR FILE IS OPEN FOR '//    &
 126       'INPUT, IT MUST BE OPEN FOR OUTPUT')
 127   905 CALL BORT ('BUFRLIB: COPYMG - ALL MESSAGES MUST BE CLOSED IN '//  &
 128       'OUTPUT BUFR FILE, A MESSAGE IS OPEN')
 129   906 CALL BORT ('BUFRLIB: COPYMG - INPUT AND OUTPUT BUFR FILES MUST '//&
 130       'HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE')
 131       END SUBROUTINE COPYMG