SUBROUTINE PACKRA_OPER(KFILDO,KFILRA,RACESS,NUMRA,
     1                       ID,IDPARS,JP,ISCALD,IPLAIN,
     2                       PLAIN,NVRBL,ND4,
     3                       NDATE,NYR,NMO,NDA,NHR,
     4                       ICALL,CCALL,AA,ISDATA,XDATA,ND1,
     5                       NSTA,ICALLD,CCALLD,IPACK,ND5,MINPK,
     6                       IS0,IS1,IS2,IS4,ND7,
     7                       JTOTBY,JTOTRC,
     8                       L3264B,L3264W,ISTOP,IER)
C
C        OCTOBER   2003   GLAHN   TDL   MOS-2000
C        FEBRUARY  2004   GLAHN   TWO DIAGNOSTICS CORRECTED
C        MARCH     2005   JPD     ADDED DIMENSION STATEMENT FOR
C                                 ARRAY ICALL; CORRECTED SOME
C                                 COMMENTS; ADDED CALLS TO
C                                 W3TAGE FOR OPERATIONS; CHANGED
C                                 NAME FOR OPERATIONAL VERSION.
C        JUNE      2012   ENGLE   ADDED PLAIN( ) TO THE CALLING SEQUENCE
C                                 FOR ALL CALLS TO PAWRA. 
C        SEPTEMBER 2012   ENGLE   ADDED CALL TO WRTDLMC TO WRITE STATION
C                                 CALL LETTERS TO RANDOMA ACCESS FILE.
C
C        PURPOSE
C           TO PACK AND WRITE DATA TO A MOS-2000 RANDOM ACCESS 
C           VECTOR FILE.  THE FILE IS OPENED BY TRYING TO READ THE
C           DIRECTORY RECORD.  IF IT EXISTS, IT IS CHECKED WITH
C           THE STATION LIST IN CCALL( ).  IF IT CHECKS, THE DATA
C           IN AA( , ) ARE WRITTEN.  IF IT DOES NOT CHECK, DATA
C           ARE NOT WRITTEN AND AN ERROR IS INDICATED ON RETURN.
C   
C        DATA SET USE
C            KFILDO - UNIT NUMBER OF OUTPUT (PRINT) FILE.  (OUTPUT)
C            KFILRA - UNIT NUMBER OF RANDOM ACCESS FILE.  (OUTPUT)
C
C        VARIABLES
C              KFILDO = UNIT NUMBER OF OUTPUT (PRINT) FILE.  (INPUT)
C           KFILRA(J) = UNIT NUMBER OF RANDOM ACCESS TDLPACK
C                       OUTPUT FILE (J=1,5).  (INPUT)
C           RACESS(J) = FILE NAMES MATCHING KFILRA(J) (J=1,5).
C                       (INPUT)
C             NUMRA   = NUMBER OF VALUES IN KFILRA( ) AND RACESS( ).
C                       (INPUT)
C             ID(J,N) = THE INTEGER VARIABLE ID (J=1,4) (N=1,NVRBL)
C                       (INPUT)
C         IDPARS(J,N) = THE PARSED, INDIVIDUAL COMPONENTS OF THE
C                       VARIABLE
C                       ID CORRESPONDING TO ID( ) (J=1,15) (N=1,NVRBL).
C                       (INPUT)
C                       J=1--CCC (CLASS OF VARIABLE),
C                       J=2--FFF (SUBCLASS OF VARIABLE),
C                       J=3--B (BINARY INDICATOR),
C                       J=4--DD (DATA SOURCE, MODEL NUMBER),
C                       J=5--V (VERTICAL APPLICATION),
C                       J=6--LBLBLBLB (BOTTOM OF LAYER, 0 IF ONLY
C                            1 LAYER),
C                       J=7--LTLTLTLT (TOP OF LAYER),
C                       J=8--T (TRANSFORMATION),
C                       J=9--RR (RUN TIME OFFSET, ALWAYS + AND BACK
C                            IN TIME),
C                       J=10--OT (TIME APPLICATION),
C                       J=11--OH (TIME PERIOD IN HOURS),
C                       J=12--TAU (PROJECTION IN HOURS),
C                       J=13--I (INTERPOLATION TYPE),
C                       J=14--S (SMOOTHING INDICATOR), AND
C                       J=15--G (GRID INDICATOR).
C             JP(J,N) = CONTROLS THE OUTPUT BY VARIABLE (N=1,ND4).
C                       J=1--INDICATES WHETHER (>0) OR NOT (=0) THE
C                            DATA WILL BE PACKED AND WRITTEN
C                            TO TO A MOS-2000 EXTERNAL RANDOM ACCESS
C                            FILE, DEPENDING ON THE UNIT NUMBERS KFILRA
C                            NON ZERO;
C                       J=2--NOT USED IN PACKRA.
C                       J=3--NOT USED IN PACKRA.
C           ISCALD(N) = THE DECIMAL SCALING CONSTANT TO USE WHEN
C                       PACKING THE DATA (N=1,NVRBL).  (INPUT)
C       IPLAIN(L,J,N) = 32 CHARACTERS (L=1,L3264W) (J=1,4) OF PLAIN
C                       LANGUAGE DESCRIPTION OF VARIABLE (N=1,NVRBL).
C                       NOTE THAT THIS REQUIRES TWO 32-BIT WORDS TO HOLD
C                       THE DESCRIPTION BUT ONLY ONE 64-BIT WORD.
C                       (INPUT)
C            PLAIN(N) = THE PLAIN LANGUAGE DESCRIPTION OF THE VARIABLE 
C                       EQUIVALENCED TO IPLAIN( , ) (N=1,NVRBL).
C                       (CHARACTER*32) (INPUT)
C                 ND4 = MAXIMUM NUMBER OF VARIABLES.  USED AS DIMENSION.
C               NDATE = THE DATE/TIME FOR WHICH VARIABLES ARE BEING
C                       DEALT WITH.  (INPUT)
C                 NYR = YEAR, 4 DIGITS.  (INPUT)
C                 NMO = MONTH.  (INPUT)
C                 NDA = DAY OF MONTH.  (INPUT)
C                 NHR = HOUR, 2 DIGITS.  (INPUT)
C            CCALL(K) = 8 STATION CALL LETTERS (K=1,NSTA).  USED FOR
C                       PRINTOUT ONLY.  (CHARACTER*8)  (INPUT)
C             AA(N,K) = DATA FOR WRITING (N=1,NVRBL) (K=1,NSTA).
C                       (INPUT)
C           ISDATA(K) = USED IN PACKRA IN CALLING PACK1D (K=1,ND1).
C                       (INTERNAL)
C            XDATA(K) = DATA FOR WRITING (K=1,NSTA).  (INTERNAL)
C                 ND1 = DIMENSION OF ISDATA( ) AND XDATA( ).  (INPUT)
C                NSTA = THE NUMBER OF STATIONS IN CCALL( ).  (INPUT)
C         ICALLD(L,K) = 8 STATION CALL LETTERS AS CHARACTERS IN AN
C                       INTEGER VARIABLE (L=1,L3264W) (K=1,ND5).
C                       NOTE THAT THIS REQUIRES TWO 32-BIT WORDS TO HOLD
C                       THE DESCRIPTION BUT ONLY ONE 64-BIT WORD.
C                       EQUIVALENCED TO CCALLD( ).  (INTERNAL)
C           CCALLD(K) = 8 STATION CALL LETTERS (K=1,ND5).  (INTERNAL)
C            IPACK(J) = WORK ARRAY (J=1,ND5).  (INTERNAL)
C                 ND5 = DIMENSION OF IPACK( ).  (INPUT)
C               MINPK = MINIMUM GROUP SIZE WHEN PACKING THE VALUES.
C                       (INPUT)
C              IS0(J) = MOS-2000 GRIB SECTION 0 ID'S (J=1,3).
C                       (INTERNAL)
C              IS1(J) = MOS-2000 GRIB SECTION 1 ID'S (J=1,29).
C                       (INTERNAL)
C              IS2(J) = MOS-2000 GRIB SECTION 2 ID'S (J=1,12).
C                       (INTERNAL)
C              IS4(J) = MOS-2000 GRIB SECTION 4 ID'S (J=1,4). 
C                       (INTERNAL)
C                 ND7 = DIMENSION OF IS0( ), IS1( ), IS2( ), AND IS4( ).
C                       NOT ALL LOCATIONS ARE USED.  (INPUT)
C              JTOTBY = THE TOTAL NUMBER OF BYTES WRITTEN TO THE
C                       EXTERNAL RANDOM ACCESS FILE.  (INPUT-OUTPUT)
C              JTOTRC = THE TOTAL NUMBER OF LOGICAL RECORDS WRITTEN 
C                       TO THE EXTERNAL RANDOM ACCESS FILE.
C                       (INPUT-OUTPUT)
C              L3264B = INTEGER WORD LENGTH IN BITS OF MACHINE BEING 
C                       USED (EITHER 32 OR 64).  (INPUT)
C              L3264W = NUMBER OF WORDS IN 64 BITS (EITHER 1 OR 2).  
C                       (INPUT)
C               ISTOP = INCREMENTED BY ONE EACH TIME AN ERROR IS 
C                       ENCOUNTERED.  (INPUT-OUTPUT)
C                 IER = STATUS RETURN.
C                         0 = GOOD RETURN.
C                        16 = ND7 NOT LARGE ENOUGH.  SET ND7 GE 54.
C                       160 = UNIT NUMBER FOR WRITING RANDOM ACCESS
C                             FILE NO EQUAL 49.
C                       SEE ROUTINES PACK1D, UNPKBG, AND WRITEP 
C                       FOR OTHER VALUES.  (INTERNAL-OUTPUT)
C              ISCALE = THE BINARY SCALING CONSTANT TO USE WHEN
C                       PACKING THE DATA.  SET TP 0 BY DATA STATEMENT.
C                       (INTERNAL)
C              IOCTET = THE PACKED RECORD SIZE IN OCTETS (BYTES).
C                       PROVIDED BY PACK1D.  (INTERNAL)
C               CFILX = NAME OF FILE TO WRITE TO.  (INTERNAL)
C               KFILX = UNIT NUMBER OF FILE TO WRITE TO.  (INTERNAL)
C                       (CHARACTER*60)
C               NCHAR = NUMBER OF CHARACTERS OF PLAIN LANGUAGE TO PACK.
C                       SET BY DATA STATEMENT AT 32.  (INTERNAL)
C        1         2         3         4         5         6         7 X
C 
C        NONSYSTEM SUBROUTINES USED 
C            RDTLDM, WRTDLM, CLFILM,TRDATA, SETMIS, PAWRA
C
      CHARACTER*8 CCALL(ND1)
      CHARACTER*8 CCALLD(ND5)
      CHARACTER*32 PLAIN(ND4)
      CHARACTER*60 RACESS(5),CFILX
