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