var/external/bufr/ufbcpy.f

   1       SUBROUTINE UFBCPY(LUBIN,LUBOT)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    UFBCPY
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE COPIES A COMPLETE SUBSET BUFFER, UNPACKED
   9 C   INTO INTERNAL MEMORY FROM LOGICAL UNIT LUBIN BY A PREVIOUS CALL
  10 C   TO BUFR ARCHIVE LIBRARY SUBROUTINE READSB OR READNS, TO
  11 C   LOGICAL UNIT LUBOT.  BUFR ARCHIVE LIBRARY SUBROUTINE OPENMG OR
  12 C   OPENMB MUST HAVE BEEN PREVIOUSLY CALLED TO OPEN AND INITIALIZE A
  13 C   BUFR MESSAGE WITHIN MEMORY FOR LOGICAL UNIT LUBOU.  BOTH FILES MUST
  14 C   HAVE BEEN OPENED TO THE INTERFACE (VIA A CALL TO BUFR ARCHIVE
  15 C   LIBRARY SUBROUTINE OPENBF) WITH IDENTICAL BUFR TABLES.
  16 C
  17 C PROGRAM HISTORY LOG:
  18 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  19 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  20 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  21 C                           ROUTINE "BORT"
  22 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  23 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  24 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  25 C                           BUFR FILES UNDER THE MPI)
  26 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  27 C                           INTERDEPENDENCIES
  28 C 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  29 C                           INCREASED FROM 15000 TO 16000 (WAS IN
  30 C                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  31 C                           WRF; ADDED DOCUMENTATION (INCLUDING
  32 C                           HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC
  33 C                           INFO WHEN ROUTINE TERMINATES ABNORMALLY
  34 C 2009-06-26  J. ATOR    -- USE IOK2CPY
  35 C 2009-08-11  J. WOOLLEN -- ADD COMMON UFBCPL TO REMEMBER WHICH UNIT
  36 C                           IS COPIED TO WHAT SUBSET BUFFER IN ORDER TO
  37 C                           TRANSFER LONG STRINGS VIA UFBCPY AND WRTREE
  38 C
  39 C USAGE:    CALL UFBCPY (LUBIN, LUBOT)
  40 C   INPUT ARGUMENT LIST:
  41 C     LUBIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR
  42 C                FILE
  43 C     LUBOT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR
  44 C                FILE
  45 C
  46 C REMARKS:
  47 C    THIS ROUTINE CALLS:        BORT     IOK2CPY  STATUS
  48 C    THIS ROUTINE IS CALLED BY: COPYSB
  49 C                               Also called by application programs.
  50 C
  51 C ATTRIBUTES:
  52 C   LANGUAGE: FORTRAN 77
  53 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  54 C
  55 C$$$
  56
  57       INCLUDE 'bufrlib.prm'
  58
  59       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
  60      .                INODE(NFILES),IDATE(NFILES)
  61       COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
  62       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
  63      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
  64      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
  65      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
  66      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
  67       COMMON /UFBCPL/ LUNCPY(NFILES)
  68
  69       CHARACTER*10 TAG
  70       CHARACTER*3  TYP
  71
  72       REAL*8 VAL
  73
  74 C----------------------------------------------------------------------
  75 C----------------------------------------------------------------------
  76
  77 C  CHECK THE FILE STATUSES AND I-NODE
  78 C  ----------------------------------
  79
  80       CALL STATUS(LUBIN,LUI,IL,IM)
  81       IF(IL.EQ.0) GOTO 900
  82       IF(IL.GT.0) GOTO 901
  83       IF(IM.EQ.0) GOTO 902
  84       IF(INODE(LUI).NE.INV(1,LUI)) GOTO 903
  85
  86       CALL STATUS(LUBOT,LUO,IL,IM)
  87       IF(IL.EQ.0) GOTO 904
  88       IF(IL.LT.0) GOTO 905
  89       IF(IM.EQ.0) GOTO 906
  90
  91       IF(INODE(LUI).NE.INODE(LUO)) THEN
  92         IF( (TAG(INODE(LUI)).NE.TAG(INODE(LUO))) .OR.
  93      .     (IOK2CPY(LUI,LUO).NE.1) ) GOTO 907
  94       ENDIF
  95
  96 C  EVERYTHING OKAY COPY USER ARRAY FROM LUI TO LUO
  97 C  -----------------------------------------------
  98
  99       NVAL(LUO) = NVAL(LUI)
 100
 101       DO N=1,NVAL(LUI)
 102       INV(N,LUO) = INV(N,LUI)
 103       VAL(N,LUO) = VAL(N,LUI)
 104       ENDDO
 105
 106       LUNCPY(LUO)=LUBIN
 107
 108 C  EXITS
 109 C  -----
 110
 111       RETURN
 112 900   CALL BORT('BUFRLIB: UFBCPY - INPUT BUFR FILE IS CLOSED, IT MUST'//
 113      . ' BE OPEN FOR INPUT')
 114 901   CALL BORT('BUFRLIB: UFBCPY - INPUT BUFR FILE IS OPEN FOR '//
 115      . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
 116 902   CALL BORT('BUFRLIB: UFBCPY - A MESSAGE MUST BE OPEN IN INPUT '//
 117      . 'BUFR FILE, NONE ARE')
 118 903   CALL BORT('BUFRLIB: UFBCPY - LOCATION OF INTERNAL TABLE FOR '//
 119      . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '//
 120      . 'INTERNAL SUBSET ARRAY')
 121 904   CALL BORT('BUFRLIB: UFBCPY - OUTPUT BUFR FILE IS CLOSED, IT '//
 122      . 'MUST BE OPEN FOR OUTPUT')
 123 905   CALL BORT('BUFRLIB: UFBCPY - OUTPUT BUFR FILE IS OPEN FOR '//
 124      . 'INPUT, IT MUST BE OPEN FOR OUTPUT')
 125 906   CALL BORT('BUFRLIB: UFBCPY - A MESSAGE MUST BE OPEN IN OUTPUT '//
 126      . 'BUFR FILE, NONE ARE')
 127 907   CALL BORT('BUFRLIB: UFBCPY - INPUT AND OUTPUT BUFR FILES MUST '//
 128      . 'HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE')
 129       END