C
      DIMENSION ISDATA(ND1),XDATA(ND1),ICALL(L3264W,ND1)
      DIMENSION AA(NVRBL,NSTA)
      DIMENSION ID(4,ND4),IDPARS(15,ND4),JP(3,ND4),ISCALD(ND4)
      DIMENSION IPLAIN(L3264W,4,ND4)
      DIMENSION IPACK(ND5),ICALLD(L3264W,ND5)
      DIMENSION IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7)
      DIMENSION JD(4),KFILRA(5)
C
      DATA ISCALE/0/
      DATA NCHAR/32/
C
      IER=0
C
C        FIND WHETHER KFILRA( ) = 49.  THIS IS THE MOS-2000 EXTERNAL
C        READ/WRITE UNIT NUMBER.  IF SO, THE FILE NAME IS THE
C        CORRESPONDING RACESS( ).
C
      DO 406 J=1,NUMRA
C
      IF(KFILRA(J).EQ.49)THEN
         KFILX=KFILRA(J)
         CFILX=RACESS(J)
         GO TO 410
      ENDIF
C
 406  CONTINUE
C 
      WRITE(KFILDO,408)
 408  FORMAT(/' NO RANDOM ACCESS FILE IS WRITTEN BECAUSE NO UNIT',
     1        ' IS 49.')
      IER=160
      ISTOP=ISTOP+1
      GO TO 500
