SUBROUTINE MELD75(KFILDO,KFILIO,KFILRA,RACESS,NUMRA,KFIL10,INLTAB, 1 IP16,ID,IDPARS,JD,JP,ISCALD, 2 NDATE,JDATE, 3 FD2,OBSCUR,OV,CIG,NX,NY,ND2X3, 4 IPACK,IWORK,DATA,ND5,MINPK, 5 LSTORE,ND9,LITEMS,CORE,ND10,NBLOCK,NFETCH, 6 IS0,IS1,IS2,IS4,ND7, 7 ALATL,ALONL,NPROJ,ORIENT, 8 MESH,BMESH,XLAT, 9 NTOTBY,NTOTRC,NTOTGB,NTOTGR, A L3264B,L3264W,MISTOT,ISTOP,JER,IER) C C DECEMBER 2017 GLAHN MDL LAMP C ADAPTED FROM BKOVOB (U201) AND MELD70 C C PURPOSE C THIS ROUTINE IS FOR COMPUTING THE THREE COMPONENTS C OF CEILING: TOTAL OBSCURATION, OVERCAST, AND LOWEST C BROKEN LAYER, WHEN THERE IS A CEILING FORECAST. C C IT IS EXPECTED THE EQUATIONS FOR CEILING, OBSCURATION, C OVERCAST, AND BROKEN HAVE BEEN EVALUATED IN MELD70 AND THE C GRIDDED CATEGORICAL FORECASTS EXIST IN IRA (BROKEN IS C NOT ACTUALLY USED). C C THE STEPS IN COMPUTATION AT EACH GRIDPOINT, BASED ON THE C GRIDDED FORECASTS ARE: C 1) WHEN THERE IS OBSCURATION AND CEILING, THE C OBSCURATION TAKES THE VALUE OF THE CEILING FORECAST. C 2) WHEN THERE IS AN OVERCAST AND CEILING, AND NOT AN C OBSCURATION, THE OVERCAST TAKES THE VALUE OF THE C CEILING FORECAST. C 3) ALL CEILING FORECASTS THAT HAVE NOT BEEN MADE C OBSCURED OR OVERCAST ARE CONSIDERED BROKEN WITH C THE HEIGHT OF THE CEILING. C UNLIMITED = 888 IS USED IN ALL CASES WHEN THERE IS NOT C A SPECIFIC FORECAST OF ANY OF THE COMPONENTS. C C THE COMPUTED VALUES ARE WRITTEN TO FILES AS INDICATED C BY ICATS( ) READ HERE; NO DATA ARE RETURNED THROUGH THE C CALL SEQUENCE. C C DATA SET USE C KFILDO - DEFAULT UNIT NUMBER FOR OUTPUT (PRINT) FILE. C (OUTPUT) C KFILIO - UNIT NUMBER FOR WRITING GRIDPOINT FORECASTS. C (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 OF TDL MOS-2000 FILE SYSTEM ACCESS. C (INPUT-OUTPUT) C IP16 - UNIT NUMBER FOR INDICATING WHEN A RECORD IS C WRITTEN TO A FILE. (OUTPUT) C C VARIABLES C KFILDO = DEFAULT UNIT NUMBER FOR OUTPUT (PRINT) FILE. C (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 C MOS-2000 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 OF TDL MOS-2000 FILE SYSTEM ACCESS. C (INPUT) C INLTAB = UNIT NUMBER OF .CN FILE TO READ. (INPUT) C IP16 = INDICATES WHETHER (>0) OR NOT (=0) C A STATEMENT WILL BE OUTPUT TO IP16 C WHEN A FILE IS WRITTEN. (INPUT)) C ID(J) = THE INTEGER VARIABLE ID (J=1,4) FROM THE C U755.CN FILE. (INPUT) C IDPARS(J) = THE PARSED, INDIVIDUAL COMPONENTS OF THE C PREDICTOR ID CORRESPONDING TO ID( ) (J=1,15). C (INPUT) C J=1--CCC (CLASS OF VARIABLE), C J=2--FFF (SUBCLASS OF VARIABLE), C J=3--B (BINARY INDICATOR), C J=4--DD (DATA SOURCE, MODEL NUMBER), C J=5--V (VERTICAL APPLICATION), C J=6--LBLBLBLB (BOTTOM OF LAYER, 0 IF ONLY 1 LAYER), C J=7--LTLTLTLT (TOP OF LAYER), C J=8--T (TRANSFORMATION), C J=9--RR (RUN TIME OFFSET, ALWAYS + AND BACK IN TIME), C J=10--OT (TIME APPLICATION), C J=11--OH (TIME PERIOD IN HOURS), C J=12--TAU (PROJECTION IN HOURS), C J=13--I (INTERPOLATION TYPE), C J=14--S (SMOOTHING INDICATOR), AND C J=15--G (GRID INDICATOR). C 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. IT IS ASSOCIATED C WITH ID( ). (INPUT) C NDATE = THE DATE/TIME FOR WHICH PREDICTOR IS NEEDED. (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 OBSCUR(J) = WORK ARRAY, THE OBSCURED FORECASTS (J=1,NXY). C (INTERNAL) C OV(J) = WORK ARRAY, THE OVERCAST FORECASTS (J=1,NXY). C (INTERNAL) C CIG(J) = WORK ARRAY, THE CEILING FORECASTS (J=1,NXY). C (INTERNAL) C FD2(J) = WORK ARRAY (J=1,NXY) (INTERNAL) C NX = HORIZONTAL SIZE OF GRID. (INPUT) C NY = VERTICAL SIZE OF GRID. (INPUT) C ND2X3 = DIMENSION OF 6 ARRAYS ABOVE, WHICH ARE FDX IN C CALLING PROGRAM. (INPUT) C IPACK(J) = WORK ARRAY (J=1,ND5). (INTERNAL) C IWORK(J) = WORK ARRAY (J=1,ND5). (INTERNAL) C DATA(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 LSTORE(L,J) = THE ARRAY HOLDING INFORMATION ABOUT THE DATA C STORED (L=1,12) (J=1,LITEMS). (INPUT-OUTPUT) C L=1,4--THE 4 ID'S FOR THE DATA. C L=5 --LOCATION OF STORED DATA. WHEN IN CORE, C THIS IS THE LOCATION IN CORE( ) WHERE C THE DATA START. WHEN ON DISK, C THIS IS MINUS THE RECORD NUMBER WHERE C THE DATA START. C L=6 --THE NUMBER OF 4-BYTE WORDS STORED. C L=7 --2 FOR DATA PACKED IN TDL GRIB, 1 FOR NOT. C L=8 --THE DATE/TIME OF THE DATA IN FORMAT C YYYYMMDDHH. C L=9 --NUMBER OF TIMES DATA HAVE BEEN RETRIEVED. C L=10 --NUMBER OF THE SLAB IN DIR( , ,L) AND C IN NGRIDC( ,L) DEFINING THE CHARACTERISTICS C OF THIS GRID. C L=11 --THE NUMBER OF THE PREDICTOR IN THE SORTED C LIST IN ID( ,N) (N=1,NPRED) FOR WHICH THIS C VARIABLE IS NEEDED, WHEN IT IS NEEDED ONLY C ONCE FROM LSTORE( , ). WHEN IT IS NEEDED C MORE THAN ONCE, THE VALUE IS SET = 7777. C L=12 --USED INITIALLY IN ESTABLISHING MSTORE( , ). C LATER USED AS A WAY OF DETERMINING WHETHER C TO KEEP THIS VARIABLE. C ND9 = THE SECOND DIMENSION OF LSTORE( , ). (INPUT) C LITEMS = THE NUMBER OF ITEMS (COLUMNS) IN LSTORE( , ) THAT C HAVE BEEN USED IN THIS RUN. (INPUT) C CORE(J) = THE ARRAY TO STORE OR RETRIEVE THE DATA IDENTIFIED IN C LSTORE( , ) (J=1,ND10). WHEN CORE( ) IS FULL C DATA ARE STORED ON DISK. (INPUT) C ND10 = DIMENSION OF CORE( ). (INPUT) C NBLOCK = THE BLOCK SIZE IN WORDS OF THE MOS-2000 RANDOM C DISK FILE. (INPUT) C NFETCH = INCREMENTED EACH TIME GFETCH IS ENTERED. C IT IS A RUNNING COUNT FROM THE BEGINNING OF THE C PROGRAM. THIS COUNT IS MAINTAINED IN CASE THE USER C NEEDS IT (DIAGNOSTICS, ETC.). (OUTPUT) C IS0(J) = MOS-2000 GRIB SECTION 0 ID'S (J=1,3). (INTERNAL) C IS1(J) = MOS-2000 GRIB SECTION 1 ID'S (J=1,22+). (INTERNAL) C IS2(J) = MOS-2000 GRIB SECTION 2 ID'S (J=1,12). C IS2(3) AND IS2(4) ARE USED BY THE CALLING C PROGRAM AS THE GRID DIMENSIONS. (INTERNAL-OUTPUT) C IS4(J) = MOS-2000 GRIB SECTION 4 ID'S (J=1,4). (INTERNAL) C ND7 = DIMENSION OF IS0( ), IS1( ), IS2( ), AND IS4( ). C NOT ALL LOCATIONS ARE USED. (INPUT) C 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 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 L3264B = INTEGER WORD LENGTH IN BITS OF MACHINE BEING USED C (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 ISTOP( ) IN INCREMENTED EVEN IF THERE IS A STOP C IN CASE THE STOP IS PULLED OUT. (INPUT/OUTPUT) C JER = INCREMENTED BY 1 FOR EACH MAJOR ERROR. C (INPUT/OUTPUT) C IER = STATUS RETURN. C 0 = GOOD RETURN. C SEE GFETCH FOR OTHER VALUES. C WHEN IER NE 0, DATA ARE RETURNED AS MISSING. C (INTERNAL-OUTPUT) C NTIMES = THE NUMBER OF TIMES, INCLUDING THIS ONE, THAT THE C RECORD HAS BEEN FETCHED. THIS IS STORED IN C LSTORE(9, ). (INTERNAL) C LD(J) = HOLDS THE 4 ID WORDS OF THE DATA TO BE C RETRIEVED BY GFETCH (J=1,4). (INTERNAL) C MISSP = PRIMARY MISSING VALUE INDICATOR. RETURNED AS ZERO C WHEN DATA ARE NOT PACKED OR MISSING NOT C PRESENT. (INTERNAL) C MISSS = SECONDARY MISSING VALUE INDICATOR. RETURNED AS ZERO C WHEN DATA ARE NOT PACKED. (INTERNAL) C ITABLE(I) = CCCFFF OF THE CONVERTED DATA (J=1) AND THE NEEDED C DATA TO CONVERT FOR 3 IDS. C (INTERNAL) C FCST(IXY,3) = THE FORECASTS OBSCURATION (J=1), OVERCAST (J=2), C AND BROKEN (J=3) (IXY=IX*JY). THESE ARE WRITTEN C TO FILES ACCORDING TO ICAT( ) READ BELOW. C (ALLOCATABLE) (INTERNAL) C NGRIDT(L) = HOLDS INFO TO PROVIDE TO PACKGR (L=1,6). C (INTERNAL) C W3TAGE = AN NCEP ROUTINE REQUIRED WITH STOPS FOR C OPERATIONS. 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 GFETCH, W3TAGE, TIMPR, PRSID2, PAWGTS, PACKGR, GSTORE C CHARACTER*6 DUMMY CHARACTER*32 PLAIN(3),RACK CHARACTER*60 RACESS(6) C DIMENSION IDPARS(15),ID(4) DIMENSION OBSCUR(ND2X3),OV(ND2X3),CIG(ND2X3),FD2(ND2X3) DIMENSION IPACK(ND5),IWORK(ND5),DATA(ND5) DIMENSION IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7) DIMENSION LSTORE(12,ND9) DIMENSION CORE(ND10) DIMENSION LD(4),LDPARS(15),ICAT(4),ISTOP(2),NGRIDT(6),JDATE(4), 1 IRACK(8) DIMENSION KFILRA(6),ITABLE(7) C EQUIVALENCE (RACK,IRACK) C ALLOCATABLE FCST(:,:) C DATA PLAIN/' GLMP HRRR MELD FOB(C) CAT ', 1 ' GLMP HRRR MELD OVC(C) CAT ', 2 ' GLMP HRRR MELD BKN(C) CAT '/ C DATA ITABLE/228081005,228278005,228363005,228002005, !ORIGINAL IDS 1 228279005,228361005,228006005/ !NEW IDS C CEILING, OBSCURED, OVERCAST, BROKEN C D CALL TIMPR(KFILDO,KFILDO,'START MELD75 ') C IER=0 CCCCC WRITE(KFILDO,100)KFILIO,NUMRA,KFIL10,NDATE,ID(1),NX,NY,ND2X3 CCCCC 100 FORMAT(/' AT 100--KFILIO,NUMRA,KFIL10,NDATE,ID(1),NX,NY,ND2X3', CCCCC 1 8I12) C C READ THE CONTROLS FOR WRITING THE FILES. DUMMY IS A NAME C IN .CN FOR VISUAL IDENTIFICATION. C READ(INLTAB,101)DUMMY,(ICAT(J),J=1,4) 101 FORMAT(A6,4I4) C IF(DUMMY.NE.'CCATS ')THEN WRITE(KFILDO,102)DUMMY 102 FORMAT(/' ****PROCESSOR READ = ',A6,' SHOULD HAVE BEEN CCATS', 1 ' STOP IN MELD75 AT 102.') CALL W3TAGE('MELD75') STOP 102 ENDIF C NXY=NX*NY C NXY IS THE SIZE OF THE GRID IN THE ARRAYS OF SIZE ND2X3. C C SET UP ALLOCATED STORAGE FOR THE GRIDS NEEDED. C ALLOCATE (FCST(NXY,3),STAT=IOS) C IF(IOS.EQ.1)THEN WRITE(KFILDO,114) 114 FORMAT(/' ****ALLOCATION OF FCST( , ) FAILED IN MELD75 AT ', 1 '114. ARRAY ALREADY ALLOCATED. ABORT IN MELD75.') ISTOP(1)=ISTOP(1)+1 CALL W3TAGE('MELD70') STOP 114 C ELSEIF(IOS.EQ.2)THEN WRITE(KFILDO,115) 115 FORMAT(/' ****ALLOCATION OF FCST( , ) FAILED IN MELD75 AT ', 1 '115. ARRAY NOT ALLOCATED. ABORT IN MELD75.') ISTOP(1)=ISTOP(1)+1 CALL W3TAGE('MELD70') STOP 115 ENDIF C C GET THE OBSCURED FORECASTS AT THE TAU OF THE ID. C LD(1)=ITABLE(2) LD(2)=ID(2) LD(3)=ID(3) LD(4)=ID(4) CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,OBSCUR,ND2X3, 2 NWORDS,NPACK,NDATE,NTIMES,CORE,ND10, 3 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B,1,IER) IF(MISSP.NE.0)MISTOT=MISTOT+1 C IF(NWORDS.NE.NXY)THEN WRITE(KFILDO,116)NWORDS,NXY 116 FORMAT(' ****ERROR READING DATA IN MELD75,', 1 ' NWORDS, NXY =',2I10) ISTOP(1)=ISTOP(1)+1 CALL W3TAGE('MELD75') STOP 116 ENDIF C IF(IER.NE.0)THEN ISTOP(1)=ISTOP(1)+1 ISTOP(2)=ISTOP(2)+1 CALL W3TAGE('MELD75') STOP 117 ENDIF C D WRITE(KFILDO,117)(LD(J),J=1,4),NDATE,(OBSCUR(J),J=1,50) D117 FORMAT(/' IN MELD75 AT 117 OBSCURED--', D 1 '(ID(J),J=1,4),NDATE,OBSCUR( )',5I11/(20F6.0)) C C GET THE OVERCAST FORECASTS AT THE TAU OF THE ID. C LD(1)=ITABLE(3) LD(2)=ID(2) LD(3)=ID(3) LD(4)=ID(4) CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,OV,ND2X3, 2 NWORDS,NPACK,NDATE,NTIMES,CORE,ND10, 3 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B,1,IER) IF(MISSP.NE.0)MISTOT=MISTOT+1 C IF(NWORDS.NE.NXY)THEN WRITE(KFILDO,118)NWORDS,NXY 118 FORMAT(' ****ERROR READING DATA IN MELD75,', 1 ' NWORDS, NXY =',2I10) ISTOP(1)=ISTOP(1)+1 CALL W3TAGE('MELD75') STOP 118 ENDIF C IF(IER.NE.0)THEN ISTOP(1)=ISTOP(1)+1 ISTOP(2)=ISTOP(2)+1 CALL W3TAGE('MELD75') STOP 119 ENDIF C D WRITE(KFILDO,122)(LD(J),J=1,4),NDATE,(OV(J),J=1,50) D122 FORMAT(/' IN MELD75 AT 122 OVERCAST--', D 1 '(ID(J),J=1,4),NDATE,OV( )',5I11/(20F6.0)) C C GET THE CEILING FORECASTS AT THE TAU OF THE ID. C LD(1)=ITABLE(1) LD(2)=ID(2) LD(3)=ID(3) LD(4)=ID(4) CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,CIG,ND2X3, 2 NWORDS,NPACK,NDATE,NTIMES,CORE,ND10, 3 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B,1,IER) IF(MISSP.NE.0)MISTOT=MISTOT+1 C IF(NWORDS.NE.NXY)THEN WRITE(KFILDO,123)NWORDS,NXY 123 FORMAT(' ****ERROR READING DATA IN MELD75,', 1 ' NWORDS, NXY =',2I10) ISTOP(1)=ISTOP(1)+1 CALL W3TAGE('MELD75') STOP 123 ENDIF C IF(IER.NE.0)THEN ISTOP(1)=ISTOP(1)+1 ISTOP(2)=ISTOP(2)+1 CALL W3TAGE('MELD75') STOP 124 ENDIF C D WRITE(KFILDO,128)(LD(J),J=1,4),NDATE,(CIG(J),J=1,50) D128 FORMAT(/' IN MELD75 AT 128 CEILING--', D 1 '(ID(J),J=1,4),NDATE,CIG( )',5I11/(20F6.0)) C C COMPUTE ALL THREE VARIABLES IN FCST( ,1), FCST( ,2), C AND FCST( ,3) THEN WRITE THEM. C DO 250 K=1,NXY C IF(CIG(K).GT.9998.9.OR. 1 OV(K).GT.9998.9.OR. 2 OBSCUR(K).GT.9998.9)THEN FCST(K,1)=9999. FCST(K,2)=9999. FCST(K,3)=9999. C ELSEIF(CIG(K).GT.887.)THEN FCST(K,1)=888. FCST(K,2)=888. FCST(K,3)=888. C ELSE C IF(OBSCUR(K).LT.887.)THEN FCST(K,1)=CIG(K) FCST(K,2)=888. FCST(K,3)=888. C ELSEIF(OV(K).LT.888.)THEN FCST(K,1)=888. FCST(K,2)=CIG(K) FCST(K,3)=888. C ELSE FCST(K,1)=888. FCST(K,2)=888. FCST(K,3)=CIG(K) C ENDIF C ENDIF C 250 CONTINUE C C NOW PACK AND WRITE THE 3 CATEGORICAL FORECAST GRIDS TO C THE ARCHIVE UNIT KFILIO AT MESH LENGTH MESH WHEN C ICAT(2) NE.0 AND KFILIO NE 0 IN ORDER OBSCURED, C OVERCAST, AND BROKEN. C IF(ICAT(2).NE.0.AND.KFILIO.NE.0)THEN C DO 255 J=1,3 LD(1)=ITABLE(J+4) LD(2)=ID(2) LD(3)=ID(3) LD(4)=0 CALL PRSID2(KFILDO,LD,LDPARS,THRESH) RACK=PLAIN(J) ITAUM=0 NSEQ=0 NCHAR=32 XMISSP=9999. XMISSS=0. CCCCC CALL TIMPR(KFILDO,KFILDO,'CALLING PAWGTS ') CCCCC WRITE(KFILDO,252)ISCALD,NPROJ,ALATL,ALONL,ORIENT,MESH, CCCCC 1 XLAT,NX,NY,KFILIO CCCCC 252 FORMAT(/' AT 252--ISCALD,NPROJ,ALATL,ALONL,ORIENT,MESH,', CCCCC 1 'XLAT,NX,NY,KFILIO',2I4,3F10.4,I4,F10.4,2I8,I4) C CALL PAWGTS(KFILDO,KFILIO,'KFILIO',IP16,NDATE, 1 LD,LDPARS(12),ITAUM,IDPARS(4),NSEQ,ISCALD, 2 NPROJ,ALATL,ALONL,ORIENT,MESH,XLAT,NX,NY, 3 FCST(1,J),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,254) 254 FORMAT(/' ****ERROR IN PAWGTS IN MELD75 AT 254.') C THE MELD75 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. ENDIF C 255 CONTINUE 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 IN ORDER OBSCURED, OVERCAST, AND C BROKEN. C IF(ICAT(4).NE.0)THEN C DO 275 J=1,3 C DO 270 JJ=1,NUMRA C IF(KFILRA(JJ).EQ.42)THEN LD(1)=ITABLE(J+4) LD(2)=ID(2) LD(3)=ID(3) LD(4)=0 RACK=PLAIN(J) 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 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,FCST(1,J),ND2X3,NX,NY,IPACK,IWORK,ND5, 4 MINPK,IS0,IS1,IS2,IS4,ND7, 5 XMISSP,XMISSS,NWORDS,NTOTGB,NTOTGR, 6 L3264B,L3264W,ISTOP(1),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 JER=JER+1 IER=0 GO TO 264 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 ENDIF C 264 CONTINUE C GO TO 275 C ALL WRITING HAS BEEN DONE OR TRIED. GET OUT OF LOOP. C 270 CONTINUE C WRITE(KFILDO,272) 272 FORMAT(/' ****RANDOM ACCESS FILE UNIT NO. 42 NOT AVAILABLE', 1 ' FOR WRITING CATEGORICAL FORECASTS IN MELD75.', 2 ' COUNT AS MAJOR ERROR. CONTINUING.') ISTOP(1)=ISTOP(1)+1 JER=JER+1 275 CONTINUE C ENDIF 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 DO 300 J=1,3 LD(1)=ITABLE(J+4) LD(2)=ID(2) LD(3)=ID(3) LD(4)=0 CALL GSTORE(KFILDO,KFIL10,LD,0,LSTORE,ND9,LITEMS, 1 FCST(1,J),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=PLAIN(J) 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 300 CONTINUE C ENDIF C DEALLOCATE (FCST) C 600 CALL TIMPR(KFILDO,KFILDO,'END MELD75 ') C RETURN END