SUBROUTINE U900(KFILDI,KFILDO,KFILEQ,EQNNAM,
1 ICALL,CCALL,ISDATA,SDATA,XDATA,NAME,ND1,
3 ISCALD,IPLAIN,PLAIN,L3264B,L3264W,
4 ICALLD,CCALLD,IPACK,DATA,IWORK,ND5,
5 KFILIN,MODNUM,NAMIN,JFOPEN,
6 INDEXC,ND6,
7 IS0,IS1,IS2,IS4,ND7,
8 IDATE,NWORK,ND8,
9 LSTORE,ND9,
A ID,IDPARS,TRESHL,JD,ITAU,IUSED,
B CONST,AVG,CORR,COEF,IDTAND,IDTPAR,
C NGP,LGP,MTRMS,ICAT,LOCSTA,FCST,
D ND2,ND3,ND11,ND13,
E CORE,ND10,NBLOCK)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK ***
C
C SUBPROGRAM: U900
C PRGMMR: GLAHN ORG: W/OSD211 DATE: 99-02-01
C
C ABSTRACT: PROGRAM U900 IS USED TO MAKE FORECASTS FROM REGRESSION
C EQUATIONS, PROBABLY PRODUCED BY U600. THIS PROGRAM SHOULD
C RUN ON EITHER THE HP UNIX PLATFORM WHICH USES 32-BIT
C INTEGERS OR THE CRAY UNIX PLATFORM WHICH USES 64-BIT
C INTEGERS. THE ONLY DIFFERENCE IS THAT THE DRIVER IS
C COMPILED WITH THE PARAMETER STATEMENT:
C PARAMETER (L3264B=32) FOR THE 32-BIT MACHINE AND
C PARAMETER (L3264B=64) FOR THE 64-BIT MACHINE. SOME OF
C THE ASSUMPTIONS REGARDING POSSIBLY NON-FORTRAN77 ARE:
C 1) LOGICAL*1 DOES NOT PRODUCE BYTE-SIZE WORDS ON THE
C CRAY,
C 2) A VARIABLE OF TYPE CHARACTER MUST BE OF THE SAME
C TYPE IN BOTH THE CALLING AND CALLED ROUTINES, AND
C 3) CHARACTER AND INTEGER ARRAYS CAN BE EQUIVALENCED.
C IT IS ASSUMED THAT ALL EQUATIONS AVAILABLE AND READ WILL
C BE USED FOR THE STATIONS SPECIFIED (WHICH CAN BE BY
C SEPARATE LIST). THAT IS, ALL PREDICTANDS WILL HAVE
C FORECASTS MADE FOR THEM AND THE OUTPUT PRODUCED.
C OUTPUT IS OPTIONAL SEQUENTIAL TDLPACK AND/OR MOS-2000
C RANDOM ACCESS TDLPACK. DATA NEEDED MUST BE
C ON PACKED SEQUENTIAL FILES OR CAN BE OBTAINED THROUGH
C OPTX, WHICH CAN ACCESS UP TO 5 MOS-2000 EXTERNAL RANDOM
C ACCESS FILES. BINARIES CAN BE AVAILABLE ON INPUT OR
C COMPUTED WITHIN U900.
C
C NORMALLY, U900 IS USED FOR ONE DATE/TIME IN OPERATIONS,
C BUT CAN OPERATE ON MULTIPLE DATE/TIMES.
C
C
C PROGRAM HISTORY LOG:
C 00-03-18 GLAHN
C 00-05-15 ERICKSON ADDED NCEP DOCBLOCK.
C 00-05-16 MCE MODIFIED TO READ NCEP DATE FILE
C (IN PROGRESS)
C 00-05-16 DREWRY ADDED STATEMENTS TO PRINT AN ERROR MESSAGE AND
C STOP IF THE NCEP DATE FILE CAN NOT BE READ. ADDED
C STATEMENTS TO PRINT THE DATE THAT WAS READ.
C 00-05-17 MCE ADDED CALLS TO W3TAGB AND W3TAGE FOR ALL STOPS
C 00-05-17 JPD CORRECTED FORMAT STATEMENT FOR PXMISS OUTPUT
C 00-05-19 JPD CORRECTED CALL TO RDSNAM WHEN READING THE
C EQUATION FILES - CHANGED KGP TO JFOPENEQ.
C 00-06-26 ALLEN CHANGED TO READ THE EQUATION FILE UNTIL AN END OF
C FILE IS REACHED, RATHER THAN WHEN A '999999999' IS
C ENCOUNTERED. THIS ALLOWS YOU TO ONLY LIST THE
C EQUATION FILE ONCE IN THE .CN FILE, RATHER THAN
C ONCE FOR EACH EQUATION SET.
C 00-06-27 ALLEN DIMENSIONED IDUM TO ND11 BECAUSE IT WAS CAUSING
C ARRAYS TO GET CLOBBERED ON THE IBM WHEN IT WAS
C ONLY ONE-DIMENSIONAL. CHANGED CALL TO RDSNAM
C WHEN OPENING EQUATION FILES - CHANGED KGP TO IDUM.
C ALSO CHANGED THE CALL TO RDSNAM FOR STATION LIST
C AND DIRECTORY FROM ITEMP(14) TO IDUM(ND11) TO BE
C CONSISTENT IN AVOIDING THIS CLOBBERING PROBLEM.
C 00-06-29 ALLEN CHANGED RDEQN SO IT CHECKS ALL SIX LINKS NOW,
C RATHER THAN JUST TWO.
C 01-11-05 MCE CHANGED TO CALL RDEQN9; COMMENTED OUT WRITE 164
C THIS WAS MAINLY A DIAGNOSTIC.
C JAN 2016 SCHNAPP CHANGED MINPK FROM 14 TO 21
C 09-11-18 SHAFER ADDED CALL TO RDSTAL2 WHEN NALPH=2. THIS
C BYPASSES STATION CHECKING WHEN MAKING
C FORECASTS FOR LARGE NUMBER OF GRID POINTS.
C SEPTEMBER 2020 GHIRARDELLI CHANGED UNDEFINED IP12 TO IP(12) IN CALL
C TO FCST90
C
C USAGE: CALL U900 (KFILDI,KFILDO,KFILEQ,EQNNAM,ICALL,CCALL,ISDATA,
C SDATA,XDATA,NAME,ND1,ISCALD,IPLAIN,PLAIN,L3264B,
C L3264W,ICALLD,CCALLD,IPACK,DATA,IWORK,ND5,KFILIN,
C MODNUM,NAMIN,JFOPEN,INDEXC,ND6,IS0,IS1,IS2,IS4,
C ND7,IDATE,NWORK,ND8,LSTORE,ND9,ID,IDPARS,TRESHL,
C JD,ITAU,IUSED,CONST,AVG,CORR,COEF,IDTAND,IDTPAR,
C NGP,LGP,MTRMS,ICAT,LOCSTA,FCST,ND2,ND3,ND11,ND13,
C CORE,ND10,NBLOCK)
C INPUT ARGUMENT LIST:
C KFILDI - UNIT NUMBER TO READ INPUT FILE 'U900.CN'.
C SET BY DATA STATEMENT TO 5.
C KFILDO - UNIT NUMBER OF OUTPUT (PRINT) FILE. INITIALLY,
C THIS IS SET BY DATA STATEMENT TO 12. LATER, IN IPOPEN,
C IF IP(1) NE 0, KFILDO IS SET = IP(1). THIS ALLOWS
C CHANGING THE "DEFAULT" PRINT FILE ON THE FLY.
C OTHERWISE, ON SOME SYSTEMS, THE OUTPUT FILE MIGHT
C HAVE THE SAME NAME AND BE OVERWRITTEN. WHEN THE
C OUTPUT FILE IS NOT THE ORIGINAL DEFAULT, THE NAME
C IS GENERATED AND CAN BE DIFFERENT FOR EACH RUN.
C THIS ALLOWS SAVING EACH OUTPUT AND NOT HAVING IT
C OVERWRITTEN.
C KFILEQ(J) - UNIT NUMBERS (J=1,ND11) OF FILES FROM WHICH TO
C READ EQUATIONS.
C EQNNAM(J) - FILE NAMES ASSOCIATED WITH KFILEQ(J) (J=1,ND11).
C (CHARACTER*60)
C ICALL(L,K,J) - 8-CHARACTER STATION CALL LETTERS AS CHARACTERS
C IN AN INTEGER VARIABLE (L=1,L3264W).
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. (CHARACTER*8)
C ISDATA(K) - WORK ARRAY (K=1,ND1).
C SDATA(K) - WORK ARRAY (K=1,ND1).
C XDATA(K) - WORK ARRAY (K=1,ND1).
C NAME(K) - NAMES OF STATIONS (K=1,NSTA) (CHARACTER*20)
C ND1 - MAXIMUM NUMBER OF STATIONS THAT CAN BE DEALT WITH.
C ISCALD(NN) - THE DECIMAL SCALING CONSTANT TO USE WHEN
C PACKING THE FORECASTS FOR PREDICTAND NN
C (NN=1,MTANDS). ISCALD( ) COMES FROM THE
C VARIABLE CONSTANT FILE, MODIFIED TO BE 0 FOR
C BINARIES. ZERO WHEN NOT FOUND IN THE FILE.
C IPLAIN(L,J,NN) - 32 CHARACTERS (L=1,L3264W) (J=1,4) OF PLAIN
C LANGUAGE DESCRIPTION OF THE PREDICTAND
C NN (NN=1,MTANDS). NOTE THAT THIS REQUIRES
C TWO 32-BIT WORDS TO HOLD THE DESCRIPTION
C BUT ONLY ONE 64-BIT WORD. EQUIVALENCED
C TO PLAIN( ).
C PLAIN(NN) - THE PLAIN LANGUAGE DESCRIPTION OF THE
C PREDICTAND NN (NN=1,MTANDS). EQUIVALENCED TO
C IPLAIN( , , ). (CHARACTER*32)
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 ICALLD(L,K) - 8 STATION CALL LETTERS AS CHARACTERS IN AN INTEGER
C 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 NEEDED IN CONST6 FOR ARGUMENT TO RDTDLM.
C EQUIVALENCED TO CCALLD( , ).
C CCALLD(K) - 8 STATION CALL LETTERS (K=1,ND5). EQUIVALENCED
C TO ICALLD( , ).
C IPACK(J) - PACKED DATA READ FROM THE INPUT FILE(S)
C (J=1,ND5). ALSO WORK ARRAY IN RDSTAL AND
C RDSTAD.
C DATA(J) - WORK ARRAY (J=1,ND5).
C IWORK(J) - WORK ARRAY (J=1,ND5).
C ND5 - THE MAXIMUM NUMBER OF STATION CALL LETTERS ON
C THE INPUT FILES. DIMENSION OF IWORK( ),
C DATA( ), AND CCALLD( ), AND SECOND DIMENSION
C OF IPACK( , ). MUST BE GE THE LARGEST RECORD
C ON THE INPUT INTERPOLATED FILE(S). MUST ALSO
C BE GE ND1.
C KFILIN(J) - UNIT NUMBERS FOR INPUT VECTOR DATA, ALL IN
C TDLPACK FORMAT (J=1,ND6).
C MODNUM(J) - THE "MODEL" NUMBER CORRESPONDING TO KFILIN(J),
C AND NAMIN(J) (J=1,ND6). NOT USED IN U900.
C NAMIN(J) - HOLDS DATA SET NAMES FOR THE UNIT NUMBERS
C IN KFILIN(J) (J=1,ND6). (CHARACTER*60)
C JFOPEN(J) - FOR EACH FILE IN MODNUM(J), JFOPEN(J) IS SET
C TO 1 FOR J=1, MEANING THE FILE IS OPEN AND IS
C SET TO 2 FOR J GT 1 (IF ANY) MEANING THE FILE
C IS AVAILABLE, BUT NOT OPEN (J=1,NUMIN).
C JFOPENEQ(J) - FOR EACH EQUATION FILE, JFOPENEQ(J) IS SET;
C THIS VARIABLE WAS ESTABLISHED TO ALLOW U900
C TO RUN PROPERLY AND IS LIKELY UNNECESSARY.
C INDEXC(K,J) - LOCATIONS OF THE NSTA STATIONS (K=1,NSTA)
C IN THE LIST CCALL(K, ) IN REFERENCE TO THE
C STATION CALL LETTERS RECORD ON THE INPUT
C DATA SET NUMBER J (J=1,NUMIN).
C ND6 - MAXIMUM NUMBER OF INPUT DATA SETS (MODELS) THAT
C CAN BE DEALT WITH.
C IS0(J) - MOS-2000 GRIB SECTION 0 ID'S (J=1,4).
C IS1(J) - MOS-2000 GRIB SECTION 1 ID'S (J=1,21+).
C IS2(J) - MOS-2000 GRIB SECTION 2 ID'S (J=1,12).
C IS4(J) - MOS-2000 GRIB SECTION 4 ID'S (J=1,4).
C WORD) OF PLAIN TEXT = 54. SET BY PARAMETER.
C ND7 = DIMENSION OF IS0( ), IS1( ), IS2( ), AND IS4( ).
C NOT ALL LOCATIONS ARE USED. MAXIMUM SIZE IS FOR
C IS1( ) = 22 PLUS 32 CHARACTERS (ONE CHARACTER PER
C WORD) OF PLAIN TEXT = 54. SET BY PARAMETER.
C IDATE(J) = INITIAL DATE LIST (J=1,NDATES) WHICH MAY CONTAIN
C NEGATIVE VALUES INDICATING A DATE SPAN.
C THIS IS MODIFIED IN DATPRO TO CONTAIN THE COMPLETE
C DATE LIST WITH THE DATES IN THE SPANS FILLED IN
C (J=1,NDATES), WHERE NDATES HAS BEEN INCREASED
C IF NECESSARY. DATES ARE INPUT AS YYMMDDHH AND
C MODIFIED TO YYYYMMDDHH. ZEROS IN THE INPUT ARE
C ELIMINATED. TERMINATOR IS 99999999. MAXIMUM
C NUMBER OF DATES IS ND8.
C NWORK(J) - WORK ARRAY (J=1,ND8).
C ND8 - MAXIMUM NUMBER OF DATES THAT CAN BE DEALT WITH.
C LSTORE(L,J) - THE ARRAY HOLDING INFORMATION ABOUT THE DATA
C STORED IN THE MOS-2000 STORAGE SYSTEM
C (L=1,12) (J=1,LITEMS).
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.
C L=6 --THE NUMBER OF 4-BYTE WORDS STORED.
C L=7 --2 FOR DATA PACKED IN TDL GRIB, 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 --NOT USED.
C L=11 --THE NUMBER OF THE FIRST PREDICTOR IN THE SORTED
C LIST IN ID( ,N) (N=1,VRBL) FOR WHICH THIS
C VARIABLE IS NEEDED, WHEN IT DOES NOT NEED
C TO BE STORED AFTER DAY 1. WHEN THE VARIABLE
C MUST BE STORED (TO BE ACCESSED THROUGH OPTION)
C FOR ALL DAYS, ID(11,N) IS 7777 + THE NUMBER
C OF THE FIRST PREDICTOR IN THE SORTED LIST
C FOR WHICH THIS VARIABLE IS NEEDED.
C L=12 --MOT USED.
C ND9 - MAXIMUM NUMBER OF FIELDS STORED IN LSTORE( , ).
C SECOND DIMENSION OF LSTORE( , ).
C ID(J,L,M) - THE 4-WORD ID (J=1,7) FOR EACH PREDICTOR
C (M=1,MTRMS(L)) IN EACH EQUATION (L=1,KGP) OF THE
C GROUP BEING PROCESSED. VALUES OF J=5-7 NOT USED;
C DIMENSION IS 7 RATHER THAN 4 TO ACCOMMODATE
C RDEQN, WHICH IS ALSO USED FOR U700.
C IDPARS(J,L,M) = THE PARSED, INDIVIDUAL COMPONENTS OF THE
C VARIABLE ID'S CORRESPONDING TO ID( ,L,M) (J=1,15)
C (M=1,MTRMS(L)) (L=1,KGP).
C J=1--CCC (CLASS OF VARIABLE),
C J=2--FFF (SUBCLASS OF VARIABLE),
C J=3--B (BINARY INDICATOR),
C 0 = NOT BINARY,
C 1 = CUMULATIVE FROM ABOVE, VALUES GE LOWER
C THRESHOLD TRESHL = 1,
C 2 = CUMULATIVE FROM BELOW, VALUES LT UPPER
C THRESHOLD TRESHU = 1.
C 3 = DISCRETE BINARY. VALUES GE LOWER
C THRESHOLD AND LT UPPER THRESHOLD = 1.
C 5 = GRID BINARY. VALUES GE LOWER THRESHOLD
C ONLY THE VALUE OF 0, 1, OR 5 SHOULD BE USED
C FOR PREDICTORS;
C 0, 1, 2, OR 3 CAN BE USED FOR PREDICTANDS.
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 TRESHL(L,M) = THE LOWER BINARY THRESHOLD CORRESPONDING TO
C IDPARS( ,L,M) (M=1,MTRMS(L)) (L=1,KGP).
C FOR U900, THE UPPER THRESHOLD IS ALWAYS LARGE.
C THAT IS, THE PREDICTORS CARRY WITH THEM ONLY
C ONE THRESHOLD, THE LOWER ONE.
C JD(J,L,M) = THE BASIC INTEGER VARIABLE ID'S (J=1,4)
C (M=1,MTRMS(L)) (L=1,KGP). THIS IS THE SAME AS
C ID(J,L,M), EXCEPT THAT THE FOLLOWING PORTIONS
C ARE OMITTED:
C B = IDPARS(3, , ),
C G = IDPARS(15, , ), AND
C TRESHL( , ).
C THE "G" VARIABLE HAS NO MEANING IN U900,
C IT BEING ONLY FOR POSSIBLE USE IN U201.
C ITAU(L,M) = THE NUMBER OF HOURS TO ADD TO IDATE( ) TO GET
C THE VARIABLE ID( ,L,M) (M=1,MTRMS(L)), (L=1,KGP).
C THIS IS THE "LOOKAHEAD" FEATURE.
C IUSED(L,M) = WORK ARRAY ASSOCIATED WITH EACH PREDICTOR
C (M=1,MTRMS(L)) IN EACH EQUATION (L=1,KGP).
C INITIALLY SET TO ZERO; SET TO 1 WHEN THE
C TERM HAS BEEN EVALUATED.
C CONST(L,NN) = THE EQUATION CONSTANTS FOR GROUP L
C (L=1,KGP), PREDICTAND NN (NN=1,MTANDS) FOR
C THE GROUP BEING PROCESSED.
C AVG(L,NN) = THE PREDICTAND MEANS FOR GROUP L (L=1,KGP),
C PREDICTAND NN (NN=1,MTANDS) FOR THE GROUP
C BEING PROCESSED.
C CORR(L,NN) = THE MULTIPLE CORRELATIONS FOR GROUP L
C (L=1,KGP), PREDICTAND NN (NN=1,MTANDS) FOR
C THE GROUP BEING PROCESSED.
C COEF(L,M,NN) = THE COEFFICIENTS FOR GROUP L (L=1,KGP),
C TERM M (M=1,MTRMS(L)), PREDICTAND NN
C (NN=1,MTANDS)) FOR THE GROUP BEING PROCESSED.
C IDTAND(J,NN) = THE PREDICTAND ID'S (J=1,4), FOR PREDICTAND NN
C (NN=1,MTANDS) FOR THE GROUP BEING PROCESSED.
C IDTPAR(J,NN) = THE PARSED PREDICTAND ID'S (J=1,15), FOR
C PREDICTAND NN (NN=1,MTANDS) FOR THE GROUP
C BEING PROCESSED.
C NGP(J) = THE NUMBER OF STATIONS IN EACH GROUP (J=1,KGP).
C NGP(L) = FOR EACH EQUATION, THE NUMBER OF STATIONS
C IN EACH OF THE KGP GROUPS (L=1,KGP).
C LGP(L) = FOR EACH EQUATION (L=1,LGP), THE LOCATION
C IN LOCSTA( ) OF WHERE THE FIRST STATION IN
C THE SET IS.
C MTRMS(L) = THE NUMBER OF TERMS IN EACH EQUATION FOR THE
C GROUP BEING PROCESSED (L=1,KGP).
C ICAT(NN) = THE POSTPROCESSING INDICATOR FOR THE EQUATION
C GROUP BEING PROCESSED FOR PREDICTAND NN
C (NN=1,MTANDS). FOR EXAMPLE, THE
C VALUE 1 WOULD REFER TO SUBROUTINE CAT1, WHICH
C IS USED FOR INFLATION.
C LOCSTA(K) = THE LOCATION IN FCST( ,NN) (NN=1,MTANDS) OF
C WHERE TO PUT THE FORECAST (K=1,NSTA).
C FCST(K,NN) = THE FORECASTS FOR STATION K (K=1,KSTA),
C PREDICTAND NN (NN=1,MTANDS) FOR THE GROUP
C BEING PROCESSED.
C ND2 = MAXIMUM NUMBER OF TERMS IN AN EQUATION.
C ND3 = MAXIMUM NUMBER OF PREDICTANDS IN EQUATION.
C ND11 = MAXIMUM NUMBER OF FILES FROM WHICH TO READ
C EQUATIONS.
C ND13 = MAXIMUM NUMBER OF DIFFERENT EQUATIONS PER SET.
C THIS WOULD BE = ND1 FOR SINGLE STATION EQUATIONS.
C CORE(J) = SPACE ALLOCATED FOR SAVING DATA IN INTERNAL
C STORAGE SYSTEM (J=1,ND10). WHEN THIS SPACE
C IS EXHAUSTED, SCRATCH DISK IS USED.
C ND10 = THE MEMORY IN WORDS ALLOCATED TO THE SAVING OF
C PACKED DATA IN CORE( ). WHEN THIS
C SPACE IS EXHAUSTED, SCRATCH DISK WILL BE USED.
C NBLOCK = BLOCK SIZE IN WORDS OF INTERNAL MOS-2000 DISK
C STORAGE. SINCE MUCH, IF NOT ALL, INTERNAL
C STORAGE WILL BE OF PACKED DATA, THE NUMBER OF
C BYTES WILL BE THE SAME FOR EITHER A 32- OR
C 64-BIT MACHINE. THEREFORE, THE BLOCK SIZE IS
C SET BY PARAMETER TO VARY WITH L3264B. IN THE
C PARAMETER STATEMENT, THE 6400 IS ARBITRARY, AND
C CAN BE CHANGED. PERFORMANCE SHOULD NOT BE
C HIGHLY DEPENDENT ON THIS. HOWEVER, IF TOO
C LARGE, SPACE WILL BE WASTED, AND IF TOO SMALL
C MANY RECORDS WILL BE NECESSARY TO HOLD EACH
C RECORD. THE 6400 ACCOMMODATES 800 BYTES ON
C EITHER A 32- OR 64-BIT MACHINE. SET BY
C PARAMETER.
C
C OUTPUT ARGUMENT LIST: NONE. ALL INPUT TO OTHER SUBROUTINES.
C
C DATA SET USE
C INPUT FILES:
C FORT.KFILDI - UNIT NUMBER OF INPUT FILE. SET BY DATA
C STATEMENT IN DRU900. (INPUT)
C FORT.KFILEQ(J) - UNIT NUMBERS (J=1,ND11) OF FILES FROM WHICH TO
C READ EQUATIONS. (INPUT)
C FORT.KFIL10 - UNIT NUMBER OF TDL MOS-2000 FILE SYSTEM ACCESS.
C SET BY DATA STATEMENT. (INPUT-OUTPUT)
C FORT.KFILCP - UNIT NUMBER FOR PREDICTOR CONSTANT FILE. (INPUT)
C FORT.KFILPF - UNIT NUMBER FOR PREDICTAND/FORECAST
C CORRESPONDENCE TABLE. (INPUT)
C FORT.KFILIN( ) - UNIT NUMBERS FOR DATA INPUT FILES. (INPUT)
C FORT.KFILD(J) - UNIT NUMBERS FOR WHERE THE STATION LIST (J=1)
C AND THE STATION DIRECTORY (J=2) RESIDE.
C (INPUT)
C FORT.KFILDT - UNIT NUMBER FOR READING THE DATE LIST. (INPUT)
C FORT.KFILRA( ) - UNIT NUMBERS FOR EXTERNAL RANDOM ACCESS FILES
C (J=1,5). (INPUT)
C
C OUTPUT FILES:
C FORT.KFIL10 - UNIT NUMBER OF TDL MOS-2000 FILE SYSTEM ACCESS.
C SET BY DATA STATEMENT. (INPUT-OUTPUT)
C FORT.IP(J) - UNIT NUMBERS FOR OPTIONAL OUTPUT (J=1,25)
C (SEE IP( ) UNDER "VARIABLES" BELOW.
C FORT.KFILFC - UNIT NUMBER FOR WRITING THE FORECAST OUTPUT TO
C SEQUENTIAL FILE. (OUTPUT)
C FORT.KFILX - UNIT NUMBER FOR WRITING FORECAST OUTPUT TO
C MOS-2000 EXTERNAL RANDOM ACCESS FILE. (OUTPUT)
C
C VARIABLES
C KFIL10 - UNIT NUMBER OF TDL MOS-2000 FILE SYSTEM ACCESS.
C SET BY DATA STATEMENT.
C IPINIT - 4 CHARACTERS USED TO HELP IDENTIFY OUTPUT ASSOCIATED
C WITH THE IP( ) NUMBERS.
C IP(J) - EACH VALUE (J=1,25) INDICATES WHETHER (>1)
C OR NOT (=0) CERTAIN INFORMATION WILL BE WRITTEN.
C WHEN IP( ) > 0, THE VALUE INDICATES THE UNIT
C NUMBER FOR OUTPUT. THESE VALUES SHOULD NOT BE THE
C SAME AS ANY KFILX VALUES EXCEPT POSSIBLY
C KFILDO, WHICH IS THE DEFAULT OUTPUT FILE. THIS IS
C ASCII OUTPUT, GENERALLY FOR DIAGNOSTIC PURPOSES.
C THE FILE NAMES WILL BE 4 CHARACTERS 'U900',
C THEN 4 CHARACTERS FROM IPINIT, THEN 2 CHARACTERS
C FROM IP(J) (E.G., 'U900HRG130'). THE ARRAY IS
C INITIALIZED TO ZERO IN CASE LESS THAN THE EXPECTED
C NUMBER OF VALUES ARE READ IN. EACH OUTPUT ASCII
C FILE WILL BE TIME STAMPED. NOTE THAT THE TIME
C ON EACH FILE SHOULD BE VERY NEARLY THE SAME, BUT
C COULD VARY BY A FRACTION OF A SECOND. IT IS
C INTENDED THAT ALL ERRORS BE INDICATED ON THE
C DEFAULT, SOMETIMES IN ADDITION TO BEING INDICATED
C ON A FILE WITH A SPECIFIC IP( ) NUMBER, SO THAT
C THE USER WILL NOT MISS AN ERROR.
C (1) = ALL ERRORS AND OTHER INFORMATION NOT
C SPECIFICALLY IDENTIFIED WITH OTHER IP( )
C NUMBERS. WHEN IP(1) IS READ AS NONZERO,
C KFILDO, THE DEFAULT OUTPUT FILE UNIT NUMBER,
C WILL BE SET TO IP(1). WHEN IP(1) IS READ
C AS ZERO, KFILDO WILL BE USED UNCHANGED.
C (2) = THE INPUT DATES IN IDATE( ). WHEN THERE
C ARE ERRORS, PRINT WILL BE TO UNIT KFILDO AS
C WELL AS TO UNIT IP(2).
C (3) = THE OUTPUT DATES IN IDATE( ). WHEN THERE
C ARE ERRORS, OUTPUT WILL BE TO UNIT KFILDO AS
C WELL AS TO UNIT IP(3).
C (4) = THE INPUT STATION LIST (CALL LETTERS ONLY).
C IF THERE ARE INPUT ERRORS, THE STATION LIST
C WILL BE WRITTEN TO THE DEFAULT OUTPUT FILE UNIT
C KFILDO AS WELL AS TO UNIT IP(4).
C (5) = THE STATIONS AND STATION DIRECTORY INFORMATION
C IN THE ORDER TO BE DEALT WITH IN U900. THE
C STATIONS CAN BE IN ALPHABETICAL ORDER WITHIN
C EACH GROUP PROVIDED THE DIRECTORY IS. IF THERE
C ARE INPUT ERRORS, THE STATION LIST WILL BE
C WRITTEN TO THE DEFAULT OUTPUT FILE UNIT KFILDO
C AS WELL AS TO UNIT IP(5).
C (6) = NOT USED.
C (7) = THE PREDICTAND LIST, INCLUDING THE PARSED
C IDS, BUT NOT INCLUDING THE PLAIN LANGUAGE.
C (8) = NOT USED.
C (9) = THE PREDICTAND LIST, NOT INCLUDING THE
C PARSED IDS, BUT INCLUDING THE PLAIN LANGUAGE
C FROM THE CONSTANT FILE.
C (10) = INDICATES WHETHER (>1) OR NOT (=0) THE LIST OF
C FIELDS READ FOR EACH DAY WILL BE PRINTED TO THE FILE
C WHOSE UNIT NUMBER IS IP(10).
C (11) = NOT USED.
C (12) = INDICATES WHETHER (>1) OR NOT (=0) THE LIST OF
C STATIONS ON THE INPUT FILES WILL BE PRINTED TO
C THE FILE WHOSE UNIT NUMBER IS IP(12). THIS IS
C FOR BOTH SEQUENTIAL AND RANDOM ACCESS FILES.
C (13) = INDICATES WHETHER (>0) OR NOT (=0) A DIAGNOSTIC
C WILL BE PROVIDED FOR A STATION IN THE LIST
C CCALL( , ) THAT DOES NOT HAVE AN EQUATION IN
C THE SET BEING PROCESSED (IN REDQN).
C (14) = INDICATES WHETHER (>0) OR NOT (=0) A DIAGNOSTIC
C WILL BE WRITTEN WHEN AN EQUATION SET IS FOUND
C THAT DOES NOT MATCH NDATE (IN RDEQN).
C (15) = INDICATES WHETHER (>0) OR NOT (=0) A STATION
C WITH THE EQUATIONS THAT IS NOT IN THE MASTER
C STATION LIST CCALL( , ) WILL BE WRITTEN TO THE
C FILE WHOSE UNIT NUMBER IS IP(15). THIS
C WOULD HAPPEN ONLY WHEN READING THE EQUATIONS.
C (16) = INDICATES WHETHER (>0) OR NOT (=0) INPUT DATA
C WILL BE PRINTED.
C (17) = INDICATES WHETHER (>0) OR NOT (=0) FORECASTS
C WILL BE PRINTED.
C (18) = INDICATES WHETHER (>0) OR NOT (=0) FORECASTS
C WILL BE PRINTED TO THE ACCURACY PACKED.
C (19) = INDICATES WHETHER (>0) OR NOT (=0) THE
C PREDICTAND MULTIPLE CORRELATION WILL BE WRITTEN.
C (20) = INDICATES WHETHER (>0) OR NOT (=0) THE
C PREDICTAND MEANS WILL BE WRITTEN.
C (21) = INDICATES WHETHER (>0) OR NOT (=0) THE
C EQUATIONS WILL BE WRITTEN TO UNIT IP(21) FOR
C VIEWING.
C (23) = INDICATES WHETHER (>0) OR NOT (=0) STATEMENTS
C ABOUT EOF AND FILE OPENINGS AND CLOSINGS WILL
C BE OUTPUT FOR PRINTING ON UNIT IP(23).
C IUSE(J) - EACH VALUE J PERTAINS TO IP(J). WHEN AN IP(J)
C VALUE IS USED BY THE PROGRAM, IPRINT(J) = 1;
C OTHERWISE, IPRINT(J) = 0. USED BY IPRINT TO
C PRINT IP( ) VALUES.
C RUNID - INFORMATION INPUT TO IDENTIFY THE OUTPUT.
C (CHARACTER*72)
C KSKIP - WHEN NONZERO, INDICATES THAT THE OUTPUT FILE
C IS TO BE MOVED FORWARD UNTIL ALL DATA FOR
C DATE KSKIP HAVE BEEN SKIPPED. KSKIP IS INPUT
C AS YYMMDDHH OR YYYYMMDDHH AND THEN USED AS
C YYYYMMDDHH.
C KWRITE - 0 IF CALL LETTERS RECORD IS NOT TO BE WRITTEN.
C NE 0 OTHERWISE. THIS HAS NO EFFECT UNLESS KSKIP
C NE 0. IF DATA ARE SKIPPED, THE EXISTING
C CALL LETTERS RECORD IS CHECKED WITH THE ONE
C AVAILABLE FOR WRITING. IF THEY MATCH
C THE NEW ONE IS NOT WRITTEN; HOWEVER,IF THEY
C DON'T MATCH, THE NEW ONE IS WRITTEN WHEN
C KWRITE = 1, BUT THE PROGRAM HALTS WITH A
C DIAGNOSTIC WHEN KWRITE = 0.
C NSKIP - THE NUMBER OF ERRORS THAT WILL BE TOLERATED ON DAY 1
C WITHOUT HALTING.
C JSTOP - THE NUMBER OF ERRORS THAT WILL BE TOLERATED ON THE
C TOTAL RUN BEFORE PROGRAM STOPS.
C INCCYL - THE NUMBER OF HOURS BETWEEN DATES WHEN DATE SPANNING
C IS USED. NORMALLY, U900 WOULD USE ONLY ONE
C DATE/TIME AND INCCYL WOULD NOT BE NEEDED.
C NEW - 1 WHEN NEW 4-LETTER CALL LETTERS ARE TO BE USED;
C 0 WHEN OLD 3-LETTER CALL LETTERS ARE TO BE USED.
C NALPH - 1 WHEN THE CALL STATIONS USED ARE TO BE
C ALPHABETIZED (MORE EXACTLY, PUT IN THE ORDER
C THEY EXIST IN THE STATION DIRECTORY.
C 0 WHEN THE ORDER READ IN IS TO BE PRESERVED.
C LOOKAH - NUMBER OF HOURS TO LOOKAHEAD WHEN READING
C DATA IN RDSTR9.
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, TREATING IT AS
C ZERO, AS 9999, OR AS SOME OTHER VALUE.
C NREPLA - RECORD REPLACEMENT FLAG FOR WRITING RANDOM
C ACCESS FILE.
C 0 = NOT REPLACING RECORD.
C 1 = REPLACING, ERROR IF RECORD NOT FOUND TO
C REPLACE.
C 2 = REPLACING, WRITE NEW RECORD IF RECORD NOT
C FOUND TO REPLACE.
C (INPUT)
C NCHECK - IDENTIFICATION CHECKING FLAG FOR WRITING
C RANDOM ACCESS FILE.
C 0 = DON'T CHECK FOR DUPLICATES.
C 1 = CHECK FOR DUPLICATES, ERROR IF FOUND.
C (INPUT)
C KFILDT - UNIT NUMBER FOR READING THE DATE LIST.
C DATNAM - FILE NAME FOR READING DATE LIST. (CHARACTER*60)
C NDATES - THE NUMBER OF DATES IN IDATE( ).
C NUMIN - THE NUMBER OF VALUES IN KFILIN( ), AND NAMES IN
C NAMIN( ). MAXIMUM OF ND6.
C KFILRA(J) - UNIT NUMBERS FOR READING CONSTANT DATA (J=1,5).
C RACESS(J) - FILE NAMES FOR CONSTANT DATA READ ON UNIT
C NOS. KFILRA(J) (J=1,5). (CHARACTER*60)
C NUMRA - NUMBER OF VALUES IN KFILRA( ) AND RACESS( ).
C KFILD(J) - THE 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) = KFILDI,
C THE DEFAULT INPUT IS INDICATED, DIRNAM(1) IS NOT
C USED, AND THE FILE IS NOT OPENED. KFILD(1) CAN
C EQUAL KFILD(2), IN WHICH CASE THE STATION LIST IS
C TAKEN FROM THE DIRECTORY (I.E., A SEPARATE STATION
C LIST IS NOT PROVIDED).
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 NSTA - THE NUMBER OF STATIONS BEING DEALT WITH. THE
C NUMBER OF VALUES IN CCALL( , ), ETC.
C KGP - THE NUMBER OF STATIONS OR GROUPS TO BE PROCESSED.
C FOR SINGLE STATION EQUATIONS, THIS IS THE NUMBER
C OF STATIONS. MAXIMUM OF ND13.
C KFILFC - UNIT NUMBER FOR WRITING THE FORECAST OUTPUT TO
C SEQUENTIAL FILE. WHEN KFILFC = 0, PACKED
C FORECASTS ARE NOT WRITTEN.
C FORNAM - FILE NAME FOR SEQUENTIAL FILE FOR WRITING
C FORECASTS. (CHARACTER*60)
C KFILX - UNIT NUMBER FOR WRITING FORECAST OUTPUT TO
C MOS-2000 EXTERNAL RANDOM ACCESS FILE. WHEN
C KFILX = 0, PACKED FORECASTS ARE NOT WRITTEN.
C CFILX - FILE NAME FOR MOS-2000 EXTERNAL RANDOM ACCESS
C FILE FOR WRITING FORECASTS. (CHARACTER*60)
C KFILPF - UNIT NUMBER FOR PREDICTAND/FORECAST
C CORRESPONDENCE TABLE. (INPUT)
C PFCORR - DATA SET NAME FOR THE UNIT NUMBER IN KFILPF.
C (CHARACTER*60)
C KFILCP - UNIT NUMBER FOR THE VARIABLE CONSTANT FILE. THIS
C CONTAINS DEFAULT VALUES FOR CERTAIN CONSTANTS FOR
C BASIC VARIABLES SANS THRESHOLDS, ETC. THESE
C INCLUDE PACKING CONSTANTS AND NAMES.
C CONNAM - DATA SET NAME FOR THE UNIT NUMBER IN KFILCP.
C (CHARACTER*60)
C KGP - THE NUMBER OF EQUATIONS BEING PROCESSED.
C MTANDS - THE NUMBER OF PREDICTANDS FOR EACH EQUATION
C FOR THE GROUP BEING PROCESSED. THIS IS
C USED ONLY IN SUBROUTINES, AND MUST BE
C DIMENSIONED FOR TANDID, SO IT IS DIMENSIONED
C MTANDS(1) IN U900.
C NSETS - THE NUMBER OF SETS OF EQUATIONS,
C EACH HAVING A FILE NUMBER AND NAME IN
C KFILIN( ) AND NAMIN( ), RESPECTIVELY.
C EACH SET CAN HAVE A DIFFERENT NUMBER OF
C PREDICTANDS. IF THERE ARE TWO SETS OF
C EQUATIONS, THEY COULD BE ON DIFFERENT UNITS,
C BUT SINCE THE UNITS ARE NOT REWOUND OR CLOSED,
C THE UNITS (AND FILE NAMES) COULD BE THE SAME.
C INITF - 0 WHEN EVERY STATION IN THE LIST IN CCALL( , )
C HAS AN EQUATION AND INITIALIZATION OF
C FCST( , ) DOES NOT HAVE TO BE DONE IN
C FCST90.
C 1 OTHERWISE.
C NTOTBY - THE NUMBER OF BYTES PROCESSED ON THE OUTPUT
C FILE KFILFC.
C NTOTBY - THE NUMBER OF RECORDS PROCESSED ON THE
C OUTPUT FILE KFILFC.
C IS0(J) - MOS-2000 GRIB SECTION 0 ID'S (J=1,4).
C IS1(J) - MOS-2000 GRIB SECTION 1 ID'S (J=1,21+).
C IS2(J) - MOS-2000 GRIB SECTION 2 ID'S (J=1,12).
C IS4(J) - MOS-2000 GRIB SECTION 4 ID'S (J=1,4).
C LITEMS - THE NUMBER OF ITEMS IN LSTORE( , ).
C ISTOP(J) - FOR J=1, ISTOP(1) IS INCREMENTED BY 1 EACH TIME
C AN ERROR OCCURS THAT MAY BE FATAL.
C FOR J=2, ISTOP(2) IS INCREMENTED BY 1 WHENEVER AN
C INPUT DATA RECORD IS NOT FOUND.
C STATE - VARIABLE SET TO STATEMENT NUMBER TO INDICATE
C WHERE AN ERROR OCCURRED. (CHARACTER*4)
C NFETCH - COUNTS THE NUMBER OF TIMES GFETCH HAS BEEN
C ENTERED.
C NSTORE - COUNTS THE NUMBER OF TIMES GSTORE HAS BEEN
C ENTERED.
C LASTL - THE LAST LOCATION IN CORE( ) USED IN THE
C MOS-2000 INTERNAL STORAGE SYSTEM.
C LASTD - TOTAL NUMBER OF PHYSICAL RECORDS ON DISK IN THE
C INTERNAL STORAGE SYSTEM.
C MINPK - MINIMUM GROUP SIZE WHEN PACKING THE INTERPOLATED
C VALUES. SET IN DATA STATEMENT TO 14, THE AGREED
C ON VALUE FOR MOS-2000.
C IALL - 1 INDICATES ALL STATIONS WITH THE EQUATIONS WILL
C BE USED, BECAUSE NO LIST HAS BEEN FURNISHED IN
C CCALL( , ). THIS CAN HAPPEN EITHER BECAUSE
C NO FILE NUMBERS AND NAMES WERE PROVIDED FOR
C KFILD( ) AND DIRNAM ( ) OR BECAUSE NO STATIONS
C WERE IN THE LIST ON THE UNIT KFILD(1).
C = 0 OTHERWISE. (INTERNAL)
C IOS - STATUS VALUE FROM SYSTEM I/O ROUTINES.
C (INTERNAL)
C LSTOP - THE NUMBER OF ERRORS FOR DAY 1 PROCESSING.
C ITIMES - A COUNT OF THE NUMBER OF TIMES RDEQN HAS
C BEEN ENTERED FOR THAT EQUATION FILE.
C IDUM(ND11) - PLACEHOLDER FOR CALLS TO RDSNAM THAT DO NOT
C REQUIRE THE INFORMATION IN MODNUM( ) OR JFOPEN.
C
C
C SUBPROGRAMS CALLED:
C UNIQUE - FCST90, RDSTR9, SETJDT
C LIBRARY:
C MDLLIB90 - IPOPEN, IERX, RDI, RDSNAM, RDSTAD, RDSTAL, IPRINT,
C TIMPR, SKIPWR, TANDID, RDEQN, TRAIL, DATPRO,
C CLFILM
C
C EXIT STATES:
C COND = 0 - SUCCESSFUL RUN
C 20 - ERROR OR END OF FILE ON UNIT KFILEQ OR
C DATES ON EQUATION FILE DO NOT MATCH NDATE
C (FROM RDEQN).
C 21 - LIST TOO LONG FOR DIMENSION ND ON UNIT KFIL.
C (FROM RDI OR RDEQN).
C 106 - NO PREDICTORS FOUND FOR DAY 1.
C 131 - ERROR READING NCEP DATE FILE.
C 166 - NUMBER OF PREDICTANDS = ZERO OR GT ND3.
C (FROM RDEQN).
C 167 - NUMBER OF TERMS IN EQUATION = 0 OR GT ND2.
C (FROM RDEQN).
C 169 - NUMBER OF EQUATIONS GT ND1 OR GT ND13.
C (FROM RDEQN).
C
C REMARKS: NONE
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 90 (XLF90 COMPILER)
C MACHINE: IBM SP
C
C$$$
C
CHARACTER*4 STATE,IPINIT
CHARACTER*8 CCALL(ND1,6),
1 CCALLD(ND5)
CHARACTER*20 NAME(ND1)
CHARACTER*32 PLAIN(ND3)
CHARACTER*60 NAMIN(ND6),EQNNAM(ND11)
CHARACTER*60 DIRNAM(2),CONNAM,DATNAM,FORNAM,PFCORR,RACESS(5),CFILX
CHARACTER*72 RUNID/' '/
C
DIMENSION ICALL(L3264W,ND1,6),ISDATA(ND1),SDATA(ND1),XDATA(ND1)
DIMENSION IPACK(ND5),ICALLD(L3264W,ND5),
1 IWORK(ND5),DATA(ND5)
DIMENSION KFILIN(ND6),MODNUM(ND6),JFOPEN(ND6)
DIMENSION INDEXC(ND1,ND6)
DIMENSION IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7)
DIMENSION IDATE(ND8),NWORK(ND8)
DIMENSION LSTORE(12,ND9)
DIMENSION CORE(ND10),IDUM(ND11)
DIMENSION KFILEQ(ND11),JFOPENEQ(ND11)
DIMENSION NGP(ND13),LGP(ND13),MTRMS(ND13)
DIMENSION ID(7,ND13,ND2),IDPARS(15,ND13,ND2),TRESHL(ND13,ND2),
1 JD(4,ND13,ND2),ITAU(ND13,ND2),IUSED(ND13,ND2)
DIMENSION CONST(ND13,ND3),
1 AVG(ND13,ND3),
2 CORR(ND13,ND3)
DIMENSION COEF(ND13,ND2,ND3)
DIMENSION ISCALD(ND3),ICAT(ND3)
DIMENSION IDTAND(4,ND3),IDTPAR(15,ND3)
DIMENSION IPLAIN(L3264W,4,ND3)
DIMENSION LOCSTA(ND1)
DIMENSION FCST(ND1,ND3)
DIMENSION IP(25),IUSE(25),KFILD(2),ISTOP(2),MTANDS(1),
1 KFILRA(5)
C DO NOT REMOVE MTANDS(1).
C
DATA ISTOP/0,0/
DATA KFIL10/99/
DATA IP/25*0/
DATA NSTORE/0/,
1 NFETCH/0/
DATA LASTL/0/,
1 LASTD/0/
DATA MINPK/21/
DATA LITEMS/0/
DATA IUSE/1,1,1,1,1,0,1,0,1,1,0,1,1,1,1,1,1,1,1,1,1,0,1,0,0/
C CALL W3TAGB('U900',2000,0100,0050,'OSD21')
C
C THE KFILDO OUTPUT HAS BEEN TIME STAMPED IN THE DRIVER.
C NOTE THAT THIS IS ON THE DEFAULT OUTPUT FILE KFILDO.
C IF IP(1) NE 0, KFILDO IS SET TO IP(1) AND IS TIME STAMPED
C BELOW.
C
STATE='105 '
C OPEN(UNIT=KFILDI,FILE='U900.CN',STATUS='OLD',IOSTAT=IOS,ERR=900)
C
C READ AND PROCESS THE PRINT UNIT NUMBERS. FIRST,
C INITIALIZE IP( ) IN CASE NOT ALL 25 VALUES ARE READ.
C
DO 105 J=1,25
IP(J)=0
105 CONTINUE
C
STATE='108 '
READ(KFILDI,108,IOSTAT=IOS,ERR=900,END=109)IPINIT,(IP(J),J=1,25)
108 FORMAT(A4,25I3)
C LESS THAN 25 IP( ) VALUES WILL NOT BE INDICATED AS AN ERROR.
C SOME IP( ) VALUES ARE NOT USED; SEE IUSE( ).
CALL IPOPEN(KFILDO,'U900',IPINIT,IP,IER)
C WHEN IP(1) NE 0, KFILDO HAS BEEN SET TO IP(1).
C A FILE WILL BE OPENED FOR EVERY DIFFERENT VALUE IN IP( ).
C THE FILE NAMES WILL BE 4 CHARACTERS 'U900' THEN 4 CHARACTERS
C FROM IPINIT, THEN 2 CHARACTERS FROM IP(J). IPINIT MIGHT BE
C 'HRG1' INDICATING THE PERSONS INITIALS PLUS A SEQUENCE NUMBER.
IF(IER.NE.0)ISTOP(1)=ISTOP(1)+1
C AN ERROR IN IPOPEN WILL STOP THE PROGRAM AFTER CONTROL INPUT IS
C PROCESSED.
109 WRITE(KFILDO,110)IPINIT
110 FORMAT(/' IPINIT = ',A4)
CALL IPRINT(KFILDO,IP,IUSE)
C
C TIME STAMP ALL ASCII OUTPUT OTHER THAN KFILDO.
C THIS IS NOT DONE IN IPOPEN BECAUSE SOME PROGRAMS
C MIGHT NOT WANT SOME FILE TO BE TIME STAMPED.
C
DO 113 J=1,25
IF(IP(J).EQ.0.OR.IP(J).EQ.KFILDO)GO TO 113
IF(J.EQ.1)GO TO 112
C
DO 111 I=1,J-1
IF(IP(J).EQ.IP(I))GO TO 113
111 CONTINUE
C
112 CALL TIMPR(IP(J),IP(J),'START U900 ')
113 CONTINUE
C
C READ AND PRINT THE RUN IDENTIFICATION.
C
STATE='115 '
READ(KFILDI,115,IOSTAT=IOS,ERR=900,END=116)RUNID
115 FORMAT(A72)
C LESS THAN 72 CHARACTERS WILL NOT BE CONSIDERED AN ERROR.
116 WRITE(KFILDO,117)RUNID
117 FORMAT(/' ',A72)
C
C PRINT TO MAKE SURE USER KNOWS WHAT MACHINE IS BEING USED.
C
WRITE(KFILDO,119)L3264B
119 FORMAT(/' RUNNING ON A',I3,'-BIT MACHINE.')
C
C READ AND PRINT CONTROL INFORMATION.
C
STATE='125 '
READ(KFILDI,125,IOSTAT=IOS,ERR=900,END=1250)
1 KSKIP,KWRITE,NSKIP,JSTOP,INCCYL,NEW,NALPH,LOOKAH,
2 NREPLA,NCHECK,PXMISS
125 FORMAT(10(I10/),F10.0)
GO TO 1255
C INCOMPLETE CONTROL INFORMATION SHOULD BE CONSIDERED AN ERROR.
C HOWEVER, A SHORT RECORD DOES NOT CAUSE AN "END" CONDITION.
1250 WRITE(KFILDO,1251)
1251 FORMAT(/' ****CONTROL INFORMATION NOT COMPLETE.',
1 ' STOP IN U900 AT 1250')
C CALL W3TAGE('U900')
STOP 1250
C
C ACCEPT KSKIP AS YY OR YYYY FOR YEAR. IF IT IS ZERO, NO
C SKIPPING IS DONE.
C
1255 IF(KSKIP.EQ.0)GO TO 126
IF(KSKIP/1000000.GT.1900)GO TO 126
IF(KSKIP/1000000.GT.60)KSKIP=KSKIP+1900000000
IF(KSKIP/1000000.LE.60)KSKIP=KSKIP+2000000000
C
126 WRITE(KFILDO,127)KSKIP,KWRITE,NSKIP,JSTOP,
1 INCCYL,NEW,NALPH,LOOKAH,
2 NREPLA,NCHECK,PXMISS,L3264B
127 FORMAT(/' KSKIP ',I10,' SKIP PAST DATA FOR THIS DATE ON OUTPUT',
X ' FILE'/
1 ' KWRITE',I10,' WILL DIRECTORY RECORD BE WRITTEN?',
X ' 1 = YES, 0 = NO'/
2 ' NSKIP ',I10,' NUMBER OF ERRORS THAT WILL BE',
X ' TOLERATED ON DAY 1 BEFORE STOPPING'/
3 ' JSTOP ',I10,' NUMBER OF ERRORS THAT WILL BE',
X ' TOLERATED ON TOTAL RUN BEFORE STOPPING'/
4 ' INCCYL',I10,' INCREMENT IN HOURS BETWEEN DATE/TIMES'/
5 ' NEW ',I10,' NEW ICAO CALL LETTERS, 1 = YES,',
X ' 0 = NO'/
6 ' NALPH ',I10,' ALPHABETIZE CALL LETTERS ACCORDING',
X ' TO DIRECTORY, 1 = YES, 0 = NO'/
7 ' LOOKAH',I10,' NUMBER OF HOURS TO READ AHEAD TO',
X ' GET OBSERVATIONS FOR PREDICTORS'/
8 ' NREPLA',I10,' REPLACEMENT IN RANDOM ACCESS FILE,',
X ' 0 = NO, 1 = YES, IF FOUND, 2 = YES'/
9 ' NCHECK',I10,' CHECK FOR DUPLICATES RANDOM ACCESS',
X ' FILE, 1 = YES, 0 = NO'/
A ' PXMISS',F10.0,' SECONDARY MISSING VALUE TO INSERT',
X ' FOR 9997'/
B ' L3264B',I10,' INTEGER WORD SIZE OF MACHINE')
C
C READ AND PROCESS UNIT NUMBER AND FILE NAME FOR READING
C DATE LIST. FILE WILL BE OPENED AS 'OLD', UNLESS THE FILE
C IS THE DEFAULT INPUT FILE.
C
CALL RDSNAM(KFILDI,KFILDO,KFILDT,DATNAM,IDUM,IDUM,1,N,
1 'OLD','FORMATTED',IP,IER)
IF(IER.NE.0)ISTOP(1)=ISTOP(1)+1
WRITE(KFILDO,130)KFILDT
130 FORMAT(/,' NCEP DATE FILE UNIT NUMBER..',/,' ',I4)
C
C READ AND PRINT THE DATE TO BE PROCESSED
C
CALL GET_NCEPDATE(KFILDT,IYR,IMO,IDA,IHR,NDATE,IER)
C
IF(IER.NE.0)THEN
WRITE(KFILDO,131)
131 FORMAT(/' ****ERROR: CAN NOT READ NCEP DATE FILE - ',
1 'CATASTROPHIC ERROR IN U900. STOP AT 131.')
C CALL W3TAGE('U900')
STOP 131
ENDIF
NDATES=1
IDATE(1)=NDATE
WRITE(KFILDO,132)NDATES,(IDATE(J),J=1,NDATES)
132 FORMAT(/,' ',I4,' INPUT DATE AS READ',/,(1X,10I12))
C
C READ AND PROCESS UNIT NUMBERS AND FILE NAMES FOR ALL TDLPACK
C INPUT. FILES WILL BE OPENED AS 'OLD'.
C
CALL RDSNAM(KFILDI,KFILDO,KFILIN,NAMIN,MODNUM,JFOPEN,ND6,NUMIN,
1 'OLD','UNFORMATTED',IP,IER)
C ONLY THE FIRST FILE IS OPENED.
IF(IER.NE.0)ISTOP(1)=ISTOP(1)+1
C
IF(NUMIN.EQ.0)THEN
WRITE(KFILDO,141)NUMIN
141 FORMAT(/' ',I2,' MODEL INPUT DATA SETS.')
ELSE
WRITE(KFILDO,142)NUMIN,(KFILIN(M),NAMIN(M),M=1,NUMIN)
142 FORMAT(/' ',I2,' MODEL INPUT DATA SETS, UNITS AND NAMES.'/
1 (' ',I4,2X,A60))
ENDIF
C
C READ AND PROCESS THE UNIT NUMBERS AND FILE NAMES FOR THE
C MOS-2000 EXTERNAL RANDOM ACCESS FILES. FIVE ARE ALLOWED,
C FILES WILL NOT BE OPENED. THIS IS FOR INPUT ONLY, BUT
C THE OUTPUT COULD BE TO THE SAME FILE.
C
CALL RDSNAM(KFILDI,KFILDO,KFILRA,RACESS,IDUM,IDUM,5,NUMRA,
1 'NOT','NOTOPENED',IP,IER)
IF(IER.NE.0)ISTOP(1)=ISTOP(1)+1
C
IF(NUMRA.NE.0)THEN
WRITE(KFILDO,143)NUMRA,(KFILRA(J),RACESS(J),J=1,NUMRA)
143 FORMAT(/' ',I2,' MOS-2000 EXTERNAL RANDOM ACCESS DATA SETS,',
1 ' UNITS, AND NAMES.'/(' ',I4,2X,A60))
ELSE
WRITE(KFILDO,1430)NUMRA
1430 FORMAT(/' ',I2,' MOS-2000 EXTERNAL RANDOM ACCESS DATA SET.')
C THE ABOVE PRINT IS FOR THE EMPTY SET.
ENDIF
C
C CHECK FOR A MOS-2000 EXTERNAL RANDOM ACCESS FILE FOR
C FORECASTS WITH UNIT NUMBER = 49. THIS WILL BE THE
C OUTPUT FILE. SAVE THE FILE NAME IN CFILX. U900
C MUST HAVE AN OUTPUT EXTERNAL RANDOM ACCESS FILE;
C WRITING IS U900'S ONLY PURPOSE.
C
DO 1432 J=1,NUMRA
IF(KFILRA(J).EQ.49)GO TO 1434
1432 CONTINUE
C
WRITE(KFILDO,1433)
1433 FORMAT(/' ****NO UNIT NUMBER = 49 FOR RANDOM ACCESS FORECAST',
1 ' FILE. STOP IN INT910 AT 1433.')
C CALL W3TAGE('U900')
STOP 1433
C
1434 KFILX=49
CFILX=RACESS(J)
C
C READ AND PROCESS UNIT NUMBER AND SEQUENTIAL FILE NAME FOR WRITING
C FORECAST OUTPUT. FILE WILL BE OPENED AS 'NEW'.
C
CALL RDSNAM(KFILDI,KFILDO,KFILFC,FORNAM,IDUM,IDUM,1,N,
1 'NEW','UNFORMATTED',IP,IER)
IF(IER.NE.0)ISTOP(1)=ISTOP(1)+1
C
IF(KFILFC.NE.0)THEN
WRITE(KFILDO,144)KFILFC,FORNAM
144 FORMAT(/' SEQUENTIAL FORECASTS OUTPUT, UNIT AND NAME.'/
1 (' ',I4,2X,A60))
ELSE
WRITE(KFILDO,145)
145 FORMAT(/' NO SEQUENTIAL OUTPUT DATA SET PROVIDED;',
1 ' PACKED FORECASTS WILL NOT BE WRITTEN.')
FORNAM=' '
ENDIF
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 DIRECTORY
C SUPPLIED BY A USER.
C
CALL RDSNAM(KFILDI,KFILDO,KFILD,DIRNAM,IDUM,IDUM,2,N,
1 'OLD','FORMATTED',IP,IER)
IF(IER.NE.0)ISTOP(1)=ISTOP(1)+1
C
IALL=0
IF(N.EQ.0)THEN
IALL=1
GO TO 148
ENDIF
C
WRITE(KFILDO,147)(KFILD(J),DIRNAM(J),J=1,2)
147 FORMAT(/' STATION LIST AND DIRECTORY DATA SETS, UNITS AND NAMES.'/
1 (' ',I4,2X,A60))
C
C READ STATION LIST AND OTHER STATION INFORMATION. THE STATION
C LIST CAN COME FROM THE DIRECTORY OR BE SEPARATE. IF SEPARATE,
C IT CAN BE ON THE DEFAULT INPUT FILE KFILDI, OR BE ON A SEPARATE
C FILE AS DETERMINED BY KFILD(1). FORECASTS WILL BE MADE FOR ONLY
C THE STATIONS IN THIS LIST. THERE ARE STATION LIST(S) WITH THE
C EQUATIONS. WHEN THIS SET IS EMPTY, FORECASTS WILL BE MADE FOR
C ALL THE STATIONS ON THE EQUATION FILE. OTHERWISE, THE LISTS
C WITH THE EQUATIONS WILL DETERMINE, AS USUAL, WHICH EQUATIONS
C GO WITH WHICH STATIONS, BUT THE LIST HERE WILL DETERMINE WHAT
C FORECASTS TO MAKE. THE STATION LIST CAN BE USED AS READ,
C OR BE ORDERED ACCORDING TO THE STATION DIRECTORY, WHICH IS
C ALPHABETICAL BY ICAO CALL LETTERS.
C
IF(NALPH.EQ.0)THEN
CALL RDSTAL(KFILDO,IP(4),IP(5),KFILD,NEW,CCALL,
1 NAME,IPACK,IWORK,SDATA,XDATA,DATA,ISDATA,
2 ND1,NSTA,IER)
ELSE IF(NALPH.EQ.2)THEN ! TO BYPASS STATION CHECKS
CALL RDSTAL2(KFILDO,IP(4),IP(5),KFILD,NEW,CCALL,
1 NAME,IPACK,IWORK,SDATA,XDATA,DATA,ISDATA,
2 ND1,NSTA,IER)
ELSE
CALL RDSTAD(KFILDO,IP(4),IP(5),KFILD,NEW,CCALL,CCALLD,
1 NAME,IPACK,IWORK,SDATA,XDATA,DATA,ISDATA,
2 ND1,NSTA,IER)
ENDIF
C
IF(IER.NE.0)ISTOP(1)=ISTOP(1)+1
IF(NSTA.EQ.0)IALL=1
C IALL = 1 INDICATES ALL STATIONS WITH THE EQUATIONS WILL
C BE USED, BECAUSE NO LIST HAS BEEN FURNISHED IN CCALL( , ).
C NOTE THAT THIS CAN HAPPEN EITHER BECAUSE NO FILE
C NUMBERS AND NAMES WERE PROVIDED FOR KFILD( ) AND DIRNAM ( )
C ABOVE OR BECAUSE NO STATIONS WERE IN THE LIST ON THE UNIT
C KFILD(1).
148 IF(KFILD(1).NE.KFILDI)CLOSE(UNIT=KFILD(1))
CLOSE(UNIT=KFILD(2))
C THE FILES ARE CLOSED WHEN THEY ARE NOT THE SAME AS
C THE DEFAULT INPUT FILE. THE DIRECTORY IS NEVER THE DEFAULT.
C
IF(IALL.EQ.0)THEN
D WRITE(KFILDO,1505)(J,CCALL(J,1),NAME(J),J=1,NSTA)
D1505 FORMAT(/' FULL LIST OF STATIONS'//(1XI4,3XA8,1XA20))
C THE LIST COULD HAVE BEEN PRINTED IN RDSTAL OR RDSTAD
C UNDER CONTROL OF IP(4) AND IP(5).
ELSE
WRITE(KFILDO,1506)
1506 FORMAT(' NO STATION LIST AVAILABLE.'/
1 ' FORECASTS WILL BE MADE FOR ALL STATIONS',
2 ' WITH THE EQUATIONS.')
ENDIF
C
C READ AND PROCESS UNIT NUMBERS AND FILE NAMES FOR READING
C EQUATIONS. EACH EQUATION SET WILL HAVE A FILE NUMBER
C AND NAME. FILES WILL BE OPENED AS 'OLD'.
C
CALL RDSNAM(KFILDI,KFILDO,KFILEQ,EQNNAM,IDUM,JFOPENEQ,ND11,
1 NSETS,'OLD','FORMATTED',IP,IER)
IF(IER.NE.0)ISTOP(1)=ISTOP(1)+1
IF(NSETS.NE.0)THEN
WRITE(KFILDO,152)(KFILEQ(J),EQNNAM(J),J=1,NSETS)
152 FORMAT(/' EQUATIONS TO READ, UNITS AND NAMES.'/
1 (' ',I4,2X,A60))
ELSE
WRITE(KFILDO,153)
153 FORMAT(/' NO EQUATION FILES INDICATED. FATAL ERROR')
ISTOP(1)=ISTOP(1)+1
C NO SKIPPING HAS BEEN DONE AND NOTHING HAS
C BEEN WRITTEN, SO DON'T WRITE TRAILER.
GO TO 805
ENDIF
C
C READ AND PROCESS UNIT NUMBER AND FILE NAME FOR
C PREDICTAND/FORECAST CORRESPONDENCE TABLE.
C
CALL RDSNAM(KFILDI,KFILDO,KFILPF,PFCORR,IDUM,IDUM,1,N,
1 'OLD','FORMATTED',IP,IER)
IF(IER.NE.0)ISTOP(1)=ISTOP(1)+1
C
IF(KFILPF.NE.0)THEN
WRITE(KFILDO,155)KFILPF,PFCORR
155 FORMAT(/' PREDICTAND/FORECAST CORRESPONDENCE TABLE,',
1 ' UNIT AND NAME.'/(' ',I4,2X,A60))
ELSE
WRITE(KFILDO,156)
156 FORMAT(/' NO PREDICTAND/FORECAST CORRESPONDENCE',
1 ' FILE PROVIDED. IDS WITH EQUATIONS WILL',
2 ' BE USED.')
ENDIF
C
C READ AND PROCESS UNIT NUMBER FOR THE PREDICTOR
C CONSTANTS DIRECTORY.
C
CALL RDSNAM(KFILDI,KFILDO,KFILCP,CONNAM,IDUM,IDUM,1,N,
1 'OLD','FORMATTED',IP,IER)
IF(IER.NE.0)ISTOP(1)=ISTOP(1)+1
IF(KFILCP.NE.0)WRITE(KFILDO,157)KFILCP,CONNAM
157 FORMAT(/' VARIABLE CONSTANT DIRECTORY, UNIT AND NAME.'/
1 (' ',I4,2X,A60))
C
C CHECK OUTPUT FILE UNIT NUMBER KFILX WITH KFILFC
C TO MAKE SURE RANDOM ACCESS IS NOT CONTAMINATED.
C
IF(KFILFC.NE.0.AND.KFILFC.EQ.KFILX)THEN
WRITE(KFILDO,1573)KFILX,KFILFC
1573 FORMAT(/' ****KFILX = KFILFC. KFILFC IS SET = 0')
KFILFC=0
ISTOP(1)=ISTOP(1)+1
ENDIF
C
C SKIP RECORDS ON THE OUTPUT FILE WHEN KSKIP NE 0.
C THE STATION LIST IN CCALL( , ) IS CHECKED WITH THE STATION
C LIST AS THE FIRST RECORD IN THE FILE. IF THEY DO NOT
C MATCH, THE PROGRAM HALTS FOR SAFETY WHEN KWRITE = 0,
C AND WRITE THE NEW STATION LIST WHEN KWRITE = 1.
C WHEN RECORDS ARE NOT SKIPPED, THE CALL LETTERS
C RECORD IS WRITTEN. WHEN KFILFC = 0, SKIPWR DOES NOTHING.
C
KCHECK=1
CALL SKIPWR(KFILDO,KFILFC,KSKIP,KWRITE,KCHECK,
1 CCALL,ND1,NSTA,
2 CCALLD,ND1,IPACK,ND5,
3 NTOTBY,NTOTRC,L3264B,L3264W,IER)
C
IF(IER.NE.0)THEN
WRITE(KFILDO,1575)
1575 FORMAT(/' ****PROGRAM STOP AT 1575 BECAUSE OF ERROR IN',
1 ' ROUTINE SKIPWR. OTHERWISE, GOOD DATA MIGHT',
2 ' BE OVERWRITTEN.')
C CALL W3TAGE('U900')
STOP 1575
C STOP THE PROGRAM FOR SAFETY. OTHERWISE, GOOD DATA MIGHT
C BE OVERWRITTEN.
ENDIF
C
C READ ALL DATA FOR DAY 1 AND STORE IN MOS-2000
C INTERNAL STORAGE SYSTEM. PROJECTIONS ON OBSERVATIONS
C AS PREDICTORS MUST BE ADDED TO IDATE( ) TO "LOOKAHEAD."
C SINCE THE EQUATIONS ARE READ AND EVALUATED ONE
C SET AT A TIME, IT CANNOT BE COMPUTED HOW FAR AHEAD
C TO READ (AS IT CAN BE IN U700). THIS IS IN U900
C AS AN INPUT VARIABLE LOOKAD.
C
C NORMALLY THE LOOP BELOW WILL BE EXECUTED ONLY ONCE.
C HOWEVER, THE INPUT IS SEQUENTIAL AND MORE THAN ONE
C DATE COULD BE USED. ALL INPUT MUST BE FROM THE
C SEQUENTIAL FILE(S).
C
DO 400 ND=1,NDATES
C
CALL RDSTR9(KFILDO,KFIL10,KFILIN,NAMIN,JFOPEN,NUMIN,
1 IDATE(ND),LOOKAH,CCALLD,IPACK,IWORK,DATA,ND5,
2 IS0,IS1,IS2,IS4,ND7,
3 LSTORE,LITEMS,ND9,NBLOCK,CORE,ND10,
4 LASTL,LASTD,NSTORE,IP(10),
5 CCALL,INDEXC,XDATA,ND1,NSTA,PXMISS,
6 IP(12),IP(23),L3264B,L3264W,ISTOP(1),IER)
C
IF(IER.NE.0.AND.IER.NE.146)THEN
C IER = 146 WHEN AN END OF FILE REACHED WHEN
C ATTEMPTING TO READ A DIRECTORY. THIS WOULD
C OCCUR WHEN THE DAY BEING PROCESSED IS THE
C LAST DAY ON THE DATA SET.
WRITE(KFILDO,1577)
1577 FORMAT(' ****FATAL ERROR, STOP IN U900 AT 1577')
C CALL W3TAGE('U900')
STOP 1577
ENDIF
C
C READ THE EQUATIONS AND MAKE FORECASTS A SET AT A TIME.
C THE NUMBER OF SETS IS THE NUMBER OF FILE NAMES READ
C INTO EQNNAM( ). MORE THAN ONE SET CAN BE ON A FILE,
C AS IT IS NOT REWOUND. THIS IMPOSES SOME RESTRICTIONS
C ON THE ORDER OF EQUATIONS, ETC. FOR INSTANCE, IF
C KFILEQ(3) = 30, THEN THE THIRD SET OF EQUATIONS
C WILL BE READ FROM UNIT 30 (IF IT EXISTS, AND HAS NOT
C ALL BEEN READ), STARTING FROM WHERE IT IS POSITIONED.
C CONTROL AS TO THE EQUATIONS EVALUATED IS NOT BY
C PREDICTAND NAME, BUT BY FILE NAME.
C
DO 300 NSET=1,NSETS
C
ITIMES=0
C
C 6/2000 - CHANGED TO CONTINUE READING THE EQUATION FILE
C TILL AN END OF FILE IS REACHED. ITIMES KEEPS TRACK OF
C HOW MANY TIMES YOU HAVE ENTERED AN EQUATION FILE. IF
C YOU REACH AN END OF FILE ON AN EQUATION FILE, AND ITIMES
C IS NON-ZERO, THAT'S OKAY, YOU'VE JUST REACHED THE END OF
C THAT FILE. IF YOU REACH THE END OF THE FILE AND ITIMES
C IS 0, THIS IS A TRUE ERROR. INITIALIZE ITIMES TO ZERO
C FOR EACH NEW EQUATION FILE.
C
C SKIP TO NEXT FILE IF THE PREVIOUS READ INDICATED
C INCORRECT DATES. ONCE THE BEGINNING AND ENDING
C DATES ON THE EQUATION FILE DO NOT MATCH, THE FILE
C WILL NOT BE POSITIONED PROPERLY TO READ ANOTHER
C SET.
C
IF(NSET.GT.1)THEN
C
IF(IER.EQ.20)THEN
IF(KFILEQ(NSET).EQ.KFILEQ(NSET-1))GO TO 300
ENDIF
C
ENDIF
C
1580 CALL RDEQN9(KFILDO,KFILEQ(NSET),EQNNAM(NSET),IDATE(ND),
1 IP(4),IP(13),IP(14),IP(15),IP(19),IP(20),IP(21),
2 CCALL,ISDATA,NSTA,IALL,INITF,CCALLD,
3 KGP,NGP,LGP,
4 MTRMS,MTANDS,
5 ID,IDTAND,
6 LOCSTA,CONST,
7 AVG,CORR,
8 COEF,
9 ND1,ND2,ND3,ND5,ND13,IER)
IF(IER.NE.0)ISTOP(1)=ISTOP(1)+1
C
IF(IER.NE.0.AND.IER.NE.171)THEN
C IER = 171 JUST MEANS ONE OR MORE STATIONS HAS NO
C EQUATION.
C
IF((IER.EQ.168).AND.(ITIMES.GT.0))THEN
C THIS MEANS THAT YOU'VE BEEN READING THIS FILE
C IN PREVIOUS CALLS TO RDEQN, BUT NOW YOU'VE REACHED THE
C END OF THE FILE. MOVE ON TO THE NEXT EQUATION FILE.
C RESET ISTOP, BECAUSE THIS ISN'T AN ERROR WE WANT TO COUNT.
WRITE(KFILDO,1581)KFILEQ(NSET),EQNNAM(NSET)
1581 FORMAT(' IF THE IBM IOSTAT ERROR ABOVE IS -1, THIS MEANS ',
1 ' AN END OF THE FILE WAS',/,' REACHED ON UNIT NO:',
2 I3,1X,'FILE = ',A45,/' THIS IS PROBABLY NOT AN ERROR.')
ISTOP(1)=ISTOP(1)-1
GO TO 300
ELSEIF(IER.EQ.168)THEN
C THIS MEANS THAT THE EQUATION FILE WAS EMPTY. ALERT THE
C USER TO CHECK THIS OUT, BUT DON'T STOP THE PROGRAM.
WRITE(KFILDO,1582)KFILEQ(NSET),EQNNAM(NSET)
1582 FORMAT(' ****THE EQUATION FILE ON UNIT NO:',I3,' ',1X,
& 'FILE = ',A45,' DID NOT EXIST OR WAS ',
1 'EMPTY. THE USER SHOULD INVESTIGATE, BUT U900 '/,
2 ' WILL NOT STOP.')
GO TO 300
ELSEIF(IER.EQ.21)THEN
WRITE(KFILDO,158)
158 FORMAT(/' STOP IN U900 AT 158;',
1 ' INCREASE ND1 AND/OR ND5.')
C CALL W3TAGE('U900')
STOP 158
ELSEIF(IER.EQ.169)THEN
WRITE(KFILDO,159)
159 FORMAT(/' STOP IN U900 AT 159;',
1 ' INCREASE ND1 AND/OR ND13.')
C CALL W3TAGE('U900')
STOP 159
ELSEIF(IER.EQ.166)THEN
WRITE(KFILDO,160)
160 FORMAT(/' STOP IN U900 AT 160; PROVIDE PREDICTANDS',
1 ' OR INCREASE ND3')
C CALL W3TAGE('U900')
STOP 160
ELSEIF(IER.EQ.167)THEN
WRITE(KFILDO,161)
161 FORMAT(/' STOP IN U900 AT 161; PROVIDE EQUATIONS',
1 ' OR INCREASE ND2')
C CALL W3TAGE('U900')
STOP 161
ELSEIF(IER.EQ.20)THEN
C THIS IS AN END OF FILE, ERROR, OR DATES OF
C EQUATIONS DON'T MATCH IDATE( ).
GO TO 300
ELSE
WRITE(KFILDO,162)IER
162 FORMAT(/' STOP IN U900 AT 162, IER =',I5,'.')
C CALL W3TAGE('U900')
STOP 162
ENDIF
C
ENDIF
C
C ANY TIME YOU SUCCESSFULLY COME OUT OF RDEQN, INCREMENT
C ITIMES AS TO SAY THAT YOU'VE ALREADY BEEN READING THIS FILE
C
ITIMES=ITIMES+1
C
C PUT PLAIN LANGUAGE AND SCALING PARAMETER FOR PACKING
C WITH THE PREDICTANDS.
C
C WRITE(KFILDO,164)ND3,ND11,NSETS,MTANDS(1)
C164 FORMAT(/' IN U900 AT 164--ND3,ND11,NSETS,MTANDS(1)',4I6)
CALL TANDID(KFILDO,KFILCP,KFILPF,PFCORR,IP(7),IP(9),IDTAND,
1 IDTPAR,ISCALD,PLAIN,ICAT,MTANDS,1,ND3,1,
2 ISTOP(1),IER)
C NOTE THAT NSETS AND ND11 IN TANDID MUST BE PASSED AS 1
C FROM U900.
C
C SET JD( , , ), THRESH( , ), AND ITAU( , ) TO AGREE
C WITH ID( , , ) FOR U900.
C
CALL SETJDT(KFILDO,ID,IDPARS,TRESHL,JD,ITAU,KGP,MTRMS,
1 ND2,ND13,IER)
C
C MAKE FORECASTS.
C
CALL FCST90(KFILDO,KFIL10,IP(12),KFILFC,KFILX,CFILX,
1 KFILRA,RACESS,NUMRA,
2 IDATE(ND),ICALL,CCALL,ISDATA,XDATA,ND1,NSTA,
3 ICALLD,CCALLD,IPACK,IWORK,DATA,ND5,
4 LSTORE,ND9,LITEMS,CORE,ND10,
5 NBLOCK,NSTORE,NFETCH,
6 IS0,IS1,IS2,IS4,ND7,
7 KGP,NGP,LGP,MTRMS,MTANDS,ICAT,
8 ID,IDPARS,TRESHL,JD,ITAU,IUSED,
9 CONST,AVG,CORR,COEF,ND2,ND3,
A IDTAND,IDTPAR,LOCSTA,ND13,
B FCST,INITF,
C IPLAIN,PLAIN,ISCALD,MINPK,NREPLA,NCHECK,
D IP(16),IP(17),IP(18),NTOTBY,NTOTRC,
E L3264B,L3264W,ISTOP,IER)
C
IF(IER.EQ.106)THEN
WRITE(KFILDO,170)
170 FORMAT(/' ****NO PREDICTORS FOUND FOR DAY 1.',
1 ' STOP IN U900 AT 2010.')
C CALL W3TAGE('U900')
STOP 170
ENDIF
C
C NOW RETURN TO RDEQN AND TRY TO CONTINUE READING THE
C CURRENT EQUATION FILE.
C
GO TO 1580
300 CONTINUE
C
C EMPTY LSTORE( , ) AND PREPARE FOR NEXT DATE/TIME.
C
DO 310 L=1,LITEMS
LSTORE(1,L)=0
310 CONTINUE
C
LITEMS=0
LASTL=0
LASTD=0
C
C REWIND EQUATION FILES.
C
DO 320 NSET=1,NSETS
REWIND KFILEQ(NSET)
320 CONTINUE
C
400 CONTINUE
C
C WRITE TRAILER RECORD AND EOF UNLESS KFILFC = 0. IF THERE
C IS AN ERROR, TRAIL WILL PRODUCE A DIAGNOSTIC.
C
IF(KFILFC.NE.0)THEN
CALL TRAIL(KFILDO,KFILFC,L3264B,L3264W,NTOTBY,NTOTRC,IER)
ENDFILE KFILFC
ENDIF
C
C CLOSE RANDOM ACCESS FILE.
C
CALL CLFILM(KFILDO,KFILX,IER)
C
C CLOSE UP SHOP.
C
805 WRITE(KFILDO,806)NSTORE
806 FORMAT(/' THE MOS-2000 INTERNAL FILE HAS BEEN ACCESSED BY',
1 ' GSTORE',I11,' TIMES.')
WRITE(KFILDO,807)NFETCH
807 FORMAT(' THE MOS-2000 INTERNAL FILE HAS BEEN ACCESSED BY',
1 ' GFETCH',I11,' TIMES.')
IF(KFILFC.EQ.0)GO TO 8079
WRITE(KFILDO,8075)NTOTBY,NTOTRC,FORNAM
8075 FORMAT(/' A TOTAL OF ',I11,' BYTES IN ',I7,' RECORDS NOW',
1 ' EXIST ON FILE ',A60)
8079 IF(ISTOP(1).NE.0)WRITE(KFILDO,808)ISTOP(1)
808 FORMAT(/' AT LEAST ISTOP(1) =',I6,
1 ' ERRORS HAVE OCCURRED ON THIS RUN.')
IF(ISTOP(2).NE.0.AND.ISTOP(1).EQ.0)WRITE(KFILDO,809)ISTOP(2)
809 FORMAT(/' AT LEAST ISTOP(2) =',I6,
1 ' DATA RECORDS NOT FOUND ON THIS RUN.')
IF(ISTOP(2).NE.0.AND.ISTOP(1).NE.0)WRITE(KFILDO,8090)ISTOP(2)
8090 FORMAT(' AT LEAST ISTOP(2) =',I6,
1 ' DATA RECORDS NOT FOUND ON THIS RUN.')
IF(ISTOP(1).EQ.0.AND.ISTOP(2).EQ.0)WRITE(KFILDO,810)
810 FORMAT(/' NO ERRORS HAVE BEEN DETECTED ON THIS RUN.')
WRITE(KFILDO,811)
811 FORMAT(' ')
RETURN
C
C ERROR STOP BELOW IS FOR ERRORS OF CONTROL INFORMATION INPUT.
900 CALL IERX(KFILDO,KFILDO,IOS,'U900 ',STATE)
C CALL W3TAGE('U900')
STOP 9999
END