C
C        READ CALL LETTERS IF THEY EXIST AND CHECK THEM
C        TO MAKE ADDITION OF RECORDS POSSIBLE.
C
 410  JD(1)=400001000
      JD(2)=0
      JD(3)=0
      JD(4)=0
CINTEL
C      CALL RDTDLM(KFILDO,KFILX,CFILX,JD,ICALLD,ND1*L3264W,NVALUE,
C     1            L3264B,IER)
      CALL RDTDLMC(KFILDO,KFILX,CFILX,JD,CCALLD,ND1*L3264W,NVALUE,
     1            L3264B,IER)
CINTEL
C
      IF(IER.EQ.155)THEN
C           THE DIRECTORY DID NOT EXIST.  THIS IS NOT AN ERROR.
         WRITE(KFILDO,411)CFILX
 411     FORMAT('     THE DIRECTORY DOES NOT EXIST ON FILE ',
     1          A60,/,'     SO WRITE THE CALL LETTERS.')
         GO TO 440
C
      ELSEIF(IER.NE.0)THEN
         WRITE(KFILDO,412)IER,KFILX,CFILX
 412     FORMAT('     ERROR OPENING RANDOM ACCESS FILE OR',
     1          ' READING STATION DIRECTORY IN PACKRA AT 412.',/,
     2          '     IER =',I4,' ON UNIT NO. =',I4,',  FILE NAME = ',
     3            A60)
         WRITE(KFILDO,413)
 413     FORMAT('     PROGRAM STOPS IN SUBROUTINE PACKRA')
      CALL W3TAGE('PACKRA')
         STOP 412
      ENDIF
