PROGRAM RA2RA C C$$$ MAIN PROGRAM DOCUMENTATION BLOCK *** C C MAIN PROGRAM: ENS_RA2RA C PRGMMR: WIEDENFELD ORG: OST21 DATE: 2007-11-06 C C ABSTRACT: TO COPY ONE EXTERNAL RANDOM ACCESS TDLPACK FILE TO A C NEW ONE, CREATING A NEW DIRECTORY FROM ONE READ IN (IF PRESENT), C OMITTING RECORDS AS DESIRED, AND OMITTING BLANK RECORDS C (FRAGMENTATION FROM WRITING WITH REPLACEMENT). THE INPUT AND C OUTPUT FILES MUST HAVE BEEN CREATED WITH U350. OPTIONALLY, C THE STATION WBAN NUMBERS, ELEVATIONS, LATITUDES, AND LONGITUDES C WILL BE WRITTEN. MULTIPLE FILES OF INPUT DATA ARE ACCOMMODATED. C U353 CAN BE USED TO INVENTORY A FILE BY COPYING IT TO ANOTHER. C ONE OF THE TWO COULD THEN BE DELETED. C C PROGRAM HISTORY LOG: C 00-02-01 GLAHN CREATED. C 07-11-06 WIEDENFELD ADDED NCEP DOC-BLOCK, CALLS TO W3TAGB, CHANGED C VALUE KFILDO FROM 12 TO 6 C 17-06-28 SAMPLATSKY MODIFIED HOW IP( ) IS DEFINED, BY FORCING C IP(5) TO BE 0. THIS IS TO PREVENT RDSTAD C FROM PRODUCING VOLUMINOUS OUTPUT. C C USAGE: C C DATA SET USE C INPUT FILES: C FORT.KFILDI - UNIT NUMBER FOR INPUT FILE. (INPUT) C FORT.KFILD(J) - THE UNIT NUMBER FOR WHERE THE STATION LIST C (J=1) AND THE STATION DIRECTORY (J=2) RESIDES. C CORRESPONDS TO DIRNAM(J). WHEN KFILD(1) = C KFILDI, THE DEFAULT INPUT IS INDICATED, C DIRNAM(1) IS NOT USED, AND THE FILE IS NOT C OPENED. KFILD(1) CAN EQUAL KFILD(2), IN WHICH C CASE THE STATION LIST IS TAKEN FROM THE C DIRECTORY (I.E., A SEPARATE STATION LIST IS NOT C PROVIDED). (INPUT) C FORT.KFILP - UNIT NUMBER OF THE INPUT RANDOM ACCESS FILE. C (INPUT) C FORT.KFILX - UNIT NUMBER OF THE OUTPUT RANDOM ACCESS FILE. C (INPUT/OUTPUT) C C OUTPUT FILES: C FORT.KFILDO - UNIT NUMBER FOR OUTPUT (PRINT) FILE. (OUTPUT) C FORT.KFILX - UNIT NUMBER OF THE OUTPUT RANDOM ACCESS FILE. C (INPUT/OUTPUT) C C VARIABLES C KFILDI = UNIT NUMBER FOR INPUT FILE. C KFILDO = UNIT NUMBER FOR OUTPUT (PRINT) FILE. SET TO 12 C BY DATA STATEMENT. C KFILD(J) = UNIT NUMBER FOR WHERE THE STATION LIST (J=1) C AND THE STATION DIRECTORY (J=2) RESIDES. C CORRESPONDS TO DIRNAM(J). WHEN KFILD(1) = C KFILDI, THE DEFAULT INPUT IS INDICATED, C DIRNAM(1) IS NOT USED, AND THE FILE IS NOT C OPENED. KFILD(1) CAN EQUAL KFILD(2), IN WHICH C CASE THE STATION LIST IS TAKEN FROM THE C DIRECTORY (I.E., A SEPARATE STATION LIST IS NOT C PROVIDED). C KFILX = UNIT NUMBER OF THE OUTPUT RANDOM ACCESS FILE. C CFILX = FILE NAME OF OUTPUT RANDOM ACCESS FILE. C (CHARACTER*60) C KFILP = UNIT NUMBER OF THE INPUT RANDOM ACCESS FILE. C CFILP = FILE NAME OF INPUT RANDOM ACCESS FILE. C (CHARACTER*60) C ND1 = THE MAXIMUM NUMBER OF STATIONS THAT CAN BE DEALT C WITH ON THIS RUN. DIMENSION OF SEVERAL C VARIABLES. SET BY PARAMETER. C ND4 = MAXIMUM NUMBER OF VARIABLE IDS TO ELIMINATE C (EXCLUSIVE OF DIRECTORY RECORD) PLUS 1. C ND5 = ND1. ND5 IS USED TO BE CONSISTENT WITH OTHER C MOS-2000 PROGRAMS. SET BY PARAMETER. C ND7 = DIMENSION OF IS0( ), IS1( ), IS2( ),AND IS4( ). C SHOULD BE 54. SET BY PARAMETER. C L3264B = INTEGER WORD LENGTH IN BITS OF MACHINE BEING C USED (EITHER 32 OR 64). SET BY PARAMETER. C L3264W = NUMBER OF WORDS IN 64 BITS (EITHER 1 OR 2). C CALCULATED BY PARAMETER, BASED ON L3464B. C ICALL(L,K,J) = 8 STATION CALL LETTERS AS CHARACTERS IN AN C INTEGER VARIABLE (L=1,L3264W) (K=1,NSTA). C SIX SETS ARE PROVIDED FOR (J=1,6). C NOTE THAT THIS REQUIRES TWO 32-BIT WORDS TO HOLD C THE DESCRIPTION BUT ONLY ONE 64-BIT WORD. C EQUIVALENCED TO CCALL( , ). C ICALLD(L,K) = 8 STATION CALL LETTERS AS CHARACTERS IN AN C INTEGER VARIABLE (L=1,L3264W) (K=1,ND1). THIS C LIST IS USED IN RDTDLM. EQUIVALENCED TO C CCALLD( ). C CCALL(K,J) = 8-CHARACTER STATION CALL LETTERS (K=1,NSTA) C FOR UP TO 6 STATIONS (J=1,6). C EQUIVALENCED TO ICALL( ). C CCALLD(K) = 8 STATION CALL LETTERS (K=1,NSTA). THIS LIST IS C USED IN RDSTAD TO RETAIN THE ORIGINAL LIST IN C CCALL( ). C EQUIVALENCED TO ICALLD( , ). C NAME(K) = NAMES OF STATIONS (K=1,NSTA) (CHARACTER*20) C DIRNAM(J) = HOLDS NAME OF DATA SET CONTAINING THE STATION C CALL LETTERS (J=1) AND STATION DIRECTORY (J=2). C IT IS EXPECTED THAT THE STATIONS IN C THE DIRECTORY BE ORDERED ALPHABETICALLY BY CALL C LETTERS. (CHARACTER*60) C NELEV(K) = ELEVATION OF STATIONS (K=1,NSTA). EQUIVALENCED C TO ELEV( ). C ELEV(K) = ELEVATION OF STATIONS (K=1,NSTA). EQUIVALENCED C TO NELEV( ). C IWBAN(K) = WBAN NUMBERS OF STATIONS (K=1,NSTA). C EQUIVALENCED TO WBAN( ). C WBAN(K) = WBAN NUMBERS OF STATIONS (K=1,NSTA). C EQUIVALENCED TO IWBAN( ). C STALAT(K) = LATITUDE OF STATIONS (K=1,NSTA). C STALON(K) = LONGITUDE OF STATIONS (K=1,NSTA). C IFOUND(K) = SCRATCH IN RDSTAD (K=1,NSTA) C ITIMEZ(K) = TIME ZONE OF STATIONS (K=1,NSTA) C NSTA = THE NUMBER OF STATIONS TO BE WRITTEN TO C THE RANDOM ACCESS FILE. C INDEX(J) = INDEX FOR CORRESPONDENCE BETWEEN INPUT AND C OUTPUT VALUES (J=1,ND1). VALUES OF 99999999 C MEAN STATION IS NOT AVAILABLE ON INPUT. C IC(J) = SCRATCH ARRAY USED IN PACKING THE DATA C (J=1,ND1). C IPACK(J) = SCRATCH ARRAY USED IN PACKING THE DATA C (J=1,ND5). C IWORK(J) = SCRATCH ARRAY (J=1,ND5). C DATA1(J) = SCRATCH ARRAY (J=1,ND5). C IS0(L) = HOLDS THE VALUES TO FURNISH FOR GRIB C SECTION 0 (L=1,ND7). C IS1(L) = HOLDS THE VALUES TO FURNISH FOR GRIB C SECTION 1 (L=1,ND7). C IS2(L) = HOLDS THE VALUES FOR GRIB SECTION 2 (L=1,ND7). C NOT ALL LOCATIONS ARE USED. C IS4(L) = HOLDS THE VALUES FOR GRIB SECTION 4. NONE OF C THE VALUES NEED BE FURNISHED BY THE USER. C IS4(2) IS SET BY PACK1D TO INDICATE C NON-GRIDPOINT DATA, COMPLEX PACKING, ORIGINAL C SCALED VALUES TO BE PACKED (NOT SECOND ORDER C SPATIAL DIFFERENCES), AND MISSING VALUES OR NOT C DEPENDING ON WHETHER OR NOT XMISS NE OR EQ ZERO, C RESPECTIVELY. C ID(J,L) = MOS IDS OF VARIABLES TO ELIMINATE (J=1,4) C (L=1,ND4). THIS PERTAINS TO EACH INPUT FILE C SEPARATELY. C NCHAR = THE NUMBER OF CHARACTERS OF PLAIN LANGUAGE IN C PLAIN TO PACK WITH THE DATA. C IPLAIN( , ,J) = NAMES OF VARIABLES (J=1,5). EQUIVALENCED TO C PLAIN. C PLAIN(J) = NAMES OF VARIABLES (J=1,5). EQUIVALENCED TO C IPLAIN( , , ). (CHARACTER*32) C IP(J) = PRINT PARAMETERS (J=1,25). ALL ARE SET BY DATA C STATEMENT TO THE SAME VALUE AS THE DEFAULT C KFILDO = 12. C XMISSP = SET TO 9999. INDICATING THAT ANY MISSING DATA C VALUE WILL BE PACKED AS 9999. C XMISSS = SET TO 0 TO INDICATE THERE WILL BE NO SECONDARY C MISSING VALUE INDICATOR (SEE XMISSP). C MINPK = VALUES ARE PACKED IN GROUPS OF MINIMUM SIZE C MINPK. ONLY WHEN THE NUMBER OF BITS TO HANDLE C A GROUP CHANGES WILL A NEW GROUP BE FORMED. C SET TO 14 BY DATA STATEMENT. C LX = THE NUMBER OF GROUPS (THE NUMBER OF 2ND ORDER C MINIMA). WHILE NEEDED ONLY IN SUBROUTINE PACK, C IT IS OUTPUT IN THE ARGUMENT LIST OF PAWRA IN C CASE THE USER WANTS TO KNOW IT. C IOCTET = THE TOTAL MESSAGE SIZE IN OCTETS. C IER = STATUS RETURN FROM SUBROUTINES. C 0 = GOOD VALUE. C SEE CALLED SUBROUTINE FOR OTHER VALUES. C ICOUNT = COUNTS THE VARIABLES WRITTEN. C MPACK = 0 WHEN DATA DO NOT HAVE TO BE UNPACKED C AND REPACKED. EQUALS 1 OTHERWISE. C STATE = SET TO A STATEMENT NUMBER FOR USE IN WRITING C DIAGNOSTIC. C BLANK = 8 BLANK CHARACTERS. (CHARACTER*8) C RUNID = 72 CHARACTERS TO IDENTIFY RUN. (CHARACTER*72) C DATA(J) = THE DATA TO WRITE, AFTER ORDERING (J=1,NSTA). C IDUM = DUMMY VARIABLE FOR CALL TO RDSNAM. C NVALUE = NUMBER OF BYTES READ FROM THE RANDOM ACCESS C FILE, THEN THE NUMBER OF WORDS. C IWRELE = INDICATES WHETHER (=1) OR NOT (=0) THE ELEVATIONS C TAKEN FROM THE STATION DIRECTORY ARE TO BE C WRITTEN. C IWRWBN = INDICATES WHETHER (=1) OR NOT (=0) THE WBAN NUMBERS C TAKEN FROM THE STATION DIRECTORY ARE TO BE C WRITTEN. C IWRLAT = INDICATES WHETHER (=1) OR NOT (=0) THE LATITUDES C TAKEN FROM THE STATION DIRECTORY ARE TO BE C WRITTEN. C IWRLON = INDICATES WHETHER (=1) OR NOT (=0) THE LONGITUDES C TAKEN FROM THE STATION DIRECTORY ARE TO BE C WRITTEN. C IPA(J) = THE 4 IDS OF THE VARIABLE BEING DEALT WITH. C C SUBPROGRAMS CALLED: CLFILM, IERX, PAWRA, RDSNAM, RDSTAL, RDTDLM, TIMPR C W3TAGB, W3TAGE, WRTDLM C UNIQUE: - NONE C LIBRARY: C MOSLIB - CLFILM, IERX, PAWRA, RDSNAM, RDSTAL, RDTDLM, TIMPR, WRTDLM C W3LIB - W3TAGB, W3TAGE C C EXIT STATES: C COND = 0 - SUCCESSFUL RUN C 106 - ERROR READING UNIT NUMBERS FOR STATION LIST AND C STATION DIRECTORY DATA SETS C 120 - NUMBER OF CALL LETTERS TO WRITE DOES NOT EQUAL THE C NUMBER READ FROM THE CONSTANT FILE C 130 - ERROR READING DATE FILE UNIT NUMBER C 135 - MISMATCH OF CALL LETTERS TO BE WRITTEN AND THOSE ON C RANDOM ACCESS FILE C 161 - ERROR WRITING WBAN NUMBERS ON RANDOM ACCESS FILE C 171 - ERROR WRITING ELEVATIONS ON RANDOM ACCESS FILE C 181 - ERROR WRITING LATITUDES ON RANDOM ACCESS FILE C 191 - ERROR WRITING LONGITUDES ON RANDOM ACCESS FILE C 199 - ERROR IN CALL TO RDSTAL C 215 - ERROR IN CALL TO RDF C 220 - NUMBER OF DATA VALUES DOES NOT EQUAL THE NUMBER OF STATIONS C 260 - ERROR WRITING DATA ON RANDOM ACCESS FILE C 900 - ERROR OPENING OR READING A FILE, OR END OF FILE ENCOUNTERED C 1075 - ERROR READING UNIT NUMBER FOR RANDOM ACCESS C OUTPUT FILE C 1090 - ERROR READING STATION DIRECTORY IN RANDOM ACCESS FILE C 1995 - ERROR READING UNIT NUMBER OF IN ASCII FILE AND STATION C DIRECTORY C REMARKS: NONE C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 (xlf90 compiler) C MACHINE: IBM SP C C$$$ C PARAMETER (ND1=988000) PARAMETER (ND4=11000) PARAMETER (ND5=ND1) PARAMETER (ND7=54) PARAMETER (L3264B=32) C SET L3264B = 64 FOR RUNNING ON THE CRAY. PARAMETER (L3264W=64/L3264B) C CHARACTER*4 STATE CHARACTER*8 CCALL(ND1,6),CCALLD(ND1),BLANK CHARACTER*20 NAME(ND1) CHARACTER*60 DIRNAM(2),CFILX,CFILP,DATNAM CHARACTER*32 PLAIN(5) CHARACTER*72 RUNID C DIMENSION ICALL(L3264W,ND1,6),ICALLD(L3264W,ND1) DIMENSION NELEV(ND1),ELEV(ND1),IWBAN(ND1),WBAN(ND1), 1 STALAT(ND1),STALON(ND1),IFOUND(ND1), 2 IC(ND1),INDEX(ND1),ITIMEZ(ND1) DIMENSION ID(4,ND4) DIMENSION IPACK(ND5),IWORK(ND5),DATA(ND5),DATA1(ND5) DIMENSION IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7) DIMENSION IPLAIN(L3264W,4,5) DIMENSION KFILD(2),IDUM(2),IP(25),JD(4),IPA(4) C EQUIVALENCE (NELEV,ELEV),(IWBAN,WBAN) EQUIVALENCE (PLAIN,IPLAIN),(ICALL,CCALL),(ICALLD,CCALLD) C DATA KFILDI/5/, 1 KFILDO/6/ DATA XMISSP/9999./, 1 XMISSS/0./ DATA MINPK/14/ DATA PLAIN/'WBAN NUMBER ', 1 'ELEVATION ', 2 'LATITUDE ', 3 'LONGITUDE ', 4 ' '/ DATA BLANK/' '/ DATA ICOUNT/0/ C CALL W3TAGB('ENS_RA2RA',2007,0258,0065,'OST211') C CALL TIMPR(KFILDO,KFILDO,'START U353 ') C C MODIFIED JUN 2017 C C SET IP( ) TO DEFAULT OUTPUT, EXCEPT FOR IP(5). THIS IS TO C PREVENT RDSTAD FROM PRODUCING VOLUMINOUS PRINT OF LAT/LON C FOR EVERY SINGLE STATION. C DO 101 J=1,25 IF (J.EQ.5) THEN IP(J)=0 ELSE IP(J)=KFILDO END IF 101 CONTINUE C C OPEN INPUT FILE. C STATE='101 ' C OPEN(UNIT=KFILDI,FILE='U353.CN',STATUS='OLD',IOSTAT=IOS, C 1 ERR=900) C C READ AND PRINT RUN DESCRIPTION. C STATE='102 ' READ(KFILDI,102,IOSTAT=IOS,ERR=900,END=900)RUNID 102 FORMAT(A72) WRITE(KFILDO,103)RUNID 103 FORMAT(' ',A72) C C READ CONTROL TO INDICATE WHETHER OR NOT WBAN NUMBERS, C ELEVATIONS, LATITUDES, AND LONGITUDES WILL BE WRITTEN. C STATE='104 ' READ(KFILDI,104,IOSTAT=IOS,ERR=900,END=900) 1 IWRELE,IWRWBN,IWRLAT,IWRLON 104 FORMAT(4I4) WRITE(KFILDO,105)IWRELE,IWRWBN,IWRLAT,IWRLON 105 FORMAT(/,' IWRELE',I4,' WILL ELEVATIONS BE WRITTEN?',/, 1 ' IWRWBN',I4,' WILL WBAN NUMBERS BE WRITTEN?',/, 2 ' IWRLAT',I4,' WILL LATITUDES BE WRITTEN?',/, 3 ' IWRLON',I4,' WILL LONGITUDES BE WRITTEN?') C C READ AND PROCESS UNIT NUMBERS AND FILE NAMES FOR STATION LIST C (CALL LETTERS) AND STATION DIRECTORY WHICH HOLDS CALL LETTERS, C LATITUDE, LONGITUDE, WBAN NUMBER, ELEVATION, AND NAME FOR EACH C POSSIBLE STATION. THIS CAN BE A MASTER DIRECTORY, OR BE A C DIRECTORY SUPPLIED BY A USER. C CALL RDSNAM(KFILDI,KFILDO,KFILD,DIRNAM,IDUM,IDUM,2,NUMIN,'OLD', 1 'FORMATTED',IP,IER) C IF(IER.NE.0)THEN WRITE(KFILDO,106)IER 106 FORMAT(/,' ****ERROR READING UNIT NUMBERS AND NAMES OF STATION' 1 ,' LIST AND DIRECTORY DATA SETS IN U353 AT 106.', 2 ' IER =',I4) CALL W3TAGE('ENS_RA2RA') STOP 106 ENDIF C WRITE(KFILDO,1060)(KFILD(J),DIRNAM(J),J=1,2) 1060 FORMAT(/,' STATION LIST AND DIRECTORY DATA SETS, UNITS AND NAMES.' 1 ,/,(' ',I4,2X,A60)) C C READ AND PROCESS UNIT NUMBER AND FILE NAME OF OUTPUT C RANDOM ACCESS FILE. C CALL RDSNAM(KFILDI,KFILDO,KFILX,CFILX,IDUM,IDUM,1,NUMIN,'NOT', 1 'FORMATTED',IP,IER) C NOTE THAT THIS FILE IS NOT OPENED. C IF(IER.NE.0)THEN WRITE(KFILDO,107)IER 107 FORMAT(/,' ****ERROR READING UNIT NUMBER AND NAME OF', 1 ' OUTPUT RANDOM ACCESS FILE IN U353 AT 107.', 2 ' IER =',I4) CALL W3TAGE('ENS_RA2RA') STOP 107 ENDIF C WRITE(KFILDO,1070)KFILX,CFILX 1070 FORMAT(/,' OUTPUT RANDOM ACCESS FILE UNIT AND NAME.',/, 1 (' ',I4,2X,A60)) C C INITIALIZE CCALL( , ) AND CCALLD( ). C DO 109 K=1,ND1 C DO 108 J=1,6 CCALL(K,J)=BLANK 108 CONTINUE C CCALLD(K)=BLANK 109 CONTINUE C C READ AND PRINT THE STATION LIST AND DIRECTORY C INFORMATION. C NEW=1 C NEW CALL LETTERS ARE USED IN RANDOM ACCESS FILES. CALL RDSTAD(KFILDO,IP(4),IP(5),KFILD,NEW,CCALL,CCALLD, 1 NAME,NELEV,IWBAN,STALAT,STALON,ITIMEZ,IFOUND, 2 ND1,NSTA,IER) C IF(IER.NE.0)THEN WRITE(KFILDO,1095) 1095 FORMAT(/,' ****STOP IN U353 AT 1095.') C RDSTAD WILL HAVE PRODUCED A DIAGNOSTIC FOR ANY C IER NE 0. CALL W3TAGE('ENS_RA2RA') STOP 1095 ENDIF C C CONVERT ELEVATIONS AND WBAN NUMBERS TO FLOATING POINT. C DO 110 J=1,NSTA ELEV(J)=NELEV(J) WBAN(J)=IWBAN(J) 110 CONTINUE C C ZERO ARRAYS. C DO 111 J=1,ND7 IS0(J)=0 IS1(J)=0 IS2(J)=0 IS4(J)=0 111 CONTINUE C C OUTPUT FILE MUST BE NEW. TRY TO READ DIRECTORY C RECORD. IF IT IS NOT FOUND, IT IS ASSUMED TO BE NEW. C JD(1)=400001000 JD(2)=0 JD(3)=0 JD(4)=0 CALL RDTDLMC(KFILDO,KFILX,CFILX,JD,ICALLD,ND1*L3264W,NVALUE, 1 L3264B,IER) C IF(IER.EQ.155)THEN WRITE(KFILDO,119) 119 FORMAT(' THIS IS EXPECTED ON THIS NEW FILE.') GO TO 130 ELSE C THERE WAS AN ERROR OR THE FILE IS NOT NEW. WRITE(KFILDO,120)CFILX 120 FORMAT(/,' ****THE OUTPUT FILE ',A60,/, 1 ' SEEMS TO BE NOT NEW; IT MUST BE.',/, 2 ' STOP IN U353 AT 120.') CALL W3TAGE('ENS_RA2RA') STOP 120 ENDIF C C WRITE CALL LETTERS RECORD. C 130 CALL WRTDLMC(KFILDO,KFILX,CFILX,JD,ICALL,NSTA*L3264W, 1 0,0,L3264B,IER) 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(IWRWBN.NE.0.OR. 1 IWRELE.NE.0.OR. 2 IWRLAT.NE.0.OR. 3 IWRLON.NE.0)THEN WRITE(KFILDO,150) 150 FORMAT(/,' CONSTANT DATA RECORDS WRITTEN.') WRITE(KFILDO,151) 151 FORMAT(/,' NO. IDS OF RECORDS ON FILE', 1 17X,' DATE D SCALE B SCALE GRIDPOINT DATA', 2 ' DATA DESCRIPTION',/) ENDIF C C THE STATION LIST IN CCALL( ) AND THE DATA IN WBAN( ), C ELEV( ), STALAT( ), AND STALON( ) ARE IN THE ORDER C TO BE WRITTEN. C C WRITE WBAN NUMBERS IF DESIRED. PAWRA WRITES WITH C REPLACEMENT. C IF(IWRWBN.EQ.0)GO TO 165 C DO 160 J=1,ND7 IS1(J)=0 160 CONTINUE C JD(1)=400003000 IS1(17)=0 NCHAR=11 CALL PAWRA(KFILDO,KFILX,CFILX,JD, 1 WBAN,IC,ND1,NSTA,IPACK,ND5,MINPK, 2 IS0,IS1,IS2,IS4,ND7, 3 IPLAIN(1,1,1),PLAIN,NCHAR, 4 XMISSP,XMISSS,LX,IOCTET, 5 L3264B,L3264W,IER) ICOUNT=ICOUNT+1 WRITE(KFILDO,255)ICOUNT,(IS1(J),J=9,12), 1 IS1(8),IS1(17),IS1(18),IS1(2), 2 (IS1(J),J=23,23+IS1(22)-1) C IF(IER.NE.0)THEN WRITE(KFILDO,161)IER 161 FORMAT(/,' ****ERROR WRITING WBAN NUMBERS', 1 ' ON RANDOM ACCESS FILE IN U353 AT 161. IER =',I4) CALL W3TAGE('ENS_RA2RA') STOP 161 ENDIF C C WRITE ELEVATIONS IF DESIRED. PAWRA WRITES WITH C REPLACEMENT. C 165 IF(IWRELE.EQ.0)GO TO 175 C DO 170 J=1,ND7 IS1(J)=0 170 CONTINUE C JD(1)=400005000 IS1(17)=0 NCHAR=9 CALL PAWRA(KFILDO,KFILX,CFILX,JD, 1 ELEV,IC,ND1,NSTA,IPACK,ND5,MINPK, 2 IS0,IS1,IS2,IS4,ND7, 3 IPLAIN(1,1,2),PLAIN,NCHAR, 4 XMISSP,XMISSS,LX,IOCTET, 5 L3264B,L3264W,IER) ICOUNT=ICOUNT+1 WRITE(KFILDO,255)ICOUNT,(IS1(J),J=9,12), 1 IS1(8),IS1(17),IS1(18),IS1(2), 2 (IS1(J),J=23,23+IS1(22)-1) C IF(IER.NE.0)THEN WRITE(KFILDO,171)IER 171 FORMAT(/,' ****ERROR WRITING ELEVATIONS', 1 ' ON RANDOM ACCESS FILE IN U353 AT 171. IER =',I4) STOP 171 ENDIF C C WRITE LATITUDES IF DESIRED. PAWRA WRITES WITH C REPLACEMENT. C 175 IF(IWRLAT.EQ.0)GO TO 185 C DO 180 J=1,ND7 IS1(J)=0 180 CONTINUE C JD(1)=400006000 IS1(17)=2 NCHAR=8 CALL PAWRA(KFILDO,KFILX,CFILX,JD, 1 STALAT,IC,ND1,NSTA,IPACK,ND5,MINPK, 2 IS0,IS1,IS2,IS4,ND7, 3 IPLAIN(1,1,3),PLAIN,NCHAR, 4 XMISSP,XMISSS,LX,IOCTET, 5 L3264B,L3264W,IER) ICOUNT=ICOUNT+1 WRITE(KFILDO,255)ICOUNT,(IS1(J),J=9,12), 1 IS1(8),IS1(17),IS1(18),IS1(2), 2 (IS1(J),J=23,23+IS1(22)-1) C IF(IER.NE.0)THEN WRITE(KFILDO,181)IER 181 FORMAT(/,' ****ERROR WRITING LATITUDES', 1 ' ON RANDOM ACCESS FILE IN U353 AT 181. IER =',I4) CALL W3TAGE('ENS_RA2RA') STOP 181 ENDIF C C WRITE LONGITUDES IF DESIRED. PAWRA WRITES WITH C REPLACEMENT. C 185 IF(IWRLON.EQ.0)GO TO 1915 C DO 190 J=1,ND7 IS1(J)=0 190 CONTINUE C JD(1)=400007000 IS1(17)=2 NCHAR=9 CALL PAWRA(KFILDO,KFILX,CFILX,JD, 1 STALON,IC,ND1,NSTA,IPACK,ND5,MINPK, 2 IS0,IS1,IS2,IS4,ND7, 3 IPLAIN(1,1,4),PLAIN,NCHAR, 4 XMISSP,XMISSS,LX,IOCTET, 5 L3264B,L3264W,IER) ICOUNT=ICOUNT+1 WRITE(KFILDO,255)ICOUNT,(IS1(J),J=9,12), 1 IS1(8),IS1(17),IS1(18),IS1(2), 2 (IS1(J),J=23,23+IS1(22)-1) C IF(IER.NE.0)THEN WRITE(KFILDO,191)IER 191 FORMAT(/,' ****ERROR WRITING LONGITUDES', 1 ' ON RANDOM ACCESS FILE IN U353 AT 191. IER =',I4) CALL W3TAGE('ENS_RA2RA') STOP 191 ENDIF C C READ AND PROCESS UNIT NUMBER AND FILE NAME FOR RANDOM C ACCESS INPUT. FILE IS NOT OPENED. C 1915 CALL RDSNAM(KFILDI,KFILDO,KFILP,CFILP,IDUM,IDUM,1,NUMIN, 1 'NOT','UNFORMATTED',IP,IER) IF(IER.NE.0)THEN WRITE(KFILDO,192)IER 192 FORMAT(/,' ****ERROR READING UNIT NUMBER AND NAME OF', 1 ' RANDOM ACCESS INPUT DATA SET IN U353 AT 192.', 2 ' IER =',I4) STOP 192 ENDIF C IF(NUMIN.EQ.0)THEN WRITE(KFILDO,1920)ICOUNT 1920 FORMAT(/,' INPUT RANDOM ACCESS DATA SET LIST EXHAUSTED.',/, 1 ' ',I6,' DATA RECORDS, EXCLUSIVE OF DIRECTORY,', 2 ' HAVE BEEN WRITTEN.') GO TO 300 ENDIF C WRITE(KFILDO,1921)KFILP,CFILP 1921 FORMAT(/,' RANDOM ACCESS INPUT DATA SET, UNIT AND NAME. ', 1 I4,2X,A60) C C READ LIST OF IDS TO ELIMINATE. C STATE='195 ' NVRBL=1 194 READ(KFILDI,195,IOSTAT=IOS,ERR=900,END=204) 1 (ID(J,NVRBL),J=1,4) C NOTE THAT A TERMINATOR IS NOT REQUIRED. HOWEVER, IF C MULTIPLE FILES ARE TO BE INPUT, THE TERMINATOR IS REQUIRED. 195 FORMAT(I9,3I10) C IF(ID(1,NVRBL).NE.999999)THEN NVRBL=NVRBL+1 IF(NVRBL.LE.ND4)GO TO 194 C WRITE(KFILDO,200)ND4 200 FORMAT(/,' ****ND4 =',I4,' NOT LARGE ENOUGH TO HOLD IDS', 1 ' AND TERMINATOR IN U353 AT 200. IDS READ ARE:',/, 2 (' ',4I11)) CALL W3TAGE('ENS_RA2RA') STOP 200 C ENDIF C 204 NVRBL=NVRBL-1 C THIS IS THE END OF THE VARIABLE IDS BEING READ. C C WRITE THE IDS OF THE DATA TO PUT ONTO THE RANDOM C ACCESS FILE. C WRITE(KFILDO,205)NVRBL,CFILP,((ID(J,L),J=1,4),L=1,NVRBL) 205 FORMAT(/,' ',I4,' VARIABLES TO ELIMINATE FROM RANDOM ACCESS FILE ' 1 ,A60,/,(7X,4I11)) C C READ THE DIRECTORY RECORD FROM THE RANDOM ACCESS INPUT, C COMPARE WITH THE DIRECTORY LIST, AND FORM A CORRESPONDENCE C TABLE IN INDEX( ) BETWEEN THE OUTPUT AND INPUT. C JD(1)=400001000 JD(2)=0 JD(3)=0 JD(4)=0 CALL RDTDLMC(KFILDO,KFILP,CFILP,JD,ICALLD,ND1*L3264W,NVALUE, 1 L3264B,IER) C IF(IER.EQ.155)THEN C THE DIRECTORY DID NOT EXIST. THIS IS AN ERROR. WRITE(KFILDO,2051)CFILP 2051 FORMAT(' ****THE DIRECTORY DOES NOT EXIST ON INPUT FILE ', 1 A60,/, 2 ' STOP IN U353 AT 2051.') CALL W3TAGE('ENS_RA2RA') STOP 2051 ENDIF C IF(IER.EQ.154)THEN WRITE(KFILDO,2055)CFILP 2055 FORMAT(/,' ****ERROR IN U353 AT 2055', 1 ' READING INPUT FILE ',A60,/, 2 ' ND1 MUST BE INCREASED.') C A DIAGNOSTIC WILL HAVE BEEN WRITTEN IN RDTDLM. CALL W3TAGE('ENS_RA2RA') STOP 2055 C ENDIF C IF(IER.NE.0)THEN WRITE(KFILDO,2056)CFILP,IER 2056 FORMAT(' ERROR READING STATION DIRECTORY', 1 ' IN INPUT RANDOM ACCESS FILE ',A60,/, 2 ' STOP IN U353 AT 2056. IER =',I4) CALL W3TAGE('ENS_RA2RA') STOP 2056 ENDIF C NWORDS=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. NWORDS IS THE NUMBER OF C STATIONS ON THE INPUT FILE. C C FORM THE CORRESPONDENCE TABLE IN INDEX( ). C IFIRST=0 C DO 210 J=1,NSTA INDEX(J)=J C C MODIFIED IF TEST TO CHECK ALL LINKS c DO 209 K=1,NWORDS C c IF((CCALL(J,1).EQ.CCALLD(K)).OR. c 1 (CCALL(J,2).EQ.CCALLD(K)).OR. c 2 (CCALL(J,3).EQ.CCALLD(K)).OR. c 3 (CCALL(J,4).EQ.CCALLD(K)).OR. c 4 (CCALL(J,5).EQ.CCALLD(K)).OR. c 5 (CCALL(J,6).EQ.CCALLD(K))) THEN c INDEX(J)=K c GO TO 210 c ENDIF c209 CONTINUE C C A DROP THROUGH HERE MEANS STATION WAS NOT FOUND. C c INDEX(J)=99999999 c IFIRST=IFIRST+1 c IF(IFIRST.EQ.1)WRITE(KFILDO,206) c206 FORMAT(/,' ****STATIONS ON OUTPUT NOT ON INPUT') c WRITE(KFILDO,207)IFIRST,CCALL(J,1) c207 FORMAT(' ',I4,2X,A8) C 210 CONTINUE C C DETERMINE WHETHER OR NOT RECORDS WILL HAVE TO BE C UNPACKED AND REPACKED FOR THIS INPUT FILE. C WHEN NSTA = NWORDS AND INDEX(K) = K FOR ALL K, C THEN THE OUTPUT DIRECTORY IS THE SAME AS THE C INPUT DIRECTORY AND THE RECORDS CAN STAY PACKED C FOR WRITING. C C THE ABILITY TO NOT UNPACK DATA WAS DISABLED C ON IBM, ALWAYS UNPACK DATA- PROTECTS IDS IN ISO C C MPACK=0 MPACK=1 C C IF(NSTA.NE.NWORDS)THEN C MPACK=1 C GO TO 2115 C ENDIF C C DO 211 K=1,NSTA C C IF(INDEX(K).NE.K)THEN C MPACK=1 C GO TO 2115 C ENDIF C C211 CONTINUE C C2115 CONTINUE C D WRITE(KFILDO,212)NSTA,(CCALL(J,1),J=1,NSTA) D212 FORMAT(/,' ',I4,' STATIONS WRITTEN',/,(10(' ',A8))) D WRITE(KFILDO,213)NWORDS,(CCALLD(J),J=1,NWORDS) D213 FORMAT(/,' ',I4,' STATIONS ON INPUT',/,(10(' ',A8))) D WRITE(KFILDO,214)NSTA,(INDEX(J),J=1,NSTA) D214 FORMAT(/,' ',I4,' INDEX VALUES',/,(10(' ',I8))) IF(MPACK.EQ.0)THEN WRITE(KFILDO,215) 215 FORMAT(/,' DATA RECORDS WRITTEN WITHOUT UNPACKING', 1 ' AND REPACKING.') ELSE WRITE(KFILDO,216) 216 FORMAT(/,' DATA RECORDS WRITTEN AFTER UNPACKING', 1 ' AND REPACKING.') ENDIF C WRITE(KFILDO,217) 217 FORMAT(/,' NO. IDS OF RECORDS ON FILE', 1 17X,' DATE D SCALE B SCALE GRIDPOINT DATA', 2 ' DATA DESCRIPTION',/) C C READ THE NEXT DATA RECORD FROM THE RANDOM ACCESS INPUT. C 220 JD(1)=9999 JD(2)=0 JD(3)=0 JD(4)=0 CALL RDTDLM(KFILDO,KFILP,CFILP,JD,IPACK,ND5,NVALUE, 1 L3264B,IER) C IF(IER.EQ.153)THEN WRITE(KFILDO,236)CFILP 236 FORMAT(/,' READING HAS BEEN COMPLETED ON', 1 ' RANDOM ACCESS INPUT FILE ',A60) CLOSE(UNIT=KFILP) C OPEN FILE IS CLOSED BEFORE ANOTHER IS READ. GO TO 1915 ENDIF C IF(IER.NE.0)THEN WRITE(KFILDO,237)CFILP,IER 237 FORMAT(' ERROR READING STATION DIRECTORY', 1 ' IN INPUT ACCESS FILE ',A60,/, 2 ' STOP IN U353 AT 237. IER =',I4) STOP 237 ENDIF C IF(L3264B.EQ.32)THEN IPA(1)=IPACK(6) IPA(2)=IPACK(7) IPA(3)=IPACK(8) IPA(4)=IPACK(9) C ELSE LOC=3 IPOS=33 CALL UNPKBG(KFILDO,IPACK,ND5,LOC,IPOS,IPA(1),32,L3264B,IER,*241) CALL UNPKBG(KFILDO,IPACK,ND5,LOC,IPOS,IPA(2),32,L3264B,IER,*241) CALL UNPKBG(KFILDO,IPACK,ND5,LOC,IPOS,IPA(3),32,L3264B,IER,*241) CALL UNPKBG(KFILDO,IPACK,ND5,LOC,IPOS,IPA(4),32,L3264B,IER,*241) ENDIF C c--------------- C C PATCH FOR GRIDDED MOS QPF: SKIP RECORD IF THE READ IN C ID IS NOT 203293XXX. IF IT IS, CHANGE THE ID. C IF (KFILP.EQ.29) THEN IF (IPA(1)/1000.NE.203293) GOTO 220 IPA(1)=203295000+(MOD(IPA(1),1000)) END IF C c--------------- GO TO 243 C 241 WRITE(KFILDO,242)IER 242 FORMAT(/,' ****ERROR UNPACKING IDS OF DATA IN U353 AT 242,', 1 ' IER = ',I4) STOP 242 C C DETERMINE WHETHER THE DATA ARE TO BE WRITTEN. C 243 IF((IWRWBN.NE.0.AND.IPA(1).EQ.400003000).OR. 1 (IWRELE.NE.0.AND.IPA(1).EQ.400005000).OR. 2 (IWRLAT.NE.0.AND.IPA(1).EQ.400006000).OR. 3 (IWRLON.NE.0.AND.IPA(1).EQ.400007000))GO TO 220 C THE CONSTANT RECORDS MAY HAVE BEEN WRITTEN PREVIOUSLY. C DO 245 L=1,NVRBL IF(IPA(1).EQ.ID(1,L).AND. 1 IPA(2).EQ.ID(2,L).AND. 2 IPA(3).EQ.ID(3,L).AND. 3 IPA(4).EQ.ID(4,L))GO TO 220 C THERE IS A MATCH; DON'T WRITE THIS RECORD. C 245 CONTINUE C IF(MPACK.EQ.0)GO TO 250 C ON IBM MPACK IS ALWAYS 1 C WHEN MPACK = 0, THE RECORD NEEDS NOT BE UNPACKED. C C MUST UNPACK THE DATA AND REPACK IT BECAUSE THE C INPUT AND OUTPUT LISTS MAY NOT MATCH. (IF THERE C WERE AN EXACT MATCH BETWEEN INPUT AND OUTPUT, THIS C WOULD NOT BE NECESSARY, BUT IS NOT ACCOMMODATED.) C CALL UNPACK(KFILDO,IPACK,IWORK,DATA,ND5, 1 IS0,IS1,IS2,IS4,ND7,MISSPX,MISSSX, 2 2,L3264B,IER) C IF(IER.NE.0)THEN WRITE(KFILDO,247)IER 247 FORMAT(/,' ****ERROR IER =',I5,' UNPACKING DATA.', 1 ' STOP IN U353 AT 247.') STOP 247 ENDIF C DO 248 J=1,NSTA C IF(INDEX(J).EQ.99999999)THEN DATA1(J)=9999. ELSE DATA1(J)=DATA(INDEX(J)) ENDIF C 248 CONTINUE C D WRITE(KFILDO,2480)(DATA(J),J=1,NWORDS) D WRITE(KFILDO,2480)(DATA1(J),J=1,NSTA) D2480 FORMAT(' ',10F10.3) XMISSP=MISSPX XMISSS=MISSSX IS1(9)=IPA(1) CALL PACK1D(KFILDO,DATA1,IWORK,NSTA, 1 IS0,IS1,IS2,IS4,ND7,XMISSP,XMISSS,IPACK,ND5, 2 MINPK,LX,IOCTET,L3264B,IER) C IF(IER.NE.0)THEN WRITE(KFILDO,249)IER 249 FORMAT(/,' ****ERROR IER =',I5,' PACKING DATA.', 1 ' STOP IN U353 AT 249.') CALL W3TAGE('ENS_RA2RA') STOP 249 ENDIF C C WRITE THE DATA WITH REPLACEMENT. REPLACEMENT TAKES CARE OF C THE SITUATION WHERE DUPLICATE IDS ARE ARE READ C MORE THAN ONCE, EITHER DUPLICATES ON ONE INPUT OR C THE SAME IDS ON TWO OR MORE INPUT FILES. C 250 CALL WRTDLM(KFILDO,KFILX,CFILX,IPA,IPACK,(IOCTET*8)/L3264B, 1 2,0,L3264B,IER) C IF(IER.NE.0)THEN WRITE(KFILDO,251)IER 251 FORMAT(/,' ****ERROR IER =',I5,' WRITING DATA', 1 ' ON RANDOM ACCESS FILE. STOP IN U353 AT 251.') CALL W3TAGE('ENS_RA2RA') STOP 251 ENDIF C ICOUNT=ICOUNT+1 WRITE(KFILDO,255)ICOUNT,(IS1(J),J=9,12), 1 IS1(8),IS1(17),IS1(18),IS1(2), 2 (IS1(J),J=23,23+IS1(22)-1) 255 FORMAT(' ',I5,4I11,I12,2I10,I13,10X,32A1) C255 FORMAT(' ',I5,4I11,I12,2I10,I13,10X,32R1) C GO TO 220 C READ AND PROCESS ANOTHER RECORD . C C CLOSE RANDOM ACCESS FILE. C 300 CALL CLFILM(KFILDO,KFILX,IER) WRITE(KFILDO,301) 301 FORMAT(' ') CALL TIMPR(KFILDO,KFILDO,'END U353 ') CALL W3TAGE('ENS_RA2RA') STOP C 900 CALL IERX(KFILDO,KFILDO,IOS,'U353 ',STATE) WRITE(KFILDO,901) 901 FORMAT(' ') CALL TIMPR(KFILDO,KFILDO,'END U353 ') CALL W3TAGE('ENS_RA2RA') STOP 900 END