SUBROUTINE MELD70(KFILDO,KFILIO,KFILRA,RACESS,NUMRA,KFIL10, 1 KFILOG,KFILOV,INLTAB,KFILEQ,EQNNAM, 2 KFILVO,VOTNAM,IP12,IP16,IP17,IP18,IP19, 3 ID,IDPARS,JD,JP,ISCALD, 4 IWRITA,MODNO,IOPER,IREG, 5 NDATE,JDATE,CCALL,ICALLD,CCALLD,NAME,XP,YP, 6 STALAT,STALON,ISDATA,SDATA,NSTA,ND1, 7 DIR,NGRIDC,NGRID,ND11,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,NTOTVO, K L3264B,L3264W,MISTOT,ISTOP,JER,IER) C C MARCH 2017 GLAHN MDL LAMP C ADAPTED FROM U155 MELD C APRIL 2017 GLAHN CHANGING ND2 TO ND14 AND ND3 TO ND15 C APRIL 2017 GLAHN MODIFIED FOR MULTIPLE REGIONS; C USING RDEQNM VICE RDEQNG C APRIL 2017 GLAHN ADDED CCALL( , ) AND NSTA1 C JULY 2017 GLAHN MODIFIED USE OF "B" FOR HRRR IN C DO 150 LOOP; ADDED ISCALD TO CALL C JULY 2017 GLAHN ADDED JTOTBY, JTOTRC TO CALL AND USED C WHEN WRITING KFILOG; INSERTED COUNTING C PROB ERRORS BETWEEN LEVELS IN 1508 C LOOP C JULY 2017 GLAHN ADDED MTABLE, MPLAIN, IDCNT, ND16 TO C CALL IMPLEMENTED THEM C JULY 2017 GLAHN REMOVED ISPOT, MTIMES, DIFFV ,DIFFA C FROM CALL; IMPLEMENTED PIXSM1 C AUGUST 2017 GLAHN ADDED PAKRET TO PACK DATA BEFORE C WRITING TO IRA C AUGUST 2017 GLAHN REMOVED BA AND WRITEP C AUGUST 2017 GLAHN REVISED ITABLE( , ) C SEPTEMBER 2017 GLAHN REMOVED +IB TO DEFINE ID C SEPTEMBER 2017 GLAHN ADDED IDWRTP( ) AND IDWRTC( ) C SEPTEMBER 2017 GLAHN ADDED NOVRBL, NVRBL( , ) C OCTOBER 2017 GLAHN REMOVED MDIM; CHANGE IN FORMAT 1006 C OCTOBER 2017 GLAHN ADDED ENTRY 228003205 TO ITABLE( , ) C OCTOBER 2017 GLAHN ADDED IF TEST IN LOOP DO 220 C IF(P(J).LT.FD4(J)) C NOVEMBER 2017 GLAHN REMOVED 'IF(ID(1).EQ.ITABLE(1,1))THEN' C AT 104 C NOVEMBER 2017 GLAHN ADDED INTERPOLATION TO STATIONS, C INTRPC, PACKV; ADDED 6TH ROW TO C ITABLE( , ) C NOVEMBER 2017 GLAHN ADDED IDWDD; MODNO NOT USED C NOVEMBER 2017 GLAHN REMOVED DIMENSION OF IDWRTP AND IDWRTC C DECEMBER 2017 GLAHN EXTENSIVE MODS TO WRITE ALL FORECASTS C FROM EQUATIONS BUT NO OTHER PROCESSING; C REMOVED READING NVRBL; REMOVED IB C DECEMBER 2017 GLAHN CHANGED IDIS( ) TO JPROB( ) AND DCAT C TO DPROB C DECEMBER 2017 GLAHN ADDED PLAIN LANGUAGE FOR FORECASTS C DECEMBER 2017 GLAHN ADDED MISTOT C DECEMBER 2017 GLAHN MODIFIED FORMAT 280 C JUNE 2018 GLAHN REMOVED CLOUD LAYERS FROM ITABLE( , ) C AND CPLAIN( , ). SET IDEM TO 3 C JUNE 2018 GLAHN COPIED MELD70 TO MELD71 C JUNE 2018 GLAHN CHANGED NAME MELD71 TO MELD70 C JULY 2018 GLAHN REMOVED DIMENSIONS OF IDWRTP, IDWRTC, C AND IPOS; ELIMINATED TABLE( , ), KDIM C JULY 2018 GLAHN ADDED MTOTBY AND MTOTRC TO CALL; C REVISED ITABLE( , ) C JULY 2018 GLAHN ENABLED ICAT(10), SWITCH TO MAKE C OR NOT MAKE PROB LEVELS CONSISTENT C JULY 2018 GLAHN INSERTED CALL TO OPT755 C AUGUST 2018 GLAHN ADDED IP12 TO CALL C DECEMBER 2018 GLAHN CHANGED DD=33 TO 03 IN ITABLE( , ) C DECEMBER 2018 GLAHN ADDED PREDICTOR LOOKBACK FEATURE WHEN C DATA NOT FOUND AT DO 1245 C FEBRUARY 2019 GLAHN SUBSTITUTED IDWRTC FOR IDTABLE(2, ) C NEAR 160 C MAY 2019 GLAHN CORRECTED ITWRTC TO IDWRTC C MAY 2019 GLAHN PUT IN CHECK OF B = 1 AT 1345 C JUNE 2019 GLAHN ADDED CAPABILITY TO REPLACE PORTIONS C OF THE FORECAST GRID WITH AN ALTERNATE C JUNE 2019 GLAHN CORRECTED LOOKBACK IN DO 1245 LOOP C JUNE 2019 GLAHN INTERCHANGED ORDER OF PLACEMENT OF C ALTERNATE GRID AND PIXSM1 C JUNE 2019 GLAHN ADDED IALT, ISETS, AND IDSETS C JULY 2019 GLAHN CHANGED TEST IN DO 121 LOOP C JULY 2019 GLAHN ADDED NAREA AND SEALND( ) TO CALL C TO PIXSM3 C JULY 2019 GLAHN ADDED WRITING ASCII FILE; ADDED C NTOTVO, NAME( ), VOTNAM, IWRITA C STALAT( ), STALON( ) TO CALL C AUGUST 2019 GLAHN MODIFIED FORMAT 1133 c NOVEMBER 2019 GLAHN REVISED STATEMENT NOS. 160-2470 C NOVEMBER 2019 GLAHN ADDED NGRIDC( , , ) AND ND11 TO CALL C ADDED READING CONTROLS FOR SPOTRM; C CALL TO SPOTRM AND ADJUSTMENT OR C GRID BY CAP1 AND CAP2 C NOVEMBER 2019 GLAHN ADDED PIXSM3 AFTER SPOTRM C NOVEMBER 2019 GLAHN ADDED NGRID, XP( ), AND YP( ) TO CALL C NOVEMBER 2019 GLAHN ADDED ADDITONAL OPTIONS FOR SPOTRM C AND FOLLOWING PIXSM2 C JANUARY 2020 GLAHN ADDED JGULF TO CALL TO SPOTRM C JANUARY 2020 GLAHN ADDED SKY TO TABLE( , ), CPLAIN( , ) C JANUARY 2020 GLAHN ADDED DIAGNOSTIC 307 C FEBRUARY 2020 GLAHN REMOVED JGULF CALL TO SPOTRM C MARCH 2020 GLAHN ADDED CL AND PK FOR ASKII WRITING OF C SKY AND PROBABILIYT OF SKY 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 MELD70 IS SPECIFIC TO 16 VIS CATEGORIES AND 24 CIG AND C CLOUD BASE CATEGORIES. C C MELD70 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 GRIDPOINT AND REGION C C THIS SUBROUTINE IS ENTERED ONCE FOR EACH ID READ IN C RDV755 WHEN, WHICH IS A SPECIFIC ELEMENT/PROJECTION. C MELD70 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 CLIPPING TO THE NDFD AREA HAS NOT BEEN IMPLEMENTED. THE C CLIPPING GRID HAS BEEN READ IN CASE IT IS NEEDED. 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 KFILOV - UNIT NUMBER OF OUTPUT VECTOR FILE. C INTERPLATION TO STATIONS CAN BE DONE AND C THE OUTPUT PACKED AND WRITTEN. (OUTPUT) C KFIL10 - UNIT NUMBER FOR INTERNAL RANDOM ACCESS STORAGE. C (INPUT/OUTPUT) C IP12 - PROVIDED TO SUBROUTINE CONST FOR POSSIBLE C PRINTING OF STATION IDENTIFIERS. (INPUT) 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 KFILVO = UNIT NUMBER OF OUTPUT ASCII FILE WITH C LATITUDES, LONGITUDES, AND DATA AT STATIONS C INTERPOLATED FROM THE GRID FOR GMOS_PLOT. C ZERO MEANS OUTPUT WILL NOT BE WRITTEN. C (INPUT) C VOTNAM = NAME OF DATA SET FOR OUTPUT ASCII DATA IN FORMAT C CORRESPONDING TO UNIT NO. KFILVO. C (CHARACTER*60) (OUTPUT) C IP12 = PROVIDED TO SUBROUTINE CONST FOR POSSIBLE C PRINTING OF STATION IDENTIFIERS. (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) = JP(1) = 1 INDICATES THE GRIDS WILL BE CLIPPED C ACCORDING TO THE MASK IN CPNDFD( , ). ZERO C OTHERWISE. C JP(2) = 1 (NAREA = 2) INDICATES CATEGORICAL C FORECASTS WILL BE REPLACED WITH THE ALTERNATE C GRID OVER WATER, SIBERIA, AND PORTIONS OF CANADA C (AREA 2) OR OF WATER (AREA 1). ZERO OTHERWISE. C JP(3) = STATION VALUES WILL BE INTERPOLATED C FROM THE CATEGORICAL GRIDS AND WRITTEN TO C KFILOV WHEN KIFLOV NE 0. ZERO OTHERWISE. C ISCALD = THE DECIMAL SCALING CONSTANT TO USE WHEN PACKING C THE DATA FOR THIS VARIABLE. (INPUT) C IWRITA = INDICATES WHETHER OR NOT ASCII DATA ARE TO BE C WRITTEN TO FILE VOTNAM ON UNIT NO. KFILVO C 0 = DO NOT WRITE; C 1 = WRITE. C (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 EQUATIONS 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 NAME(K) = NAMES OF STATIONS (K=1,NSTA). (CHARACTER*20) C (INPUT) C XP(K) = THE X POSITION FOR STATION K (K=1,NSTA) ON C THE FORECAST GRID AREA AT THE CURRENT GRID MESH C LENGTH XMESH. (INPUT) C YP(K) = THE Y POSITION FOR STATION K (K=1,NSTA) ON C THE FORECAST GRID AREA AT THE CURRENT GRID MESH C LENGTH XMESH. (INPUT) C STALAT(K) = LATITUDE OF STATIONS (K=1,NSTA). (INPUT) C STALON(K) = LONGITUDE OF STATIONS (K=1,NSTA). (INPUT) 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 NGRIDC(L,M) = HOLDS THE GRID CHARACTERISTICS (L=1,6) FOR EACH C GRID COMBINATION (M=1,NGRID). C L=1--MAP PROJECTION NUMBER (3=LAMBERT, 5=POLAR C STEREOGRAPHIC). C L=2--GRID LENGTH IN METERS, C L=3--LATITUDE AT WHICH GRID LENGTH IS C CORRECT *1000, C L=4--GRID ORIENTATION IN DEGREES *1000, C L=5--LATITUDE OF LL CORNER IN DEGREES *1000, AND C L=6--LONGITUDE OF LL CORNER IN DEGREES *1000. C NGRID = THE NUMBER OF GRID COMBINATIONS IN NGRIDC( , ), C MAXIMUM OF ND11. C ND11 = MAXIMUM NUMBER OF GRID COMBINATIONS THAT CAN BE C DEALT WITH ON THIS RUN. LAST DIMENSION OF C NGRIDC( , ) AND DIR( , , ). 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 PIXSM3. (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 (INPUT) 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 NTOTVO = THE TOTAL NUMBER OF ASCII RECORDS FOR GIS C WRITTEN TO FILE KFILVO. 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, A COMPROMISED C GRID, OR A 9999 (MISSING) GRID TO BE OUTPUT. C THIS INCLLUDES A GRID THAT COULD NOT BE C CHECKED WITH STATION FORECASTS. (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 REGIONS 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 SETS. 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 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 MELD70. (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),, THE C INDICATOR FOR CEILING (=1) OR VISIBILITY (=2) C (J=5) FOR 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, PLUS OTHER PROCESSING INFO: 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 PIXSM3 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)= 0 = DO NOT MAKE PROBABILITY LEVELS C CONSISTENT. C 1 = MAKE PROBABILITY LEVELS CONSISTENT, C CUMULATIVE FROM BELOW. 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 IDALT(J) = 4-WORD ID OF ALTERNATE GRID TO SUBSTITUTE FOR C A PORTION OF THE AREA. (INTERNAL) C IDSETS(J) = 4-WORD ID OF VECTOR FORECASTS TO INSERT AT C STATIONS ON THE GRID. (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 IDWT(J) = THE WEIGHT IDS FOR THIS SET OF EQUATIONS C (J=1,4). (INTERNAL) C IDWTSV(J) = WEIGHTS IDWT(J) SAVED FROM ENTRY TO ENTRY C (J=1,4). (INTERNAL) C WT(J,L) = THE REGIONAL WEIGHTS (J=1,NXY) (L=1,IREG). C (INTERNAL) (ALLOCATED/SAVED) C CPRJ = WILL HOLD ASCII VERSION OF PROJECTION, 3 DIGITS. C (CHARACTER*3) C ISPOTRM = CONTROL FOR RUNNING SPOTRM AND FOLLOWING C PIXSM3 C 0 = NEITHER C 1 = SPOTRM ONLY C 2 = PIXSM3 ONLY C 3 = BOTH 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 PIXSM3 PAWGTS PACKGR PAKRET GSTORE, SETMD1, C SPOTRM C PARAMETER (IDIM=6) 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*3 CPRJ 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*20 NAME(ND1) CHARACTER*32 PLAIN,RACK,CPLAIN(2,IDIM),PLAINT CHARACTER*32 MPLAIN(ND16+1) C PLAINT IS PASSED TO SPOTRM AND IS NOT USED. CHARACTER*60 EQNNAM,RACESS(6),VOTNAM,VOTNAME 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 C FROM RDEQHR. DIMENSION XP(ND1),YP(ND1) DIMENSION ISDATA(ND1),SDATA(ND1),STALAT(ND1),STALON(ND1) DIMENSION LNDSEA(NSTA),LTAG(NSTA),LTAGPT(NSTA),HOLD(ND2X3) C LNDSEA( ), LTAG( ), LTAGPT( ), AND HOLD( ) ARE AUTOMATIC ARRAYS. DIMENSION DIR(ND1,2,ND11) 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 ALT(NX*NY) C ALT( ) IS AN AUTOMATIC ARRAY. 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),IDWT(4),IDWTSV(4), 3 IDWTPR(15),IDALT(4),IDSETS(4) DIMENSION IPLANT(L3264W,4) C IPLANT( , ) IS AN AUTOMATIC ARRAY PASSED TO SPOTRM AND NOT C USED. DIMENSION NVRBL(15,3) DIMENSION ITABLE(5,IDIM) C EQUIVALENCE (RACK,IRACK) C ALLOCATABLE PROB(:,:),XPROB(:,:),WT(:,:) C SAVE IDWTSV,WT C DATA ITABLE/228110203,000000000,708100203,0,2, !VIS HRRR PROB, 3LAGGED 1 228130295,228160095,708100295,2,2, !VIS LAMP/HRRR MELD 2 228060203,000000000,708000203,0,1, !CIG HRRR PROB, 3LAGGED 3 228070295,228080095,708000295,0,1, !CIG LAMP/HRRR OR LAMP/RAP MELD 4 228380203, 0,708313233,0,3, !SKY RAP PROB 5 228380295,208381095, 0,0,2/ !SKY,LAMP/RAP MELD C PROBABILITY, CATEGORICAL, PREDICTAND, SCALING, 1=CIG' 2=VIS C 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/' 3HRRR VIS PROB ', 1 ' 3HRRR VIS CAT ', 2 ' GLMP HRRR MELD VIS PROB ', 3 ' GLMP HRRR MELD VIS CAT ', 4 ' 3HRRR CIG PROB ', 5 ' 3HRRR CIG CAT ', 6 ' GLMP HRRR MELD CIG PROB ', 7 ' GLMP HRRR MELD CIG CAT ', 8 ' RAP SKY PROB ', 9 ' RAP SKY CAT ', A ' GLMP/RAP MELD SKY PROB ', B ' GLMP/RAP MELD SKY CAT '/ C DATA IDWT/4*0/, 1 IDWTSV/4*0/ C CALL TIMPR(KFILDO,KFILDO,'START MELD70 ') C CCCC WRITE(KFILDO,100)ND1,ND14,ND15,ND2X3,ND5,ND7, CCCC 1 ND9,ND10,ND16,NX,NY CCCC 100 FORMAT(' IN MELD70--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 MELD70 AT 1021.') CALL W3TAGE('MELD70') 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 MELD70 AT 1022.') CALL W3TAGE('MELD70') 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 MELD70 AT 1023.') CALL W3TAGE('MELD70') 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 MELD70 AT 1024.') CALL W3TAGE('MELD70') STOP 1024 ENDIF c c READ THE CONTROLS FOR SPOTRM. C READ(INLTAB,1025)DUMMY,ISPOTRM,NOPTN,DIFFAS,NOCEAN,LAKE,DISTX, 1 DPOWER,RAY,RMAX,LH,CAP1,CAP2 1025 FORMAT(A6,2I4,F4.0,2I4,4F4.0,I4,2F4.0) WRITE(KFILDO,1026)DUMMY,ISPOTRM,NOPTN,DIFFAS,NOCEAN,LAKE,DISTX, 1 DPOWER,RAY,RMAX,LH,CAP1,CAP2 1026 FORMAT(1X,A6,2I4,F4.0,2I4,F4.0,F4.1,F4.2,F4.0,I4,2F4.0) C IF(DUMMY.NE.'SPOTRM')THEN WRITE(KFILDO,1027)DUMMY 1027 FORMAT(/' ****PROCESSOR READ = ',A6,' SHOULD HAVE BEEN SPOTRM', 1 ' STOP IN MELD70 AT 1027.') CALL W3TAGE('MELD70') STOP 1027 ENDIF C C READ THE ID OF THE ALTERNATE FORECAST GRID. THIS WILL C REPLACE PORTIONS OF THE FORECAST GRID. THIS ENTRY MUST BE HERE. C WHETHER OR NOT TO USE IT IS GOVERNED BY IALT. C READ(INLTAB,103)DUMMY,(IDALT(J),J=1,4),IALT 103 FORMAT(A6,4I10,I4) C IF(DUMMY.NE.'ALTID ')THEN WRITE(KFILDO,1033)DUMMY 1033 FORMAT(/' ****PROCESSOR READ = ',A6,' SHOULD HAVE BEEN ALTID', 1 ' STOP IN MELD70 AT 1033.') CALL W3TAGE('MELD70') STOP 1033 ENDIF C IF(IALT.NE.0)THEN WRITE(KFILDO,1034)(IDALT(J),J=1,4) 1034 FORMAT(/' ID OF ALTERNATE FORECAST GRID = ',3I10.9,I9) ELSE WRITE(KFILDO,1035) 1035 FORMAT(/' ALTERNATE GRID FOR SUBSTITUTION NOT USED.') ENDIF C C READ THE ID OF THE VECTOR FORECASTS TO INSERT AT STATIONS C WHEN ISETS NE 0. THIS ENTRY MUST BE HERE. WHETHER OR C NOT TO USE IT IS GOVERNED BY ISET. C READ(INLTAB,104)DUMMY,(IDSETS(J),J=1,4),ISETS 104 FORMAT(A6,4I10,I4) C IF(DUMMY.NE.'SETSTA')THEN WRITE(KFILDO,1043)DUMMY 1043 FORMAT(/' ****PROCESSOR READ = ',A6,' SHOULD HAVE BEEN SETSTA'/ 1 ' STOP IN MELD70 AT 1043.') CALL W3TAGE('MELD70') STOP 1043 ENDIF C IF(ISETS.NE.0)THEN WRITE(KFILDO,1044)(IDSETS(J),J=1,4) 1044 FORMAT(/' ID OF STATION FORECASTS TO INSERT = ',3I10.9,I9) ELSE WRITE(KFILDO,1045) 1045 FORMAT(/' STATION FORECASTS NOT INSERTED.') ENDIF C NXY=NX*NY C NXY IS THE SIZE OF THE GRID IN THE ARRAYS OF SIZE ND2X3. C C FOR DEVELOPMENT: 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 ONE FILE. THE ONLY C IDENTIFICATION BY PROJECTION IS THE TAU FOR THE C PREDICTANDS. C IF(IOPER.EQ.0)THEN C THIS IS DEVELOPMENT MODE. CALL RVSNAM(KFILDO,EQNNAM,IDPARS(12),IER) C RVSNAM MODIFIES FILE NAME FOR DEVELOPMENT MODE. WRITE(KFILDO,105) 105 FORMAT(/' RUNNING IN DEVELOPMENT MODE; CHANGING EQUATION', 1 ' FILE NAME.') C IF(IER.NE.0)THEN C IF THERE IS AN ERROR, IT WILL BE REPORTED IN RVSNAM. CALL W3TAGE('MELD70') STOP 107 ENDIF C ELSE WRITE(KFILDO,1050) 1050 FORMAT(/' RUNNING IN OPERATIONAL MODE.') ENDIF C 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 ' COPS OPEN(UNIT=KFILEQ,FILE=EQNNAM,STATUS='OLD',IOSTAT=IOS,ERR=1075) WRITE(KFILDO,107)EQNNAM,KFILEQ 107 FORMAT(/' OPENING FILE ',A60,' ON UNIT NO.',I4) ENDIF C GO TO 1078 C 1075 WRITE(KFILDO,1076)EQNNAM,IOS 1076 FORMAT(/' ****ERROR OPENING FILE ',A60,' IOS =',I6,/ 1 ' STOP IN MELD70 AT 1076.') CALL W3TAGE('MELD70') STOP 1076 C 1078 DO 1490 MSET=1,IREG C 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('MELD70') 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 MELD70--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 = NUMBER OF TERMS IN EQUATIONS GT ND14. C 168 = SYSTEM READING ERROR. CALL W3TAGE('MELD70') 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('MELD70') 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('MELD70') 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. ABORT IN MELD70.') ISTOP(1)=ISTOP(1)+1 IER=777 CALL W3TAGE('MELD70') STOP 113 ENDIF C IF(NSET.NE.IREG)THEN WRITE(KFILDO,1132)NSET,IREG 1132 FORMAT(' ****NUMBER OF REGIONAL EQUATIONS READ NSET =',I4, 1 ' DOES NOT EQUAL NUMBER OF EXPECTED IREG =',I4, 2 '. ABORT IN MELD70 AT 1132.') ISTOP(1)=ISTOP(1)+1 IER=777 CALL W3TAGE('MELD70') STOP 1132 ENDIF C C READ THE FILE NAME FOR THE REGIONAL WEIGHTS WHEN IREG > 1. C IF(IREG.GT.1)THEN READ(INLTAB,1133)DUMMY,KFILWT,WTNAM,IDWT(1) C THIS IS READING CCCFFFBDD; MAY NEED TO READ 4 IDS. 1133 FORMAT(A6,I4,2X,A60,4I10) C IF(DUMMY.NE.'REGWT ')THEN WRITE(KFILDO,1134)DUMMY 1134 FORMAT(/' ****PROCESSOR READ = ',A6,' SHOULD HAVE BEEN', 1 ' REGWT. STOP IN MELD70 AT 1134.') CALL W3TAGE('MELD70') STOP 1134 ENDIF C C PARSE IDWT( ) INTO ITS 15 COMPONENTS IDWTPR( ). C CALL PRSID1(KFILDO,IDWT,IDWTPR) C C IF THE IDWT( ) IS THE SAME AS THE SAVED IDWTSV( ), THEN C THE SET NEEDED IS ALREADY AVAILABLE IN WT( ). OTHERWISE, C DEALLOCATE AND ALLOCATE. C IF(IDWT(1).NE.IDWTSV(1).OR. 1 IDWT(1).NE.IDWTSV(1).OR. 2 IDWT(1).NE.IDWTSV(1).OR. 3 IDWT(1).NE.IDWTSV(1))THEN DEALLOCATE(WT,STAT=IOS) ALLOCATE(WT(NXY,NSET),STAT=IOS) C IF(IOS.EQ.1)THEN WRITE(KFILDO,1135) 1135 FORMAT(/' ****ALLOCATION OF WT( , ) FAILED IN MELD70', 1 ' AT 1135. ARRAY ALREADY ALLOCATED.', 2 ' ABORT IN MELD70.') ISTOP(1)=ISTOP(1)+1 IER=777 CALL W3TAGE('MELD70') STOP 1135 C ELSEIF(IOS.EQ.2)THEN WRITE(KFILDO,1136) 1136 FORMAT(/' ****ALLOCATION OF WT( , ) FAILED IN MELD70', 1 ' AT 1136. ARRAY NOT ALLOCATED.', 2 ' ABORT IN MELD70.') ISTOP(1)=ISTOP(1)+1 IER=777 CALL W3TAGE('MELD70') STOP 1136 ENDIF C C READ ALL REGIONAL WEIGHTS IF REGIONS = NSETS GT 1. C CALL RDRGWT(KFILDO,KFILWT,WTNAM,IP18,JDATE, 1 IDPARS,IDWT,IDWTPR,IDWTSV,WT,IREG,NXY,NAREA, 2 IPACK,IWORK, 3 IS0,IS1,IS2,IS4,ND7, 4 L3264B,IER) C THERE IS NO NON=ZERO ERROR. ALL ERRORS CAUSE STOPS. C C PACK AND WRITE THE GRID TO THE DISPOSABLE FILE FOR C CHECKOUT. C ITAUM=0 NSEQ=0 NCHAR=32 XMISSP=9999. XMISSS=0. LD(2)=IDWT(2) LD(3)=IDWT(3) LD(4)=IDWT(4) C IF(KFILOG.NE.0)THEN C DO 1139 L=1,IREG LD(1)=((IDWT(1)/100000)*100+NREG*1000)+IDWTPR(3)*100 1 +IDWTPR(4) RACK='REGIONAL SMOOTHING WEIGHT ' 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 WT(1,L),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,1138) 1138 FORMAT(/' ****ERROR IN PAWGTS IN MELD70 AT 151.') C THE MELD70 PROBABILITY GRID IS NOT WRITTEN TO C 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 1139 CONTINUE C ENDIF C ENDIF C ENDIF C C SET UP ALLOCATED STORAGE FOR THE FORECAST 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 ' MELD70 AT 114. ARRAYS ALREADY ALLOCATED.', 2 ' ABORT IN MELD70.') ISTOP(1)=ISTOP(1)+1 IER=777 CALL W3TAGE('MELD70') STOP 114 ELSEIF(IOS.EQ.2)THEN WRITE(KFILDO,115) 115 FORMAT(/' ****ALLOCATION OF XPROB( , ), PROB( , ) FAILED IN', 1 ' MELD70 AT 115. ARRAYS NOT ALLOCATED.', 2 ' ABORT IN MELD70.') ISTOP(1)=ISTOP(1)+1 IER=777 CALL W3TAGE('MELD70') 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 CCCC WRITE(KFILDO,1155)LL,IDTAND(1,1),IDWRTP,IDWRTC, CCCC 1 IDWDD CCCC 1155 FORMAT(' AT 1155--LL,IDTAND(1,1),IDWRTP,IDWRTC,', CCCC 1 'IDWDD',I4,3I12.9,I4) GO TO 118 ENDIF C 116 CONTINUE C WRITE(KFILDO,117)IDTAND(1,1) 117 FORMAT(/' ****COULD NOT FIND 1ST WORD ID OF VARIABLE',I10.9, 1 ' IN ITABLE(3, ). STOP IN MELD70 AT 117.') WRITE(KFILDO,1170)((ITABLE(I,J),I=1,4),J=1,IDIM) 1170 FORMAT(/,' ITABLE IS:',//,(3I10.9,I4)) CALL W3TAGE('MELD70') 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 CCCCD WRITE(KFILDO,1183)N,MM,NVRBL(N,1),IDTAND(1,MM) CCCCD1183 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(' NVRBL(N,J)',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 MELD70. PREDICTANDS ARE:',/, 3 (I10)) CALL W3TAGE('MELD70') 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 IREG=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).EQ.MTABLE(N,1))THEN C CHANGED ABOVE FROM BELOW 7/2/19. CCCC 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),(MTABLE(NN,1),NN=1,IDCNT) 122 FORMAT(/' ****DID NOT FIND PREDICTOR',I10.9,' IN MTABLE( , ).'/ 1 ' MTABLE(N,1)='/(10X,I11)) WRITE(KFILDO,1220) 1220 FORMAT(' FATAL ERROR. STOP IN MELD70 AT 122.') CALL W3TAGE('MELD70') STOP 122 C 123 ITIME=3 C ITIME=3 ACTIVATES RR. LDATE=NDATE IOPTX=0 C IOPTX = COUNT OF NUMBER OF TIMES OPT755 IS ENTERED. LD(1)=MTABLE(N,2) LD(2)=IDEQN(2,NSET,M) LD(3)=IDEQN(3,NSET,M) LD(4)=IDEQN(4,NSET,M) C C THE BELOW PROVIDES FOR THREE LOOKBACKS WHEN PREDICTOR C NOT FOUND. OPTION LIKE CAPABILITY NOT YET DEVELOPED. C DO 1245 LL=1,3 124 CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,FD2,NXY, 2 NWORDS,NPACK,LDATE,NTIMES,CORE,ND10, 3 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B, 4 ITIME,IER) C NOTE USE OF LDATE VICE NDATE. IF(MISSP.NE.0)MISTOT=MISTOT+1 C IF(IER.EQ.0)THEN GO TO 1247 C ELSEIF(IER.EQ.47)THEN C IF(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 c ELSEIF(LL.EQ.1.AND.IOPTX.EQ.0)THEN C THIS OPTION CAPABILITY HAS NOT BEEN TESTED. CALL OPT755(KFILDO,KFIL10, 1 ID,IDPARS,THRESH,JD,NDATE, 2 KFILRA,RACESS,NUMRA,CCALL,ICALLD, 3 CCALLD, 4 ISDATA,SDATA,DIR,ND1,NSTA, 5 NGRIDC,NGRID,ND11,NSLAB,IPACK,IWORK,DATA,ND5, 6 LSTORE,ND9,LITEMS,CORE,ND10,LASTL, 7 NBLOCK,LASTD,NSTORE,NFETCH, 8 IS0,IS1,IS2,IS4,ND7, 9 FD2,FD3,FD4,FD5, A ND2X3,IP12,IP16, B ISTAV,L3264B,L3264W,MISTOT,IER) IF(IER.EQ.0)GO TO 1247 IOPTX=1 LD(4)=IDEQN(4,NSET,M) LD(3)=LD(3)+1 C THIS FEATURE SHOULD OPERATE AT LARGE PROJECTIONS AND C NOT GO NEGATIVE. IF IT DOES, THERE SHOULD JUST BE A C FAILURE WITH NO HARM DONE. CALL UPDAT(LDATE,-1,LDATE) C THE PROJECTION GOES UP, THE DATE GOES BACK. C DROPS FROM HERE TO THE 1245 CONTINUE. C ELSE LD(4)=IDEQN(4,NSET,M) LD(3)=LD(3)+1 C THIS FEATURE SHOULD OPERATE AT LARGE PROJECTIONS AND C NOT GO NEGATIVE. IF IT DOES, THERE SHOULD JUST BE A C FAILURE WITH NO HARM DONE. CALL UPDAT(LDATE,-1,LDATE) C THE PROJECTION GOES UP, THE DATE GOES BACK. C DROPS FROM HERE TO THE 1245 CONTINUE. ENDIF C ENDIF C 1245 CONTINUE C 1247 IF(IER.NE.0)THEN WRITE(KFILDO,125)IER,(LD(J),J=1,4) 125 FORMAT(/' ****IER = ',I4,' FROM GFETCH IN MELD70 LOOKING FOR', 1 4I10,' ABORT RUN AT 125 IN MELD70.') 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 MELD70--(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 MELD70.') 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. CCCC WRITE(KFILDO,134)(MTABLE(N,J),J=1,3),THRESH CCCC 134 FORMAT(/' AT 134--(MTABLE(N,J),J=1,3),THRESH',3I10,F10.5) C C IF(LDPARS(3).NE.1)THEN C B MUST = 1 FOR BINARY. WRITE(KFILDO,1345)IDEQN(1,NSET,M) 1345 FORMAT(' ****BINARY IN PREDICTOR ',I9.9, 1 ' IS NOT EQUAL TO 1. STOP IN MELD70 AT 1345.') CALL W3TAGE('MELD70') STOP 1345 ENDIF 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) C C**************** CCCC IF(J.EQ.NXY/2)THEN CCCC WRITE(KFILDO,1385)M,MM,NSET,COEF(NSET,M,MM),FD2(J), CCCC 1 XPROB(J,MM) CCCC 1385 FORMAT(/'M,MM,NSET,COEF(NSET,M,MM),FD2(J),', CCCC 1 'XPROB(J,MM)',3I4,3F10.3) CCCC ENDIF C**************** C ELSE XPROB(J,MM)=9999. ENDIF 139 CONTINUE C C**************** CCCCD WRITE(KFILDO,1395)MM,M,XPROB(10000,MM),COEF(NSET,M,MM), CCCCD 1 SAVE,FD2(10000) CCCCD1395 FORMAT(/' AT 1395--MM,M,XPROB(10000,MM),COEF(NSET,M,MM),', CCCCD 1 'SAVE,FD2(10000)',2I4,4F12.5) C**************** C 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 C DO 148 LLL=1,IREG 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)*WT(J,LLL) ELSE PROB(J,M)=9999. ENDIF C 146 CONTINUE 147 CONTINUE C 148 CONTINUE C ELSE C THERE IS ONLY ONE REGION, SO TRANSFER 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 1490 CONTINUE C C EQUATIONS FOR ALL CATEGORIES HAVE BEEN EVALUATED FOR ALL C REGIONS. REGIONAL WEIGHTS HAVE BEEN APPLIED TO THE C WHOLE GRID FOR EACH REGION AND CATEGORY, SO THE PROBS C IN PROB( , ) ARE THE FINAL, BEFORE TRUNCATION AND C POSSIBLE CLIPPING. 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 CLIPPING IS DESIRED. NCLIPY = 1 INDICATES THE GRID C IS AVAILABLE. CLIPPING 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(/' CLIPPING PROBABILITY GRIDS') C DO 1501 MM=1,MTANDS C DO 1500 JJ=1,NXY C IF(CPNDFD(JJ).LT..5)THEN PROB(JJ,MM)=9999. ENDIF C 1500 CONTINUE C 1501 CONTINUE C ELSE WRITE(KFILDO,1502) 1502 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. THIS IS DONE ONLY IF ICAT(10) IS NE 0. C IF(ICAT(10).NE.0)THEN C WRITE(KFILDO,1503) 1503 FORMAT(/' PROBABILITY LEVELS BEING MADE CONSISTENT.') 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), 1 (IDTAND(J,MM),J=1,3),ICOUNT,IDTAND(4,MM) 1507 FORMAT(' LEVEL',I4,' =',I11,' OF ',3I10,' MODIFIED',I8, 1 ' TIMES TO BE CONSISTENT WITH THE LEVEL ABOVE =', 2 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 ELSE WRITE(KFILDO,151) 151 FORMAT(/' PROBABILITY LEVELS NOT BEING MADE CONSISTENT.') ENDIF 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 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,1513) 1513 FORMAT(/' ****ERROR IN PAWGTS IN MELD70 AT 151.') C THE MELD70 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, HENCE 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,10) CCCC 1518 FORMAT(/' IN MELD70 AT 1518, PROBABILITIES IN PERCENT', CCCC 1 '--ISCALD,MM,(FD3(J),J=1,10)',2I4/(10F10.2)) C CCCC 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 MELD70 AT 1520.') C THE MELD70 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 C 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 MELD70.') 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+40) D153 FORMAT(' AT 153 IN MELD--(PROB(J,MM),J=NXY/2,NXY/2+40',/, 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 ORIGINAL 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 MELD70 AT 1542.', 1 ' FORECASTS ARE NOT WRITTEN TO INTERNAL', 2 ' STORAGE.'/ 3 ' THIS MAY CAUSE A MAJOR ERROR DOWNSTREAM.') C THE MELD70 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 INTERPOLATE 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 FCST') C IF(ICAT(1).EQ.0)THEN WRITE(KFILDO,1549) 1549 FORMAT(/' CATEGORICAL FORECASTS NOT BEING MADE.', 1 ' ICAT(1) = 0.'/) GO TO 501 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.'/) GO TO 501 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)=IDWRTC LD(2)=ID(2) LD(3)=ID(3) LD(4)=ID(4) CALL PRSID2(KFILDO,LD,LDPARS,THRESH) C CCCC WRITE(KFILDO,160)(LD(J),J=1,4) CCCC 160 FORMAT(/' AT 160 IN MELD70--(LD(J),J=1,4) ',3I12.9,I12) 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) C***************************************************** CCCC DO 164 K=1,NXY CCCCC CCCC IF(P(K).GT.120.01.AND.P(K).LT.887.99)THEN CCCC WRITE(KFILDO,162)K,P(K) CCCC 162 FORMAT(/' IN MELD70--K,P(K)',I10,F10.3) CCCC ENDIF CCCCC CCCC 164 CONTINUE C***************************************************** 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 READ THE GRID OF THE ALTERNATE CATEGORICAL FORECAST WHEN C IALT NE 0 AND JP(2).NE.0) C IF(IALT.NE.0.AND.JP(2).NE.0)THEN C WRITE(KFILDO,167)(IDALT(J),J=1,4) 167 FORMAT(/' READING ALTERNATE GRID FOR REPLACEMENT ', 1 3I10.9,3I10.3) MDATE=NDATE IDALT(3)=(IDALT(3)/1000)*1000+IDPARS(12) C SET THE PROJECTION IN IDALT( ). C DO 170 LL=1,7 C THIS PROVIDES FOR SIX LOOKBACKS IN CASE VARIABLE IS C NOT FOUND. CALL GFETCH(KFILDO,KFIL10,IDALT,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,FD2,NXY, 2 NWORDS,NPACK,MDATE,NTIMES,CORE,ND10, 3 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B, 4 ITIME,IER) C NOTE USE OF MDATE VICE NDATE. IF(MISSP.NE.0)MISTOT=MISTOT+1 C IF(IER.EQ.0)THEN GO TO 175 C ELSEIF(IER.EQ.47)THEN IDALT(3)=IDALT(3)+1 C INCRASE THE PROJECTION BY 1 HOUR. CALL UPDAT(MDATE,-1,MDATE) C DECREASE THE RUN TIME BY 1 HOUR. ENDIF C 170 CONTINUE C C CAN'T FIND THE GRID. STOP. WRITE(KFILDO,171) 171 FORMAT(/' ****CANNOT FIND THE MODEL FORECAST GRID TO', 1 ' REPLACE PORTIONS OF THE MELD FORECAST.', 2 ' STOP IN MELD70 AT 171.') CALL W3TAGE('MELD70') STOP 171 ENDIF C C NOW INSERT MODEL FIELD OVER WATER AND SIBERIA C FOR AREA = 2, WHEN JP(2) NE 0. C 175 IF(JP(2).NE.0)THEN C IF(NAREA.EQ.2)THEN C IF(ITABLE(5,IPOS).EQ.1)THEN C THIS IS CEILING. CALL SETMD1(KFILDO,NAREA,JP(2),P, 1 FD2,SEALND,NX,NY,IER) C FD2( ) HOLDS THE ALTERNATE GRID. C ELSEIF(ITABLE(5,IPOS).EQ.2)THEN C THIS IS VISIBILITY. CALL SETMD2(KFILDO,NAREA,JP(2),P, 1 FD2,SEALND,NX,NY,IER) C FD2( ) HOLDS THE ALTERNATE GRID. ELSE WRITE(KFILDO,177) 177 FORMAT(/' ****DID NOT FIND A SETDMX TO CALL', 1 ' IN MELD70. STOP AT 177.') CALL W3TAGE('MELD70') STOP 177 ENDIF C IF(IER.NE.0)THEN WRITE(KFILDO,178) 178 FORMAT(/' ****ERROR IN SETMD1 OR SETMD2.', 1 ' STOP IN MELD70 AT 178.') CALL W3TAGE('MELD70') STOP 178 ENDIF C ENDIF C ENDIF C C INTERPOLATE TO STATIONS BEFORE SMOOTHING SO POINTS AROUND C STATIONS CAN BE RESET. C CALL INTRPC(KFILDO,P,NX,NY,DIR,ND1,NSTA,SDATA) C CALL PIXEL SMOOTHER PIXSM3 IF DESIRED. SMOOTHS ONLY WATER C AND SIBERIA.. C IF(ICAT(5).GT.0)THEN C IF(NTELEV.NE.0)THEN C THE ELEVATION GRID IS IN TELEV( ). ISPOT=ICAT(6) MTIMES=ICAT(7) DIFFV=ICAT(8) DIFFA=ICAT(9) IRESTR=1 C IRESTR = 1 MEANS TO RESTORE LAND (SMOOTH ONLY WATER). CALL PIXSM3(KFILDO,LD,LDPARS,JD,NAREA, 1 ISPOT,MTIMES,DIFFV,DIFFA, 2 P,NX,NY,FD3,TELEV,SEALND,IRESTR, 3 ISTOP,JER,IER) ELSE WRITE(KFILDO,179) 179 FORMAT(/' ****TERRAIN WAS NOT READ, SO PIXSM3 WAS', 1 ' NOT EXECUTED. FORECAST WILL BE PRODUCED', 2 ' WITHOUT IT.') ENDIF C ELSE WRITE(KFILDO,180) 180 FORMAT(/' PIXSM3 IS NOT BEING USED.') C ENDIF C C CALL SPOTRM AFTER PREPARING INPUTS. SPOTRM WAS WRITTEN FOR C U155/U405A AND REQUIRES SOME INPUTS NOT ALREADY AVAILABLE C HERE, SO INITIALIZE CERTAIN VARIABLES. C IF(ISPOTRM.EQ.1.OR.ISPOTRM.EQ.3)THEN C DO 182 K=1,NSTA LNDSEA(K)=9 C THESE ARE LAND STATIONS. C IF(CCALL(K)(6:6).EQ.' ')THEN LTAG(K)=0 C THIS IS NOT A BOGUS STATION. USED AS A STATION C FOR WHICH THERE IS AN ACCURATE FORECAST, ALTHOUGH C THERE MAY HAVE NOT BEEN DATA (OBS OR LAMP FCST) C ON WHIHC TO PRODUCE SUCH; THIS INFO IS NOT AVAILABLE C IN U755. ELSE LTAG(K)=0 C THIS IS A BOGUS STATION. DECIDED TO USE IT. MADE C A DIFFERENCE IN ARCTIC AND ESPECIALLY IN NW CANADA. C A MORE UNIFORM DISTRIBUTION OF STATIONS IS BETTER C EVEN THOUGH SOME ARE BOGUS. TO NOT USE, SET = 4 ENDIF C LTAGPT(K)=0 C DATA ARE NOT AUGMENTED. 182 CONTINUE C KFILOG=0 C DO NOT WRITE THE GRID. NCLIP=0 C DO NOT CLIP TO NDFD MASK. C C FOR CEILING, VALUES OF UNLIMITED (=888) HAVE TO BE SET C LOWER (USE 130) BEFORE SMOOTHING. C IF(ITABLE(5,IPOS).EQ.1)THEN C DO 183 J=1,NX*NY C IF(SEALND(J).GT.8.5)THEN C THIS IS A LAND POINT. C IF(P(J).GT.887.)THEN C THIS IS UNLIMITED CEILING. P(J)=130. ENDIF C ENDIF C 183 CONTINUE C ENDIF C CALL SPOTRM(KFILDO,KFILOG,IP16,NAREA, 1 CCALL,XP,YP,LNDSEA,NOPTN,LTAG,LTAGPT, 2 STALAT,STALON,NSTA, 3 ID,IDPARS,P,HOLD,MESH,NX,NY, 4 TELEV,SEALND,CPNDFD,NX,NY,MESH, 5 IPACK,DATA,IWORK,ND5, 6 MODNO,NDATE,NCLIP, 7 ALATL,ALONL,NPROJ,ORIENT,XLAT,ISCALD, 8 DIFFAS,NOCEAN,LAKE,DISTX,DPOWER,RAY,RMAX, 9 LH, A IS0,IS1,IS2,IS4,ND7, B JTOTBY,JTOTRC,PLAINT,IPLANT, C L3264B,L3264W,MINPK,ISTOP(1),IER) C C FOR VISIBILITY, AFTER SPOTRM, AREAS OF UNRESTRICTED C VISIBILITY (>10.1) MAY BE SLIGHTLY BELOW 10, SO SET ALL C LAND VALUES ABOVE CAP1 (~9.1) TO CAP2 (10.1). C FOR CEILING, AFTER SPOTRM, AREAS OF UNRESTRICTED C CEILING (>120) MAY BE SLIGHTLY BELOW 120, SO SET ALL C LAND VALUES ABOVE CAP1 TO CAP2 (888). SPOTRM DOES C NOT MODIFY THE 4 GRIDPOINTS AROUND A STATION, SO THEY C SHOULD NOT BE MODIFIED. C IF(ITABLE(5,IPOS).EQ.1.OR.ITABLE(5,IPOS).EQ.2)THEN C THIS IS FOR CEILING AND VISIBILITY. C DO 185 J=1,NX*NY C IF(SEALND(J).GT.8.5)THEN C THIS IS A LAND POINT. C IF(P(J).GT.CAP1)THEN P(J)=CAP2 ENDIF C ENDIF C 185 CONTINUE C ENDIF C ENDIF C RUN PIXEL SMOOTHER AFTER SPOTRM. IT IS NOT EXPECTED C TO MAKE CHANGES OVER WATER, BUT TO TAKE OUT NOISE OVER C LAND. C IF(ISPOTRM.EQ.2.OR.ISPOTRM.EQ.3)THEN C IF(NTELEV.NE.0)THEN ISPOT=5 C THIS HARDWIRES REMOVAL TO 5 PIXELS. MTIMES=ICAT(7) DIFFV=ICAT(8) DIFFA=ICAT(9) IRESTR=0 C IRESTR = 0 MEANS TO NOT RESTORE LAND (SMOOTH WATER C AND LAND). CALL PIXSM3(KFILDO,LD,LDPARS,JD,NAREA, 1 ISPOT,MTIMES,DIFFV,DIFFA, 2 P,NX,NY,FD3,TELEV,SEALND,IRESTR, 3 ISTOP,JER,IER) ELSE WRITE(KFILDO,186) 186 FORMAT(/' ****TERRAIN WAS NOT READ, SO PIXSM3 WAS', 1 ' NOT EXECUTED. FORECAST WILL BE PRODUCED', 2 ' WITHOUT IT.') ENDIF C ENDIF C C SET 4 POINTS AROUND EACH STATION TO ITS INTERPOLATED VALUE. C PIXSM3 COULD HAVE CHANGED 4 POINTS ROUND STATIONS. SPOTRM C SHOULD NOT HAVE, BUT THIS INSURES IT. C CALL SET4PT(KFILDO,P,NX,NY,DIR,ND1,NSTA,SDATA,IER) C C CALL SETVTG TO MAKE SURE THE 4 GRIDPOINTS AROUND A C STATION AGREE WITH (ARE WITHIN) THE MELD FORECASTS C PUT INTO THE LAMP CATEGORIES. C IF(NTELEV.NE.0)THEN CALL SETVTG(KFILDO,KFIL10,LD,LDPARS,JD,NDATE,NAREA, 1 CCALL,NAME,DIR,FD2,FD4,ND1,NSTA, 2 P,NX,NY,IPACK,IWORK, 3 LSTORE,ND9,LITEMS,CORE,ND10, 4 NBLOCK,NFETCH, 5 IS0,IS1,IS2,IS4,ND7, 6 L3264B,ISTOP,JER,IER) ELSE WRITE(KFILDO,188) 188 FORMAT(/' ****TERRAIN WAS NOT READ, SO PIXSM3 WAS', 1 ' NOT EXECUTED. FORECAST WILL BE PRODUCED', 2 ' WITHOUT IT.') 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. C 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 CCCC WRITE(KFILDO,250)LD,ISCAL CCCC 250 FORMAT(/' AT 250--DECIMAL SCALING FOR ', CCCC 1 3I12.9,I12.3,' IS',I4) C NCHAR=32 XMISSP=9999. XMISSS=0. 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 MELD70 AT 251.') C THE MELD70 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 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 MELD70. 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 THE GRIDPOINTS AROUND A STATION HAVE BEEN MADE CONSISTENT C WITH THE CATEGORICAL CEILING (8 CATEGORIES) OR VISIBILITY C (7 CATEGORIES) DERIVED FROM THE STATION MELD FORECASTS, C WHEN THE FILE TO READ FROM IS AVAILABLE, IN PLASTC1 OR C PLASTV1 CALLED FROM PIXSM3. 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 WRITE INTERPOLATED FORECASTS TO ASCII FILE KFILVO. C IF(KFILVO.NE.0.AND.IWRITA.NE.0)THEN C TO WRITE ASCII, A FILE KFILVO HAS TO BE AVAILABLE AND C IWRITA MUST INDICATE TO WRITE THIS VARIABLE. REWIND KFILVO C EACH VARIABLE IS WRITTEN TO A NEW FILE, LATER COPIED C FOR RETENTION. WRITE(CPRJ,'(I3.3)')IDPARS(12) C THIS PUTS THE PROJECTION IN ASCII IN CPRJ. VOTNAME=VOTNAM JPOS=60 C 295 IF(JPOS.LE.0)THEN C THE ASCII FILE NAME VOTNAM IS ALL BLANKS. WRITE(KFILDO,296)VOTNAM 296 FORMAT(/' ****THE ASCII FILE NAME IS ALL BLANKS.', 1 ' DO NOT WRITE TO UNIT NUMBER KFILVO. ', 2 A60) IWRITA=0 C THIS WILL MODIFY IWRITA( ) IN U755, BUT NO MATTER. ELSEIF(VOTNAM(JPOS:JPOS).EQ.' ')THEN C CCCC WRITE(KFILDO,2895)JPOS,VOTNAM CCCC 2895 FORMAT(/' IN MELD--JPOS,VOTNAM',I6,2X,A60) JPOSL=JPOS C JPOSL WILL BE THE FIRST NON BLANK IN VOTNAM. JPOS=JPOS-1 GO TO 295 ELSE C THE FILE NAME IN VOTNAM ENDS AT POSITION JPOSL. C ADD THE REST OF THE NAME SANS THE ELEMENT DESIGNATION. C IF(JPOSL+9.LE.60)THEN VOTNAME(JPOSL:JPOSL+4)='. .f' VOTNAME(JPOSL+5:JPOSL+7)=CPRJ(1:3) C THE FILE NAME IN VOTNAME IS COMPLETE EXCEPT FOR THE C ELEMENT DESIGNATION IN POSITIONS JPOSL+1 C AND JPOSL+2. CCCC WRITE(KFILDO,297)IDPARS(12),CPRJ,VOTNAM,VOTNAME CCCC 297 FORMAT(/' AT 297--CPRJ,VOTNAM,VOTNAME ',I6,2X,A3,/, CCCC 1 A60,/,A60) ELSE WRITE(KFILDO,298)VOTNAM 298 FORMAT(/' ****ASCII FILE NAME READ IS TO LONG TO', 1 ' ACCOMMODATE ELEMENT AND PROJECTION', 2 ' EXTENSION. SHORTEN TO LE 51 CHARACTERS.'/ 3 ' DO NOT WRITE TO FILE',A60) IWRITA=0 C THIS WILL MODIFY IWRITA( ) IN U755, BUT NO MATTER. ENDIF C ENDIF C IF(IWRITA.NE.0)THEN C IT MAY HAVE BEEN DETERMINED ABOVE TO NOT WRITE THE C FILE. NZERO=0 C IF(IDWRTC/100.EQ.2280800)THEN VOTNAME(JPOSL+1:JPOSL+2)='CG' C INSERTS CG FOR CEILING. ELSEIF(IDWRTC/100.EQ.2281600)THEN VOTNAME(JPOSL+1:JPOSL+2)='VS' C INSERTS VS FOR VISIBILITY. ELSEIF(IDWRTC/100.EQ.2283800)THEN VOTNAME(JPOSL+1:JPOSL+2)='PK' C INSERTS VS FOR PROBABILIYT OF SKY COVER. ELSEIF(IDWRTC/100.EQ.2283810)THEN VOTNAME(JPOSL+1:JPOSL+2)='CK' C INSERTS VS FOR OF SKY COVER. ENDIF C CCCC WRITE(KFILDO,2985)ITRP(2),KFILOV CCCC 2985 FORMAT(/' AT 2985--ITRP(2),KFILOV',2I10) C IF(ITRP(2).NE.4.OR.KFILOV.EQ.0)THEN CALL INTRPC(KFILDO,P,NX,NY,DIR,ND1,NSTA,SDATA) C INTERPOLATE UNLESS INTERPOLATED ABOVE. C THE GRIDPOINTS AROUND A STATION HAVE BEEN MADE C CONSISTENT WITH THE CATEGORICAL CEILING (8 CATEGORIES) C OR VISIBILITY (7 CATEGORIES) DERIVED FROM THE STATION C MELD FORECASTS, WHEN THE FILE TO READ FROM IS C AVAILABLE, IN PLASTC1 OR PLASTV1 CALLED FROM PIXSM3. ENDIF C DO 300 K=1,NSTA C IF(P(K).GT.120.01.AND.P(K).LT.887.99)THEN WRITE(KFILDO,199)K,P(K) 199 FORMAT(' IN MELD70--K,P(K)',I6,F10.3) ENDIF C C IF(STALAT(K).NE.0..OR.STALON(K).NE.0)THEN C WILL NOT ATTEMPT TO PLOT AT LOCATION (0,0). C CCCCC IF(CCALL(K)(6:6).EQ.' ')THEN C THIS SCREENS OUT BOGUS (ASSUMES BOGUS HAS A C NON-BLANK IN THE 6TH POSITION, AND A C LEGITIMATE STATION DOESN'T). CALL PLATYP(KFILDO,KFILVO,CCALL(K),NAME(K), 1 SDATA(K),SDATA(K),STALAT(K),STALON(K), 2 NZERO,NZERO,NZERO,IWRITA, 3 NZERO,NZERO,NOSCII,ISTOP(1),IER) CCCCC ENDIF C ENDIF C 300 CONTINUE C CLOSE(UNIT=KFILVO) C THE FILE IS CLOSED SO THAT BUFFERS WILL BE DUMPED BEFORE C COPYING BELOW. CALL SYSTEM('cp -p '//VOTNAM//' '//VOTNAME) OPEN(UNIT=KFILVO,FILE=VOTNAM,FORM='FORMATTED', 1 STATUS='OLD') C REOPEN THE CLOSED FILE. NTOTVO=NTOTVO+NOSCII C THIS IS A RUNNING COUNT OF RECORDS WRITTEN TO C THE ASCII FILE ON UNIT NO. KFILVO. C IF(IP16.NE.0)THEN LD(1)=IDWRTC C IDWRTC HAS BEEN SET ABOVE. LD(2)=ID(2) LD(3)=ID(3) LD(4)=ID(4) WRITE(IP16,305)(LD(MMM),MMM=1,4),PLAIN,NDATE 305 FORMAT(/' WRITING ASCII TO UNIT KFILVO',3I10.9,I10.3, 1 3X,A32,' FOR DATE',I12) ENDIF C ENDIF C ELSE WRITE(KFILDO,307)KFILVO,IWRITA 307 FORMAT(/' ASCII FILE KFILVO NOT WRITTEN. KFILVO ='I4, 1 ' IWRITA =',I4) ENDIF C C WHENEVER CONTROL COMES HERE, ALL THRESHOLDS HAVE BEEN DEALT C WITH FOR THIS NN VARIABLE. C C CLOSE THE EQUATION FILE WHEN IN DEVELOPMENT MODE. THE UNIT C NUMBER MAY BE NEEDED AGAIN. FOR OPERATIONS, LEAVE FILE OPEN. C 501 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 MELD70') 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 MELD70 ') C RETURN END