C
      NVALUE=NVALUE/L3264W
C        THE CALL LETTERS ARE 8 BYTES EACH.  THIS IS TWO WORDS
C        ON A 32-BIT MACHINE.  THE NUMBER OF WORDS WRITTEN AND
C        READ MUST ACCOUNT FOR THIS.  THE ACTUAL NUMBER OF CALL
C        LETTERS IS NVALUE/L3264W.
C
C        CALL LETTERS WERE READ.  DO THEY MATCH?
C
      IF(NVALUE.EQ.NSTA)GO TO 425
      WRITE(KFILDO,420)NVALUE,NSTA,
     1     (CCALL(J),CCALLD(J),J=1,MAX(NVALUE,NSTA))
 420  FORMAT(/' ****NUMBER OF CALL LETTERS READ FROM',
     1        ' RANDOM ACCESS OUTPUT FILE =',I7,/,
     2        '     DOES NOT EQUAL THE NUMBER TO BE WRITTEN =',
     3        I7,'.  STOP IN PACKRA AT 420.',/,
     4        ('     ',A8,1X,A8))
C        VALUES BEYOND NVALUE IN CCALL( ) WILL NOT BE
C        CHARACTER ORIENTED, AND PROBABLY NOT PRINTABLE AS A8.
      CALL W3TAGE('PACKRA')
      STOP 420
C
 425  MATCH=0
C
      DO 430 J=1,NSTA
      IF(CCALL(J).EQ.CCALLD(J))GO TO 430
      WRITE(KFILDO,426)CCALL(J),CCALLD(J)
 426  FORMAT(/' ****MISMATCH OF CALL LETTERS TO BE WRITTEN',
     1        ' AND THOSE ON RANDOM ACCESS FILE.',2(2X,A8))
      MATCH=1
 430  CONTINUE
C
      IF(MATCH.EQ.0)GO TO 448
      WRITE(KFILDO,434)(CCALL(J),CCALLD(J),J=1,NSTA)
 434  FORMAT(/' TO WRITE  ON CONSTANT FILE',/,
     1       (' ',A8,2X,A8))
      WRITE(KFILDO,435)
 435  FORMAT(/'     STOP IN PACKRA AT 435.' ) 
      CALL W3TAGE('PACKRA')
      STOP 435
C  
C        WRITE CALL LETTERS RECORD WHEN SUCH A RECORD DOES
C        NOT EXIST.
C
CINTEL
C 440  CALL WRTDLM(KFILDO,KFILX,CFILX,JD,ICALL,NSTA*L3264W,
C     1               0,0,L3264B,IER)
 440  CALL WRTDLMC(KFILDO,KFILX,CFILX,JD,CCALL,NSTA*L3264W,
     1               0,0,L3264B,IER)
CINTEL
      JTOTBY=JTOTBY+NSTA*8
      JTOTRC=JTOTRC+1
