SUBROUTINE U910(KFILDI,KFILDO,ICALL,CCALL, 1 ISDATA,SDATA,NGP,XDATA,MWORK,NAME,ND1,ND2, 2 ID,IDPARS,TRESHL,TRESHU,JD,JP, 3 ITAU,IWDTH,WDTH,IPREC,PREC,CFMT,NCAT, 4 ISCALD,PRINT,HEAD,IPLAIN,PLAIN,L3264B,L3264W,ND4, 5 AA,ICALLD,CCALLD,IPACK,DATA,IWORK,ND5, 6 IS0,IS1,IS2,IS4,ND7, 7 IDATE,NWORK,ND8, 8 LSTORE,ND9, 9 CORE,ND10,NBLOCK) C$$$ SUBPROGRAM DOCUMENTATION BLOCK *** C C SUBPROGRAM: U910 C PRGMMR: GLAHN ORG: W/OSD211 DATE: 98-07-01 C C ABSTRACT: PROGRAM U910 IS USED TO READ DATA FROM A MOS-2000 C EXTERNAL RANDOM ACCESS FILE, PERFORM COMPUTATIONS, AND C WRITE THE RESULTS BACK TO THAT SAME FILE, AS WELL C AS TO A SEQUENTIAL. DATA CAN BE PRINTED. THE PRINTING C FORMAT IS GOVERNED BY USER INPUT; THE WRITING PRECISION C IS THE SAME AS INPUT. 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 C DRU910 IS COMPILED WITH THE PARAMETER STATEMENT: C PARAMETER (L3264B=32) FOR THE 32-BIT MACHINE AND C PARAMETER (L3264B=64) FOR THE 64-BIT MACHINE. C C PROGRAM HISTORY LOG: C 00-05-04 GLAHN C 00-05-15 ERICKSON ADDED NCEP DOCBLOCK. C 00-07-03 MCE/JPD/DR ADDED AA TO CALL OF U910; C CHANGED CK ON NPRINT (AROUND 200); C ADDED LOGIC TO WRITE PROBABILITY C FORECASTS FOR MULTIPLE CATEGORIES C TO THE RANDOM ACCESS FILE. C 12-09-24 ENGLE ADDED CALL TO WRTDLMC TO WRITE STATION C CALL LETTERS TO RANDOMA ACCESS FILE. C 12-11-06 GHIRARDELLI MERGED IN SMALL DIFFERENCES FROM LAMP C VERSION. C 16-12-XX SCHNAPP CHANGED MINPK FROM 14 to 21 C 18-07-08 SCHNAPP INCREASED MINPK TO 46 C C USAGE: CALL U910(KFILDI,KFILDO,ICALL,CCALL,ISDATA,SDATA,NGP, C XDATA,MWORK,NAME,ND1,ND2,ID,IDPARS,TRESHL, C TRESHU,JD,JP,ITAU,IWDTH,WDTH,IPREC,PREC,CFMT, C NCAT,ISCALD,PRINT,HEAD,IPLAIN,PLAIN,L3264B,L3264W, C ND4,ICALLD,CCALLD,IPACK,DATA,IWORK,ND5,IS0,IS1, C IS2,IS4,ND7,IDATE,NWORK,ND8,LSTORE,ND9,CORE, C ND10,NBLOCK) C INPUT ARGUMENT LIST: C KFILDI - UNIT NUMBER TO READ INPUT FILE 'U910.CN'. C SET BY DATA STATEMENT TO 5 IN DRU910. C KFILDO - UNIT NUMBER OF OUTPUT (PRINT) FILE. THIS IS SET C BY DATA STATEMENT TO 12 IN DRU910. 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 ICALL(L,K,J) - CALL LETTERS, EQUIVALENCED TO CCALL( , ) C (L=1,2) (K=1,ND1) (J=1,6). 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,NSTA). C SDATA(K) - WORK ARRAY (K=1,NSTA). USED AS STALAT( ) IN INT910. C NGP(J) - THE NUMBER OF STATIONS IN EACH GROUP (J=1,KGP). C XDATA(K,L) - THE ARRAY USED TO HOLD DATA FOR OUTPUT (K=1,NSTA) C (L=1,ND2). USED AS STALON( ) IN INT910. C MWORK(J) - WORK ARRAY (J=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 STORAGE SPACE IS HIGHLY DEPENDENT ON ND1. C ND2 - MAXIMUM NUMBER OF VARIABLES TO BE DEALT WITH C IN A SERIES. THIS IS MAINLY FOR A GROUP OF C PROBABILITY FORECASTS. C ID(J,N) - THE INTEGER VARIABLE ID'S (J=1,4) (N=1,NVRBL). C IDPARS(J,N) - THE PARSED, INDIVIDUAL COMPONENTS OF THE VARIABLE C ID'S CORRESPONDING TO ID( ,N) (J=1,15), (N=1,NVRBL). C (OUTPUT) 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 THRESHOLD C TRESHL = 1, C 2 = CUMULATIVE FROM BELOW, VALUES LT UPPER THRESHOLD C TRESHU = 1. C 3 = DISCRETE BINARY. VALUES GE LOWER THRESHOLD AND C LT UPPER THRESHOLD = 1. C 5 = GRID BINARY. VALUES GE LOWER THRESHOLD C ONLY THE VALUE OF 0, 1, OR 5 SHOULD BE USED FOR C 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 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 TRESHL(N) - THE LOWER BINARY THRESHOLD CORRESPONDING TO IDPARS( ,N) C (N=1,ND4). C TRESHU(N) - THE UPPER BINARY THRESHOLD CORRESPONDING TO IDPARS( ,N) C (N=1,ND4). C JD(J,N) - THE BASIC INTEGER VARIABLE ID'S (J=1,4) (N=1,ND4). C THIS IS THE SAME AS ID(J,N), EXCEPT THAT THE FOLLOWING C PORTIONS ARE OMITTED: C B = IDPARS(3, ), C G = IDPARS(15, ), AND C TRESHL( ). C JD( , ) IS USED TO IDENTIFY WHICH CALCULATIONS C CAN BE MADE DIRECTLY IN U910, WHICH IS ONLY FORMING C BINARIES. THE "G" VARIABLE HAS NO MEANING IN U910, C IT BEING ONLY FOR POSSIBLE USE IN U201. C JP(J,N) - CONTROLS THE OUTPUT BY VARIABLE (N=1,ND4). C J=1--INDICATES WHETHER (>0) OR NOT (=0) VARIABLE N C WILL BE WRITTEN TO THE BINARY OUTPUT FILE C WHEN KFILIO NE 0; C J=2--INDICATES WHETHER (>0) OR NOT (=0) VARIABLE N C WILL BE WRITTEN TO UNIT IP(16) WITH THE FORMAT C PROVIDED WITH THE VARIABLE; AND C J=3--INDICATES WHETHER (>0) OR NOT (=0) VARIABLE N C WILL BE WRITTEN TO UNIT IP(15) NOT UNDER C CONTROL OF THE FORMAT PROVIDED BUT TO THE C RESOLUTION PACKED. C ITAU(N) - THE NUMBER OF HOURS TO ADD TO NDATE TO GET C THE VARIABLE N (N=1,ND4). THIS IS THE C "LOOKAHEAD" FEATURE. C IWDTH(N) - WIDTH OF FIELD FOR PRINTING (N=1,ND4). C WDTH(N) - WIDTH OF FIELD FOR PRINTING (N=1,ND4). COMPUTED C AND USED ONLY IN PRU660. (CHARACTER*2) C IPREC(N) - PRECISION FOR PRINTING (N=1,ND4). THIS IS THE C NUMBER OF PLACES AFTER THE DECIMAL POINT. C PREC(N) - CHARACTER REPRESENTATION OF IPREC(J) (N=1,ND4). C COMPUTED AND USED ONLY IN PRU660. (CHARACTER*1) C CFMT(N) - FORMAT FOR PRINTING, EITHER I OR F (N=1,ND4). C NCAT(N) - A CATEGORY NUMBER FOR EACH VARIABLE (N=1,ND4). C 0 = THIS VARIABLE IS IN A SERIES, NOT THE FIRST. C M = THIS VARIABLE IS THE FIRST OF A SERIES OF C M VARIABLES. C ISCALD(N) - THE DECIMAL SCALING CONSTANT TO USE WHEN PACKING THE C COLLATED DATA (N=1,ND4). ISCALD COMES FROM THE C VARIABLE CONSTANT FILE, MODIFIED TO BE 2 FOR GRID C BINARIES, AND 0 FOR BINARIES. ZERO WHEN NOT FOUND C IN THE FILE. NO BINARY SCALING IS PROVIDED FOR. C PRINT(N) - FURNISHED TO PRU660 FOR PRINTING (N=1,ND4). C HEAD(J,N) - HEADING FOR COLUMNS WHEN PRINTING DATA (J=1,30) C (N=1,ND4). (CHARACTER*1) C AA(L,K) = THE ARRAY TO HOLD DATA FOR PRINTING WITH PRU660 C (L=1,ND2) (K=1,NSTA) C IPLAIN(L,J,N) - 32 CHARACTERS (L=1,L3264W) (J=1,4) OF PLAIN C LANGUAGE DESCRIPTION OF VARIABLES (N=1,ND4). C NOTE THAT THIS REQUIRES TWO 32-BIT WORDS TO HOLD C THE DESCRIPTION BUT ONLY ONE 64-BIT WORD. C EQUIVALENCED TO PLAIN( ). C PLAIN(N) - THE PLAIN LANGUAGE DESCRIPTION OF THE VARIABLES C (N=1,ND4). EQUIVALENCED TO IPLAIN( , , ). C (CHARACTER*32) C L3264B - INTEGER WORD LENGTH IN BITS OF MACHINE BEING USED C (EITHER 32 OR 64). SET BY PARAMETER IN DRU910. C L3264W - NUMBER OF WORDS IN 64 BITS (EITHER 1 OR 2). C CALCULATED BY PARAMETER, BASED ON L3464B. C ND4 - MAXIMUM NUMBER OF VARIABLES THAT CAN BE DEALT WITH C IN ONE RUN. 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). THIS LIST IS C USED IN RDSTAD TO RETAIN THE ORIGINAL LIST IN C CCALL( , ). C IPACK(J) - PACKED DATA READ FROM THE INPUT FILE(S) C (J=1,ND5). C DATA(J) - WORK ARRAY (J=1,ND5). C IWORK(J) - WORK ARRAY (J=1,ND5). USED AS IWBAN( ) IN C INT910. C ND5 - THE MAXIMUM NUMBER OF STATION CALL LETTERS ON C THE INPUT FILES. DIMENSION OF IWORK( ), C DATA( ), AND IPACK( ) AND SECOND DIMENSION OF C ICALLD( , ). C MUST BE GE THE LARGEST RECORD ON THE INPUT C VECTOR FILE(S). MUST ALSO BE GE ND1. C IT IS A SEPARATE DIMENSION FROM ND1, SO THAT C ONLY THOSE ARRAYS REQUIRING INPUT FROM INPUT C FILES ARE THIS LARGE. 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 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. 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 CORE(J) - SPACE ALLOCATED FOR SAVING PACKED DATA C (J=1,ND10). WHEN THIS SPACE IS EXHAUSTED, C SCRATCH DISK WILL BE 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 STORAGE. C SINCE MUCH, IF NOT ALL, INTERNAL STORAGE WILL BE OF C PACKED DATA, THE NUMBER OF BYTES WILL BE THE SAME FOR C EITHER A 32- OR 64-BIT MACHINE. THEREFORE, THE BLOCK C SIZE IS SET BY PARAMETER TO VARY WITH L3264B. IN THE C PARAMETER STATEMENT, THE 6400 IS ARBITRARY, AND CAN BE C CHANGED. PERFORMANCE SHOULD NOT BE HIGHLY DEPENDENT C ON THIS. HOWEVER, IF TOO LARGE, SPACE WILL BE WASTED, C AND IF TOO SMALL MANY RECORDS WILL BE NECESSARY TO C HOLD EACH RECORD. THE 6400 ACCOMMODATES 800 BYTES C ON EITHER A 32- OR 64-BIT MACHINE. SET BY PARAMETER C IN DRU910. 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 DRU910. (INPUT) C FORT.KFIL10 - UNIT NUMBER OF TDL MOS-2000 INTERNAL FILE C SYSTEM ACCESS. SET BY DATA STATEMENT. C (INPUT-OUTPUT) C FORT.KFILD(J) - UNIT NUMBERS FOR WHERE THE STATION LIST (J=1) C AND THE STATION DIRECTORY (J=2) RESIDES. C (INPUT) C FORT.KFILDT - UNIT NUMBER FOR READING THE DATE LIST. C (INPUT) C FORT.KFILP - UNIT NUMBER FOR READING THE VARIABLE LIST. C (INPUT) C FORT.KFILCP - UNIT NUMBER FOR VARIABLE CONSTANT FILE. C (INPUT) C FORT.KFILRA(J) - UNIT NUMBERS FOR EXTERNAL RANDOM ACCESS FILES C (J=1,5). (INPUT/OUTPUT) C C OUTPUT FILES: C FORT.KFILDO - UNIT NUMBER OF OUTPUT (PRINT) FILE. SET BY C DATA STATEMENT IN DRU910. (OUTPUT) C FORT.KFIL10 - UNIT NUMBER OF TDL MOS-2000 INTERNAL FILE C SYSTEM ACCESS. SET BY DATA STATEMENT. C (INPUT-OUTPUT) C FORT.KFILIO - UNIT NUMBER OF SEQUENTIAL OUTPUT TDLPACK FILE. C (OUTPUT) C FORT.IP(J) - UNIT NUMBERS FOR OPTIONAL OUTPUT (J=1,25) C (SEE IP( ) UNDER "VARIABLES" BELOW.) (OUTPUT) C FORT.KFILRA(J) - UNIT NUMBERS FOR EXTERNAL RANDOM ACCESS FILES C (J=1,5). (INPUT/OUTPUT) C C VARIABLES C KFIL10 - UNIT NUMBER OF TDL MOS-2000 FILE SYSTEM ACCESS. C SET BY DATA STATEMENT. C KFILIO - UNIT NUMBER OF SEQUENTIAL OUTPUT TDLPACK FILE. C (INPUT) C IPINIT - 4 CHARACTERS USED TO HELP IDENTIFY OUTPUT ASSOCIATED C WITH THE IP( ) NUMBERS. (CHARACTER*4) 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 'U910', C THEN 4 CHARACTERS FROM IPINIT, THEN 2 CHARACTERS C FROM IP(J) (E.G., 'U910HRG130'). 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 U910. THE C STATIONS WILL 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) = THE VARIABLE IDS AS THEY ARE BEING READ IN. C THIS IS GOOD FOR CHECKOUT; FOR ROUTINE C OPERATION, IP(7), IP(8), AND/OR IP(9), C MAY BE BETTER. C (7) = THE VARIABLE LIST IN SUMMARY FORM. C IF THERE ARE ERRORS, THE VARIABLE LIST WILL C BE WRITTEN TO THE DEFAULT OUTPUT FILE C UNIT KFILDO AS WELL AS TO UNIT IP(7). C THIS LIST INCLUDES THE PARSED ID'S IN IDPARS( , ). C (8) = THE VARIABLE LIST IN SUMMARY FORM. C THIS LIST INCLUDES THE PARSED ID'S IN C IDPARS( , ). C (9) = THE VARIABLE LIST IN SUMMARY FORM. C THIS DIFFERS FROM (8) IN THAT (9) DOES NOT C INCLUDE THE PARSED ID'S IN IDPARS( , ), C BUT RATHER INCLUDES THE INFORMATION TAKEN C FROM THE PREDICTOR CONSTANT FILE. C (10) = NOT USED. 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). C (13) = NOT USED. C (14) = NOT USED. C (15) = INDICATES WHETHER (>0) OR NOT (=0) THE DATA C WILL BE WRITTEN TO UNIT IP(15) WHEN JP(3, ) >0. C THIS PRINT IS LIKE THAT PROVIDED BY U201, AND C IS SEPARATE FROM THE OPTIONAL LISTING PROVIDED C UNDER CONTROL OF JP(2, ) WITH THE FORMAT C PROVIDED. C (16) = INDICATES WHETHER (>0) OR NOT (=0) THE DATA C WILL BE WRITTEN TO UNIT IP(16) WHEN JP(2, ) >0. C THIS PRINT IS UNDER CONTROL OF THE FORMAT C PROVIDED WITH EACH VARIABLE. C JSTOP - THE NUMBER OF ERRORS THAT WILL BE TOLERATED ON THE C TOTAL RUN BEFORE PROGRAM STOPS. 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 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 NPRINT - THE NUMBER OF CYCLES OF DATA TO PRINT UNDER C JP(2, ) CONTROL. C NDATES - THE NUMBER OF DATES IN IDATE( ). C KFILRA(J) - HOLDS THE UNIT NUMBERS FOR ACCESSING THE MOS-2000 C EXTERNAL RANDOM ACCESS FILES (J=1,5). C RACESS(J) - FILE NAMES OF THE MOS-2000 EXTERNAL RANDOM ACCESS C FILES CORRESPONDING TO KFILRA(J) (J=1,5). C (CHARACTER*60) C NUMRA - THE NUMBER OF VALUES IN KFILRA( ) AND RACESS( ). C KFILX - THE UNIT NUMBER FOR THE OUTPUT RANDOM ACCESS C FILE. (OUTPUT) C CFILX - THE FILE NAME OF THE OUTPUT RANDOM ACCESS C FILE CORRESPONDING TO KFILX. (CHARACTER*60) C (OUTPUT) C OUTNAM - NAME OF DATA SET FOR PACKED VECTOR OUTPUT TO C BE WRITTEN TO UNIT KFILIO. (CHARACTER*60) C NSTA - THE NUMBER OF STATIONS BEING DEALT WITH. THE C NUMBER OF VALUES IN CCALL( , ), ETC. MAXIMUM C OF ND1. C KGP - THE NUMBER OF GROUPS OF STATIONS TO BE PROCESSED. C MAXIMUM OF ND1. C LNGTH - LINE LENGTH FOR PRINTING TO IP(16). (OUTPUT) C ICHARS - NUMBER OF CHARACTERS FOR CALL LETTERS IN C PRINTING, MIN OF 4, MAX OF 8. INT910 ASSURES C THIS RANGE. C NVRBL - THE NUMBER OF VARIABLES. C ISTOP(J) - FOR J=1, ISTOP IS INCREMENTED BY 1 EACH TIME C AN ERROR OCCURS THAT MAY BE FATAL. C FOR J=2, ISTOP IS INCREMENTED BY 1 WHENEVER AN C INPUT DATA RECORD IS NOT FOUND. 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 LASTL - THE LAST LOCATION IN CORE( ) USED. THIS MAY BE C MODIFIED, ALONG WITH ITEMS, IF COMPACTION IS C DONE BY GCPAC. INITIALIZED TO ZERO ON FIRST C ENTRY TO GSTORE. ALSO SET TO ZERO IN U910 IN C CASE GSTORE IS NOT ENTERED. C LASTD - TOTAL NUMBER OF PHYSICAL RECORDS ON DISK. INITIALIZED C TO ZERO ON FIRST ENTRY TO GSTORE. ALSO SET TO C ZERO IN U910 IN CASE GSTORE IS NOT ENTERED. C NSTORE - THE NUMBER OF TIMES GSTORE HAS BEEN ENTERED. C NFETCH - THE NUMBER OF TIMES GFETCH HAS BEEN ENTERED. C NTOTBY - THE TOTAL NUMBER OF BYTES ON THE FILE ASSOCIATED C WITH UNIT NO. KFILIO (THE OUTPUT FILE). C IT IS INITIALIZED BY SKIPWR AND UPDATED AS C DATA ARE WRITTEN. (THIS DOES NOT ACCOUNT FOR C ANY BYTES WRITTEN BY THE SYSTEM THAT ARE NOT C PART OF THE FORTRAN WRITES. THIS IS PROBABLY C 8 BYTES PER RECORD.) C NTOTRC - THE TOTAL NUMBER OF RECORDS IN THE FILE. IT IS C INITIALIZED BY SKIPWR AND UPDATED AS DATA ARE C WRITTEN. C NCOMBO - REQUIRED BY GFETCH. NOT ACTUALLY USED. C NRRDAT - REQUIRED BY GFETCH. THE VALUE SET BY DATA C STATEMENT WILL CAUSE THE DATA STORED TO BE KEPT C FROM DAY TO DAY. C ISTAB - RETURNED FROM OPTX, BUT NOT USED. C C C SUBPROGRAMS CALLED: C UNIQUE: - INT910 C LIBRARY: C MDLLIB90 - GSTORE, PACKV, PRU660, SETMIS, TRAIL, RDTDLM, WRTDLM, C UPDAT, OPTX, WRTDLR, CLFILM C C EXIT STATES: C COND = 0 - SUCCESSFUL RUN C 120 - ONE OR MORE STATIONS NOT FOUND IN THE DIRECTORY. C THIS IS NOT FATAL. (FROM OPTX). C 135 - MISMATCH OF CALL LETTERS TO BE WRITTEN AND THOSE C ON RANDOM ACCESS FILE. C 141 - ERROR WRITING STATION DIRECTORY ON RANDOM ACCESS FILE. C 155 - THE DIRECTORY DID NOT EXIST. THIS IS NOT AN ERROR. C (FROM RDTDLM). C 238 - TOTAL NUMBER OF ERRORS ALLOWED HAS BEEN EXCEEDED. C 1090 - ERROR READING STATION DIRECTORY. C C REMARKS: NONE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 (xlf90 compiler) C MACHINE: IBM SP C C$$$ C CHARACTER*1 CFMT(ND4),HEAD(30,ND4),PREC(ND4) CHARACTER*2 WDTH(ND4) CHARACTER*4 IPINIT CHARACTER*8 CCALL(ND1,6) CHARACTER*8 CCALLD(ND5) CHARACTER*20 NAME(ND1) CHARACTER*32 PLAIN(ND4) CHARACTER*60 OUTNAM,RACESS(5),CFILX C DIMENSION ISDATA(ND1),SDATA(ND1),NGP(ND1),MWORK(ND1) DIMENSION ICALL(L3264W,ND1,6) DIMENSION XDATA(ND1,ND2) DIMENSION ID(4,ND4),IDPARS(15,ND4),TRESHL(ND4),TRESHU(ND4), 1 JD(4,ND4),JP(3,ND4),ITAU(ND4), 2 IWDTH(ND4),IPREC(ND4),NCAT(ND4), 3 ISCALD(ND4),PRINT(ND4) DIMENSION IPLAIN(L3264W,4,ND4) DIMENSION AA(ND2*ND1) DIMENSION IPACK(ND5),ICALLD(L3264W,ND5), 1 IWORK(ND5),DATA(ND5) DIMENSION IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7) DIMENSION IDATE(ND8),NWORK(ND8) DIMENSION LSTORE(12,ND9) DIMENSION CORE(ND10) DIMENSION KFILRA(5) DIMENSION IP(25),ISTOP(2),LD(4) C DATA ISTOP/0,0/ DATA KFIL10/99/ DATA IP/25*0/ DATA LASTL/0/, 1 LASTD/0/ DATA NFETCH/0/, 1 NSTORE/0/ DATA MINPK/46/ DATA NTOTBY/0/, 1 NTOTRC/0/ DATA NCOMBO/999/ DATA NRRDAT/2100010100/ C C READ CONTROL INFORMATION. C CALL INT910(KFILDI,KFILDO,KFILIO,IP, 1 CCALL,MWORK,IWORK,SDATA,XDATA, 2 ISDATA,IPACK,NGP,KGP,NAME,NSTA,ND1,CCALLD,ND5, 3 ID,IDPARS,TRESHL,TRESHU,JD,JP,NCAT, 4 ITAU,ICHARS,IWDTH,IPREC,CFMT,ISCALD,HEAD, 5 PLAIN,L3264B,L3264W,ND4, 7 KFILRA,RACESS,NUMRA,KFILX,CFILX, 7 OUTNAM,IDATE,NDATES,NWORK,ND8, 8 JSTOP,NREPLA,NCHECK, 9 NPRINT,NVRBL,LNGTH, A NTOTBY,NTOTRC,IPINIT,ISTOP(1),IER) C NOTE THAT MWORK( ), IWORK( ), SDATA( ), AND XDATA( ), C ARE THE SAME AS NELEV( ), IWBAN( ), STALAT( ), AND C STALON( ), RESPECTIVELY, IN INT710. C NOTE THAT FOR IWORK, ND5 MUST BE MAINTAINED AS GE ND1. C C WHEN FORECASTS ARE TO BE WRITTEN TO THE RANDOM ACCESS C FILE, READ CALL LETTERS IF THEY EXIST AND CHECK THEM C TO MAKE ADDITION OF RECORDS POSSIBLE. C IF(KFILX.EQ.0)GO TO 145 C LD(1)=400001000 LD(2)=0 LD(3)=0 LD(4)=0 CINTEL C CALL RDTDLM(KFILDO,KFILX,CFILX,LD,ICALLD,ND1*L3264W,NVALUE, C 1 L3264B,IER) CALL RDTDLMC(KFILDO,KFILX,CFILX,LD,CCALLD,ND1*L3264W,NVALUE, 1 L3264B,IER) CINTEL C IF(IER.EQ.155)THEN C THE DIRECTORY DID NOT EXIST. THIS IS NOT AN ERROR. WRITE(KFILDO,1115)CFILX 1115 FORMAT(' THE DIRECTORY DOES NOT EXIST ON FILE ',A60,/, 1 ' SO WRITE THE CALL LETTERS.') GO TO 140 C ELSEIF(IER.NE.0)THEN WRITE(KFILDO,112)IER 112 FORMAT(' ERROR READING STATION DIRECTORY', 1 ' IN RANDOM ACCESS FILE IN U910 AT 112. IER =',I4) C CALL W3TAGE('U910') STOP 1090 ENDIF C NVALUE=NVALUE/L3264W C THE CALL LETTERS ARE 8 BYTES EACH. THIS IS TWO WORDS C ON A 32-BIT MACHINE. THE NUMBER OF WORDS WRITTEN AND C READ MUST ACCOUNT FOR THIS. THE ACTUAL NUMBER OF CALL C LETTERS IS NVALUE/L3264W. C C CALL LETTERS WERE READ. DO THEY MATCH? C IF(NVALUE.EQ.NSTA)GO TO 125 WRITE(KFILDO,120)NVALUE,NSTA, 1 (CCALL(J,1),CCALLD(J),J=1,MAX(NVALUE,NSTA)) 120 FORMAT(/,' ****NUMBER OF CALL LETTERS READ FROM', 1 ' RANDOM ACCESS OUTPUT FILE =',I5,/, 1 ' DOES NOT EQUAL THE NUMBER TO BE WRITTEN =',I5, 2 '. STOP IN U910 AT 120.',/,(' ',A8,1X,A8)) C VALUES BEYOND NVALUE IN CCALL( , ) WILL NOT BE C CHARACTER ORIENTED, AND PROBABLY NOT PRINTABLE AS A8. C CALL W3TAGE('U910') STOP 120 C 125 MATCH=0 C DO 130 J=1,NSTA IF(CCALL(J,1).EQ.CCALLD(J))GO TO 130 WRITE(KFILDO,126)CCALL(J,1),CCALLD(J) 126 FORMAT(/,' ****MISMATCH OF CALL LETTERS TO BE WRITTEN', 1 ' AND THOSE ON RANDOM ACCESS FILE.',2(2X,A8)) MATCH=1 130 CONTINUE C IF(MATCH.EQ.0)GO TO 145 WRITE(KFILDO,134)(CCALL(J,1),CCALLD(J),J=1,NSTA) 134 FORMAT(/,' TO WRITE ON CONSTANT FILE',/, 1 (' ',A8,2X,A8)) WRITE(KFILDO,135) 135 FORMAT(/,' STOP IN U910 AT 135.' ) C CALL W3TAGE('U910') STOP 135 C C WRITE CALL LETTERS RECORD WHEN SUCH A RECORD DOES C NOT EXIST. C CINTEL C 140 CALL WRTDLM(KFILDO,KFILX,CFILX,LD,ICALL,NSTA*L3264W, C 1 0,0,L3264B,IER) 140 CALL WRTDLMC(KFILDO,KFILX,CFILX,LD,CCALL,NSTA*L3264W, 1 0,0,L3264B,IER) CINTEL C THE CALL LETTERS ARE 8 BYTES EACH. THIS IS TWO WORDS C ON A 32-BIT MACHINE. THE NUMBER OF WORDS WRITTEN AND C READ MUST ACCOUNT FOR THIS. C IF(IER.NE.0)THEN WRITE(KFILDO,141)IER 141 FORMAT(/,' ****ERROR WRITING STATION DIRECTORY', 1 ' ON RANDOM ACCESS FILE IN U910 AT 141. IER =',I4) C CALL W3TAGE('U910') STOP 141 ENDIF C C FILL THE INDEX ISDATA( ) FOR STORING BY GSTORE. C 145 DO 150 K=1,NSTA ISDATA(K)=K 150 CONTINUE C CALL GSTORE(KFILDO,KFIL10,LD,NCOMBO,LSTORE,ND9,LITEMS, 1 ISDATA,NSTA,1,NRRDAT,0, 2 CORE,ND10,LASTL,NBLOCK,LASTD,NSTORE,L3264B,IER) C NOTE THAT ISDATA( ) IS INTEGER. ALTHOUGH THE CORRESPONDING C VARIABLE IN GSTORE IS REAL, THIS IS OK. C DO 300 ND=1,NDATES C C SET UP SOME VALUES FOR LOADING IS1( ) WHEN PACKING. C NDATE=IDATE(ND) NYR=NDATE/1000000 NMO=NDATE/10000-NYR*100 NDA=NDATE/100-NYR*10000-NMO*100 NHR=NDATE-NYR*1000000-NMO*10000-NDA*100 C C PROCESS ONE VARIABLE AT A TIME IN VRBL91. C DO 250 N=1,NVRBL IF(NCAT(N).EQ.0)GO TO 250 C WHEN NCAT(N) = 0, THE VARIABLE HAS ALREADY BEEN C RETURNED IN XDATA( ,J) (J=1,NCAT(N)). C C SET MDATE FOR THIS VARIABLE. C IF(ITAU(N).EQ.0)THEN MDATE=NDATE ELSE CALL UPDAT(NDATE,ITAU(N),MDATE) ENDIF C C C COMPUTE THIS VARIABLE; NCAT( ) PROBABILITIES C ARE HANDLED. C NOTE THAT 9997 AS WELL AS 9999 MUST BE HANDLED. C THE DATA WILL BE RETURNED READY TO USE, EXCEPT C FOR POSSIBLE BINARY FORMULATION, IN XDATA( ,N). C CALL OPTX(KFILDO,KFIL10,IP(12),KFILRA,RACESS,NUMRA, 1 ID(1,N),IDPARS(1,N),TRESHL(N),JD(1,N),ITAU(N), 2 NDATE,MDATE,CCALL,ISDATA,XDATA,ND1,NCAT(N),NSTA, 3 ICALLD,CCALLD,IPACK,IWORK,DATA,ND5, 4 LSTORE,ND9,LITEMS,CORE,ND10, 5 LASTL,LASTD,NBLOCK,NSTORE,NFETCH, 6 IS0,IS1,IS2,IS4,ND7, 7 L3264B,L3264W,ISTAB,IER) C IF(IER.NE.0)THEN C IF(IER.EQ.120)THEN ISTOP(1)=ISTOP(1)+1 C IER = 120 FROM FINDST IN CONST IN OPTX MEANS ONE OR MORE C STATIONS NOT FOUND IN THE DIRECTORY. THIS IS NOT FATAL. IER=0 ELSE ISTOP(2)=ISTOP(2)+1 C AN ERROR IN OPTX WILL GENERATE A DIAGNOSTIC AND DATA IN C XDATA( , ) HAVE BEEN SET TO 9999. ISTOP(2) IS INCREMENTED, C EVEN WHEN IER = 47, WHICH JUST MEANS DATA COULD NOT C BE FOUND. (IT IS POSSIBLE THAT ERRORS OTHER THAN JUST C MISSING DATA OCCURRED.) ENDIF C ENDIF C C PRINT THE DATA AS NECESSARY. ONLY THOSE VARIABLES C FOR WHICH JP(2, ) NE 0 WILL BE PRINTED. NOTE THAT C AN ERROR WITH IER NE 0 FROM OPTX WILL STILL DROP THROUGH C HERE. C IF(NPRINT.LT.ND)GO TO 200 D WRITE(KFILDO,170)N,NSTA,KGP,NGP(1),NCAT(N) D170 FORMAT(/,' U910 AT 170--N,NSTA,KGP,NGP(1),NCAT(N)',5I8) C DO 180 L=1,NCAT(N) IF(JP(2,N+L-1).NE.0)GO TO 190 180 CONTINUE C C A DROP THROUGH HERE MEANS NO PRINT IS NECESSARY IN PRU660. C AA( , ) IS USED ONLY IN PRU660. GO TO 200 C 190 ICOUNT=1 C DO 195 K=1,NSTA DO 194 L=1,NCAT(N) AA(ICOUNT)=XDATA(K,L) ICOUNT=ICOUNT+1 194 CONTINUE 195 CONTINUE C CALL PRU660(KFILDO,IP(16),CCALL,NSTA,NGP,KGP,JP(1,N),IDATE(ND), 1 LNGTH,ICHARS,IWDTH(N),WDTH(N),IPREC(N),PREC(N), 2 CFMT(N),HEAD(1,N), 3 AA,PRINT(N),NCAT(N),ISTOP(1),IER) C ISTOP(1) IS NOT ACTUALLY USED IN PRU660. C C SET XMISSS = 0. OR 9997. DEPENDING ON WHETHER A 9997. C APPEARS IN THE DATA TO BE PACKED. SET XMISSP = 0. C OR 9999. DEPENDING ON WHETHER A 9999. OR 9997. APPEAR C IN THE DATA TO BE PACKED. C 200 DO 245 L=1,NCAT(N) NL=N+L-1 C IF(JP(1,NL).EQ.0)GO TO 245 CALL SETMIS(KFILDO,XDATA(1,L),NSTA,XMISSP,XMISSS) C C PACK AND WRITE THE DATA. THE DATA ARE ALWAYS PACKED C AND WRITTEN TO THE MOS-2000 RANDOM ACCESS FILE. C THEY ARE WRITTEN TO THE SEQUENTIAL FILE ONLY IF JP(1,N) GT 0. C CALL PACKV(KFILDO,KFILIO,ID(1,NL),IDPARS(1,NL), 1 JP(1,NL),ISCALD(NL),0, 2 IPLAIN(1,1,NL),PLAIN(NL),NDATE,NYR,NMO,NDA,NHR, 3 CCALL,ISDATA,XDATA(1,L),ND1,NSTA,IPACK,ND5,MINPK, 4 IS0,IS1,IS2,IS4,ND7,XMISSP,XMISSS, 5 IP(15),LWORDS,NTOTBY,NTOTRC, 6 L3264B,L3264W,ISTOP(1),IER) IF(KFILX.EQ.0)GO TO 210 CALL WRTDLR(KFILDO,KFILX,CFILX,IS1(9),ICALL,CCALL,ND1,NSTA, 1 ICALLD,CCALLD,ND5,IPACK,LWORDS, 2 NREPLA,NCHECK,L3264B,L3264W,IER) IF(IER.EQ.0)GO TO 245 ISTOP(1)=ISTOP(1)+1 C AN ERROR IN WRTDLR WILL PRINT A DIAGNOSTIC. 210 IF(ISTOP(1).LE.JSTOP)GO TO 250 C C TOTAL ERRORS ALLOWED HAVE BEEN EXCEEDED. C WRITE(KFILDO,238)ISTOP(1),N,IDATE(ND) 238 FORMAT(/,' NUMBER OF ERRORS =',I6,' AFTER VARIABLE NO.',I4, 1 ' DATE',I11,' EXCEEDS JSTOP.', 2 ' STOP IN U910 AT 238.') WRITE(KFILDO,806)NSTORE WRITE(KFILDO,807)NFETCH C CALL W3TAGE('U910') STOP 238 245 CONTINUE C 250 CONTINUE C 300 CONTINUE C C WRITE TRAILER RECORD AND EOF UNLESS KFILIO = 0. IF THERE C IS AN ERROR, TRAIL WILL PRODUCE A DIAGNOSTIC. C IF(KFILIO.NE.0)THEN CALL TRAIL(KFILDO,KFILIO,L3264B,L3264W,NTOTBY,NTOTRC,IER) ENDFILE KFILIO ENDIF C C CLOSE RANDOM ACCESS FILE. C CALL CLFILM(KFILDO,KFILX,IER) C C CLOSE UP SHOP. C 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(KFILIO.EQ.0)GO TO 8079 WRITE(KFILDO,8075)NTOTBY,NTOTRC,OUTNAM 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 END