SUBROUTINE RDSTR5(KFILDO,KFIL10,KFILIN,MODNUM,NAMIN,JFOPEN, 1 LDATB,LDATE,LKHERE,ND6,NUMIN,NDATE, 2 ID,IDPARS,ITIME,NPREDX,ND4, 3 NCEPNO,LAMPNO, 4 IPACK,IWORK,DATA,CCALLD,ND5, 5 IS0,IS1,IS2,IS4,ND7, 6 LSTORE,LITEMS,ND9,NBLOCK,CORE,ND10, 7 LASTL,LASTD,NSTORE,NGRIDC,ND11,NGRID,IP10, 8 CCALL,NAME,STALAT,STALON,SDATA,DIR, 9 INDEXC,ND1,NSTA, A PXMISS,IP12,IP23,L3264B,L3264W,ISTOP,IER) C C FEBRUARY 2001 GLAHN LAMP-2000 C ADAPTED FROM RDSTR2 IN U201LIB C MAY 2001 GLAHN CHANGED 1000 TO 10000 IN C (IS1(10)/10000)*10000 LOOKING FOR C GRIDPOINT DATA C JUNE 2001 GLAHN MODS FOR RADAR DATA C OCTOBER 2001 GLAHN ADDED NRADNO FOR RADAR DATA C AUGUST 2002 GLAHN ELIMINATED PART OF COMMENT FOLLOWING C STATEMENT 219 C DECEMBER 2002 RUDACK MODIFIED FORMAT STATEMENTS TO ADHERE C TO THE F90 COMPILER STANDARDS FOUND ON C THE IBM SYSTEM C MARCH 2003 GLAHN COMMENTS; SPELLING C AUGUST 2015 SAMPLATSKY MODIFIED CHECK ON 4TH WORD OF C ID JUST INSIDE DO 218 LOOP. NEW C MRMS/TL VARIABLES DO NOT CONTAIN C A WORD 4 FILLED WITH 0. C C PURPOSE C TO READ PACKED DATA FROM ALL GRIDPOINT AND VECTOR SOURCES C NEEDED FOR THE FIRST DAY FOR U150, EXCEPT CONSTANT DATA, C AND TO STORE FIELDS NEEDED. THIS RDSTR5 IS DIFFERENT C FROM RDSTR2 MAINLY IN THAT AN EXPANDED LIST OF VARIABLES C EXISTS IN ID( , ) AND THAT LIST, TOGETHER WITH ASSUMPTIONS C ABOUT PROJECTIONS NEEDED ALLOWS ONLY THE DATA NEEDED TO C BE SAVED, RATHER THAN ALL DATA AS RDSTR2 DOES. C C GRIDPOINT AND VECTOR DATA MUST BE TREATED SOMEWHAT C DIFFERENTLY. C C FOR GRIDPOINT DATA: C EACH DATA SOURCE MUST BE READ WITH A UNIT NUMBER LT 80. C THE DATA ARE STORED AS READ, INCLUDING THE TDLPACK C SECTIONS. ALSO, THE GRID LOCATIONS OF THE STATIONS C ARE COMPUTED FOR ALL GRIDS ENCOUNTERED. THE FIRST C DATE/TIME SAVED FOR A PARTICULAR MODEL IS CALCULATED C BASED ON THE DAY 1 DATE/TIME NDATE MINUS THE MAXIMUM C RUN TIME OFFSET RR FOR THAT PARTICULAR MODEL OF ANY C VARIABLE INDICATING THAT MODEL. ALL ID'S NEED A MODEL C NUMBER DD TO ASSOCIATE WITH THE MODEL NUMBER IN MODNUM( ) C FOR THE LOOKBACK FEATURE. THIS KEEPS DATA FROM ALL C MODELS, IN CASE MODELS ARE MIXED, FROM BEING SAVED C IN CASE RR IS DIFFERENT FOR THE DIFFERENT MODELS. C IF IT IS DISCOVERED THAT, WHEN KFILIN( ) NE 0, NO C VARIABLE DD MATCHES THE MODEL NUMBER MODNUM( ), C THAT UNIT IS CLOSED. C NOTE: NCEP MODEL FIELDS ARE LIMITED TO TAU = 36 AND C LAMP MODEL FIELDS ARE LIMITED TO TAU = 2 HOURS. C IT COULD BE, THE 36 WOULD NEED TO BE INCREASED. C C FOR VECTOR DATA: C EACH DATA SOURCE MUST BE READ WITH A UNIT NUMBER GE 80. C THERE IS NO MODEL NUMBER ASSOCIATED WITH AN INPUT C SOURCE, AND MODNUM( ) MUST = 0 FOR THAT SOURCE. C A DIRECTORY RECORD IS READ INITIALLY AND AFTER ANY C ENCOUNTER OF A TRAILER RECORD. THE DATA MUST BE C UNPACKED AND ASSOCIATED WITH THE CURRENTLY RESIDENT C DIRECTORY FOR THAT DATA SOURCE. THE DATA ARE THEN C STORED UNPACKED FOR THOSE LOCATIONS (STATIONS) C IN CCALL( , ). THE LOOKBACK FEATURE APPLIES TO ALL C VECTOR SOURCES EQUALLY, IN DISTINCTION TO GRIDPOINT C SOURCES FOR WHICH LOOKBACK APPLIES TO EACH SOURCE C (MODEL) SEPARATELY. FOR THE LOOKBACK FEATURE, WHEN C DD IN ID( ) NE 0 AND THE UNIT NO. IS LT 80, RR IS C USED TO DETERMINE THE DATA TO SAVE. WHEN THE DD C IN ID( ) IS = 0, AND THE UNIT NUMBER IS GE 80, RR IS C APPLIED TO ALL SUCH INPUTS TOGETHER. THIS MEANS C THAT SPECIFIC MODELS CAN BE DEALT WITH INDEPENDENTLY, C BUT VECTOR DATA ARE GROUPED TOGETHER. C C DATA SET USE C KFILDO - UNIT NUMBER OF OUTPUT (PRINT) FILE. (OUTPUT) C KFIL10 - UNIT NUMBER OF TDL MOS-2000 FILE SYSTEM ACCESS. C (INPUT-OUTPUT) C C VARIABLES C KFILDO = UNIT NUMBER OF OUTPUT (PRINT) FILE. (INPUT) C KFIL10 = UNIT NUMBER OF TDL MOS-2000 FILE SYSTEM ACCESS. C (INPUT) C KFILIN(J) = UNIT NUMBERS FOR INPUT DATA, ALL IN TDLPACK C FORMAT. INPUT CAN INCLUDE GRIDPOINT (TAPES) C DATA, PREDICTAND (OBSERVATIONS) DATA, VARIOUS C CONSTANTS, OR MOS FORECASTS (FOR 2ND GENERATION C MOS, POSSIBLY FOR LOCAL IMPLEMENTATION C (J=1,NUMIN). NUMBERS GE 80 ARE RESERVED FOR, C AND ARE TO BE USED FOR, VECTOR DATA. C (INPUT/OUTPUT) C MODNUM(J) = THE "MODEL" NUMBER CORRESPONDING TO KFILIN(J) C (J=1,NUMIN). THIS IS NEEDED TO MATCH WITH DD IN C THE VARIABLE ID'S FOR THE LOOKBACK FEATURE. C HOWEVER, FOR INPUT DATA THAT COULD HAVE COME C FROM A PREVIOUS RUN OF U201, THE VECTOR DATA C HAVE A MIXTURE OF DD'S, AND THE MODEL NUMBER C FOR ALL VECTOR DATA MUST BE ZERO. (INPUT/OUTPUT) C NAMIN(J) = NAME OF THE INPUT FILES BEING PROCESSED C (J=1,NUMIN). (CHARACTER*60) (INPUT/OUTPUT) C JFOPEN(J) = FOR EACH FILE IN KFILIN(J), JFOPEN(J) IS 1 WHEN C THE FILE IS OPEN, IS 0 WHEN IT HAS ALREADY BEEN C USED AND IS 2 WHEN THE FILE HAS NOT BEEN OPENED C (J=1,NUMIN). (INPUT/OUTPUT) C LDATB(J) = BEGINNING DATE NEEDED FOR THE MODEL CORRESPONDING C TO NAMIN(J), ETC. (J=1,NUMIN). THIS IS NOT C OVERALL, BUT IS VALID FOR DAY 1. C (INTERNAL-OUTPUT) C LDATE(J) = ENDING DATE NEEDED FOR THE MODEL CORRESPONDING C TO NAMIN(J), ETC. (J=1,NUMIN). THIS IS NOT C OVERALL, BUT IS VALID FOR DAY 1. C (INTERNAL-OUTPUT) C LKHERE(J) = KEEPS TRACK OF WHICH FILES AN EOF HAS BEEN C REACHED (J=1,NUMIN). INITIALLY SET TO 1; SET C TO ZERO WHEN AN EOF HAS BEEN REACHED. C (INTERNAL) C ND6 = THE MAXIMUM OF NUMIN. DIMENSION OF KFILIN( ), C MODNUM( ), LDATB( ), AND LDATE( ). (INPUT) C NUMIN = THE NUMBER OF VALUES IN KFILIN( ), MODNUM( ), C NAMIN( ), JFOPEN( ), LDATB( ), AND LDATE( ). C IN CASE THERE IS NO DD MATCHING A MODEL NUMBER IN C MODNUM( ), THE FILE IS ELIMINATED FROM THE LIST C IN KFILIN( ), MODNUM( ), NAMIN( ), AND JFOPEN( ) C AND NUMIN ADJUSTED DOWNWARD ACCORDINGLY. C (INPUT/OUTPUT) C NDATE = DAY 1 DATE IN FORM YYYYMMDDHH. (INPUT) C ID(J,N) = THE PREDICTOR ID'S (J=1,4) (N=1,NPREDX). (INPUT) C IDPARS(J,N) = THE PARSED, INDIVIDUAL COMPONENTS OF THE PREDICTOR C ID'S CORRESPONDING TO ID( ,N) (J=1,15), (N=1,NPREDX). 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 1 LAYER), C J=7--LTLTLTLT (TOP OF LAYER), C J=8--T (TRANSFORMATION), C J=9--RR (RUN TIME OFFSET, ALWAYS + AND BACK 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 ITIME(N) = FOR EACH VARIABLE (N=1,NPREDX) INDICATES WHETHER (=1) C OR NOT (=0) THE RR IS TO BE USED BY GFETCH WHEN C FETCHING DATA. (NOT ACTUALLY USED) C NPREDX = NUMBER OF ID'S IN ID( , ) AND IDPARS( , ). THIS C INCLUDES THE NPRED ENTRIES READ INITIALLY AS THE C VARIABLES TO PROCESS AND THE AUGMENTATION LIST READ C IN SUBROUTINE AUGIDS. (INPUT) C ND4 = THE MAXIMUM NUMBER OF PREDICTORS FOR WHICH C INTERPOLATED VALUES CAN BE PROVIDED. 2ND DIMENSION C OF ID( , ) AND IDPARS( , ). (INPUT) C IPACK(J) = HOLDS THE TDLPACK RECORD (J=1,NWORDS). NWORDS C IS CALCULATED NWORDS=NBYTES*8/L3264B, WHERE NBYTES C IS THE LENGTH IN BYTES READ FROM THE RECORD ITSELF. C (INTERNAL) C IWORK(J) = ARRAY TO FURNISH TO SUBROUTINE UNPACK C (J=1,ND5). (INTERNAL) C DATA(J) = ARRAY TO FURNISH TO SUBROUTINE GSTORE AND UNPACK C (J=1,ND5). HOWEVER, IT SHOULD NOT ACTUALLY BE C USED BECAUSE ONLY THE ID'S ARE UNPACKED INTO C IS0( ), IS1( ), IS2( ), AND IS4( ). (INTERNAL) C CCALLD(J) = CALL LETTERS AS READ FROM INPUT FILES (K=1,ND5) C (INTERNAL) C ND5 = DIMENSION OF IPACK( ), IWORK( ), DATA( ) AND. C CCALLD( ). (INPUT) C IS0(J) = MOS-2000 GRIB SECTION 0 ID'S (J=1,3). (INTERNAL) C IS1(J) = MOS-2000 GRIB SECTION 1 ID'S (J=1,22+). (INTERNAL) C IS2(J) = MOS-2000 GRIB SECTION 2 ID'S (J=1,12). (INTERNAL) C IS4(J) = MOS-2000 GRIB SECTION 4 ID'S (J=1,4). (INTERNAL) C ND7 = DIMENSION OF IS0( ), IS1( ), IS2( ), AND IS4( ). C NOT ALL LOCATIONS ARE USED. (INPUT) C LSTORE(L,J) = THE ARRAY TO HOLD INFORMATION ABOUT THE DATA C STORED (L=1,12) (J=1,LITEMS). (INPUT-OUTPUT) C L=1,4--THE 4 ID'S FOR THE DATA. C L=5 --LOCATION OF STORED DATA. WHEN IN CORE, C THIS IS THE LOCATION IN CORE( ) WHERE C THE DATA START. WHEN ON DISK, C THIS IS MINUS THE RECORD NUMBER WHERE C THE DATA START. NOTE THAT WHEN A FIELD C CANNOT BE STORED IN CORE( ), IT IS PUT C ON DISK. IT MAY BE THAT A LATER FIELD C WILL FIT, AND IT IS PUT IN CORE( ). C L=6 --THE NUMBER OF 4-BYTE WORDS STORED. C L=7 --2 FOR DATA PACKED IN TDLPACK, 1 FOR NOT. C L=8 --THE DATE/TIME OF THE DATA IN FORMAT C YYYYMMDDHH. C L=9 --NUMBER OF TIMES DATA HAVE BEEN RETRIEVED. C L=10 --NSLAB, THE NUMBER OF THE SLAB IN DIR( , ,L) C AND IN NGRIDC( ,L) DEFINING THE CHARACTERISTICS C OF THIS GRID. C L=11 --THE NUMBER OF THE PREDICTOR IN THE SORTED C LIST IN ID( ,N) (N=1,NPREDX) FOR WHICH THIS C VARIABLE IS NEEDED, WHEN IT IS NEEDED ONLY C ONCE FROM LSTORE( , ). WHEN IT IS NEEDED C MORE THAN ONCE, THE VALUE IS SET = 7777. C L=12 --USED INITIALLY IN ESTABLISHING MSTORE( , ). C LATER USED AS A WAY OF DETERMINING WHETHER C TO KEEP THIS VARIABLE. C LITEMS = THE NUMBER OF ITEMS (COLUMNS) IN LSTORE( , ) THAT C HAVE BEEN USED IN THIS RUN. INITIALIZED TO ZERO C AT BEGINNING. C ND9 = 2ND DIMENSION OF LSTORE( , ). (INPUT) C NBLOCK = THE RECORD SIZE FOR THE FILE TO WRITE THE DATA C WHEN CORE( ) IS FULL. (INPUT) C CORE(J) = THE ARRAY TO STORE THE DATA IDENTIFIED IN C LSTORE( , ) (J=1,ND10). WHEN CORE( ) IS FULL C DATA ARE STORED ON DISK. (OUTPUT) C ND10 = DIMENSION OF CORE( ). (INPUT) C LASTL = THE LAST LOCATION IN CORE( ) USED. INITIALIZED TO 0 C ON FIRST ENTRY TO GSTORE. (INPUT/OUTPUT) C LASTD = TOTAL NUMBER OF PHYSICAL RECORDS ON DISK. C (INPUT/OUTPUT) C NSTORE = RUNNING COUNT OF NUMBER OF TIMES DATA ARE STORED BY C GSTORE. INITIALIZED TO ZERO THE FIRST TIME GSTORE C IS CALLED. THE USER NEED NOT WORRY ABOUT THIS. C IT CAN BE USED FOR DIAGNOSTICS IF NEEDED. C (OUTPUT) C NGRIDC(L,M) = HOLDS THE GRID CHARACTERISTICS (L=1,6) FOR EACH GRID C COMBINATION (M=1,NGRID). C L=1--MAP PROJECTION NUMBER (3=LAMBERT, 5=POLAR C STEREOGRAPHIC). C L=2--GRID LENGTH IN MILLIMETERS, C L=3--LATITUDE AT WHICH GRID LENGTH IS CORRECT *10000, C L=4--GRID ORIENTATION IN DEGREES *10000, C L=5--LATITUDE OF LL CORNER IN DEGREES *10000, AND C L=6--LONGITUDE OF LL CORNER IN DEGREES *10000. C ND11 = MAXIMUM NUMBER OF GRID COMBINATIONS THAT CAN BE C DEALT WITH ON THIS RUN. LAST DIMENSION OF C NGRIDC( , ). (INPUT) C NGRID = THE NUMBER OF GRID COMBINATIONS IN NGRIDC( , ), C MAXIMUM OF ND11. (OUTPUT) C IP10 = INDICATES WHETHER (>1) OR NOT (=0) THE LIST OF C FIELDS READ FOR DAY 1 WILL BE PRINTED TO UNIT IP10 C ALONG WITH THE FIRST AND LAST DATE/TIME C NEEDED FOR EACH FILE FOR DAY 1. (INPUT) C CCALL(K,J) = 8-CHARACTER STATION CALL LETTERS (OR GRIDPOINT C LOCATIONS FOR GRID DEVELOPMENT) TO PROVIDE C OUTPUT FOR (J=1) AND 5 POSSIBLE OTHER STATION C CALL LETTERS (J=2,6) THAT CAN BE USED INSTEAD C IF THE PRIMARY (J=1) STATION CANNOT BE FOUND C IN AN INPUT DIRECTORY (K=1,NSTA). ALL STATION C DATA ARE KEYED TO THIS LIST, EXCEPT POSSIBLY C CCALLD( ) AND CCALLP( ). (CHARACTER*8) C (OUTPUT) C NAME(K) = NAMES OF STATIONS (K=1,NSTA). USED FOR PRINTOUT C ONLY. (CHARACTER*20) (INPUT) C STALAT(K) = LATITUDE OF STATIONS (K=1,NSTA). (INPUT) C STALON(K) = LONGITUDE OF STATIONS (K=1,NSTA). (INPUT) C SDATA(J) = WORK ARRAY (J=1,NSTA). (INTERNAL) C DIR(K,J,M) = THE IX (J=1) AND JY (J=2) POSITIONS ON THE GRID C FOR THE COMBINATION OF GRID CHARACTERISTICS M C (M=1,NGRID) AND STATION K (K=1,NSTA) IN NGRIDC( ,M). C (OUTPUT) C INDEXC(K,J) = LOCATIONS OF THE STATIONS CORRESPONDING TO C CCALL(K, ) (K=1,NSTA) FOR EACH MODEL J (J=1,NUMIN). C FOR GRIDPOINT DATA, INDEXC( , ) WILL BE EMPTY C FOR THAT MODEL J. IF A STATION'S LOCATION IS C UNKNOWN, INDEXC( , ) = 99999999. (OUTPUT) C ND1 = MAXIMUM NUMBER OF STATIONS THAT CAN BE DEALT WITH. C (INPUT) C NSTA = THE NUMBER OF STATIONS IN CCALL( , ). (INPUT) C PXMISS = THE VALUE OF A SECONDARY MISSING VALUE TO INSERT C WHEN THE SECONDARY MISSING VALUE IS 9997. C THIS ALLOWS MAINTAINING A 9997 OR TREATING IT AS C ZERO. (INPUT) C IP12 = INDICATES WHETHER (>1) OR NOT (=0) THE LIST OF C STATIONS AND THEIR I,J POSITIONS ON THE C GRID WILL BE WRITTEN TO THE FILE WHOSE UNIT C NUMBER IS IP12. ALSO, WHETHER POSITIONS IN C RECORD(S) OF VECTOR DATA SOURCES OF THE STATIONS C WILL BE WRITTEN TO UNIT IP12. NOTE THAT BOTH C OF THESE PERTAIN ONLY TO THE DATA BEING SAVED C ACCORDING TO THE LOOKBACK FACILITY. IF THERE C IS A DIRECTORY RECORD IMMEDIATELY FOLLOWING THE C DATA FOR THE LAST DATE NEEDED, IT WILL HAVE BEEN C READ, AND THE POSITIONS PRINTED WILL REFER TO C THIS NEW DIRECTORY. (INPUT) C IP23 = INDICATES WHETHER (>0) OR NOT (=0) STATEMENTS C ABOUT EOF AND FILE OPENINGS AND CLOSINGS WILL C BE OUTPUT FOR PRINTING ON UNIT IP23. (INPUT) C L3264B = INTEGER WORD LENGTH OF MACHINE BEING USED. (INPUT) C L3264W = NUMBER OF WORDS IN 64 BITS (EITHER 1 OR 2), C BASED ON L3464B. (INPUT) C ISTOP = INCREMENTED BY ONE EACH TIME AN ERROR IS ENCOUNTERED. C (INPUT-OUTPUT) C IER = STATUS RETURN. C 0 = GOOD RETURN. C 38 = ND5 IS NOT LARGE ENOUGH TO HOLD DATA FROM C UNPACK. C 51 = RETURN FROM GRCOMB WHEN ND11 IS ABOUT TO BE C EXCEEDED. C 55 = NO PREDICTOR MODEL NUMBER IDPARS(4) EQUALS C A DATASET MODEL NUMBER INPUT. C 56 = NO FIELDS FOUND FOR DAY 1. C 60 = MAP PROJECTION NUMBER NOT EXPECTED (FROM DIRCMP). C SEE ROUTINE GSTORE FOR OTHER VALUES. (INTERNAL-OUTPUT) C NBYTES = NUMBER OF BYTES IN RECORD, FOLLOWING THE INITIAL C 64 BITS CONTAINING NBYTES ITSELF. (INTERNAL) C NWORDS = NUMBER OF WORDS IN IPACK( ). NWORDS IS CALCULATED C NWORDS=NBYTES*8/L3264B, WHERE NBYTES IS THE LENGTH C IN BYTES READ FROM THE RECORD ITSELF. (INTERNAL) C INCDTL = THE INCREMENT IN HOURS OF THE FIRST DATE TO USE C WITH REFERENCE TO THE CYCLE DATE/TIME IN NDATE. C USED TO COMPUTE LDATB( ). (INTERNAL) C INCDTH = THE INCREMENT IN HOURS OF THE LAST DATE TO USE C WITH REFERENCE TO THE CYCLE DATE/TIME IN NDATE. C USED TO COMPUTE LDATE( ). (INTERNAL) C ICOUNT = COUNT OF FILES NOT NEEDED AND CLOSED. (INTERNAL) C MSTA = THE NUMBER OF STATIONS READ FROM A VECTOR FILE. C (INTERNAL) C ISTAV = INDICATES WHETHER (=1) OF NOT (=0) THE VARIABLE C IS A VECTOR. ISTAV IS ASSOCIATED WITH NSLAB C STORED BY GSTORE AND RETRIEVED BY GFETCH. C WHEN NSLAB NE 0, IT IS A SLAB NUMBER FOR A GRID. C WHEN IT IS 0, IT IS NOT A GRID. (INTERNAL) C NBYTES(J) = ARRAY USED TO DEAL WITH DIFFERENT WORD LENGTHS C OF HP AND CRAY WHEN READING DATA (J=1,2). C LSTOPC = AN INTERNAL COUNTER TO KEEP AN INFINITE READING C LOOP FROM OCCURRING. (INTERNAL) C LSTOP = THE VALUE TO COMPARE LSTOPC WITH TO STOP THE C READING. CURRENTLY SET AT 500; THIS ASSUMES C 500 READING ERRORS SHOULD NOT OCCUR IN A SINGLE C RUN. NOTE THAT THIS COUNT IS SEPARATE FROM C ISTOP IN CASE ISTOP HAS TO BE LARGE WHEN DEALING C WITH HOURLY DATA AND MISSING STATIONS. C NUMINX = INITIAL VALUE OF NUMIN. USED TO CONTROL PRINT. C MSDATE(J) = KEEPS TRACK OF WHETHER ANY DATA ARE AVAILABLE C FOR A PARTICULAR DATE ON AN INPUT FILE C (J=1,NUMIN). THIS IS USED IN SWITCH. C (AUTOMATIC) (INTERNAL) C NRADNO = MODEL NUMBER FOR RADAR DATA. (INTERNAL) C 1 2 3 4 5 6 7 X C C NONSYSTEM SUBROUTINES USED C UNPACK, UNPKBG, GSTORE, UPDAT, GRCOMB, RDDIR, SWITCH C CHARACTER*8 CCALL(ND1,6), 1 CCALLD(ND5) CHARACTER*20 NAME(ND1) CHARACTER*60 NAMIN(ND6) C DIMENSION SDATA(ND1),STALAT(ND1),STALON(ND1) DIMENSION DIR(ND1,2,ND11) DIMENSION ID(4,ND4),IDPARS(15,ND4),ITIME(ND4) DIMENSION IPACK(ND5),IWORK(ND5),DATA(ND5) DIMENSION KFILIN(ND6),MODNUM(ND6),JFOPEN(ND6), 1 LDATB(ND6),LDATE(ND6),LKHERE(ND6),MSDATE(ND6) C MSDATE( ) IS AN AUTOMATIC VARIABLE. DIMENSION INDEXC(ND1,ND6) DIMENSION IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7) DIMENSION LSTORE(12,ND9) DIMENSION CORE(ND10) DIMENSION NGRIDC(6,ND11) DIMENSION NBYTES(2) C DATA LSTOP/500/, 1 LSTOPC/0/ DATA NRADNO/4/ C IER=0 LITEMS=0 ICOUNT=0 NUMINX=NUMIN C C INITIALIZE LKHERE( ). C DO 120 IN=1,NUMIN LKHERE(IN)=1 120 CONTINUE C C DETERMINE DATE RANGE OF DATA FOR EACH MODEL FOR THE FIRST DATE. C THIS IS DONE EVEN FOR FILES NOT OPEN IN CASE ONE OR MORE HAS C TO BE OPENED DURING PROCESSING OF DAY 1. C DO 170 IN=1,NUMIN MODELX=MODNUM(IN) INCDTL=9999 INCDTH=0 C INCDTH INITIALIZED TO ZERO SO THAT HIGH END DATE WILL NOT BE C LESS THAN THE CURRENT DATE C DO 160 N=1,NPREDX C C TAKE CARE OF DATA WITH SPECIFIC MODEL NUMBERS C THAT MATCH MODELX. C IF(MODELX.EQ.IDPARS(4,N))THEN INCDTL=MIN(INCDTL,-IDPARS(9,N)) INCDTH=MAX(INCDTH,-IDPARS(9,N)) ENDIF C 160 CONTINUE C IF(INCDTL.NE.9999)GO TO 165 WRITE(KFILDO,162)IN,MODELX 162 FORMAT(/' ****NO PREDICTOR MODEL NUMBER IDPARS(4)', 1 ' MATCHES MODEL INPUT NUMBER MODNUM(',I2,') = ',I2,'.') IER=55 ISTOP=ISTOP+1 C SINCE THIS FILE IS NOT NEEDED, IT IS CLOSED AND REFERENCE C TO IT IS ELIMINATED BELOW. FILES WITH MODEL DATA C (DD NE 0) MAY BE CLOSED. SELDOM IF EVER WILL A FILE C HOLDING OBSERVATIONAL DATA BE CLOSED. CLOSE(KFILIN(IN)) IF(IP23.NE.0)WRITE(IP23,163)KFILIN(IN) 163 FORMAT(' UNIT NO.',I3,' BEING CLOSED IN RDSTR5.') KFILIN(IN)=0 ICOUNT=ICOUNT+1 INCDTL=0 165 CALL UPDAT(NDATE,INCDTL,LDATB(IN)) CALL UPDAT(NDATE,INCDTH,LDATE(IN)) C ACTUAL DATES ARE NOW IN LDATB(IN) AND LDATE(IN). THESE ARE THE C FIRST AND LAST DATE/TIMES, RESPECTIVELY, NEEDED FOR DAY 1. 170 CONTINUE C IF(ICOUNT.EQ.0)GO TO 190 C C ELIMINATE THE FILES NOT NEEDED. C 172 DO 180 IN=1,NUMIN D WRITE(KFILDO,173)IN,NUMIN,KFILIN(IN) D173 FORMAT(' AT 173 IN RDSTR5--IN,NUMIN,KFILIN(IN)',3I5) IF(KFILIN(IN).GT.0)GO TO 180 IF(IN.EQ.NUMIN)GO TO 176 C DO 175 J=IN+1,NUMIN KFILIN(J-1)=KFILIN(J) MODNUM(J-1)=MODNUM(J) JFOPEN(J-1)=JFOPEN(J) NAMIN(J-1)=NAMIN(J) LDATB(J-1)=LDATB(J) LDATE(J-1)=LDATE(J) 175 CONTINUE C 176 NUMIN=NUMIN-1 IF(NUMIN.GT.0)GO TO 172 GO TO 250 180 CONTINUE C 190 CONTINUE C IF(NUMIN.EQ.0)GO TO 194 IF(IP10.EQ.0)GO TO 194 WRITE(IP10,191) 191 FORMAT(/' BEGINNING AND ENDING DATES FOR EACH MODEL FOR DAY 1') C DO 193 IN=1,NUMIN IF(JFOPEN(IN).EQ.0)GO TO 193 WRITE(IP10,192)MODNUM(IN),KFILIN(IN),LDATB(IN),LDATE(IN) 192 FORMAT(' MODEL NO.',I3,' ON UNIT NO.',I3,2I12) 193 CONTINUE C C START PROCESSING DAY 1 DATA C 194 DO 220 IN=1,NUMIN IF(JFOPEN(IN).NE.1)GO TO 220 C READ ONLY OPEN FILES. ISTAV=0 C ASSUME INITIALLY THAT DATA ARE GRIDPOINT. IF(KFILIN(IN).LT.80)GO TO 200 C C FALL THROUGH HERE MEANS THE DATA ARE VECTOR. DIRECTORY C HAS TO BE READ, ETC. C IF(NSTA.EQ.0)THEN C HAVING NO STATION LIST AND PROCESSING VECTOR DATA ARE C INCOMPATIBLE. CLOSE THIS FILE. JFOPEN(IN)=0 WRITE(KFILDO,1945)KFILIN(IN) 1945 FORMAT(/' ****TRYING TO PROCESS VECTOR DATA WITH NO', 1 ' STATION LIST IN RDSTR5 AT 1945. FILE UNIT NO.', 2 I3,' IS CLOSED.') ISTOP=ISTOP+1 GO TO 220 ENDIF C 195 CALL RDDIR(KFILDO,KFILIN(IN),IP12,NAMIN(IN),NDATE, 1 CCALL,INDEXC(1,IN),ND1,NSTA,CCALLD,ND5,MSTA, 2 L3264B,L3264W,IER) C IF(IER.EQ.0)THEN GO TO 199 C ELSEIF(IER.EQ.120)THEN ISTOP=ISTOP+1 GO TO 199 C C FOR ONE OF THE ERRORS BELOW, THE FILE IS SWITCHED C BUT THE DIRECTORY NOT READ. THIS PUTS THE NEW C FILE IN THE SAME STATE (OPENED BUT NOT READ) AS C AN ORIGINAL FILE WOULD BE UPON ENTRY. C ELSEIF(IER.EQ.146)THEN C IER = 146 IS NOT UNEXPECTED AND IS NOT COUNTED AS AN ERROR. IF(IP23.NE.0)WRITE(IP23,196)KFILIN(IN),NDATE,NAMIN(IN) 196 FORMAT(/' END OF FILE ON UNIT NO.',I3, 1 ' PROCESSING DATE',I11,' FILE = ',A60) CALL SWITCH(KFILDO,IN,KFILIN,NAMIN,JFOPEN,LKHERE,MSDATE, 1 NUMIN,ND6,NDATE,IRD,IP23,ISTOP,IER) GO TO 220 C ELSE C THIS TAKES CARE OF IER = 140 AND 145. ISTOP=ISTOP+1 CALL SWITCH(KFILDO,IN,KFILIN,NAMIN,JFOPEN,LKHERE,MSDATE, 1 NUMIN,ND6,NDATE,IRD,IP23,ISTOP,IER) GO TO 220 ENDIF C 199 ISTAV=1 C C READ THE DATA, EITHER VECTOR OR GRIDPOINT. C 200 READ(KFILIN(IN),IOSTAT=IOS,ERR=201,END=204) 1 (NBYTES(J),J=1,L3264W), 2 (IPACK(J),J=1,MIN(ND5,NBYTES(L3264W)*8/L3264B)) C IPACK( ) CONTAINS THE PACKED RECORD. C THE RECORD CONSISTS OF AN INITIAL 64 BYTES CONTAINING THE NUMBER C OF BYTES FOLLOWING. FOR A 32-BIT MACHINE, THIS IS TWO WORDS. C FOR A 32-BIT MACHINE, IPACK(5) HOLDS THE DATE/TIME OF THE RECORD. C IF(L3264B.EQ.32)THEN IDATE=IPACK(5) ELSE C THE LEFT HALF OF IPACK(3) HOLDS THE DATE/TIME OF THE RECORD C FOR A 64-BIT MACHINE. LOC=3 IPOS=1 CALL UNPKBG(KFILDO,IPACK,ND5,LOC,IPOS,IDATE,32,L3264B,IER,*900) ENDIF C NWORDS=NBYTES(L3264W)*8/L3264B GO TO 205 C 201 WRITE(KFILDO,202)KFILIN(IN),NDATE,IOS,NAMIN(IN) 202 FORMAT(/' ****ERROR READING PACKED RECORDS ON UNIT NO.',I3, 1 ' PROCESSING DATE',I11,' IN RDSTR5 AT 202, IOSTAT =',I5/ 2 ' FILE = ',A60) ISTOP=ISTOP+1 LSTOPC=LSTOPC+1 IF(LSTOPC.LT.LSTOP)GO TO 200 C THIS CHECK IS TO STOP AN INFINITE LOOP THAT MIGHT OCCUR. WRITE(KFILDO,203)LSTOPC 203 FORMAT(' A TOTAL OF',I6,' READING ERRORS HAVE OCCURRED.', 1 ' RETURN FROM RDSTR5 AT 203.') GO TO 250 C 204 CALL SWITCH(KFILDO,IN,KFILIN,NAMIN,JFOPEN,LKHERE,MSDATE, 1 NUMIN,ND6,NDATE,IRD,IP23,ISTOP,IER) C C FALL THROUGH HERE MEANS THE DATA ARE VECTOR, ANOTHER C FILE EXISTS WITH THE SAME UNIT NUMBER, AND THE OPEN C WAS MADE OK. GO TO 220 C 205 IF(IDATE.EQ.9999)GO TO 195 C THE ABOVE TEST IS FOR A TRAILER RECORD ON VECTOR DATA. C IF FOUND, A NEW DIRECTORY RECORD IS READ. C IF(IDATE.LT.LDATB(IN))THEN GO TO 200 C THE ABOVE SPACES UP TO THE DAY WANTED. ELSE IF(IDATE.GT.LDATE(IN))THEN BACKSPACE KFILIN(IN) C THE READ ABOVE HAS GONE BEYOND THE DATE WANTED BY 1 RECORD; C THEREFORE, THE BACKSPACE. FOR VECTOR DATA, THE POINTER C MAY BE DIRECTLY AFTER A NEW DIRECTORY RECORD. GO TO 220 ENDIF C C THIS IS A DATE/TIME TO SAVE FOR THIS MODEL FOR DAY 1. C THIS IS A RECORD FROM MODEL NAMIN(IN) THAT MUST BE SAVED SO C THAT IT CAN BE RETAINED IN A RANDOM ACCESS MANNER. THE TDL C MOS-2000 STORAGE SYSTEM IS USED FOR THIS PURPOSE. MODEL C DATA ARE STORED PACKED, BUT VECTOR DATA HAVE TO BE UNPACKED C AND ASSOCIATED WITH THE CURRENT DIRECTORY FOR THAT SOURCE C AND ARE THEN STORED UNPACKED FOR THE NSTA STATIONS. C CALL UNPACK(KFILDO,IPACK,IWORK,DATA,ND5,IS0,IS1,IS2,IS4,ND7, 1 MISSP,MISSS,ISTAV+1,L3264B,IER) C ONLY ID'S ARE UNPACKED FOR GRIDPOINT DATA; DATA ARE ALSO C UNPACKED FOR VECTOR DATA. ISTAV+1 DOES THAT. C D WRITE(KFILDO,206)(IS0(K),K=1,3) D206 FORMAT(/' IS0',1X,A4,2I10) D WRITE(KFILDO,207)(IS1(K),K=1,22) D207 FORMAT(/' IS1',10I11/' ',10I11/' ',2I11) D WRITE(KFILDO,208)(IS2(K),K=1,12) D208 FORMAT(/' IS2',10I11/(' ',10I11)) D WRITE(KFILDO,209)(IS4(K),K=1,4) D209 FORMAT(/' IS4',10I11/(' ',10I11)) C IF(IER.NE.0)THEN ISTOP=ISTOP+1 GO TO 200 ENDIF C IER NE 0 INDICATES PROBLEM WITH UNPACKING RECORD. IT IS NOT C TREATED AS FATAL, BUT THIS RECORD IS SKIPPED. A DIAGNOSTIC C WILL HAVE BEEN PRINTED IN UNPACK. C C DETERMINE WHETHER DATA READ MATCHES THE TYPE EXPECTED, C VECTOR OR GRIDPOINT. C IVECT=1 IF(BTEST(IS1(2),0))IVECT=0 C IVECT = 1 FOR VECTOR DATA, 0 FOR GRIDPOINT DATA. IF(IVECT.NE.ISTAV)THEN WRITE(KFILDO,211)MODNUM(IN),KFILIN(IN) 211 FORMAT(/' ****MODEL NO.',I3,' ON UNIT NO.',I3, 1 ' IMPLYING GRIDPOINT OR VECTOR DATA DOES NOT AGREE'/ 2 ' WITH TYPE OF DATA READ IN RDSTR5. ', 3 ' MODEL NUMBERS OF 80 AND ABOVE ARE RESERVED', 4 ' FOR VECTOR DATA.') ISTOP=ISTOP+1 C DATA ARE NOT STORED. GO TO 200 ENDIF C IF(ISTAV.EQ.1)THEN C C THIS SECTION IS FOR VECTOR DATA. C C FIRST DETERMINE WHETHER THIS RECORD NEED BE SAVED BY C CHECKING WITH ID( , ). THIS WILL BE OBSERVATIONAL C DATA AND THE TAU WILL BE ZERO. THE PROPER DATES C HAVE ALREADY BEEN CONSIDERED. C DO 213 N=1,NPREDX C IF(IS1(9).EQ.IDPARS(1,N)*1000000+ 1 IDPARS(2,N)*1000+ 2 IDPARS(4,N).AND. 3 IS1(10).EQ.0.AND. 4 IS1(11).EQ.0.AND. 5 IS1(12).EQ.0)GO TO 214 C IT IS ONLY THE CCCFFFXDD THAT MATTERS FOR THESE C VECTOR HOURLY DATA. C 213 CONTINUE C C THIS IS NOT A FIELD NEEDED. GO TO 200 C C THIS SECTION IS FOR VECTOR DATA. C DATA ARE STORED, UNPACKED, FOR STATIONS NEEDED. C 9997 IS SET TO PXMISS. C 214 ISTA=IS4(3) IF(ISTA.GT.ND5)THEN WRITE(KFILDO,215)ND5,ISTA,KFILIN(IN),NAMIN(IN) 215 FORMAT(/' ****ND5 =',I6,' TOO SMALL FOR DATA ARRAY', 1 ' IN RDSTR5 AT 215. INCREASE TO GE',I6/ 2 ' READING ON UNIT NO.',I3,' FILE = ',A60) IER=38 C SET SDATA( ) TO MISSING. DATA( ) WILL NOT HAVE C BEEN OVERFLOWED, BUT WILL CONTAIN THE MISSING C INDICATOR. C ISTOP=ISTOP+1 C DATA ARE NOT STORED. GO TO 200 C ELSE C C PUT DATA INTO SDATA( ). NOTE THAT EXCEPT FOR THE C INITIAL RETRIEVAL INTO DATA( ), ONLY THE NSTA WORDS C OF DATA ARE DEALT WITH. THIS HAS TO BE DONE IN C RDSTR5 IN CASE THE DIRECTORY CHANGES. C DO 217 K=1,NSTA C IF(INDEXC(K,IN).EQ.99999999)THEN SDATA(K)=9999. ELSE SDATA(K)=DATA(INDEXC(K,IN)) IF(SDATA(K).EQ.9997.)SDATA(K)=PXMISS C THE ABOVE STATEMENT ALLOWS THE MISSING VALUE C 9997 TO BE TREATED AS SOME OTHER VALUE. THIS C WOULD USUALLY BE 0, BUT COULD BE, SAY, 9999. ENDIF C 217 CONTINUE C CALL GSTORE(KFILDO,KFIL10,IS1(9),0,LSTORE,ND9,LITEMS, 1 SDATA,NSTA,1,0,IS1(8), 2 CORE,ND10,LASTL,NBLOCK,LASTD,NSTORE,L3264B,IER) C IS1(9) IS THE FIRST OF 4 ID WORDS. C "NSLAB" IS STORED AS ZERO SIGNIFYING VECTOR DATA. C IF(IER.NE.0)THEN ISTOP=ISTOP+1 C IER NE 0 IS TREATED AS FATAL WITH RETURN TO CALLING C PROGRAM. GO TO 250 C ENDIF C ENDIF C ELSE C C THIS SECTION IS FOR GRIDPOINT DATA. C C FIRST DETERMINE WHETHER THIS RECORD NEED BE SAVED BY C CHECKING WITH ID( , ). THIS WILL BE LAMP OR NCEP C DATA AND THE TAU WILL DEPEND ON WHICH. THE PROPER DATES C HAVE ALREADY BEEN CONSIDERED. C DO 218 N=1,NPREDX C IF(IS1(9).EQ.IDPARS(1,N)*1000000+ 1 IDPARS(2,N)*1000+ 2 IDPARS(4,N))THEN C IF(IS1(10)-(IS1(10)/10000)*10000.EQ.IDPARS(7,N))THEN C THE ABOVE ALLOWS THE UUUU IN ID(2, ). C IF(IS1(12).LT.1000) THEN C IF(IS1(12).EQ.0)THEN c-------------------------------------------------- C C AT THIS POINT, THE ID IS OK, EXCEPT ID(3, ) C HAS NOT BEEN CHECKED. THE TAU MUST BE C CONSIDERED. THE LIST IN ID( , ) MAY OR MAY NOT C CONTAIN TAUS OTHER THAN ZERO. TRROHH=IS1(11)/1000 ITAU=IS1(11)-TRROHH*1000 C IF(TRROHH.EQ.0)THEN C IF(IDPARS(4,N).EQ.NCEPNO)THEN IF(ITAU.LE.36)GO TO 219 C NCEP FIELDS ARE LIMITED IN TAU TO C 36 HOURS. ELSEIF(IDPARS(4,N).EQ.LAMPNO)THEN IF(ITAU.LE.2)GO TO 219 C LAMP FIELDS ARE LIMITED IN TAU TO 2 HOURS. ELSEIF(IDPARS(4,N).EQ.NRADNO)THEN GO TO 219 ENDIF C ONLY FIELDS WITH DD = NCEPNO, LAMPNO, OR NRADNO ARE C SAVED. ENDIF C ENDIF C ENDIF C ENDIF C 218 CONTINUE C C THIS IS NOT A FIELD NEEDED. GO TO 200 C DATA ARE STORED PACKED. C GRCOMB IS NOT ENTERED FOR VECTOR DATA. C 219 CALL GRCOMB(KFILDO,0,IS2,ND7,NGRIDC,ND11,NGRID,NSLAB, 1 CCALL,NAME,STALAT,STALON,DIR,ND1,NSTA,IER) C UPON RETURN FROM GRCOMB, NSLAB IS THE NUMBER OF THE GRID C COMBINATION IN NGRIDC OF THE GRID TO STORE. NOTE THAT "IP12" C IS USED AS ZERO HERE AND THAT THE PRINT OF ALL X,Y POSITIONS C IS AT THE END OF RDSTR5. C IF(IER.NE.0)THEN ISTOP=ISTOP+1 C IER NE 0 IS TREATED AS FATAL WITH RETURN TO CALLING C PROGRAM. GO TO 250 C ENDIF C CALL GSTORE(KFILDO,KFIL10,IS1(9),NSLAB,LSTORE,ND9,LITEMS, 1 IPACK,NWORDS,2,0,IS1(8), 2 CORE,ND10,LASTL,NBLOCK,LASTD,NSTORE,L3264B,IER) C IS1(9) IS THE FIRST OF 4 ID WORDS. C "NSLAB" IS STORED AS NON-ZERO SIGNIFYING GRID DATA. ENDIF C IF(IER.NE.0)THEN ISTOP=ISTOP+1 C IER NE FROM GSTORE 0 IS TREATED AS FATAL IN RDSTR5 C WITH RETURN TO CALLING PROGRAM. GO TO 250 ENDIF C GO TO 200 C 220 CONTINUE C IF(LITEMS.EQ.0)THEN C IF(NUMINX.NE.0)THEN C IF(IP10.NE.0)THEN WRITE(IP10,228) 228 FORMAT(/' ****NO FIELDS FOUND FOR DAY 1') ENDIF C IF(IP10.NE.KFILDO)THEN WRITE(KFILDO,228) ENDIF C ISTOP=ISTOP+1 IER=56 GO TO 250 C ENDIF C ELSE C IF(IP10.NE.0)THEN WRITE(IP10,229)LITEMS,((LSTORE(J,K),J=1,12),K=1,LITEMS) 229 FORMAT(/' ',I4,' FIELDS READ AND STORED FOR DAY 1'/ 1 (' ',3I10.9,I11.3,2I8,I3,I12,2I3,I5,I12)) ENDIF C ENDIF C C WRITE GRID LOCATIONS OF STATIONS, IF DESIRED. C IF(IP12.EQ.0)GO TO 250 IF(NGRID.EQ.0)GO TO 240 WRITE(IP12,232) 232 FORMAT(/' IX, JY GRID LOCATIONS FOR EACH STATION FOR EACH GRID') C DO 234 K=1,NSTA WRITE(IP12,233)CCALL(K,1),NAME(K),(DIR(K,1,M),DIR(K,2,M), 1 M=1,NGRID) 233 FORMAT(' ',A8,1X,A20,6(3X,2F6.2)/ 1 (' ',29X,6(3X,2F6.2))) 234 CONTINUE C C WRITE LOCATIONS IN VECTOR RECORDS OF THE STATIONS C FOR EACH VECTOR INPUT, IF DESIRED. C 240 DO 245 IN=1,NUMIN IF(KFILIN(IN).LT.80)GO TO 245 IF(JFOPEN(IN).EQ.0)GO TO 245 WRITE(IP12,242)KFILIN(IN),(K,CCALL(K,1),NAME(K),INDEXC(K,IN), 1 K=1,NSTA) 242 FORMAT(/' LOCATIONS IN RECORD FOR EACH STATION FOR UNIT NO.',I4// 1 (I8,2X,A8,1X,A20,I8)) 245 CONTINUE C 250 RETURN C 900 WRITE(KFILDO,901)IER 901 FORMAT(/' ****ERROR IN UNPKBG IN RDSTR5. IER =',I4) RETURN END