C        THE CALL LETTERS ARE 8 BYTES EACH.  THIS IS TWO WORDS
C        ON A 32-BIT MACHINE.  THE NUMBER OF WORDS WRITTEN AND
C        READ MUST ACCOUNT FOR THIS.
C
      IF(IER.NE.0)THEN
         WRITE(KFILDO,445)IER
 445     FORMAT(/' ****ERROR WRITING STATION DIRECTORY',
     1           ' ON RANDOM ACCESS FILE IN PACKRA AT 441.',
     2           '  IER =',I4)
         WRITE(KFILDO,447)
 447     FORMAT('     PROGRAM STOPS IN SUBROUTINE PACKRA')
      CALL W3TAGE('PACKRA')
         STOP 445
      ENDIF
C
      IF(ND7.LT.54)THEN
C           IS1( ) WILL BE OVERFLOWED IN PAWRA.
         WRITE(KFILDO,446)ND7
 446     FORMAT(/' ****IS1( ) IN UNPACK CALLED BY PACKRA/PAWRA WILL',
     1           ' BE OVERFLOWED.  INCREASE ND7 FROM ',I4,' TO 54.'/
     2           '     RANDOM ACCESS DATA WILL NOT BE WRITTEN.')
         IER=16
         ISTOP=ISTOP+1
         GO TO 500
      ENDIF
C
 448  DO 460 N=1,NVRBL
      IF(JP(1,N).EQ.0)GO TO 460
C        JP(1, ) CONTROLS WRITING FOR EACH VARIABLE.  ALSO,
C        DATA WILL NOT BE WRITTEN UNLESS A RANDOM ACCESS UNIT = 49.
C
C        LOAD IS1( ) FOR PACKING.  ALL OTHER VALUES ARE PROVIDED
C        BY THE PACKING ROUTINES.
C
      IS1(2)=0
C        IS1(2) = 0 SIGNIFIES VECTOR DATA.
      IS1(3)=NYR
      IS1(4)=NMO
      IS1(5)=NDA
      IS1(6)=NHR
      IS1(7)=0
      IS1(8)=NDATE
      IS1(9)=ID(1,N)
      IS1(10)=ID(2,N)
      IS1(11)=ID(3,N)
      IS1(12)=ID(4,N)
      IS1(13)=IDPARS(12,N)
      IS1(14)=0
      IS1(15)=IDPARS(4,N)
      IS1(16)=0
      IS1(17)=ISCALD(N)
      IS1(18)=ISCALE
      IS1(19)=0
      IS1(20)=0
      IS1(21)=0
      IS1(22)=32
C
C        WRITE THE DATA WITH REPLACEMENT.
C    
      CALL TRDATA(KFILDO,AA,XDATA,N,NVRBL,NSTA)
C
C        SET QMISSS = 0. OR 9997. DEPENDING ON WHETHER A 9997.
C        APPEARS IN THE DATA TO BE PACKED.  SET QMISSP = 0.
C        OR 9999. DEPENDING ON WHETHER A 9999. OR 9997. APPEAR
C        IN THE DATA TO BE PACKED.  THESE VALUES ARE USED SO AS
C        NOT TO CONFLICT WITH XMISSP AND XMISSS IN CASE THEY ARE
C        EVER TRANSMITTED TO THE ROUTINE.
C
      CALL SETMIS(KFILDO,XDATA,NSTA,QMISSP,QMISSS)
C
      CALL PAWRA(KFILDO,KFILX,CFILX,ID(1,N),
     1           XDATA,ISDATA,ND1,NSTA,IPACK,ND5,MINPK,
     2           IS0,IS1,IS2,IS4,ND7,
     3           IPLAIN(1,1,N),PLAIN(N),NCHAR,
     4           QMISSP,QMISSS,LX,IOCTET,
     5           L3264B,L3264W,IER)
      JTOTBY=JTOTBY+IOCTET
      JTOTRC=JTOTRC+1
C
      WRITE(KFILDO,455)(ID(J,N),J=1,4),PLAIN(N)
 455  FORMAT(' WRITING DATA TO RANDOM ACCESS FILE',4I11,4X,A32)
C
 460  CONTINUE
C
C        CLOSE RANDOM ACCESS FILE.
C
      CALL CLFILM(KFILDO,KFILX,IER)
  500 RETURN
      END