SUBROUTINE MELD71(KFILDO,KFILIO,KFILRA,RACESS,NUMRA,KFIL10, 1 KFILOG,KFILOV,INLTAB,KFILEQ,EQNNAM, 2 IP16,IP17,IP18,IP19, 3 ID,IDPARS,JD,JP,ISCALD, 4 MODNO,IOPER,IREG, 5 NDATE,JDATE,CCALL,ICALLD,CCALLD, 6 ISDATA,SDATA,NSTA,ND1,DIR, 7 ND13,ND14,ND15, 8 P,FD2,FD3,FD4,FD5,ND2X3,NX,NY, 9 IPACK,DATA,IWORK,ND5,MINPK, D NTELEV,TELEV,SEALND,NCLIPY,CPNDFD, B MTABLE,MPLAIN,IDCNT,ND16, C LSTORE,ND9,LITEMS,CORE,ND10,LASTL, D NBLOCK,LASTD,NSTORE,NFETCH, E IS0,IS1,IS2,IS4,ND7, F IPLAIN,PLAIN, G NAREA,ALATL,ALONL,NPROJ,ORIENT, K MESH,BMESH,XLAT, I NTOTBY,NTOTRC,NTOTGB,NTOTGR,JTOTBY,JTOTRC, J MTOTBY,MTOTRC, K L3264B,L3264W,MISTOT,ISTOP,JER,IER) C C JULY 2018 GLAHN MDL LAMP C ADAPTED FROM MELD70 C C PURPOSE C THIS ROUTINE HAS BEEN TAILORED SPECIFICALLY TO C IMPLEMENTING THE VIS, CIG, AND CLOUD BASES LAMP/HRRR MELD, C CONSISTING OF REEP EQUATIONS AND THRESHOLDS--THE PROCESS C DESCRIBED IN MDL ON 14-2. THE OUTPUT IS IN MILES FOR VIS C AND HUNDREDS OF FT FOR CLOUDS, CONVERTED FROM CATEGORIES, C WHICH WERE MADE FROM PROBABILITIES AND THRESHOLDS. C MELD71 IS SPECIFIC TO 16 VIS CATEGORIES AND 24 CIG AND C CLOUD BASE CATEGORIES. C C MELD71 DEALS WITH BOTH GENERALIZED OPERATOR AND C REGIONAL EQUATIONS. C C INPUTS ARE: C (1) THE LAMP 2.5-KM PROBABILITY ANALYSIS GRIDS, C (2) THE HRRR GRID WITH THE SAME GRID CHARACTERISTICS C (MILES FOR VIS, HUNDREDS OF FT FOR CIG), TIME C SHIFTED AND PIXSM RUN IN U202, C (3) THE EQUATIONS FROM U602, AND C (4) THE THRESHOLDS FROM U830. C (5) WEIGHTS FOR EACH GRIDPONT AND REGION C C THIS SUBROUTINE IS ENTERED ONCE FOR EACH ID READ IN C RDV755, WHICH IS A SPECIFIC ELEMENT/PROJECTION. C MELD71 READS THE THRESHOLDS, AND MAKES THE FORECASTS. C C THE GRIDS CAN COME INTO INTERNAL RA STORAGE AND BE C ACCESSIBLE FROM THERE. C C THE ORIGINAL DEFINITION OF THE 2ND WORD OF THRESHOLDS C WAS CHANGED TO HAVE 4 ZEROS AT THE END. THAT IS, C THE DEFINITION IS IN LLLL LEAVING UUUU INTACT. C C THE PROBABILITIES DERIVED FROM THE EQUATIONS ARE IN C TERMS OF FRACTIONS, AND ARE USED THAT WAY FOR CATEGORICAL C EVALUATION. THEY ARE WRITTEN TO BOTH THE C SEQUENTIAL AND RANDOM ACCESS FILES IN FRACTIONS C TO AGREE WITH THE WAY THE LAMP ANALYSIS PROBABILITIES C ARE WRITTEN. BUT THEY ARE ALSO WRITTEN TO THE DISPOSABLE C FILE KFILOG (UNLESS IT IS ZERO) MULTIPLIED BY 100 (WITH C THE SAME IDS) SO THAT THEY CAN BE DISPLAYED BY GMOS_PLOT. C C DATA SET USE C KFILDO - UNIT NUMBER FOR OUTPUT (PRINT) FILE. (OUTPUT) C KFILIO - UNIT NUMBER FOR WRITING GRIDPOINT FORECASTS. C THIS IS THE ARCHIVE FILE. (OUTPUT) C KFILOV - UNIT NUMBER OF OUTPUT VECTOR FILE. C INTERPLATION TO STATIONS CAN BE DONE AND THE C OUTPUT PACKED AND WRITTEN. (OUTPUT) C KFILRA(J)- HOLDS THE UNIT NUMBERS FOR ACCESSING THE MOS-2000 C EXTERNAL RANDOM ACCESS FILES (J=1,6). C (INPUT/OUTPUT) C KFIL10 - UNIT NUMBER FOR INTERNAL RANDOM ACCESS STORAGE. C (INPUT/OUTPUT) C IP16 - UNIT NUMBER FOR INDICATING WHEN A RECORD IS C WRITTEN TO THE SEQUENTIAL FILE. (OUTPUT) C IP17 - UNIT NUMBER FOR DIAGNOSTICS IN PACKV. (OUTPUT) C IP18 - INDICATES WHETHER (>0) OR NOT (=0) C ELEMENTS OF THE EQUATIONS WILL BE WRITTEN C ON UNIT IP18. (INPUT) C IP19 - WHEN NOT EQUAL TO 0, STATION CALL LETTERS READ C IN CONST WILL BE WRITTEN TO IP19. (OUTPUT) C C VARIABLES C KFILDO = UNIT NUMBER FOR OUTPUT (PRINT) FILE. (INPUT) C KFILIO = UNIT NUMBER FOR WRITING FINAL GRIDPOINT C FORECASTS. THIS IS THE ARCHIVE FILE. (INPUT) C KFILRA(J) = HOLDS THE UNIT NUMBERS FOR ACCESSING THE MOS-2000 C EXTERNAL RANDOM ACCESS FILES (J=1,6). C THE ACCESS ROUTINES ALLOW 6 RANDOM ACCESS C FILES. (INPUT) C RACESS(J) = THE FILE NAMES CORRESPONDING TO KFILRA(J) C (J=1,6). (CHARACTER*60) (INPUT) C NUMRA = THE NUMBER OF UNIT NUMBERS IN KFILRA( ) AND C NAMES IN RACESS( ). (INPUT) C KFIL10 = UNIT NUMBER FOR INTERNAL RANDOM ACCESS STORAGE. C (INPUT) C KFILOG = UNIT NUMBER FOR DISPOSABLE TDLPACK GRIDPOINT C OUTPUT. (INPUT) C KFILOV = UNIT NUMBER OF OUTPUT VECTOR FILE. C INTERPLATION TO STATIONS CAN BE DONE AND THE C OUTPUT PACKED AND WRITTEN. (INPUT) C INLTAB = UNIT NUMBER OF .CN FILE TO READ. (INPUT) C KFILEQ = UNIT NUMBER OF FILE HOLDING EQUATIONS. C (INPUT) C EQNNAM = FILE NAME HOLDING EQUATIONS, INCLUDING THE C PATH. (CHARACTER*60) (INPUT) C IP16 = INDICATES WHETHER (>0) OR NOT (=0) C A STATEMENT WILL BE OUTPUT TO IP16 C WHEN A SEQUENTIAL FILE IS WRITTEN THROUGH C PAWGTS. (INPUT)) C IP17 = INDICATES WHETHER (>0) OR NOT (=0) C DATA WILL BE WRITTEN TO IP17 TO UNITS C PACKED IN PACKV FOR THE VARIABLE N WHEN C WHEN JP(3,N) NE 0. (INPUT) C IP18 = INDICATES WHETHER (>0) OR NOT (=0) C EQUATIONS READ IN RDEQNM WILL BE WRITTEN C TO IP18 IN RDEQNG. (INPUT) C IP19 = INDICATES WHETHER (>0) OR NOT (=0) C STATIONS READ FROM CONSTANT FILE WILL C BE PRINTED TO IP19. (INPUT) C ID(J) = 4 WORD ID OF VARIABLE BEING COMPUTED (J=1,4) C (INPUT) C IDPARS(J) = THE PARSED, INDIVIDUAL COMPONENTS OF THE C PREDICTOR ID'S CORRESPONDING TO ID( ,N) C (J=1,15). C J=1--CCC (CLASS OF VARIABLE), C J=2--FFF (SUBCLASS OF VARIABLE), C J=3--B (BINARY INDICATOR), C J=4--DD (DATA SOURCE, MODEL NUMBER), C J=5--V (VERTICAL APPLICATION), C J=6--LBLBLBLB (BOTTOM OF LAYER, 0 IF ONLY C 1 LAYER), C J=7--LTLTLTLT (TOP OF LAYER), C J=8--T (TRANSFORMATION), C J=9--RR (RUN TIME OFFSET, ALWAYS + AND BACK C IN TIME), C J=10--OT (TIME APPLICATION), C J=11--OH (TIME PERIOD IN HOURS), C J=12--TAU (PROJECTION IN HOURS), C J=13--I (INTERPOLATION TYPE), C J=14--S (SMOOTHING INDICATOR), AND C J=15--G (GRID INDICATOR). C (INPUT) C JD(J) = THE BASIC INTEGER PREDICTOR ID'S (J=1,4). C THIS IS THE SAME AS ID(J,N), EXCEPT THAT THE C PORTIONS PERTAINING TO PROCESSING ARE OMITTED: C B = IDPARS(3, ), C T = IDPARS(8,), C I = IDPARS(13, ), C S = IDPARS(14, ), C G = IDPARS(15, ), AND C THRESH( ). C JP(J,N) = INDICATES WHETHER A PARTICULAR VARIABLE N MAY C HAVE INTERMEDIATE TDLPACK OUTPUT (J=2), OR C PRINT OF VECTOR RECORDS IN PACKV (J=3) C (N=1,ND4). THIS IS AN OVERRIDE FEATURE FOR THE C PARAMETERS TDLPACKING IN EACH VARIABLE'S CONTROL C FILE. (INPUT) C ISCALD = THE DECIMAL SCALING CONSTANT TO USE WHEN PACKING C THE DATA FOR THIS VARIABLE. (INPUT) C MODNO = NOT USED. (MODNO PERTAINS TO THE WHOLE RUN, C AND THE DD TO WRITE MAY NOT BE THE SAME FOR ALL C VARIABLES. RATHER THE DD TO WRITE COMES FROM C ITABLE(1, ). (INPUT) C IOPER = 1 FOR OPERATIONS; 0 FOR DEVELOPMENT. CONTROLS C HOW EQUATIONS HEADER IS READ AND USED. (INPUT) C IREG = NUMBER OF REGIONS FOR REGIONAL EQUATIONS. C 1 = GENERALIZED OPERATOR. THIS IS A SAFETY TO C ASSURE THE NUMBER OF REGIONAL EQQUATIONS READ C IS WHAT IS EXPECTED. (INPUT) C NDATE = DATE/TIME, YYYYMMDDHH. THIS IS THE ANALYSIS C RUN TIME, INCLUDING HH. (INPUT) C JDATE(J) = NDATE PARSED INTO ITS 4 COMPONENTS: C J=1 IS YYYY C J=2 IS MM C J=3 IS DD C J=4 IS HH C (INPUT) C CCALL(K) = 8-CHARACTER STATION CALL LETTERS (J=1). (INPUT) C ICALLD(L,K) = 8 STATION CALL LETTERS AS CHARACTERS IN AN C INTEGER VARIABLE (L=1,L3264W) (K=1,NSTA). C EQUIVALENCED TO CCALLD( ) IN DRU755. (INTERNAL) C CCALLD(K) = 8 STATION CALL LETTERS (K=1,NSTA). EQUIVALENCED C TO ICALLD( , ) IN DRU755. STATIONS FOR EACH C REGION ARE READ INTO CCALLD( ) BY RDEQNM, C BUT ARE NOT SAVED. CONST WILL OVERWRITE THEM. C (CHARACTER*8) (INTERNAL) C ISDATA(K) = WORK ARRAY (K=1,ND1). (INTERNAL) C SDATA(K) = WORK ARRAY (K=1,ND1). HOLDS THE THRESHOLDS. C (INTERNAL) C NSTA = NUMBER OF POINTS FOR WHICH DATA ARE AVAILABLE. C (INPUT) C ND1 = MAXIMUM NUMBER OF STATIONS THAT CAN BE DEALT C WITH. NOTE THAT THIS DOES NOT NECESSARILY C INCLUDE THE NUMBER OF STATIONS IN A C DIRECTORY. EVEN THOUGH STATIONS ARE NOT USED C IN THIS ROUTINE, ND1 IS CARRIED AS THE MAXIMUM C TO USE IN RDEQNG. (INPUT) C TO USE IN RDEQNG. (INPUT) 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 C NGRIDC( M). (INPUT) C ND13 = MAXIMUM NUMBER OF REGIONS IN EQUATIONS. C (INPUT) C ND14 = MAXIMUM NUMBER OF TERMS IN AN EQUATION. C (INPUT) C ND15 = MAXIMUM NUMBER OF CATEGORIES IN PROBABILITY C EQUATIONS. (INPUT) C ISPOT = THE SIZE OF SPOT TO REMOVE = ISPOT. (INPUT) C MTIMES = NUMBER OF PASSES OVER THE DATA FOR PIXEL C SMOOTHER. MTIMES SHOULD BE EVENLY DIVISIBLE C BY 4 FOR SYMMETRY. (INTERNAL) C DIFFV = DIFFERENCE BETWEEN END POINTS IN TERMS OF C GRIDPOINTS WHEN EXCEEDED REMOVAL IS NOT DONE. C (INPUT) C DIFFA = THE ELEVATION DIFFERENCE IF EXCEEDED, REMOVAL C IS NOT DONE. (INPUT) C P(J) = RETURNS THE CATEGORICAL FORECASTS. (J=1,NX*NY). C (OUTPUT) C FD2(J) = HOLDS THE PREDICTOR GRIDS (J=1,ND2X3). ALSO C WORK ARRAY IN PACKGR. (INTERNAL) C FD3(J) = HOLDS FORECAST GRIDS SCALED FOR WRITING TO C THE DISPOSABLE FILE (J=1,ND2X3). ALSO AS C WORK ARRAY IN PIXSM1. (INTERNAL) C FD4(J) = WORK ARRAY (NOT ACTUALLY USED) (J=1,ND2X3). C (INTERNAL) C FD5(J) = WORK ARRAY (NOT ACTUALLY USED) (J=1,ND2X3). C (INTERNAL) C ND2X3 = SIZE OF P( ), FD2( ), FD3( ), FD4( ), AND C FD5( ). (INPUT) C NX = NUMBER OF GRIDPOINTS IN THE XI (LEFT TO RIGHT) C DIRECTION AT CURRENT MESH LENGTH MESH. C (INPUT) C NY = NUMBER OF GRIDPOINTS IN THE JY (BOTTOM TO TOP) C DIRECTION AT CURRENT MESH LENGTH MESH. C (INPUT) C IPACK(J) = WORK ARRAY (J=1,ND5). (INTERNAL) C DATA(J) = WORK ARRAY (J=1,ND5). (INTERNAL) C IWORK(J) = WORK ARRAY (J=1,ND5). (INTERNAL) C ND5 = DIMENSION OF IPACK( ), IWORK( ), AND DATA( ). C (INPUT) C MINPK = MINIMUM GROUP SIZE WHEN PACKING THE DATA. C (INPUT) C NTELEV = 1 WHEN THE TERRAIN IS IN TELEV( ); C 0 OTHERWISE. C (INPUT) C TELEV(J) = THE TERRAIN ELEVATION FROM THE MOS-2000 EXTERNAL C RANDOM ACCESS FILE (J=1,NX*NY). PRESENT C ONLY WHEN NTELEV = 1. (INPUT) C SEALND(J) = THE LAND/SEA MASK (J=1,NX*NY). C 0 = OCEAN WATER GRIDPOINTS; C 3 = INLAND WATER GRIDPOINTS. C 9 = LAND GRIDPOINTS. C (INPUT) C NCLIPY = 1 WHEN THE NDGD MASK GRID IS AVAILABLE AND C IN CPNDFD( ). C 0 OTHERWISE. C (INPUT) C CPNDFD(J) = THE NDFD MASK FROM THE MOS-2000 EXTERNAL C RANDOM ACCESS FILE (J=1,NX*NY) AT NOMINAL C MESHLENGTH MESHE. A "1" MEANS WITHIN THE AREA; C A "0" MEANS CLIP IT OUT. THE GRID IS PRESENT C ONLY WHEN NCLIPY = 1. (INPUT) C MTABLE(I,J) = CORRESPONDENCE TABLE BETWEEN VECTOR PREDICTAND C ID OUT OF U602 (J=1) AND GRIDDED ID TO READ C TO EVALUATE THE TERM (J=2), I=1,ND16). C MTABLE(I,3) IS CALCULATED TO INDICATE WHETHER OR C NOT A BINARY MUST BE MADE. C (INPUT) C MPLAIN(I) = DEFINITION OF THE VARIABLES IN MTABLE(I,J), C (I=1,ND16). (CHARACTER*32) (INPUT) C IDCNT = NUMBER OF ENTRIES IN MTABLE( , ) AND MPLAIN( ). C (INPUT) C ND16 = MAXIMUM OF IDCNT. DIMENSION OF MPLAIN( ) AND C FIRST DIMENSION OF MTABLE( , ). (INPUT) C LSTORE(L,J) = THE ARRAY HOLDING INFORMATION ABOUT THE DATA C STORED (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 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 --NUMBER OF THE SLAB IN DIR( , ,L) AND C IN NGRIDC( ,L) DEFINING THE C L=11 --THE NUMBER OF THE FIRST VARIABLE IN THE C LIST IN ID( ,N) (N=1,NPRED) FOR C WHICH THIS VARIABLE IS NEEDED, WHEN IT C DOES NOT NEED TO BE STORED AFTER DAY 1. C WHEN THE VARIABLE MUST BE STORED (TO BE C ACCESSED THROUGH OPTION) FOR ALL DAYS, C ID(11,N) IS 7777 + THE NUMBER OF THE C FIRST VARIABLE IN THE LIST FOR WHICH C THIS VARIABLE IS NEEDED. C CHARACTERISTICS OF THIS GRID. C L=12 --USED INITIALLY IN ESTABLISHING C MSTORE( , ). LATER USED AS A WAY OF C DETERMINING WHETHER TO KEEP THIS VARIABLE. C (INPUT) C ND9 = MAXIMUM NUMBER OF FIELDS STORED IN LSTORE( , ). C SECOND DIMENSION OF LSTORE( , ). (INPUT) C SECOND DIMENSION OF LSTORE( , ). (INPUT) C LITEMS = THE NUMBER OF ITEMS IN LSTORE( , ). (INPUT) C CORE(J) = SPACE ALLOCATED FOR SAVING PACKED GRIDPOINT C FIELDS (J=1,ND10). WHEN THIS SPACE IS C EXHAUSTED, SCRATCH DISK WILL BE USED. THIS C IS THE SPACE USED FOR THE MOS-2000 INTERNAL C RANDOM ACCESS SYSTEM. (INPUT) C ND10 = THE MEMORY IN WORDS ALLOCATED TO THE SAVING OF C DATA CORE( ). WHEN THIS SPACE IS EXHAUSTED, C SCRATCH DISK WILL BE USED. (INPUT) C LASTL = THE LAST LOCATION IN CORE( ) USED. RETURNED C FROM GSTORE. (INTERNAL) C NBLOCK = BLOCK SIZE IN WORDS OF INTERNAL MOS-2000 DISK C STORAGE. (INPUT) C LASTD = TOTAL NUMBER OF PHYSICAL RECORDS ON DISK C IN INTERNAL RANDOM ACCESS STORAGE. RETURNED C FROM GSTORE. (INTERNAL) C NSTORE = NUMBER OF TIMES A RECORD HAS BEEN STORED TO C INTERNAL STORAGE. (INPUT/OUTPUT) C NFETCH = NUMBER OF TIMES A RECORD HAS BEEN FETCHED FROM C INTERNAL STORAGE. (INPUT/OUTPUT) C IS0(J) = MOS-2000 GRIB SECTION 0 ID'S (J=1,4). C (INTERNAL) C IS1(J) = MOS-2000 GRIB SECTION 1 ID'S (J=1,21+). C (INTERNAL) C IS2(J) = MOS-2000 GRIB SECTION 2 ID'S (J=1,12). C (INTERNAL) C IS4(J) = MOS-2000 GRIB SECTION 4 ID'S (J=1,4). C (INTERNAL) C ND7 = DIMENSION OF IS0( ), IS1( ), IS2( ), AND C IS4( ). (INPUT) C IPLAIN(L,J) = 32 CHARACTERS (L=1,L3264W) (J=1,4) OF PLAIN C LANGUAGE DESCRIPTION OF THE VARIABLE. C NOTE THAT THIS REQUIRES TWO 32-BIT WORDS TO HOLD C THE DESCRIPTION BUT ONLY ONE 64-BIT WORD. C EQUIVALENCED TO PLAIN( ) IN DRU755. C PLAIN = THE PLAIN LANGUAGE DESCRIPTION OF THE VARIABLE C IN ID( ). EQUIVALENCED TO IPLAIN( , ) IN C DRU755. (CHARACTER*32) C NAREA = THE AREA OVER WHICH THE ANALYSIS IS MADE: C 1 = CONUS, C 2 = ALASKA, C 3 = HAWAII, C 4 = PUERTO. C (NOT USED) C ALATL = NORTH LATITUDE OF LOWER LEFT CORNER POINT C OF A GRID OF THE SIZE NX, NY. TRUNCATED C TO TEN THOUSANDTHS OF DEGREES. NOTE THAT THE C MOS-2000 ARCHIVE IS ONLY TO THOUSANDTHS OF C DEGREES. (INPUT) C ALONL = WEST LONGITUDE OF LOWER LEFT CORNER POINT C OF A GRID OF THE SIZE NX, NY. TRUNCATED C TO TEN THOUSANDTHS OF DEGREES. NOTE THAT THE C MOS-2000 ARCHIVE IS ONLY TO THOUSANDTHS OF C DEGREES. (INPUT) C NPROJ = NUMBER OF MAP PROJECTION TO WHICH THIS GRID C APPLIES. C 3 = LAMBERT. C 5 = POLAR STEREOGRAPHIC. C 7 = MERCATOR. C (INPUT) C ORIENT = ORIENTATION OF GRID IN WEST LONGITUDE. (INPUT) C MESH = THE NOMINAL MESH LENGTH OF THE CURRENT GRID. C (INPUT) C BMESH = ACTUAL MESH LENGTH CORRESPONDING TO MESH. C (INPUT) C XLAT = NORTH LATITUDE AT WHICH GRIDLENGTH IS SPECIFIED C IN DEGREES. (INPUT) C NTOTBY = THE TOTAL NUMBER OF BYTES ON THE FILE ASSOCIATED C WITH UNIT NO. KFILIO. (INPUT/OUTPUT) C NTOTRC = THE TOTAL NUMBER OF RECORDS IN THE FILE ON UNIT C NUMBER KFILIO. (INPUT/OUTPUT) C JTOTBY = THE TOTAL NUMBER OF BYTES ON THE FILE ASSOCIATED C WITH UNIT NO. KFILOG. (INPUT/OUTPUT) C JTOTRC = THE TOTAL NUMBER OF RECORDS IN THE FILE ON UNIT C NUMBER KFILOG. (INPUT/OUTPUT) C NTOTGB = TOTAL BYTES WRITTEN TO RANDOM ACCESS FILE. C (INPUT/OUTPUT) C NTOTGR = THE TOTAL NUMBER OF EXTERNAL RANDOM ACCESS C RECORDS WRITTEN TO KFILRA = 42. (INPUT/OUTPUT) C MTOTBY = THE TOTAL NUMBER OF BYTES ON THE FILE ASSOCIATED C WITH UNIT NO. KFILOV. C MTOTRC = THE TOTAL NUMBER OF RECORDS IN THE FILE ON UNIT C NUMBER KFILOV. C L3264B = INTEGER WORD LENGTH IN BITS OF MACHINE BEING C USED (EITHER 32 OR 64). (INPUT). C L3264W = NUMBER OF WORDS IN 64 BITS (EITHER 1 OR 2). C (INPUT) C MISTOT = RUNNING TOTAL OF RETRIEVED GRIDS WITH ONE OR C MORE MISSING VALUES. (INPUT/OUTPUT) C (INPUT-OUTPUT) C ISTOP(J) = (J=1,2): C ISTOP(1)--IS INCREMENTED BY 1 EACH TIME AN ERROR C OCCURS. C ISTOP(2)--IS INCREMENTED WHEN A DATA RECORD C COULD NOT BE FOUND. C (INPUT/OUTPUT) C JER = 0 UNTIL A MAJOR ERROR OCCURS, THEN IT IS C INCREMENTED BY 1. IT COUNTS THE MAJOR ERRORS C THAT WILL CAUSE EITHER NO GRID OR A 9999 C (MISSING) GRID TO BE OUTPUT. (INPUT/OUTPUT) C IER = ERROR RETURN. C 0 = GOOD RETURN. C 777 = FATAL ERROR. C (OUTPUT) C LLLL = INDICATES THE FORECAST CYCLE*100 AND THE C SEASON FOR WHICH THE THRESHOLDS ARE VALID. C HAS BEEN IMPLEMENTED FOR THE STANDARD WARM AND C COOL SEASONS BELOW 155. (SEE P. 14.2 IN C TDL ON 00-1. (INTERNAL) C XPROB(J,NN) = THE NN (NN=1,MTANDS) ARRAYS TO HOLD THE PARTIAL C AND THEN THE FINAL PROBABILITY FORECASTS FOR C THE WHOLE GRID (J=1,NXY) FOR ONE REGION. C (INTERNAL) C PROB(J,NN) = THE NN (NN=1,MTANDS) ARRAYS TO HOLD THE FINAL C PROBABILITY FORECASTS FOR THE WHOLE GRID C (J=1,ND2X3) FOR ALL REGIONS COMBINED. C THIS IS AFTER THE INDIVIDUAL REGIOINS HAVE C BEEN MULTIPLIED BY THEIR REGIONAL WEIGHTS. C (INTERNAL) C IDIM = THE NUMBER OF VARIABLES ACCOMMODATED. C SECOND DIMENSION IN TABLE( , ). C SET BY PARAMETER. (INTERNAL) C JDIM = MAXIMUM NUMBER OF CATEGORIES OF PROBABILITY C EQUATIONS. SET BY PARAMETER. (INTERNAL) C NSET = THE NUMBER OF EQUATION SET. REFERS TO C NUMBER OF REGIONAL EQUATIONS. (INTERNAL) C MTRMS(L) = THE NUMBER OF TERMS IN EACH EQUATION C (L=1,NSET) FOR THIS SET. (INTERNAL) C MTANDS = THE NUMBER OF PREDICTANDS FOR EACH EQUATION. C (INTERNAL) C IDEQN(J,L,M) = THE 4-WORD ID (J=1,4) FOR EACH PREDICTOR C (M=1,NTRMS) IN EACH EQUATION (L=1,NSET), C FOR THIS EQUATION SET. (INTERNAL) C IDTAND(J,NN) = THE PREDICTAND ID'S (J=1,4) NN=1,MTANDS) FOR C THIS EQUATION SET. (INTERNAL) C ECONST(L,NN) = THE EQUATION CONSTANTS FOR GROUP L (L=1,NSET) C AND PREDICTAND NN (NN=1,MTANDS) FOR THIS C EQUATION SET. (THIS WAS CHANGED FROM CONST( , ) C TO ECONST( , ) BECAUSE CONST IS THE NAME OF A C CALLED SUBROUTINE. (INTERNAL) C AVG(L,NN) = THE PREDICTAND MEANS FOR GROUP L (L=1,NSET) AND C PREDICTAND NN (NN=1,MTANDS) FOR THIS EQUATION C SET. (OUTPUT) C CORR(L,NN) = THE MULTIPLE CORRELATIONS FOR GROUP L C (L=1,NSET) AND PREDICTAND NN (NN=1,MTANDS) FOR C THIS EQUATION SET. (INTERNAL) C COEF(L,M,NN) = THE COEFFICIENTS FOR GROUP L (L=1,NSET), C TERM M (M=1,MTRMS), AND PREDICTAND NN C (NN=1,MTANDS) FOR THIS EQUATION SET. (INTERNAL) C EQNTHR = THE THRESHOLD FROM THE EQUATION BEING DEALT C WITH. (INTERNAL) C NGRIDT(L) = HOLDS INFO TO PROVIDE TO PACKGR (L=1,6). C (INTERNAL) C CCALLR(K) = LISTS OF STATIONS FROM RDEQNM. NOT NEEDED C IN MELD71. (K=1,ND5) (INTERNAL) C ITABLE(J,L) = 1ST ID WORD OF VARIABLE BEING COMPUTED (J=1), C THE 1ST WORD OF THE ID OF THE CATEGORICAL C FORECASTS (J=2), THE 1ST WORD OF PREDICTAND C IN THE EQUATIONS (J=3), DECIMAL SCALING FOR C WRITING THE CATEGORICAL FORECASTS (J=4) FOR C IDIM ENTRIES (L=1,IDIM). C IPROB(J) = INDICATES (=1) WHERE THE PROBS WILL BE WRITTEN: C (1) = 1, IPROBS ARE CUMULATIVE FROM BELOW, C = 2, IPROBS ARE CUMULATIVE FROM ABOVE C (NOT IMPLEMENTED) C (2) = KFILIO (ARCHIVE) WHEN KFILIO NE 0 C = KFILOG (DISPOSABLE) WHEN KFILOG NE 0 C MULTIPLIED BY 100 FOR DISPLAY C (3) = KFIL10 (INTERNAL RAS) C (4) = KFILRA (EXTERNAL RA) WHEN KFILRA = 42. C (5) = NOT USED. C (INTERNAL) C ICAT(J) = INDICATES (=1) WHERE THE CATEGORICAL FORECASTS C WILL BE WRITTEN: C (1) = 0 =CATEGORICAL FORECASTS WILL NOT BE MADE, C AND, THEREFORE, NOT BE WRITTEN ANYWHERE C = 1 = CATEGORICAL FORECASTS WILL BE MADE, C WHEN THRESHOLD NOT TRIPPED FOR A C PREVIOUS VARIABLE (E.G., CEILING) C = 2 = CATEGORICAL FORECASTS WILL BE MADE, C NOT CONSIDERING A PREVIOUS VARIABLE C (2) = KFILIO (ARCHIVE) WHEN KFILIO NE 0 C (3) = KFIL10 (INTERNAL RAS) C (4) = KFILRA (EXTERNAL RA) WHEN KFILRO = 42. C (5) = INDICATES WHETHER (=1) OR NOT (=0) THE C PIXEL REMOVER PIXSM1 IS USED C (6) = ISPOT, THE NUMBER OF PIXELS TO REMOVE C (E.G., 7) C (7) = MTIMES, THE NUMBER OF TIMES TO GO OVER C THE DATA (SHOULD BE EVENLY DIVISIBLE BY 4 C (8) = DIFFV, THE MAXIMUM DIFFERENCE IN END C POINTS TO REMOVE PIXELS (e.g., 1) C (9) = DIFFA, THE MAXIMUM DIFFERENCE IN ELEVATION C BETWEEN POINTS REMOVED (e.g., 200) C (10)= 1 = EACH ELEMENT TREATED SEPARATELY AND C OUTPUT, C 2 = ALL ELEMENTS COMBINED FOR ONE OUTPUT, C 3 = BOTH OF THE ABOVE. C (INTERNAL) C JPROB(J) = (1) = WRITES TO DISPOSABLE WHEN KFILOG NE 0 C (INTERNAL) C ITRP(J) = (1) = 0 INDICATES INTERPOLATION TO STATIONS WILL C NOT BE DONE FOR PROBABILITIES, C = 4 INDICATES INTERPOLATION OF THE C PROBABILITIES WILL BE DONE WITH NEAREST C NEIGHBOR AND WRITTEN TO THE VECTOR OUTPUT C FILE. C (2) = 0 INDICATES INTERPOLATION TO STATIONS WILL C NOT BE DONE FOR CATEGORICAL FORECASTS, C = 4 INDICATES INTERPOLATION OF THE C CATEGORICAL FORECASTS WILL BE DONE WITH C NEAREST NEIGHBOR AND WRITTEN TO THE VECTOR C OUTPUT FILE. C (INTERNAL) C IDWRTP = THE 1ST WORD ID FOR WRITING THE PROBABILITY C FORECAST RECORDS. (INTERNAL) C IDWRTC = THE 1ST WORD ID FOR WRITING THE CATEGORICAL C FORECAST RECORDS. (INTERNAL) C IPOS = THE POSITION IN CPLAIN( , ) TO GET THE PLAIN C LANGUAGE TO WRITE. (INTERNAL) C IDWDD = THE DD OF THE VARIABLE TO WRITE. (INTERNAL) C NVRBL(J,L),= THE LIST OF 1ST WORD IDS TO MAKE FORECASTS FOR C (L=1), THE STARTING POSITION OF EACH VARIABLE C IN THE IDTAND( , ) LIST (L=2), AND THE NUMBER C OF THRESHOLDS FOR THAT VARIABLE (L=3) C (J=1,NOVRBL). (INTERNAL) C NOVRBL = THE NUMBER OF ITEMS IN NVRBL( , ). READ FROM C THE CONTROL FILE. (INTERNAL) C CPLAIN(I,MM) = PLAIN LANGUAGE FOR WRITING PROBABILITY C FORECASTS (I=1) AND CATEGORICAL FORECASTS (I=2) C (MM=1,IDIM). (CHARACTER*32) (INTERNAL) C RACK = 32 CHARACTERS OF PLAIN LANGUAGE FOR WRITING C PACKED DATA. EQUIVALENCED TO IPACK( ). C (CHARACTER*32) (INTERNAL) C IRACK = 32 CHARACTERS OF PLAIN LANGUAGE FOR WRITING C PACKED DATA IN AN INTEGER ARRAY. EQUIVALENCED C TO PACK( ). INTERNAL) C 1 2 3 4 5 6 7 X C C NONSYSTEM SUBROUTINES CALLED C TIMPR W3TAGE RVSNAM RDEQNM GFETCH PRSID1 PRSID2 CONST C PIXEL PIXSM1 PAWGTS PACKGR PAKRET GSTORE C PARAMETER (IDIM=3) C IDIM IS THE NUMBER OF VARIABLES ACCOMMODATED. PARAMETER (JDIM=24) C JDIM IS THE MAXIMUM CATEGORIES OF ANY VARIABLE. PARAMETER (MDIM=3*JDIM) C MDIM IS THE MAXIMUM NUMBER OF PREDICTANDS IN A SET OF C EQUATIONS, ASSUMED TO BE 3 DIFFERENT PREDICTANDS FOR JDIM C NUMBER OF CATEGORIES PER PREDICTAND. C CHARACTER*4 STATE CHARACTER*6 DUMMY CHARACTER*8 CCALLD(ND5),CCALL(ND1) CHARACTER*8 CCALLR(ND5) C CCALLR( ) IS AN AUTOMATIC ARRAY. CHARACTER*10 CFIOP CHARACTER*32 PLAIN,RACK,CPLAIN(2,IDIM),PLAINT CHARACTER*32 MPLAIN(ND16+1) CHARACTER*60 EQNNAM,RACESS(6) C DIMENSION MTRMS(ND13) DIMENSION IDEQN(4,ND13,ND14) DIMENSION ECONST(ND13,ND15), 1 AVG(ND13,ND15), 2 CORR(ND13,ND15) DIMENSION COEF(ND13,ND14,ND15) DIMENSION IDTAND(4,ND15+1) C IDTAND(4,ND15+1) IS AN AUTOMATIC ARRAY USED IN AND RETURNED FROM C RDEQHR. C DIMENSION ISDATA(ND1),SDATA(ND1) DIMENSION P(ND2X3),FD2(ND2X3),FD3(ND2X3),FD4(ND2X3),FD5(ND2X3) DIMENSION IPACK(ND5),IWORK(ND5),DATA(ND5),ICALLD(L3264W,ND5) DIMENSION IPLAIN(L3264W,4) DIMENSION IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7) DIMENSION LSTORE(12,ND9) DIMENSION CORE(ND10) DIMENSION TELEV(NX*NY),SEALND(NX*NY),CPNDFD(NX*NY) DIMENSION MTABLE(ND16+1,3) DIMENSION ID(4),IDPARS(15),JD(4),LD(4),LDPARS(15),MD(4),JP(3), 1 KFILRA(6),JDATE(4),ISTOP(2),IRACK(8),NGRIDT(6), 2 IPROB(5),ICAT(10),JPROB(6),ITRP(6) DIMENSION NVRBL(15,3) DIMENSION ITABLE(4,IDIM) C EQUIVALENCE (RACK,IRACK) C ALLOCATABLE PROB(:,:),XPROB(:,:) C DATA ITABLE/000000000,000000000,000000000,2, !DUMMY FOR VSBY 1 228060233,000000000,708000233,0, !CIG HRRR PROB, 3LAGGED 2 228070205,228081005,708000295,0/ !CIG LAMP/HRRR MELD C PROBABILITY THRESHOLD CATEGORICAL PREDICTAND C/V SCALING ENTRY IN TABLE C IN THE TABLE ABOVE, C THE FIRST VALUE IS THE U755.CN PROBABILITY BEING PUT ONTO A C GRID. IT MUST MATCH VALUE IN THE CN755.CN. THE SECOND VALUE C IS THE ID OF THE CATEGORICAL FORECASTS, IF MADE. THE 3RD C VALUE IS THE ID OF THE PREDICTAND IN THE EQUATIONS. THE 4TH C VALUE IS THE DECIMAL SCALING FACTOR FOR THE CATEGORICAL C FORECASTS. C DATA CPLAIN/' GLMP HRRR MELD VIS PROB ', 1 ' GLMP HRRR MELD VIS CAT ', 2 ' 3HRRR PROB ', 3 ' 3HRRR CAT ', 4 ' GLMP HRRR MELD CIG PROB ', 5 ' GLMP HRRR MELD CIG CAT '/ C CALL TIMPR(KFILDO,KFILDO,'START MELD71 ') C CCCC WRITE(KFILDO,100)ND1,ND14,ND15,ND2X3,ND5,ND7, CCCC 1 ND9,ND10,ND16,NX,NY CCCC 100 FORMAT(' IN MELD71--ND1,ND14,ND15,ND2X3,ND5,ND7,', CCCC 1 'ND9,ND10,ND16,NX,NY'/20I8) WRITE(KFILDO,100)EQNNAM,KFILEQ 100 FORMAT(' EQNNAM = ',A60,' ON UNIT NO.',I4) C IER=0 C C READ THE PROBS CONTROLS. DUMMY IS A NAME IN .CN FOR VISUAL C IDENTIFICATION. FIRST 3 RECORDS IN FILE READ IN CN755. C READ(INLTAB,101)DUMMY,(IPROB(J),J=1,5) 101 FORMAT(A6,20I4) WRITE(KFILDO,102)DUMMY,(IPROB(J),J=1,5) 102 FORMAT(1X,A6,20I4) C IF(DUMMY.NE.'PROBS ')THEN WRITE(KFILDO,1021)DUMMY 1021 FORMAT(/' ****PROCESSOR READ = ',A6,' SHOULD HAVE BEEN PROBS', 1 ' STOP IN MELD71 AT 1021.') CALL W3TAGE('MELD71') STOP 1021 ENDIF C C READ THE CUMULATIVE CATEGORICAL CONTROLS. C READ(INLTAB,101)DUMMY,(ICAT(J),J=1,10) WRITE(KFILDO,102)DUMMY,(ICAT(J),J=1,10) C IF(DUMMY.NE.'CCATS ')THEN WRITE(KFILDO,1022)DUMMY 1022 FORMAT(/' ****PROCESSOR READ = ',A6,' SHOULD HAVE BEEN CCATS', 1 ' STOP IN MELD71 AT 1022.') CALL W3TAGE('MELD71') STOP 1022 ENDIF C C READ THE DISCRETE CATEGORICAL CONTROLS. C READ(INLTAB,101)DUMMY,(JPROB(J),J=1,6) WRITE(KFILDO,102)DUMMY,(JPROB(J),J=1,6) C IF(DUMMY.NE.'DPROB ')THEN WRITE(KFILDO,1023)DUMMY 1023 FORMAT(/' ****PROCESSOR READ = ',A6,' SHOULD HAVE BEEN DPROB', 1 ' STOP IN MELD71 AT 1023.') CALL W3TAGE('MELD71') STOP 1023 ENDIF C C READ THE INTERPOLATION CONTROLS. C READ(INLTAB,101)DUMMY,(ITRP(J),J=1,6) WRITE(KFILDO,102)DUMMY,(ITRP(J),J=1,6) C IF(DUMMY.NE.'INTRP ')THEN WRITE(KFILDO,1024)DUMMY 1024 FORMAT(/' ****PROCESSOR READ = ',A6,' SHOULD HAVE BEEN INTRP', 1 ' STOP IN MELD71 AT 1024.') CALL W3TAGE('MELD71') STOP 1024 ENDIF C C READ THE FILE NAME FOR THE REGIONAL WEIGHTS. C IF(IREG.GT.1)THEN READ(INLTAB,1025)DUMMY,KFILWT,WTNAM 1025 FORMAT(A6,I4,2X,A60) C IF(DUMMY.NE.'WTTIL ')THEN WRITE(KFILDO,1026)DUMMY,WTFIL 1026 FORMAT(/' ****PROCESSOR READ = ',A6,' SHOULD HAVE BEEN', 1 ' INTRP. STOP IN MELD71 AT 1026.') CALL W3TAGE('MELD71') STOP 1025 ENDIF C ENDIF C NXY=NX*NY C NXY IS THE SIZE OF THE GRID IN THE ARRAYS OF SIZE ND2X3. C C FOR DEVELOPOMENT: C THE NAME OF THE EQUATION FILE FOR ONE PROJECTION IS C IN U755.CN. BECAUSE THE .CN IS NOT PROJECTION SPECIFIC, C THE PROJECTION MUST BE MODIFIED FOR THE SPECIFIC C PROJECTION. THIS IS DONE IN RVSNAM. C FOR OPERATIONS: C ALL PROJECTIONS ARE ON NONE FILE. THE ONLY C IDENTIFICAION BY PROJECTION IS THE TAU FOR THE C PREDICTANDS. C IF(IOPER.EQ.0)THEN C THIS IS DEVELOPMT MODE. CALL RVSNAM(KFILDO,EQNNAM,IDPARS(12),IER) C IF(IER.NE.0)THEN CALL W3TAGE('MELD71') STOP 107 ENDIF C ENDIF C C IF THERE IS AN ERROR, IT WILL BE REPORTED IN RVSNAM. C READ THE EQUATIONS PRODUCED BY U602. THE FILE NAME C AND UNIT NUMBER COME FROM THE CN7 CONTROL FILE READ C IN CN755. C C OPEN THE EQUATION FILE UNLESS IT IS ALREADY OPEN. C INQUIRE(UNIT=KFILEQ,ACCESS=CFIOP) C IF(CFIOP.NE.'SEQUENTIAL')THEN WRITE(KFILDO,106)CFIOP 106 FORMAT(/' CFIOP = ',A10) STATE='107 ' OPEN(UNIT=KFILEQ,FILE=EQNNAM,STATUS='OLD',IOSTAT=IOS,ERR=505) WRITE(KFILDO,107)EQNNAM,KFILEQ 107 FORMAT(/' OPENING FILE ',A60,' ON UNIT NO.',I4) C ENDIF C DO_500: DO 500 MSET=1,1000 C C****************THIS MAY HAVE RELEVANCE FOR REGIONAL EQUATIONS. C C THIS IS A DUMMY LOOP TO KEEP FROM HAVING A BACKWARD GO TO. C NST LE ND13 CHECKED IN RDEQNM. THE EQNNAM FURNISHED TO C RDEQNM IS THE FILE NAME. NSET IS THE NUMBER OF C REGIONAL EQUATIONS; = 1 FOR GENERALIZED EQUATIONS. C RETURNED FROM RDEQNM. C C READ THE EQUATION FILE DOWN TO STATION LIST. C C THE HEADER IS READ ONLY ONCE. 108 CALL RDEQHR(KFILDO,KFILEQ,IP18,EQNNAM,IOPER,NDATE, 1 MTANDS,IDTAND,ND15,IER) IF(IER.NE.0)THEN C THIS MAY BE JUST THE END OF A PROJECTION. IT WOULD C LIKELY INDICATE TRYING TO EVALUATE A PROJECTION FOR C WHICH THERE ARE NO EQUATIONS. WRITE(KFILDO,109)IER 109 FORMAT(/' AT 109--IER',I4) CALL W3TAGE('MELD71') STOP 109 ENDIF C CALL RDEQNM(KFILDO,KFILEQ,EQNNAM, 1 IP18, 2 CCALLR,NSTA1, 3 NSET, 4 MTRMS,MTANDS, 5 IDEQN, 6 ECONST, 7 AVG,CORR, 8 COEF, 9 ND14,ND15,ND5,ND13,IER) CCCC WRITE(KFILDO,110)IOPER,MSET,NSET,IDPARS(12),IER CCCC 110 FORMAT(/' AT 110 IN MELD71--IOPER,MSET,NSET,IDPARS(12),IER',5I6) C IF(IER.NE.0)THEN ISTOP(1)=ISTOP(1)+1 C ISTOP( ) INCREMENTED EVEN WITH A STOP, IN CASE THE C STOP IS PULLED OUT. ALL ERRORS ARE DOCUMENTED IN C RDEQNM. C 169 = NSET GT ND13. C 167 = MUMBER OF TERMS IN EQUATIONS GT ND14. C 168 = SYSTEM READING ERROR. CALL W3TAGE('MELD71') STOP 110 ENDIF C C MAKE SURE THE EQUATION FILE MATCHES THE PROJECTION. C MTAU=IDTAND(3,1)-(IDTAND(3,1)/1000)*1000 C IF(IOPER.EQ.0)THEN C THIS IS DEVELOPMENT MODE. IF(MTAU.NE.IDPARS(12))THEN WRITE(KFILDO,112)MTAU,IDPARS(12) 112 FORMAT(/' ****PROJECTION OF EQUATIONS =',I4, 1 ' NOT EQUAL TO THE PROJECTION DESIRED =',I4, 2 '. ABORT.') ISTOP(1)=ISTOP(1)+1 IER=777 CALL W3TAGE('MELD71') STOP 112 ENDIF C ELSE C THIS IS OPERATIONAL MODE. IF(MTAU.LT.IDPARS(12))THEN WRITE(KFILDO,1125)MTAU 1125 FORMAT(/' EQUATION FOR PROJECTION',I4, 1 ' BEING SKIPPED ON INPUT EQUATION FILE.') CCCCC CYCLE DO_500 GO TO 108 ELSEIF(MTAU.GT.IDPARS(12))THEN WRITE(KFILDO,112)MTAU,IDPARS(12) ISTOP(1)=ISTOP(1)+1 IER=777 CALL W3TAGE('MELD71') STOP 1125 ENDIF C ENDIF C D WRITE(KFILDO,1127)MTAU,IDPARS(12) D1127 FORMAT(/' AT 1127--MTAU,IDPARS(12)',2I6) C C A DROP THROUGH HERE MEANS THE CORRECT CYCLE HAS BEEN C READ. C C THE EQUATIONS FOR ALL PREDICTANDS FOR THIS PROJECTION IN C THE SERIES HAVE BEEN READ. C IF(MTANDS.GT.ND15)THEN WRITE(KFILDO,113) 113 FORMAT(/' ****MTANDS GT ND15 AND THE VALUES IN TABLE( , )', 1 ' ABORT IN MELD71.') ISTOP(1)=ISTOP(1)+1 IER=777 CALL W3TAGE('MELD71') STOP 113 ENDIF C IF(NSET.NE.IREG)THEN WRITE(KFILDO,1135)NSET,IREG 1135 FORMAT(' ****NUMBER OF REGIONAL EQUATIONS READ NSET =',I4, 1 ' DOES NOT EQUAL NUMBER OF EXPECTED IREG =',I4, 2 '. ABORT IN MELD71 AT 1135.') ISTOP(1)=ISTOP(1)+1 IER=777 CALL W3TAGE('MELD71') STOP 1135 ENDIF C C SET UP ALLOCATED STORAGE FOR THE GRIDS NEEDED. C DEALLOCATE(XPROB,PROB,STAT=IOS) ALLOCATE (XPROB(NXY,MTANDS),PROB(NXY,MTANDS),STAT=IOS) C IF(IOS.EQ.1)THEN WRITE(KFILDO,114) 114 FORMAT(/' ****ALLOCATION OF XPROB( , ), PROB( , ) FAILED IN', 1 ' MELD71 AT 114. ARRAYS ALREADY ALLOCATED.', 2 ' ABORT IN MELD71.') ISTOP(1)=ISTOP(1)+1 IER=777 CALL W3TAGE('MELD71') STOP 114 ELSEIF(IOS.EQ.2)THEN WRITE(KFILDO,115) 115 FORMAT(/' ****ALLOCATION OF XPROB( , ), PROB( , ) FAILED IN', 1 ' MELD71 AT 115. ARRAYS NOT ALLOCATED.', 2 ' ABORT IN MELD71.') ISTOP(1)=ISTOP(1)+1 IER=777 CALL W3TAGE('MELD71') STOP 115 ENDIF C C SET IDWRTP AND IDWRTC TO THE 1ST WORD OF THE RECORD C TO WRITE FOR THE PROBABILITY AND CATEGORICAL FORECASTS, C RESPECTIVELY. C DO 116 LL=1,IDIM C IF(IDTAND(1,1).EQ.ITABLE(3,LL))THEN C ALL FIRST WORDS FOR THIS PREDICTAND ARE THE SAME. IDWRTP=ITABLE(1,LL) IDWRTC=ITABLE(2,LL) IDWDD=IDPARS(4) C THE ABOVE IS THE DD TO WRITE. IPOS=LL C IPOS( ) IS THE LOCATION OF THE PREDICTAND IN THE C ITABLE( , ) AND CPLAIN( , ). C D WRITE(KFILDO,1155)LL,IDTAND(1,1),IDWRTP,IDWRTC, D 1 IDWDD D1155 FORMAT(' AT 1155--LL,IDTAND(1,1),IDWRTP,IDWRTC,', D 1 'IDWDD',I4,3I12.9,I4) GO TO 118 ENDIF C 116 CONTINUE C WRITE(KFILDO,117)IDTAND(1,MM) 117 FORMAT(/' ****COULD NOT FIND 1ST WORD ID OF VARIABLE',I10.9, 1 ' IN ITABLE(3, ). STOP IN MELD71 AT 117.') WRITE(KFILDO,1170)((ITABLE(I,J),I=1,5),J=1,IDIM) 1170 FORMAT(/,' ITABLE IS:',//,(4I10.9,I4)) CALL W3TAGE('MELD71') STOP 117 C COMPUTE NVRBL(N,J) C J=1, THE ID OF THE PREDICTAND IN THE EQUATION. C J=2, THE STARTING LOCATION IN THE EQUATION LIST OF C N'TH DIFFERENT ID. C J=2, THE NUMBER OF CATEGORIES (THRESHOLDS) FOR THE C N'TH DIFFERENT ID. C 118 N=1 NVRBL(N,1)=IDTAND(1,1) NVRBL(N,2)=1 NVRBL(N,3)=1 C DO 1184 MM=2,MTANDS C D WRITE(KFILDO,1183)N,MM,NVRBL(N,1),IDTAND(1,MM) D1183 FORMAT(/' AT 1183--N,MM,NVRBL(N,1),IDTAND(1,MM)',2I3,2I11) C IF(NVRBL(N,1).EQ.IDTAND(1,MM))THEN NVRBL(N,3)=NVRBL(N,3)+1 C ELSE N=N+1 NVRBL(N,1)=IDTAND(1,MM) NVRBL(N,2)=MM NVRBL(N,3)=1 ENDIF C 1184 CONTINUE C NOVRBL=N C ON LOOP EXIT, THE NUMBER OF VARIABLES IN THE EQUATIONS C IS N; SET NOVRBL. C WRITE(KFILDO,1185) 1185 FORMAT(/' POSITION IN THE IDTAND LIST OF EACH VARIABLE TO', 1 ' MAKE FORECASTS FOR, AND THE NUMBER OF THRESHOLDS', 2 ' FOR EACH') C DO 1189 N=1,NOVRBL WRITE(KFILDO,1186)(NVRBL(N,J),J=1,3) 1186 FORMAT(3X,I11.9,2I4) C IF(ICAT(1).NE.0)THEN C IF CATEGORICAL FORECASTS ARE NOT TO BE MADE, THE ABOVE C WAS NOT NECESSARY. IF(NVRBL(N,2).EQ.0.OR.NVRBL(N,3).EQ.0)THEN WRITE(KFILDO,1187)NVRBL(N,1),(IDTAND(1,MM),MM=1,MTANDS) 1187 FORMAT(/,' ****ERROR FINDING VARIABLE',I10, 1 ' IN PREDICTANDS IN EQUATIONS.', 2 ' STOP AT 1187 IN MELD71. PREDICTANDS ARE:',/, 3 (I10)) CALL W3TAGE('MELD71') STOP 1187 ENDIF C ENDIF C 1189 CONTINUE C c MAKE FORECASTS FOR ALL EQUATIONS. c C INITIALIZE PROB( , ) WITH THE CONSTANT FOR EACH PREDICTAND. C DO 120 MM=1,MTANDS DO 119 J=1,NXY XPROB(J,MM)=ECONST(1,MM) 119 CONTINUE 120 CONTINUE C CCCC WRITE(KFILDO,1200)IDCNT,MTRMS(1),NSET CCCC 1200 FORMAT(/' AT 1200--IDCNT,MTRMS(1),NSET',3I10) CCCC WRITE(KFILDO,1201)(XPROB(J,MTANDS),J=1,20) CCCC 1201 FORMAT(/' AT 1201--(XPROB(J,MTANDS),J=1,20)'/ CCCC 1 (10F10.2)) C C READ THE PREDICTOR GRIDS SPECIFIED IN IDEQN(J,NSET,M) C (M=1,MTRMS) ONE AT A TIME INTO FD2( ). MTABLE( , ) HOLDS C THE CORRESPONDENCE BETWEEN THE VECTOR PREDICTOR ID AND C THE GRIDPOINT ID; READ IN IN INT755. LOOP OVER ALL C REGIONS. IF THE EQUATIONS ARE GENERAL OPERATOR iIERG=1), C THAT IS OK. C D WRITE(KFILDO,1204)NSET,MTRMS(1),IDCNT D1204 FORMAT(/' AT 1204--NSET,MTRMS(1),IDCNT',3I6) C DO 149 L=1,NSET C DO 145 M=1,MTRMS(1) C DO 121 N=1,IDCNT C IF(IDEQN(1,NSET,M)/1000.EQ.MTABLE(N,1)/1000)THEN CCCC WRITE(KFILDO,1205)(MTABLE(N,J),J=1,3) CCCC 1205 FORMAT(/' AT 1205--(MTABLE(N,J),J=1,3)',3I12) GO TO 123 ENDIF C 121 CONTINUE C WRITE(KFILDO,122)IDEQN(1,NSET,M) 122 FORMAT(/' ****DID NOT FIND PREDICTOR',I10.9,' IN MTABLE( , ).', 1 ' FATAL ERROR. STOP IN MELD71 AT 122.') CALL W3TAGE('MELD71') STOP 122 C 123 ITIME=3 C ITEME=3 ACTIVATES RR. LD(1)=MTABLE(N,2) LD(2)=IDEQN(2,NSET,M) LD(3)=IDEQN(3,NSET,M) LD(4)=IDEQN(4,NSET,M) 124 CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,FD2,NXY, 2 NWORDS,NPACK,NDATE,NTIMES,CORE,ND10, 3 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B, 4 ITIME,IER) IF(MISSP.NE.0)MISTOT=MISTOT+1 IF(IER.EQ.47.AND.LD(4).NE.0)THEN C SOME VARIABLES WILL HAVE THE THRESHOLD AND SOME WILL NOT. C FOR INSTANCE, A CONTINUOUS FIELD LIKE OBS CIG HEIGHT WILL C HAVE A BINARY MADE FROM THE CONTINUOUS. LD(4)=0 GO TO 124 CCCC ELSE CCCC WRITE(KFILDO,1245)NWORDS CCCC 1245 FORMAT(' RETURNED ',I8,'WORDS.') ENDIF C IF(IER.NE.0)THEN WRITE(KFILDO,125)IER,(LD(J),J=1,4) 125 FORMAT(/' ****IER = ',I4,' FROM GFETCH IN MELD71 LOOKING FOR', 1 4I10,' ABORT RUN AT 125 IN MELD71.') ISTOP(1)=ISTOP(1)+1 ISTOP(2)=ISTOP(2)+1 IER=777 GO TO 505 ENDIF C CCCC WRITE(KFILDO,125)(LD(J),J=1,4),ND9,LITEMS,ND5,NWORDS,NBLOCK, CCCC 1 NFETCH,NSLAB,ND10,MISSP,MISSS,L3264B,IER, CCCC 2 (IS2(J),J=1,12) CCCC 125 FORMAT(' AT 125 IN MELD71--(LD(J),J=1,4),ND9,LITEMS,ND5,', CCCC 1 'NWORDS,NBLOCK,NFETCH,NSLAB,ND10,MISSP,MISSS,', CCCC 2 'L3264B,IER,(IS2(J),J=1,12)',/,4I12/12I10/12I10) C IF(NWORDS.NE.NXY)THEN WRITE(KFILDO,127)NWORDS,NXY 127 FORMAT(/' ****NUMBER OF WORDS READ BY GFETCH =',I8, 1 ' NOT EQUAL TO THE GRID SIZE =',I8,'. ABORT', 2 ' IN MELD71.') ISTOP(1)=ISTOP(1)+1 IER=777 GO TO 505 CCCC ELSE CCCC WRITE(KFILDO,128)(FD2(J),J=NXY/2,NXY/2+300) CCCC 128 FORMAT(' AT 128 IN MELD--(FD2(J),J=NXY/2,NXY/2+300)',/, CCCC 1 (15F8.2)) ENDIF C C USE THE FORECASTS IN FD2( ) TO MULTIPLY BY THE COEFFICIENTS. c SOME HAVE TO BE MADE BINARY. C CCCC WRITE(KFILDO,130)(LD(J),J=1,4),(FD2(J),J=1,100) CCCC 130 FORMAT(' AT 130--(LD(J),J=1,4),(FD2(J),J=1,100)', CCCC 1 4I12/(10F10.3)) C C MAKE PREDICTOR BINARY IF NECESSARY. C SAVE=FD2(10000) C SAVE IS FOR PRINT BELOW. IT IS THE VARIABLE READ BEFORE C MAKING A BINARY. C IF(MTABLE(N,3).EQ.1)THEN CALL PRSID2(KFILDO,IDEQN(1,NSET,M),LDPARS,THRESH) C THE ABOVE PARSES IDEQN( ,NSET,M) INTO LDPARS( ) AND THRESH. CCCCC WRITE(KFILDO,134)(MTABLE(N,J),J=1,3),THRESH CCCCC 134 FORMAT(/' AT 134--(MTABLE(N,J),J=1,3),THRESH',3I10,F10.5) C C DO 135 J=1,NXY C IF(FD2(J).LT.9998.9)THEN C IF THE FORECAST IS MISSING, LEAVE IT MISSING. C IF(FD2(J).GE.THRESH)THEN FD2(J)=1. ELSE FD2(J)=0. ENDIF C ENDIF C 135 CONTINUE C ENDIF C C MULTIPLY PREDICTOR BY COEFFICIENT. C ICOUNT=0 C DO 140 MM=1,MTANDS DO 139 J=1,NXY C C************* CCCC IF(FD2(J).LT.9996.9.AND.MOD(J,1000000).EQ.0)THEN CCCC WRITE(KFILDO,1380)J,MM,ICOUNT,COEF(NSET,M,MM),FD2(J) CCCC 1380 FORMAT(' J,MM,ICOUNT,COEF(NSET,M,MM),FD2(J)', CCC 1 3I10,F10.5/(11F10.4)) CCCC ICOUNT=ICOUNT+1 CCCC ENDIF C************* C IF(FD2(J).LT.9998.9.AND.XPROB(J,MM).LT.9998.9)THEN XPROB(J,MM)=XPROB(J,MM)+COEF(NSET,M,MM)*FD2(J) ELSE XPROB(J,MM)=9999. ENDIF 139 CONTINUE C D WRITE(KFILDO,1395)MM,M,XPROB(10000,MM),COEF(NSET,M,MM), D 1 SAVE,FD2(10000) D1395 FORMAT(/' AT 1395--MM,M,XPROB(10000,MM),COEF(NSET,M,MM),', D 1 'SAVE,FD2(10000)',2I4,4F12.5) 140 CONTINUE C 145 CONTINUE C C FORECASTS FOR A REGION HAVE BEEN MADE IN XPROB( , ). C THESE ARE TRANSFERRED INTO PROB( , ) AFTER BEING C MULTIPLIED BY THE REGIONAL WEIGHTS, IF THERE IS C MORE THAN ONE REGION. C IF(IREG.GT.1)THEN MD(1)=449000000+NPROJ*100000+5*0000+IREG C THIS IS FOR THE MAP PROJECTION USED AND A 2.5-KM MESH. C THE REGION NUMBER IS IN THE DD. C IF(JDATE(2).GE.4.AND.JDATE(2).LE.9)THEN MD(2)=JDATE(4)*1000000+170000 C IT IS ASSUMED THE STANDARD 6-MONTH STRATIFICATION C IS USED (THE 17 FOR THE WARM SEASON). (SEE ON C 00-01M P.14.2.) ELSE MD(2)=JDATE(4)*1000000+180000 ENDIF C MD(3)=0 MD(4)=0 PLAINT='REGIONAL WEIGHTS ' C DO_148: DO 148 LLL=1,NUMRA C IF(KFILRA(LLL).GE.42.AND.KFILRA(LLL).LE.44)THEN C CALL CONSTG(KFILDO,KFILRA(LLL),RACESS(LLL),MD, 1 IPACK,IWORK,FD4,ND5, 2 IS0,IS1,IS2,IS4,ND7, 3 ISTAV,L3264B,IER) C IF(IER.NE.0)THEN WRITE(KFILDO,1454)IER 1454 FORMAT(' ERROR IN CONSTG FROM MELD71 AT 1454.', 1 ' IER =',I4,'. IT MAY JUST INCORRECT UNIT', 2 ' NUMBER. NOS. 42, 43 AND 44 ARE TRIED.') ISTOP(2)=ISTOP(2)+1 ELSE WRITE(KFILDO,1455)LLL 1455 FORMAT(/' REGION NO.',I4,' WEIGHT READ.') C DO 147 M=1,MTANDS DO 146 J=1,NXY C IF(PROB(J,M).LT.9998.9.AND.XPROB(J,M).LT.9998.9)THEN PROB(J,M)=PROB(J,M)+XPROB(J,M)*FD4(J) ELSE PROB(J,M)=9999. ENDIF C 146 CONTINUE 147 CONTINUE C ENDIF C ENDIF C 148 END DO DO_148 C ELSE C THERE IS ONLY ONE REGION, SO TRNSFER XPROB( , ) INTO C PROB( , ). C DO 1485 M=1,MTANDS DO 1485 J=1,NXY PROB(J,M)=XPROB(J,M) 1485 CONTINUE 1486 CONTINUE C ENDIF C 149 CONTINUE C C ALL EQUATIONS HAVE BEEN EVALUATED. C C TRUNCATE THE PROBABILITIES TO 0 AND 1. IF THE CONSTANT C OF AN EQUATION IS 9997, IT MEANS THE PROBABILITY IS C TREATED AS ZERO. DO THAT HERE. C DO 1493 MM=1,MTANDS DO 1492 J=1,NXY C IF(PROB(J,MM).LT.9998.9)THEN IF(NINT(PROB(J,MM)).EQ.9997)PROB(J,MM)=0. PROB(J,MM)=MAX(PROB(J,MM),0.) PROB(J,MM)=MIN(PROB(J,MM),1.) ENDIF C 1492 CONTINUE 1493 CONTINUE C C CLIP TO THE NDFD, OR OTHER, AREA IF DESIRED AND THE C THE CLIPPING GIRD IS AVAILABLE. JP(1) = 1 INDICATES C CLIPING IS DESIRED. NCLIPY = 1 INDICATES THE GRID C IS AVAILABLE. CLIPING THE PROBABILITY GRIDS WILL C CAUSE THE CATEGORICAL GRIDS, IF MADE, TO BE CLIPPED, C ALSO C IF(JP(1).EQ.1)THEN C IF(NCLIPY.EQ.1)THEN C WRITE(KFILDO,1498) 1498 FORMAT(/' CLIPING PROBABILITY GRIDS') C DO 1503 MM=1,MTANDS C DO 1502 JJ=1,NXY C IF(CPNDFD(JJ).LT..5)THEN PROB(JJ,MM)=9999. ENDIF C 1502 CONTINUE C 1503 CONTINUE C ELSE WRITE(KFILDO,1504) 1504 FORMAT(' ****CLIPPING OF THE GRID TO NDGD AREA DESIRED', 1 ' BUT CLIPPING GRID NOT AVAILABLE. PROCEEDING.') ISTOP(1)=ISTOP(1)+1 ENDIF C ENDIF C C AT EACH GRIDPOINT, MAKE THE PROBABILITY OF A CATEGORY LE C THE PROBABILITY OF THE NEXT HIGHER ONE. THIS IS C CONSISTENT WITH THE WAY MONPRB WORKS FOR CUMULATIVE FROM C BELOW PROBABILITIES. VALUES OF 9997 HAVE BEEN SET TO 0. C NOTE THAT THIS OPERATES ON CLIPPED GRIDS, IF GRIDS ARE C CLIPPED C JCOUNT=0 C DO 1509 MM=MTANDS,2,-1 C IF(IDTAND(1,MM).EQ.IDTAND(1,MM-1))THEN C ICOUNT=0 C DO 1505 J=1,NXY C IF(PROB(J,MM).LT.9998.9.AND.PROB(J,MM-1).LT.9998.9)THEN C IF(PROB(J,MM-1).GT.PROB(J,MM))THEN PROB(J,MM-1)=PROB(J,MM) ICOUNT=ICOUNT+1 ENDIF C ENDIF C 1505 CONTINUE C IF(ICOUNT.GT.0)THEN C IF(JCOUNT.EQ.0)THEN WRITE(KFILDO,1506) 1506 FORMAT(/) JCOUNT=1 ENDIF WRITE(KFILDO,1507)MM-1,IDTAND(4,MM-1),(IDTAND(J,MM),J=1,3), 1 ICOUNT,IDTAND(4,MM) 1507 FORMAT(' LEVEL',I4,' =',I11,' OF ',3I10,' MODIFIED',I8, 1 ' TIMES TO BE CONSISTENT WITH THE LEVEL ABOVE =',I10) ENDIF C ELSE WRITE(KFILDO,1508)MM-1,(IDTAND(J,MM-1),J=1,4) 1508 FORMAT(' LEVEL',I4,' CHECKING OF ',3I10.9,I10, 1 ' WITH PREVIOUS VARIABLE SKIPPED.') ENDIF C 1509 CONTINUE C C THE PROBABILITIES FOR ALL MTANDS ARE NOW IN PROB( ,MM). C NOW PACK AND WRITE THE PROBABILITY GRIDS TO THE ARCHIVE C UNIT KFILIO AT MESH LENGTH MESH UNLESS KFILIO = 0 OR C IPROB(2) = 0. THE FIRST WORD ID COMES FROM IDWRTP( ) C PREPARED FROM THE TRANSITION TABLE ITABLE( , ). C LD(2)=ID(2) LD(3)=ID(3) ITAUM=0 NSEQ=0 C THE PROBABILITIES ARE DECIMAL, THE WAY THEY ARE WANTED C IN OPERATIONS. ISCALD SCALING IS *10**3. NCHAR=32 XMISSP=9999. XMISSS=0. C IF(IPROB(2).NE.0.AND.KFILIO.NE.0)THEN C DO 1515 MM=1,MTANDS C CCCCD CALL TIMPR(KFILDO,KFILDO,'CALLING PAWGTS ') LD(1)=IDWRTP LD(4)=IDTAND(4,MM) RACK=CPLAIN(1,IPOS) C CCCCD WRITE(KFILDO,151)MM,LD(1),LD(4) CCCCD151 FORMAT(/' AT 151--MM,LD(1),LD(4)',I4,2I12.9) C CALL PAWGTS(KFILDO,KFILIO,'KFILIO',IP16,NDATE, 1 LD,IDPARS(12),ITAUM,IDWDD,NSEQ,ISCALD, 2 NPROJ,ALATL,ALONL,ORIENT,MESH,XLAT,NX,NY, 3 PROB(1,MM),DATA,IWORK,IPACK,ND5,MINPK, 4 IS0,IS1,IS2,IS4,ND7, 5 IRACK,RACK,NCHAR, 6 XMISSP,XMISSS,LX,IOCTET, 7 NTOTBY,NTOTRC,L3264B,L3264W,IER) C PAWGTS WRITES TO IP16 WHEN NE 0. C IF(IER.NE.0)THEN WRITE(KFILDO,1510) 1510 FORMAT(/' ****ERROR IN PAWGTS IN MELD71 AT 151.') C THE MELD71 PROBABILITY GRID IS NOT WRITTEN TO KFILIO. ISTOP(1)=ISTOP(1)+1 JER=JER+1 IER=0 C THIS IS COUNTED AS A MAJOR ERROR BECAUSE A GRID C WAS NOT PRODUCED, BUT NOT WRITING A PROBABILITY C GRID DOES NOT STOP PROGRAM. ENDIF C 1515 CONTINUE C ENDIF C D CALL TIMPR(KFILDO,KFILDO,'START PACKING KFILOG') C NOW PACK AND WRITE THE PROBABILITY GRIDS TO THE DISPOSABLE C UNIT KFILOG AT MESH LENGTH MESH UNLESS KFILOG = 0. THE C PROBABILITIES ARE MULTIPLIED BY 100 SO THEY CAN BE MAPPED C BY GMOS_PLOT. THE PROBABILITIES ARE PACKED TO 3 PLACES, C AS SPECIFIED BY ISCALD. THE ONES MULTIPLIED CAN BE PACKED C TO ONE PLACE, HENSE THE ISCALD-2 IN THE CALL BELOW. C IF((IPROB(2).NE.0.AND.KFILIO.NE.0).OR. 1 (JPROB(1) .NE.0.AND.KFILOG.NE.0))THEN LD(2)=ID(2) LD(3)=ID(3) C DO 1521 MM=1,MTANDS C DO 1517 J=1,NXY C IF(PROB(J,MM).LT.9998.9)THEN FD3(J)=PROB(J,MM)*100. ELSE FD3(J)=PROB(J,MM) ENDIF C 1517 CONTINUE C CCCC WRITE(KFILDO,1518)ISCALD,MM,(FD3(J),J=1,20) CCCC 1518 FORMAT(/' IN MELD71 AT 1518--ISCALD,MM,(FD3(J),J=1,20)',2I4/ CCCC 1 (10F10.2)) CCCCD CALL TIMPR(KFILDO,KFILDO,'CALLING PAWGTS ') LD(1)=IDWRTP LD(4)=IDTAND(4,MM) C THE ONLY THING IN THE ID THAT CHANGES IS THE C THRESHOLD. GET THEM FROM THE EQUATIONS. RACK=CPLAIN(1,IPOS) CALL PAWGTS(KFILDO,KFILOG,'KFILOG',IP16,NDATE, 1 LD,IDPARS(12),ITAUM,IDWDD,NSEQ,ISCALD-2, 2 NPROJ,ALATL,ALONL,ORIENT,MESH,XLAT,NX,NY, 3 FD3,DATA,IWORK,IPACK,ND5,MINPK, 4 IS0,IS1,IS2,IS4,ND7, 5 IRACK,RACK,NCHAR, 6 XMISSP,XMISSS,LX,IOCTET, 7 JTOTBY,JTOTRC,L3264B,L3264W,IER) C PAWGTS WRITES TO IP16 WHEN NE 0. C IF(IER.NE.0)THEN WRITE(KFILDO,1520) 1520 FORMAT(/' ****ERROR IN PAWGTS IN MELD71 AT 1520.') C THE MELD71 PROBABILITY GRID IS NOT WRITTEN TO KFILOG. ISTOP(1)=ISTOP(1)+1 IER=0 C THIS IS NOT COUNTED AS A MAJOR ERROR WHEN WRITING C TO THE DISPOSABLE GRID. ENDIF 1521 CONTINUE C ENDIF C C NOW PACK AND WRITE THE PROBABILITY GRIDS TO THE C RANDOM ACCESS FILE AT MESH LENGTH MESH, WHEN KFILRA = 42. C THE PROBABILITIES ARE DECIMAL, THE WAY THEY ARE WANTED C IN OPERATIONS. SCALING IS *10**3. C DO 1526 JJ=1,NUMRA C IF(IPROB(4).NE.0)THEN C IF(KFILRA(JJ).EQ.42)THEN C LD(2)=ID(2) LD(3)=ID(3) XMISSP=9999. XMISSS=0. NGRIDT(1)=NPROJ NGRIDT(2)=NINT(DBLE(BMESH)*DBLE(1000000.)) C WITHOUT CONVERTING TO DOUBLE PRECISION, THE C THE MULTIPLICATION AND CONVERSION TO INTEGER C WAS OFF BY ONE UNIT FROM WHAT IS STORED WITH C INCOMING GRIDS, AND FROM WHAT WOULD BE EXPECTED. NGRIDT(3)=NINT(XLAT*10000.) NGRIDT(4)=NINT(ORIENT*10000.) NGRIDT(5)=NINT(ALATL*10000.) NGRIDT(6)=NINT(ALONL*10000.) NYR=JDATE(1) NMO=JDATE(2) NDA=JDATE(3) NHR=JDATE(4) ISCALE=0 C DO 1525 MM=1,MTANDS LD(1)=IDWRTP LD(4)=IDTAND(4,MM) RACK=CPLAIN(1,IPOS) C C THE IBM VERSION OF PACKGR IS PACKGR_OPER. C THE CALL SEQUENCE MAY VARY A BIT. C CALL PRSID1(KFILDO,LD,LDPARS) CALL PACKGR(KFILDO,KFILRA(JJ),RACESS(JJ),LD,LDPARS, 1 ISCALD,ISCALE,NGRIDT, 2 IRACK,NDATE,NYR,NMO,NDA,NHR, 3 FD2,PROB(1,MM),NXY,NX,NY,IPACK,IWORK,ND5, 4 MINPK,IS0,IS1,IS2,IS4,ND7, 5 XMISSP,XMISSS,NWORDS,NTOTGB,NTOTGR, 6 L3264B,L3264W,ISTOP,IER) C IF(IER.NE.0)THEN WRITE(KFILDO,1523)(LD(NN),NN=1,4),KFILRA(JJ),IER,MINPK 1523 FORMAT(' ****ERROR WRITING DATA FOR', 1 1X,I9.9,2I10.9,I11.3, 2 ' ON RANDOM ACCESS FILE UNIT NO.',I4,' IER =',I4, 3 '. MINPK =',I4) ISTOP(1)=ISTOP(1)+1 JER=JER+1 C ELSEIF(IP16.NE.0)THEN WRITE(IP16,1524)(LD(NN),NN=1,4),RACK,NDATE, 1 NX,NY,MESH,ALATL,ALONL 1524 FORMAT(/' WRITING DATA TO UNIT KFILRA',3I10.9,I10.3,3X, 1 A32,' FOR DATE',I12,/, 2 77X,'NX,NY,MESH,ALAT,ALON =',3I5,2F9.4) ENDIF C C 1525 CONTINUE C GO TO 1528 C ALL WRITING HAS BEEN DONE OR TRIED. GET OUT OF LOOP. ENDIF C ENDIF C 1526 CONTINUE C IF(IPROB(4).NE.0)THEN WRITE(KFILDO,1527) 1527 FORMAT(/' ****RANDOM ACCESS FILE UNIT NO. 42 NOT AVAILABLE', 1 ' FOR WRITING PROBABILITIES AND IPROB(4)', 2 'INDICATES WRITING. COUNT AS AN ERROR IN MELD71.') ISTOP(1)=ISTOP(1)+1 ENDIF 1528 CONTINUE C D DO 154 MM=1,MTANDS D WRITE(KFILDO,153)(PROB(J,MM),J=NXY/2,NXY/2+20) D153 FORMAT(' AT 153 IN MELD--(PROB(J,MM),J=NXY/2,NXY/2+20',/, D 1 (15F8.3)) D154 CONTINUE C C WRITE PROBABILITY FORECASTS TO IRA STORAGE IF DESIRED. C THESE MAY BE USED FOR FURTHER PROCESSING WHEN C IPROB(3) NE 0. THEY SHOULD HAVE THE ORIGIONAL DD. C IF(IPROB(3).NE.0)THEN LD(2)=ID(2) LD(3)=ID(3) C DO 1545 MM=1,MTANDS LD(1)=IDWRTP LD(4)=IDTAND(4,MM) RACK=CPLAIN(1,IPOS) C C GFETCH EXPECTS GRIDDED DATA TO BE PACKED, SO PACK C IT WITH PAKRET BEFORE WRITING TO IRA. C CCCC WRITE(KFILDO,1541)ITAUM,IDWDD,NSEQ,ISCALD,XMISSP,XMISSS CCCC 1541 FORMAT(' AT 1541--ITAUM,IDWDD,NSEQ,ISCALD,XMISSP,XMISSS', CCCC 1 4I6,2F10.4) C CALL PAKRET(KFILDO,NDATE, 1 LD,IDPARS(12),ITAUM,IDWDD,NSEQ,ISCALD, 2 NPROJ,ALATL,ALONL,ORIENT,MESH,XLAT,NX,NY, 3 PROB(1,MM),DATA,IWORK,IPACK,ND5,MINPK, 4 IS0,IS1,IS2,IS4,ND7, 5 IRACK,RACK,NCHAR, 6 XMISSP,XMISSS,LX,IOCTET, 7 L3264B,L3264W,IER) C IF(IER.NE.0)THEN WRITE(KFILDO,1542) 1542 FORMAT(/' ****ERROR IN PAKRET IN MELD71 AT 1542.', 1 ' FORECASTS ARE NOT WRITTEN TO INTERNAL', 2 ' STORAGE.'/ 3 ' THIS MAY CAUSE A MAJOR ERROR DOWNSTREAM.') C THE MELD71 PROBABILITY GRID IS NOT WRITTEN TO IRAS. ISTOP(1)=ISTOP(1)+1 IER=0 C ELSE C PAKRET RETURNS THE PACKED ARRAY IN IPACK CONSISTING C OF IOCTET OCTETS. WRITE TO INTERNAL RA STORAGE. C CALL GSTORE(KFILDO,KFIL10,LD,1,LSTORE,ND9,LITEMS, 1 IPACK,IOCTET*8/L3264B,2,0,NDATE, 2 CORE,ND10,LASTL,NBLOCK,LASTD,NSTORE,L3264B,IER) C "NPACK" IS STORED AS "2" SIGNIFYING PACKED GRIDDED DATA. C IF(IER.EQ.0)THEN C IF(IP16.NE.0)THEN WRITE(IP16,1543)(LD(JJ),JJ=1,4), 1 RACK,NDATE 1543 FORMAT(/' WRITING DATA TO UNIT KFIL10',3I10.9,I10.3, 1 3X,A32,' FOR DATE',I12) ENDIF C ELSE C A DIAGNOSTIC WILL HAVE OCCURRED IN GSTORE. ISTOP(1)=ISTOP(1)+1 C WRITING ERROR IS NOT CONSIDERED FATAL. IF DATA ARE C NEEDED AND CANNOT BE READ, IT WILL BE FATAL. WRITE(KFILDO,1544)(LD(JJ),JJ=1,4) 1544 FORMAT(' ERROR WRITING VARIABLE',3(1X,I9.9),1X,I10.3, 1 ' TO INTERNAL STORAGE.',/, 2 ' SOME COMPUTATIONS', 3 ' (PRE- OR POST-PROCESSING)', 3 ' MAY NOT BE ABLE TO BE MADE. PROCEEDING.') C NOT COUNTED AS A MAJOR ERROR. IF THE DATA ARE NEEDED C AND CAN'T BE FOUND, AN ERROR WILL OCCUR THERE. ENDIF C ENDIF C 1545 CONTINUE C ENDIF C C INERPOLATE TO STATIONS AND WRITE TO KFILOV WHEN DESIRED. C NOTE THAT IF GRIDS ARE CLIPPED, THEN INTERPOLATION IS ONLY TO C THE CLIPPED GRID. C IF(ITRP(1).EQ.4.AND.KFILOV.NE.0)THEN LD(2)=ID(2) LD(3)=ID(3) C DO 1548 MM=1,MTANDS LD(1)=IDWRTP LD(4)=IDTAND(4,MM) RACK=CPLAIN(1,IPOS) CALL INTRPC(KFILDO,PROB(1,MM),NX,NY,DIR,ND1,NSTA,SDATA) CALL PACKV(KFILDO,KFILOV,LD,IDPARS, 1 JP,ISCALD,0, 2 IRACK,RACK,NDATE,NYR,NMO,NDA,NHR, 3 CCALL,ISDATA,SDATA,ND1,NSTA,IPACK,ND5,MINPK, 4 IS0,IS1,IS2,IS4,ND7,XMISSP,XMISSS, 5 IP17,NWORDS,MTOTBY,MTOTRC, 6 L3264B,L3264W,ISTOP(1),IER) C IF(IER.NE.0)THEN WRITE(KFILDO,1546)(LD(J),J=1,4) 1546 FORMAT(' ****ERROR WRITING INTERPOLATED DATA TO KFILOV.', 1 ' PROCEEDING.') IER=0 ELSEIF(IP16.NE.0)THEN WRITE(IP16,1547)(LD(J),J=1,4), 1 IRACK,NDATE 1547 FORMAT(/' WRITING DATA TO UNIT KFILOV',3I10.9,I10.3,3X,8A4, 1 ' FOR DATE',I12) ENDIF C 1548 CONTINUE C ENDIF C CALL TIMPR(KFILDO,KFILDO,'START MAKING CAT FST') C IF(ICAT(1).EQ.0)THEN WRITE(KFILDO,1549) 1549 FORMAT(/' CATEGORICAL FORECASTS NOT BEING MADE.', 1 ' ICAT(1) = 0.'/) EXIT DO_500 C ELSEIF(IPROB(1).NE.1)THEN WRITE(KFILDO,155)IPROB(1) 155 FORMAT(/' IPROB(1) =',I3,'. CATEGORICAL FORECASTS NOT BEING', 1 ' MADE. IPROB(1)=2 FOR CUMULATIVE FROM ABOVE HAS NOT', 2 ' BEEN IMPLEMENTED.'/) EXIT DO_500 C ON TRANSFER, CATEGORICAL FORECASTS ARE NOT TO BE MADE C OR THEY ARE NOT CUMULATIVE FROM BELOW (CUMULATIVE FROM C ABOVE HAS NOT BEEN IMPLEMENTED). C THIS IS THE END OF PROCESSING FOR THIS EQUATION SET. ENDIF C C MAKE CATEGORICAL FORECASTS. C C THE PROBABILITIES FOR ALL MTANDS ARE NOW IN PROB( ,MM). C WHEN AN EQUATION CONSTANT = 9997, PROB( ,MM) WAS SET = 0. C THE CATEGORICAL FORECASTS ARE MADE IN CATMLG. C LD(1)=ITABLE(2,LL) LD(2)=ID(2) LD(3)=ID(3) LD(4)=ID(4) CALL PRSID2(KFILDO,LD,LDPARS,THRESH) C CALL CATMLG(KFILDO,KFIL10,IP12,KFILRA,RACESS,NUMRA, 1 LD,LDPARS,JD,IDPARS(12), 2 NDATE,CCALL,ISDATA,ND1,NSTA,P,ND2X3,NXY, 3 ICALLD,CCALLD,IPACK,IWORK,DATA,ND5, 4 LSTORE,ND9,LITEMS,CORE,ND10, 5 PROB,MTANDS,NBLOCK,NFETCH, 6 IS0,IS1,IS2,IS4,ND7, 7 L3264B,L3264W,ISTOP(1),IER) LD(1)=IDWRTC LD(2)=ID(2) LD(3)=ID(3) LD(4)=0 CALL PRSID2(KFILDO,LD,LDPARS,THRESH) C LD( ) AND LDPARS( ) ARE ALWAYS SET AND DON'T HAVE TO C BE SET AGAIN BELOW. C C CALL PIXEL SMOOTHER IF DESIRED. C IF(ICAT(5).GT.0)THEN C IF(NTELEV.NE.0)THEN ISPOT=ICAT(6) MTIMES=ICAT(7) DIFFV=ICAT(8) DIFFA=ICAT(9) CALL PIXSM1(KFILDO,LD,LDPARS,JD, 1 ISPOT,MTIMES,DIFFV,DIFFA, 2 P,NX,NY,TELEV,NX,NY,FD3,NXY, 3 L3264B,ISTOP,IER) C PIXSM1 REMOVES ISOLATED PIXELS. ELSE WRITE(KFILDO,240) 240 FORMAT(/' ****TERRAIN WAS NOT READ, SO PIXSM1 WAS', 1 ' NOT EXECUTED. FORECAST WILL BE PRODUCED', 2 ' WITHOUT IT.') ENDIF C ELSE WRITE(KFILDO,245) 245 FORMAT(/' PIXSM1 IS NOT BEING USED.') C ENDIF C C NOW PACK AND WRITE THE CATEGORICAL FORECAST GRIDS TO C THE ARCHIVE UNIT KFILIO AT MESH LENGTH MESH WHEN C ICAT(3) NE.0 AND KFILIO NE 0. RACK=CPLAIN(2,LL) IF(ICAT(2).NE.0.AND.KFILIO.NE.0)THEN ITAUM=0 NSEQ=0 ISCAL=ITABLE(4,LL) C SCALING SHOULD BE 2 FOR VIS AND 0 FOR CIG. C WRITE(KFILDO,250)LD,ISCAL 250 FORMAT(/' AT 250--DECIMAL SCALING FOR ', 1 3I12.9,I12.3,' IS',I4) C NCHAR=32 XMISSP=9999. XMISSS=0. CCCCC CALL TIMPR(KFILDO,KFILDO,'CALLING PAWGTS ') CALL PAWGTS(KFILDO,KFILIO,'KFILIO',IP16,NDATE, 1 LD,LDPARS(12),ITAUM,IDWDD,NSEQ,ISCAL, 2 NPROJ,ALATL,ALONL,ORIENT,MESH,XLAT,NX,NY, 3 P,DATA,IWORK,IPACK,ND5,MINPK, 4 IS0,IS1,IS2,IS4,ND7, 5 IRACK,RACK,NCHAR, 6 XMISSP,XMISSS,LX,IOCTET, 7 NTOTBY,NTOTRC,L3264B,L3264W,IER) C IF(IER.NE.0)THEN WRITE(KFILDO,251) 251 FORMAT(/' ****ERROR IN PAWGTS IN MELD71 AT 251.') C THE MELD71 PROBABILITY GRID IS NOT WRITTEN TO KFILIO. ISTOP(1)=ISTOP(1)+1 JER=JER+1 IER=0 C THIS IS COUNTED AS A MAJOR ERROR BECAUSE A GRID C WAS NOT PRODUCED, BUT NOT WRITING A PROBABILITY C GRID DOES NOT STOP PROGRAM. ENDIF C ENDIF C C NOW PACK AND WRITE THE CATEGORICAL GRIDS TO THE RANDOM C ACCESS FILE AT MESH LENGTH MESH WHEN ICAT(4) NE 0 AND C WHEN KFILRA = 42. C C IF(ICAT(4).NE.0)THEN C DO 270 JJ=1,NUMRA C IF(KFILRA(JJ).EQ.42)THEN ISCAL=ITABLE(4,LL) C SCALING SHOULD BE 2 FOR VIS AND 0 FOR CIG. RACK=CPLAIN(2,IPOS) XMISSP=9999. XMISSS=0. NGRIDT(1)=NPROJ NGRIDT(2)=NINT(DBLE(BMESH)*DBLE(1000000.)) C WITHOUT CONVERTING TO DOUBLE PRECISION, THE C THE MULTIPLICATION AND CONVERSION TO INTEGER C WAS OFF BY ONE UNIT FROM WHAT IS STORED WITH C INCOMING GRIDS, AND FROM WHAT WOULD BE EXPECTED. NGRIDT(3)=NINT(XLAT*10000.) NGRIDT(4)=NINT(ORIENT*10000.) NGRIDT(5)=NINT(ALATL*10000.) NGRIDT(6)=NINT(ALONL*10000.) NYR=JDATE(1) NMO=JDATE(2) NDA=JDATE(3) NHR=JDATE(4) ISCALE=0 C C THE IBM VERSION OF PACKGR IS PACKGR_OPER. C THE CALL SEQUENCE MAY VARY A BIT. C CALL PACKGR(KFILDO,KFILRA(JJ),RACESS(JJ),LD,LDPARS, 1 ISCAL,ISCALE,NGRIDT, 2 IRACK,NDATE,NYR,NMO,NDA,NHR, 3 FD2,P,NXY,NX,NY,IPACK,IWORK,ND5, 4 MINPK,IS0,IS1,IS2,IS4,ND7, 5 XMISSP,XMISSS,NWORDS,NTOTGB,NTOTGR, 6 L3264B,L3264W,ISTOP,IER) C IF(IER.NE.0)THEN WRITE(KFILDO,260)(LD(NN),NN=1,4),KFILRA(JJ),IER,MINPK 260 FORMAT(' ****ERROR WRITING DATA FOR', 1 3I10.9,I10.3,' ON RANDOM ACCESS FILE UNIT NO.', 2 I4,' IER =',I4,'. MINPK =',I4) ISTOP(1)=ISTOP(1)+1 ELSE C IF(IP16.NE.0)THEN WRITE(IP16,262)(LD(NN),NN=1,4),RACK,NDATE, 1 NX,NY,MESH,ALATL,ALONL 262 FORMAT(/' WRITING DATA TO UNIT KFILRA', 1 3I10.9,I10.3,3X,A32, 2 ' FOR DATE',I12,/, 3 77X,'NX,NY,MESH,ALAT,ALON =',3I5,2F9.4) ENDIF C ENDIF c GO TO 275 C ENDIF C ALL WRITING HAS BEEN DONE OR TRIED. GET OUT OF LOOP. C 270 CONTINUE C ELSE WRITE(KFILDO,271) 271 FORMAT(/' CATEGORICAL FORECASTS NOT WRITTEN TO EXTERNAL', 1 ' RANDOM ACCESS FILE.') ENDIF C WRITE(KFILDO,272) 272 FORMAT(/' ****RANDOM ACCESS FILE UNIT NO. 42 NOT AVAILABLE FOR', 1 ' WRITING CATEGORICAL FORECASTS IN MELD71. DO NOT', 2 ' COUNT AS MAJOR ERROR.') ISTOP(1)=ISTOP(1)+1 CCC JER=JER+1 CCC TO COUNT AS MAJOR ERROR, IMPLEMENT JER=JER+1 275 CONTINUE C C WRITE CATEGORICAL FORECASTS TO IRA STORAGE. THESE WILL C BE USED FOR CONSISTENCY CHECKING WHEN ICAT(3) NE 0. C IF(ICAT(3).NE.0)THEN C WRITE(KFILDO,280)LD 280 FORMAT(/' COMPUTED CATEGORICAL FORECASTS FOR VARIABLE ', 1 3I10.9,I10.3,' WRITTEN TO FILE', 1 ' IRA KFIL10.') C CALL GSTORE(KFILDO,KFIL10,LD,0,LSTORE,ND9,LITEMS, 1 P,NXY,1,0,NDATE, 2 CORE,ND10,LASTL,NBLOCK,LASTD,NSTORE,L3264B,IER) C "NPACK" IS STORED AS "1" SIGNIFYING NON-PACKED DATA. C IF(IER.EQ.0)THEN C IF(IP16.NE.0)THEN RACK=CPLAIN(2,IPOS) WRITE(IP16,282)(LD(JJ),JJ=1,4), 1 RACK,NDATE 282 FORMAT(/' WRITING DATA TO UNIT KFIL10',3I10.9,I10.3,3X, 1 A32,' FOR DATE',I12) ENDIF C ELSE C A DIAGNOSTIC WILL HAVE OCCURRED IN GSTORE. ISTOP(1)=ISTOP(1)+1 C WRITING ERROR IS NOT CONSIDERED FATAL. IF DATA ARE C NEEDED AND CANNOT BE READ, IT MAY BE FATAL. WRITE(KFILDO,284)(LD(JJ),JJ=1,4) 284 FORMAT(' ERROR WRITING VARIABLE',3(1X,I9.9),1X,I10.3, 1 ' TO INTERNAL STORAGE.',/, 2 ' SOME COMPUTATIONS (PRE- OR POST-PROCESSING)', 3 ' MAY NOT BE ABLE TO BE MADE. PROCEEDING.') C NOT COUNTED AS A MAJOR ERROR. ENDIF C ENDIF C C INTERPOLATE TO STATIONS AND WRITE TO KFILOV WHEN DESIRED. C IF(ITRP(2).EQ.4.AND.KFILOV.NE.0)THEN C CALL TIMPR(KFILDO,KFILDO,'STARTING INTRPC ') C LD( ) AND LDPARS( ) ARE SET ABOVE. C THE THRESHOLD IS ZERO FOR CATEGORICAL FORECASTS. ISCAL=ITABLE(4,LL) C SCALING SHOULD BE 2 FOR VIS AND 0 FOR CIG. RACK=CPLAIN(2,IPOS) C D WRITE(KFILDO,286)LD,ISCAL,LL D286 FORMAT(/' AT 286--DECIMAL SCALING FOR ', D 1 3I12.9,I12.3,' IS',I4,' LL =',I4) C CALL INTRPC(KFILDO,P,NX,NY,DIR,ND1,NSTA,SDATA) CALL PACKV(KFILDO,KFILOV,LD,LDPARS, 1 JP,ISCAL,0, 2 IRACK,RACK,NDATE,NYR,NMO,NDA,NHR, 3 CCALL,ISDATA,SDATA,ND1,NSTA,IPACK,ND5,MINPK, 4 IS0,IS1,IS2,IS4,ND7,XMISSP,XMISSS, 5 IP17,NWORDS,NTOTBY,NTOTRC, 6 L3264B,L3264W,ISTOP(1),IER) C IF(IER.NE.0)THEN WRITE(KFILDO,287)(ID(J),J=1,4) 287 FORMAT(' ****ERROR WRITING INTERPOLATED DATA TO KFILOV.', 1 ' PROCEEDING.') IER=0 ELSEIF(IP16.NE.0)THEN WRITE(IP16,288)(LD(J),J=1,4), 1 IRACK,NDATE 288 FORMAT(/' WRITING DATA TO UNIT KFILOV',3I10.9,I10.3,3X,8A4, 1 ' FOR DATE',I12) ENDIF C ENDIF C C WHENEVER CONTROL COMES HERE, ALL THRESHOLDS HAVE BEEN DEALT C WITH FOR THIS NN VARIABLE. C EXIT DO_500 500 END DO DO_500 C C CLOSE THE EQUATION FILE WNEN IN DEVELOPMENT MODE. THE UNIT C NUMBER MAY BE NEEDED AGAIN. FOR OPERATIONS, LEAVE FILE OPEN. C IF(IOPER.EQ.0)THEN CLOSE(UNIT=KFILEQ) ENDIF C 505 IF(IER.NE.0)THEN C THIS VARIABLE CANNOT BE COMPUTED. SET IT TO MISSING. WRITE(KFILDO,506) 506 FORMAT(/'****SETTING FORECASTS TO MISSING IN MELD71') C 510 DO 511 K=1,NSTA P(K)=9999. 511 CONTINUE C JER=JER+1 C WHEN THE GOOD CATEGORICAL GRID CANNOT BE RETURNED, IT IS C COUNTED AS A MAJOR ERROR. ENDIF C 600 CALL TIMPR(KFILDO,KFILDO,'END MELD71 ') C RETURN END