var/external/bufr/iok2cpy.f

   1       INTEGER FUNCTION IOK2CPY(LUI,LUO)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    IOK2CPY
   6 C   PRGMMR: J. ATOR          ORG: NP20       DATE: 2009-06-26
   7 C
   8 C ABSTRACT: THIS FUNCTION DETERMINES WHETHER A MESSAGE, OR A SUBSET
   9 C   FROM A MESSAGE, CAN BE COPIED FROM LOGICAL UNIT IOLUN(LUI) TO
  10 C   LOGICAL UNIT IOLUN(LUO).  THE DECISION IS BASED ON WHETHER THE
  11 C   EXACT SAME DEFINITION FOR THE GIVEN MESSAGE TYPE APPEARS WITHIN
  12 C   THE DICTIONARY TABLE INFORMATION FOR BOTH LOGICAL UNITS.  NOTE THAT
  13 C   IT IS POSSIBLE FOR A MESSAGE TYPE TO BE IDENTICALLY DEFINED FOR TWO
  14 C   DIFFERENT LOGICAL UNITS EVEN IF THE UNITS THEMSELVES DON'T SHARE
  15 C   THE EXACT SAME FULL SET OF DICTIONARY TABLES.
  16 C
  17 C PROGRAM HISTORY LOG:
  18 C 2009-06-26  J. ATOR    -- ORIGINAL AUTHOR
  19 C
  20 C USAGE:    IOK2CPY (LUI, LUO)
  21 C   INPUT ARGUMENT LIST:
  22 C     LUI      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  23 C                FOR LOGICAL UNIT TO COPY FROM
  24 C     LUO      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  25 C                FOR LOGICAL UNIT TO COPY TO
  26 C
  27 C   OUTPUT ARGUMENT LIST:
  28 C     IOK2CPY  - INTEGER: RETURN CODE INDICATING WHETHER IT IS OKAY TO
  29 C                COPY FROM IOLUN(LUI) TO IOLUN(LUO)
  30 C                  0 - NO
  31 C                  1 - YES
  32 C
  33 C REMARKS:
  34 C    THIS ROUTINE CALLS:        ICMPDX   NEMTBAX
  35 C    THIS ROUTINE IS CALLED BY: COPYSB   COPYMG   CPYMEM   UFBCPY
  36 C                               Normally not called by any application
  37 C                               programs.
  38 C
  39 C ATTRIBUTES:
  40 C   LANGUAGE: FORTRAN 77
  41 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  42 C
  43 C$$$
  44
  45       INCLUDE 'bufrlib.prm'
  46
  47       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
  48      .                INODE(NFILES),IDATE(NFILES)
  49       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
  50      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
  51      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
  52      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
  53      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
  54
  55       CHARACTER*10 TAG
  56       CHARACTER*8  SUBSET
  57       CHARACTER*3  TYP
  58
  59 C-----------------------------------------------------------------------
  60 C-----------------------------------------------------------------------
  61
  62       IOK2CPY = 0
  63
  64 C     Do both logical units have the same internal table information?
  65
  66       IF ( ICMPDX(LUI,LUO) .EQ. 1 ) THEN
  67         IOK2CPY = 1
  68         RETURN
  69       ENDIF
  70
  71 C     No, so get the Table A mnemonic from the message to be copied,
  72 C     then check whether that mnemonic is defined within the dictionary
  73 C     tables for the logical unit to be copied to.
  74
  75       SUBSET = TAG(INODE(LUI))
  76       CALL NEMTBAX(LUO,SUBSET,MTYP,MSBT,INOD)
  77       IF ( INOD .EQ. 0 ) RETURN
  78
  79 C     The Table A mnemonic is defined within the dictionary tables for
  80 C     both units, so now make sure the definitions are identical.
  81
  82       NTEI = ISC(INODE(LUI))-INODE(LUI)
  83       NTEO = ISC(INOD)-INOD
  84       IF ( NTEI .NE. NTEO ) RETURN
  85
  86       DO I = 1, NTEI
  87         IF ( TAG(INODE(LUI)+I) .NE. TAG(INOD+I) ) RETURN
  88         IF ( TYP(INODE(LUI)+I) .NE. TYP(INOD+I) ) RETURN
  89         IF ( ISC(INODE(LUI)+I) .NE. ISC(INOD+I) ) RETURN
  90         IF ( IRF(INODE(LUI)+I) .NE. IRF(INOD+I) ) RETURN
  91         IF ( IBT(INODE(LUI)+I) .NE. IBT(INOD+I) ) RETURN
  92       ENDDO
  93
  94       IOK2CPY = 1
  95
  96       RETURN
  97       END