SUBROUTINE U405A(KFILDI,KFILDO,KFIL10,KFILOG,KFILOV,KFILQC,KFILIO, 1 KFILVO,KFILLP,KFILCP,KFILRA,RACESS,NUMRA,NCEPNO, 2 IP8,IP12,IP14,IP16,IP17,IP18,IP19,IP20,IP21,IP22, 3 IP24,IP25,OUTVEC,OUTQCV,VOTNAM, 4 IALOC,ADIST,AELEV,ND13,ELEVLO,ELEVHI, 5 ICALL,CCALL,NAME,XP,YP,XYP,XPL,YPL, 6 TOSS,QUEST,ISDATA,SDATA,MTAGPT, 7 WDIR,WSPD,LTAG,IQUAL,LNDSEA,ELEV,STALAT,STALON, 8 NOPAR,LOCPAR,QUALST,XLAPSE,VRAD,NSTA,ND1, 9 P,FD2,FD3,FD4,FD5,FD6,U,V,FDSINS,ND2X3, A ID,IDPARS,JD,JP,ICOMPT,ISCALD, B THRESH,ANLTAB,INLTAB,IWRITS,IWRITA,IWRITF,DIR, C NGRIDC,ND11,IPLAIN,PLAIN,ND4,PLAINT,IPLANT,NPRED, D N,ICALLD,CCALLD,IPACK,DATA,IWORK,ND5, E MODNO,NDATE,MODNUM,ND6, F NAREA,ALATL,ALONL,NPROJ,ORIENT,XLAT, G NXL,NYL,MESHB,BMESH,MESHL,IOPTB,NCLIPY, H TELEV,SEALND,CPNDFD,NXE,NYE,XPE,YPE,MESHE,EMESH, I IS0,IS1,IS2,IS4,ND7, J LSTORE,LITEMS,ND9, K CORE,ND10,NBLOCK,NSTORE,NFETCH, L JTOTBY,JTOTRC,MTOTBY,MTOTRC,ITOTBY,ITOTRC, M NTOTBY,NTOTRC,NOTOSS,NTOTGR,NTOTVO, N L3264B,L3264W,MISTOT,MINPK, O ISTA,ISMPL,ISTOP,IER) C C JUNE 2004 GLAHN TDL MOS-2000 C ADAPTED FROM U400A C AUGUST 2004 GLAHN ADDED QUALCL, QUALWT( ) C SEPTEMBER 2004 GLAHN DIMENSIONED LIMIT( ); ADDED ISAVDT; C CHANGED SAVDAT( ) TO NSAVDT( ) C SEPTEMBER 2004 GLAHN ADDED IQUAL( , ) TO CALL, ETC. C OCTOBER 2004 GLAHN ADDED NELEV( ) TO CALL AND TO BCD5 C OCTOBER 2004 GLAHN CHANGED TO SET OPT( ) ONLY ONCE AND C TO WRITE DIAGNOSTIC C OCTOBER 2004 GLAHN CHANGED NELEV( ) TO ELEV( ) C OCTOBER 2004 GLAHN MODIFIED FOR LAT/LON VICE POLE C OCTOBER 2004 GLAHN ADDED LNDSEA( ), LNDWAT( , ), ISETP, C ILS; MODIFIED WRITING ARCHIVE GRID C TO MESH LENGTH MESHB C OCTOBER 2004 GLAHN INSERTED LAMBERT AND MERCATOR C NOVEMBER 2004 GLAHN ADDED KFILVO CAPABILITY C NOVEMBER 2004 GLAHN CHANGED ITABLE( , , ) FOR TEMP C NOVEMBER 2004 GLAHN ADDED ELCORR( , ), CALL TO RDSTRT C DECEMBER 2004 GLAHN ADDED IDST( , , , ), IDPARS( , , , ), C TRSTL( , , ), TRSTU( , , ), XLAPSE( ), C AA( , , , ), IDIMTB( , ), ND13, ND14, C ND15, IBASE( ); REMOVED IDIM; ADDED C IDENT( ) C DECEMBER 2004 GLAHN INCREMENTED ISTOP(1) AT 501; MINOR C COMMENTS; ADDED TEST AND FORMAT 288 C DECEMBER 2004 GLAHN PUT (1) ON CINT, ORIGIN, SMULT, AND C SADD IN CALL TO FSTGS5; REMOVED THRESH C FROM DIMENSION STATEMENT; CHANGED C CALLD TO CCALLD IN CALL C DECEMBER 2004 GLAHN CHANGED QUALWT(3) TO QUALWT(4) C JANUARY 2005 GLAHN CHANGED STATEMENT 501 TO 115 C FEBRUARY 2005 GLAHN COMPUTED HOUR OF FORECAST IHR AND C ADDED IHR AND JDATE( ) TO CALL TO C RDSTRT C FEBRUARY 2005 GLAHN PUT CALL TO FLTAG ABOVE CALL TO FSTGS5 C AND INCLUDED LTAG( ) IN CALL TO FSTGS5 C FEBRUARY 2005 GLAHN INCREASED JVAL TO 6 AND ADDED MAX AND C MIN CLIMO IDS TO ITABLE( , , ); ADDED C READING OF NORM; REMOVED COMMENT FOR C UNUSED DOTCN; ADDED SEALND, NXE, NYE, C MESHE, NORM TO CALL TO FSTGS5 C FEBRUARY 2005 GLAHN REMOVED IVRBL FROM CALL TO FSTGS5; C ADDED JFIRST( ) AND ADDED IT TO CALL C TO BCD5; INSERTED SATURATION DEFICIT C INTO ITABLE( , , ) AND INCREASED NVAL C MARCH 2005 GLAHN INITIALIZED IBASE( ); ADDED NOSTM TO C CALLS TO RDSTRT AND BCD; REMOVED C IDENT( ) FROM CALL TO RDSTRT C APRIL 2005 GLAHN REMOVED NORM OPTION AND ADDED NBLEND C OPTION C MAY 2005 GLAHN ELIMINATED STRATIFICATION FEATURE; C ADDED LAPSE CALCULATION ON THE FLC C MAY 2005 GLAHN CHANGED NOALOC( ) TO NOPAR( ), C KEY( ) TO LOCPAR( ); ADDED LOCSTA( ) C MAY 2005 GLAHN ADDED NAME( ) TO CALL. C MAY 2005 GLAHN REMOVED LOCSTA( ) C MAY 2005 GLAHN ADDED IP14 FOR COMPUTED LAPSE RATES; C ADDED ELEV( ) TO CALL TO LAPSE C JUNE 2005 GLAHN MODIFIED COMMENT C JUNE 2005 GLAHN ADDED CAPABILITY OF WITHHOLDING DATA C AND VERIFYING FIT ON THOSE DATA; C MODIFIED COMMENTS; CHECKED SPELLING C JULY 2005 GLAHN MODIFIED LD(1) FOR DATA TO ANALYZE C TO RETRIEVE IN RETVEC; ADDED CCALL TO C CALL TO WITHOL C JULY 2005 GLAHN ADDED NAME( ) TO CALL TO BCD5 C JULY 2005 GLAHN ADDED NOTOSS TO CALL AND CALL TO BCD5 C AUGUST 2005 GLAHN INCREASED NVAL TO 16 AND ITABLE( , , ) C AUGUST 2005 GLAHN INCREASED SIZE OF ANLTAB TO 14 C AUGUST 2005 GLAHN ADDED PRE AND POST PROCESSING C CAPABILITY; CHANGED ITABLE IN CALL C TO BCD5 C AUGUST 2005 GLAHN ADDED PREPRO( ) TO CALL TO FSTGS5 C AUGUST 2005 GLAHN ADDED SNOWFALL TO ITABLE( , , ) C SEPTEMBER 2005 GLAHN READ PRE- AND POSTPROCESSING NAMES C FROM VARIABLE CONTROL FILE; ADDED C POSTPROCESSING C SEPTEMBER 2005 GLAHN CHANGED NSCALE FOR SCLSNO FROM 1 TO 0 C AND TRUNC FROM 0 TO .1 C SEPTEMBER 2005 GLAHN CHANGED 228461 TO 228462 PER C DALLAVALLE C SEPTEMBER 2005 GLAHN ADDED READING TRUNC( ) FROM .CN FILE C SEPTEMBER 2005 GLAHN ADDED RH TO ITABLE PER IBM C OCTOBER 2005 GLAHN ADDED ISTA AND ISMPL; SAMPLING OF C FIRST GUESS FOR ANALYSIS POINTS; C IPOINT( , ) C OCTOBER 2005 GLAHN CHANGED FORMAT 140 TO 130 FOR C IPOINT( , ) C OCTOBER 2005 GLAHN ACCOMMODATED KFILLP = 0; ADDED KFILLP C TO CALL TO LAPSE. C OCTOBER 2005 GLAHN ADDED ELCORR( , ) AND NPASS TO CALL C TO LAPSE C OCTOBER 2005 GLAHN ADDED IBKPN AND BK( , ) C NOVEMBER 2005 GLAHN ADDED LIMITX C DECEMBER 2005 GLAHN ADDED DATA TO IS1( ) FOR CALL TO C PAWRAG C JANUARY 2006 GLAHN SUBSTITUTED PACKGR FOR PAWRAG SO THAT C IT MATCHES THE IBM VERSION IN THAT C RESPECT; COMMENT FOR JER C JANUARY 2006 GLAHN REMOVED LIMITX C JANUARY 2006 GLAHN ADDED IP24 FOR WRITING FIT TO STATIONS C OVER WHOLE AREA VICE IP14 C JANUARY 2006 GLAHN ADDED ELCORU( , ) C JANUARY 2006 GLAHN ADDED IALGOR( , ) C MARCH 2006 GLAHN MODIFIED TO REDUCE STATION LIST FOR C BCD5; ADDED CALLS TO TRAIL; ADDED C NREDUC, ADDED OUTVEC AND OUTQCV TO CALL C MARCH 2006 GLAHN BYPASSED WITHOL, RESTRD, AND FITWTH WHEN C NWITH=0 C MARCH 2006 GLAHN UPDATED ITABLE( , , ) FOR WIND U,V,S C MARCH 2006 GLAHN INCREASED ISTOP(3) TO ISTOP(5); ADDED C IP14 AND ISTOP( ) TO CALL TO ITRPSL C MARCH 2006 GLAHN ADDED KFILSL, CSTSM, N4P C MARCH 2006 GLAHN ADDED CCALLR FOR WRITING FOR GEMPAK C APRIL 2006 GLAHN ADDED MULTIPLE PROJECTIONS IN ONE C ANALYSIS; ADDED NORUNS, NHRRUN( ), C WTRUNA( ) WTRUNL; INCREASED XDATA(ND1) C TO XDATA(ND1,6) C APRIL 2006 GLAHN CHANGED ITABLE(1,1,IVRBL) TO C ITABLE(1,2,IVRBL) IN CALL TO BCD5 C APRIL 2006 GLAHN ARRANGED TO STOP WITH MISSING DATA C ONLY WHEN THE FIRST CYCLE IS MISSING; C CHANGED FLTAG TO FLTAGM C APRIL 2006 GLAHN INCREASED ANLTAB CHARACTER*14 TO *17 C APRIL 2006 GLAHN CHANGED IP14 TO IP24 IN CALL TO C FITWTH; ADDED IP24 TO CALL TO WITHOL C MAY 2006 GLAHN REMOVED FD2 IN CALL TO SCLSNO C MAY 2006 GLAHN CHANGED XP( ) ETC. TO XPL( ) IN C CHECKING WITH OPT( ) BELOW 3439 C MAY 2006 GLAHN CHANGED CALL TO SKIPWR TO SKPWR2 C JUNE 2006 GLAHN ADDED IBKPN = 99 CAPABILITY; C ADDED IBKPN TO CALL TO LAPSE C JUNE 2006 GLAHN CHANGED CALL TO SZGRID TO SZGRDM C JUNE 2006 GLAHN CHANGED CHECK ON MISSING DATA BELOW C 3434 C JUNE 2006 GLAHN ADDED CPNDFD( ) AND NCLIPY TO CALL C AND NCLIP C JULY 2006 GLAHN INSERTED /D DIAGNOSTIC 3432 C JULY 2006 GLAHN SET MESH = 99 BEFORE CALL TO SCLSNO; C INCLUDED CALL TO CLIP C JULY 2006 GLAHN NSMTYP, B( , ), NPASS, AND NCLIPO C ADDED TO CALL TO FSTGS5; CLIPPED FINAL C ANALYSIS IF NEEDED C AUGUST 2006 GLAHN ADDED TO NCLIPO CAPABILITY C SEPTEMBER 2006 GLAHN SET NVAL TO 19, ADDED LAMP CAPABILITY C SEPTEMBER 2006 GLAHN ADDED LPNO; ADDED WRITING LAPSE C RATES TO KFILVO C OCTOBER 2006 GLAHN CHANGED FORMAT 321 C OCTOBER 2006 GLAHN ADDED VARIABLES TO CALLS TO WITHOL AND C FITWTH C NOVEMBER 2006 GLAHN SET NVAL TO 25; ADDED LAMP CAPABILITY C NOVEMBER 2006 GLAHN MODIFIED TO CHECK FOR SPECIFIC MODEL NO C IN ITABLE( , , ) C NOVEMBER 2006 GLAHN PUT CALL LAPSE AFTER CALL FSTGS5; ADDED C LAPFG C DECEMBER 2006 GLAHN MINOR PRINT FORMATS AND COMMENTS; C ADDED MGUESS TO CALL TO BCD5; ADDED C DIAGNOSTIC AT 2865 C JANUARY 2007 GLAHN ADDED NSHLN( ); COMBINED WIND GUST IDS C JANUARY 2007 GLAHN CALLED PAWLPM RATHER THAN PAWING C JANUARY 2007 GLAHN MODIFIED CALL TO WITHOL C FEBRUARY 2007 GLAHN ADDED 6- AND 12-H QPF TO TABLE; PULLED C 2 LAMP VARIABLES TO KEEP WITHIN 99 C CONTINUATION LINES C FEBRUARY 2007 GLAHN ELIMINATED WRITING PACKED XLAPSE( ) C WHEN IBKPN = 99 C MARCH 2007 GLAHN REVISED FOR NCLIP TO PERTAIN TO OUTPUT; C REMOVED NCLIP, NCLIPO, NCLIPY FROM CALL C TO FSTGS5; ADDED WRITING FULL VECTOR C DATA RECORD TO KFILVO C MARCH 2007 GLAHN CHANGED SCALING BEFORE SCLSNO 0 TO 1 C MARCH 2007 GLAHN INSERTED CALL TO SCLSKY C MARCH 2007 GLAHN REMOVED NORUNS IN CALL TO SCLSNO C MARCH 2007 GLAHN CHANGED STATEMENT NO. 3430 TO 3426; C CHANGED STATION LIST REDUCTION TO C NOT DEPEND ON KFILSL C MARCH 2007 GLAHN REMOVED IQUAL( ) AND QUALWT( ) FROM C CALL TO BCD5; REMOVED IQUALA( , ) C APRIL 2007 GLAHN INSERTED MGUESS IN 2ND CALL TO BCD5 C MAY 2007 GLAHN MOVED JER=1 FROM BELOW 287 TO ABOVE C IT; INSERTED ERROR HANDLING CODE AFTER C CALLS TO SCLSNO AND SCLSKY; CHANGED C NDATE TO MDATE IN CALLS TO SCLSKY C AND SCLSNO C MAY 2007 GLAHN INCREASED IQUAL( ,2) TO IQUAL( ,5) C MAY 2007 GLAHN ADDED SCLQ06 AND SCLQ12 C MAY 2007 GLAHN CHANGED CCALL TO CCALLA IN 2 CALLS C TO PACKV C JUNE 2007 GLAHN CHANGED NVAL FROM 24 TO 22 C JUNE 2007 GLAHN CHANGED NVAL FROM 22 TO 24, C REINSERTED POP6 AND POP12 C JUNE 2007 GLAHN OMITTED ITABLE( , , ) IN DATA C STATEMENT, READ IN THE INFORMATION. C OTHER CHANGES TO ACCOMMODATE; TOOK C NREDUC OUT OF DATA STATEMENT AND PUT C IT IN THE .CN FILE; ADDED NGRIDT( ); C ADDED ISAVDT TO DATA STATEMENT; C ADDED ERROR STOP AFTER 1303; ADDED C RWATO( ) AND RWATI( ) C JUNE 2007 GLAHN INCORPORATED TRUNCATION IN .CN FILE; C ELIMINATED TRUNC( ); ADDED TLOD, C SETLOD,THID,SETHID,EX1D,EX2D; CALL C TO BCD5 AND OTHER POSTPROCESSING C JUNE 2007 GLAHN MODS TO ANALYZE PROBABILITY LEVELS; C OMITTED CAPABILITY TO REDUCE STATION C LIST; ELIMINATED CLOSING RA FILE; C ELIMINATED NREDUC C JULY 2007 GLAHN ADDED NPRED TO CALL; ADDED BACK C WRITING TO KFILOV MISTAKENLY REMOVED C JULY 2007 GLAHN ADDED CHECK ON CORRECT MSHPAS( , ) C JULY 2007 GLAHN XDATA( ) REMOVED FROM CALL AND MADE C ALLOCATABLE. C JULY 2007 GLAHN MODIFIED TEST NUMBER OF STATIONS AT C 311; ADDED NPRED TO CALL C AUGUST 2007 GLAHN ADDED VRAD(ND1), IVRAD C AUGUST 2007 GLAHN OMITTED CHECK ON KFILIO ABOVE D347 C SEPTEMBER 2007 GLAHN REPLACED NEWXY WITH NEWXY1 C OCTOBER 2007 GLAHN INCREASED DIMENSION VRAD(ND1,6) C OCTOBER 2007 GLAHN ADDED ND1 TO CALL TO BCD5 C NOVEMBER 2007 GLAHN ADDED POSTPROCESSING ROUTINE OSMTH C NOVEMBER 2007 GLAHN EXPANDED PRE- AND POST-PROCESSING C CAPABILITY; ADDED OSMTH C NOVEMBER 2007 GLAHN REMOVED IWLOOP; ADDED IWSEED, ITYPR C NOVEMBER 2007 GLAHN REPLACED R(1,1)*RSTAR(1,1) IN CALL C TO LAPSE WITH C RLAP=R(1,MGUESS)*RSTAR(1,MGUESS) AND C ELCORR(1,IGUESS(1)) WITH C ELCORR(1,MGUESS) C NOVEMBER 2007 GLAHN MOVED BOGUS TO AFTER FSTGS5 C NOVEMBER 2007 GLAHN ADDED IF(MFIRST.EQ.0)THEN C ISEED=ISEEDT(IWSEED) C NOVEMBER 2007 GLAHN ADDED EREST ROUTINE AND WRITING C DECEMBER 2007 GLAHN ADDED IP(25) AND ISTOP(6) CAPABILITY C DECEMBER 2007 GLAHN ADDED ELEV( ) TO CALL TO WTHOL2; C INCREASED 2ND DIMENSION OF ERRANL( , ) C DECEMBER 2007 GLAHN ADDED IDIM AND ID2( ) C DECEMBER 2007 GLAHN ADDED NROUGH, RCLOS2, RVARI, RDENS, C RELVAR TO DATA STATEMENT AND TO C CALL TO WTHOL2; ADDED EREST C JANUARY 2008 GLAHN ADDED RWATO(1) AND RWATI( ) TO CALL C TO EREST C JANUARY 2008 GLAHN ADDED XLAPSE TO CALL TO WTHOL2 C FEBRUARY 2008 GLAHN ADDED IP14, P, N4P TO CALL TO EREST C FEBRUARY 2008 GLAHN REMOVED RDENS, ADDED RELVAR TO CALL C TO EREST C FEBRUARY 2008 GLAHN CHANGED RCLOS2 FROM 45 TO 55; REMOVED C R(1,MGUESS) FROM CALL TO EREST C FEBRUARY 2008 GLAHN SET IEXTRA = 0 VICE 5 C FEBRUARY 2008 GLAHN ADDED EX1A AND EX2A TO CALL TO EREST C FEBRUARY 2008 GLAHN ADDED DIMENSION FOR ANLTAB C FEBRUARY 2008 GLAHN ADDED FILE NAME WITH PREPROCESSOR C SUBROUTINE NAME; KFILBO DEFINED C FEBRUARY 2008 GLAHN CORRECTED FORMAT 272 C FEBRUARY 2008 GLAHN CHANGED NS TO NE IN 2 PLACES IN 2863; C CHECKED ID( ) = ITABLE( , ) AT 2862 C REMOVED KFILSL FROM CALL C FEBRUARY 2008 GLAHN ADDED NAREA TO CALL C FEBRUARY 2008 GLAHN ADDED CDTDP C FEBRUARY 2008 GLAHN ADDED WRITING TO IP16 WHEN ANALYSIS C IS WRITTEN TO KFIL10 C FEBRUARY 2008 GLAHN CHANGED USE OF KFILVO; ADDED IWRITA C MARCH 2008 GLAHN XLAPSE( ) SET = 0 WHEN IBKPN = 99 C MARCH 2008 GLAHN ELIMINATED HARDWIRING BEFORE CALLS C TO SUBROUTINES IN PREPRO C MARCH 2008 GLAHN CHECKED IDS READ WITH ID(1) AND ID(4) C AT 1300; REMOVED CHECK AT 2862 C MARCH 2008 GLAHN ADDED CALL TO SKYAMT C MARCH 2008 GLAHN ELIMINATED KFILBO; ADDED KFILPR(3) C MARCH 2008 GLAHN ADDED KFILCP C APRIL 2008 GLAHN ADDED ICOMPT( ) C APRIL 2008 GLAHN REVISED CALL TO DIRSPD TO INCLUDE C ITABLE, JVAL, AND MODNO C MAY 2008 GLAHN ADDED LNDWAT = 2,3 CAPABILITY C MAY 2008 GLAHN MODIFIED CALL TO LAPSEU C MAY 2008 GLAHN REMOVED IGUESS IN CALL TO LAPSEU C MAY 2008 GLAHN INCREASED PREPROCESSORS TO 6 VICE 3 C JUNE 2008 GLAHN ADDED CKPOP C JUNE 2008 GLAHN ADDED NTOTGB TO CALL TO DIRSPD; C .AND.ICOMPT(M).EQ.0 MOVED BELOW 375 C JUNE 2008 GLAHN ADDED WRITING DIRECTION/SPEED TO ASCII C JUNE 2008 GLAHN WIND ID FOR ASCII CORRECTED C JUNE 2008 GLAHN CHANGED ID, IDPARS INPUT TO FSTGS5 C JULY 2008 GLAHN INSERTED ID(1,M) VICE LD INTO CALL TO C FSTGS5 AND IP16 MOVED IN CALL C JULY 2008 GLAHN ADDED LNDSEA( ) TO CALL TO AUGMT1 C JULY 2008 GLAHN ADDED IWRITS = 2 AND 3 CAPABILITY C JULY 2008 GLAHN ADDED ASCII SCALING FOR SNOW RF C JULY 2008 GLAHN MODIFIED DIRECTION PLOTTING C AUGUST 2008 GLAHN REMOVED USE OF PREQPF; ADDED CKQPF C AUGUST 2008 GLAHN ADDED QPF6P6; ADDED LOOP DO 3468 C AUGUST 2008 GLAHN INTERNAL STORAGE DATA NOT PACKED C AUGUST 2008 GLAHN ADDED CALL TO CONEKD C AUGUST 2008 GLAHN IDPARS(1,M) VICE IDPARS CALL TO FSTGS5 C AUGUST 2008 GLAHN MODIFIED TO CALL LAPSUA VICE LAPSEU C AUGUST 2008 GLAHN ADDED DIR( , , ) TO CALL; ADDED C NSLAB, DIR TO CALL TO LAPSUA C AUGUST 2008 GLAHN ADDED MESHSV, NXSV, NYSV; SET LTAG( ) C VALUES OF -1 TO +1 BEFORE WRITING C SEPTEMBER 2008 GLAHN ADDED LAPFG = 3 C SEPTEMBER 2008 GLAHN NTOTVO RESET TO 0 BELOW 375 C SEPTEMBER 2008 GLAHN SWITCH PLOTTING DIRECTION/SPEED TO C WHEN SPEED OR GUSTS ANALYZED VICE DIR C SEPTEMBER 2008 GLAHN ADDED CALL TO OSMTH1 C SEPTEMBER 2008 GLAHN COMMENT FOR LPNO; TWO CHANGES AT 2863 C AND BELOW; ONE CHANGE BEFORE CALL TO C RETVEC LD(4)=ID(4,M) VICE ITABLE(4,2) C SEPTEMBER 2008 GLAHN ADDED FD6( ) TO CALL TO CKPOP, CKQPF, C CKMAXT, CKMINT, CKTDP, CKWNDG C SEPTEMBER 2008 GLAHN CHANGED CALL TO CKMAXT AND CKMINT C OCTOBER 2008 GLAHN ADDED SPECIFIC ID( ,M), IDPARS( ,M), C AND JD( ,M) TO CALL TO BOGUS; ADDED C WRITE OF WIND SPEED ONLY TO ASCII WHEN C DIRECTION IS MISSING C OCTOBER 2008 GLAHN ADDED WTWTL, WTLTW C NOVEMBER 2008 GLAHN ADDED FL174 C DECEMBER 2008 GLAHN ADDED ASCII WRITING FOR WIND DIRECTION C JANUARY 2009 GLAHN ADDED CHECK FOR MODNO = DD AT 2869; C SOME STATEMENT NUMBERS WERE CHANGED C JANUARY 2009 GLAHN CHANGES TO ACCOMMODATE RANDOM NUMBER C GENERATOR SEED BEING REAL VICE INTEGER C MARCH 2009 GLAHN ADDED VARTAB( , ), ELIMINATED C RVARI( ) AND RCLOS2; MODIFIED CALLS TO C WTHOL2 AND EREST C FEBRUARY 2009 WAGNER PASSED MODNUM AND ND6 FROM U155 AND C PASSED ON TO LAPSUA C MARCH 2009 GLAHN CHANGED NDATE TO MDATE IN CALL TO C AUGMT1 C APRIL 2009 GLAHN ADDED TO CALL TO EREST C APRIL 2009 GLAHN ADDED NHRRUN( ) TO CALL TO AUGMT1 C APRIL 2009 GLAHN ADDED NAME( ) TO CALL TO AUGMT1 C MAY 2009 GLAHN MODIFIED DATA ID FOR HOURLY DATA C MAY 2009 GLAHN ADDED JDATE(4), NAREA TO CALL TO C AUGMT1 C MAY 2009 GLAHN ADDED NPROJ,ORIENT,BMESH,XLAT,ALATL, C AND ALONL TO CALL OT RDVRHL C JUNE 2009 GLAHN ADDED PLAINT,IPLANT TO CALL; ADDED C CALL TO CAKSNO; SET XLAPSE( ) TO ZERO C WHEN ALASKA SNOW FORECAST LE 0 C JUNE 2009 GLAHN ADDED PREX3( ) TO CALL TO SCLSNO C JUNE 2009 IM CHANGED ID TO ID(1,M) IN CALL TO EREST C JUNE 2009 SCALLION/GLAHN INSERTED WRITING ERROR GRID C TO RANDOM ACCESS FILE AT 3645 C JUNE 2009 GLAHN ADDED CALL TO STSNOZ; STATEMENTS 3437- C 3430 RENUMBERED C JUNE 2009 GLAHN REMOVED CHECK OF ILS,WTWTH, WTLTW; C CORRECTED RELATED COMMENTS C JUNE 2009 GLAHN ADDED IPLAIN( , ) AND L3254W TO CALL C TO CKQPF C JULY 2009 GLAHN ADDED CHECK ON ILS C JULY 2009 GLAHN ADDED SUBROUTINE AVGLAP C JULY 2009 GLAHN REMOVED ISTOP(1)=ISTOP(1)+1 AT 2888 C JULY 2009 GLAHN MODS FOR CAKSNO AT 348 TO 349 C AUGUST 2009 GLAHN MOVED LOOP DO 3449 ABOVE PACKING C AUGUST 2009 GLAHN ADDED VARIABLE JSTTST C SEPTEMBER 2009 WAGNER ADDED INLTAB TO SUBROUTINE CALL, C FOR MULTIPLE 405A CONTROL FILES. C REQUIRED FOR OPERATIONAL USE ON IBM. C MODIFIED OPEN STATEMENT FOR U405A C CONTROL FILES. SET KFILAN TO INLTAB C FOR THE MULTIPLE CONTROL FILES. C SEPTEMBER 2009 GLAHN ADDED ITYPR = 3(NEED ROUTINE) C OCTOBER 2009 GLAHN ADDED CALL TO SCLCIG; ADDED CHECK ON C IER AFTER SCLSKY C OCTOBER 2009 GLAHN ADDED OBS WIND SPEED TO ASCII PLOT C NOVEMBER 2009 GLAHN ADDED ACCOMMODATION FOR ASCII WRITING C OF WIND SPEED FOR GMOS_PLOT C NOVEMBER 2009 GLAHN INSERTED CALL TO LAPSE BEFORE AUGMT1; C ADDED AUTOMATIC ARRAY ELEMOD( ); REX3, C XLAPSE( ), ELEV( ), ELEMOD( ) TO CALL C TO AUGMT1 C NOVEMBER 2009 GLAHN ADDED LLMT CALL TO LAPSE. C NOVEMBER 2009 GLAHN ADDED AUGMT3 C DECEMBER 2009 GLAHN MODIFIED CALL TO SCLCIG C DECEMBER 2009 GLAHN ADDED LTAGPT( ) AND IAUG; INCREMENTED C ISTOP(3) WHEN IER NE 0 ON RETURN FROM C RETVEC; CHANGED POSTPROCESSING CALL TO C CATEQ FROM SETCFT C JANUARY 2010 GLAHN REVISED TO WRITE TRUNCATED INTEGER C VALUE FOR CEILING AND VISIBILITY VICE C NINT FOR OTHER DATA; ADDED PREX4A TO C CALL TO BCD C JANUARY 2010 GLAHN ADDED KFILRA, RACESS, NUMRA, PLAINT, C PLAIN, AND DATA TO CALL TO BCD5 C MARCH 2010 GLAHN ADDED NPASSF; CHANGED WHERE LTAGPT( ) C IS INITIALIZED C MARCH 2010 GLAHN ADDED NPASSF TO CALL TO BCD5 C MARCH 2010 GLAHN ADDED XYP( , 2) AND SDATA( ) C MARCH 2010 GLAHN ADDED CALL TO AUGMT4; DEFINED NPASSF, C NSMNUM, NOCEAN, SQUEZE, WTAUG, RAY, C DIFFA FROM AUGMT4 AND PUT INTO CALL TO C BCD5; ELIMINATED PREX4A C MARCH 2010 GLAHN ADDED WTAUG=PREX4(NN)WHEN AUGMT3 USED C MARCH 2010 GLAHN ADDED PREPROCESSOR SPOTRM; ADDED C CPNDFD TO CALL TO BCDG; ADDED C LTAGPT(K)=9999 IN DO 2881 LOOP C MARCH 2010 GLAHN ADDED PLOTTING OPTION LAMP TEMP/DP; C ADDED NOPTN AND DPOWER FOR SPOTRM C APRIL 2010 GLAHN ADDED CALL TO SCLVIS C APRIL 2010 GLAHN ADDED PASSSP AND IN CALL TO BCD5 C APRIL 2010 GLAHN INITIALIZED NAPSSF, NPASSP, AND RAY C ON ENTRY RATHER THAN DATA STATEMENT C APRIL 2010 GLAHN ADDED AVERAGE LAPSE FOR CUMULATIVE C PROBABILITIES. C APRIL 2010 GLAHN ADDED CALL TO CIGOBC C MAY 2010 GLAHN ADDED CALL TO VISOBC C MAY 2010 GLAHN ADDED SWITCH AND NPASSR C MAY 2010 GLAHN CORRECTED LOGIC BELOW 2862 C MAY 2010 GLAHN REVISED VALUES OF RELVAR FOR 2.5 KM C MAY 2010 GLAHN SET IER=0 BELOW 2888 C JUNE 2010 GLAHN ADDED CALL TO SKYCIG C JUNE 2010 GLAHN CHANGED CALL TO CONCPR; SPELL CHECK C JUNE 2010 GLAHN CHANGED PRINT OF POSTPROCESSING REAL C PARAMETERS FROM 8.0 TO 8.3 C JUNE 2010 GLAHN MODIFIED CALL TO CONVPR C JULY 2010 GLAHN ADDED NCEPNO TO CALL AND TO CALL TO C LAPSUA C JULY 2010 GLAHN CHANGED CALL TO SKYCIG; MODIFIED C DIAGNOSTIC AT 362 AND 365; ADDED C DISCRETE PROBABILITY IN DETERMINING C PROBABILITY LEVELS AND REVISED CODE; C ADDED SCALING OF SKY FOR PLOTTING C JULY 2010 GLAHN CHANGED 22202005 TO 22203005, C 22303005 TO 22303005, AND C 228071 TO 228080 FOR PLOTTING C JULY 2010 GLAHN INITIALIZED NTOTGB IN DATA STATEMENT C SEPTEMBER 2010 GLAHN INSERTED CALL TO SKYOBC; C COMMENT DEFINITION OF SQUEZE; C CHANGED FORMAT 1291 5F6.3 VICE 5F6.2 C OCTOBER 2010 GLAHN ADDED CALL TO AUGMT2; COMMENTS; C DIAGNOSTICS; CHANGED EQ TO LE IN C CHECKING LTAG( ) FOR PLOTTING TEMP C DEW POINT, CEILING AND VISIBILITY C OCTOBER 2010 GLAHN BLOCK INITIALIZING QUALST( ) MOVED; C REMOVED MTEST C OCTOBER 2010 GLAHN REMOVED REFERENCE TO AUGMT4 C OCTOBER 2010 GLAHN ADDED TO CALL TO AUGMT2 C OCTOBER 2010 GLAHN ADDED CHECK ON IVRAD BEFORE RDVRHL C DECEMBER 2010 GLAHN DIVIDED BLOCK DO 2884 TO INITIALIZE C QUALST( ) BEFORE AUGMENTATION, BUT TO C MODIFY XDATA( , , ) AFTER AUGMENTATION C FEBRUARY 2011 GLAHN ADDED CALLS TO VISMI1, VISOB1 C FEBRUARY 2011 GLAHN MODIFIED CALL TO VISMI C MARCH 2011 GLAHN ADDED CALL TO POSTPM, POST88; ADDED C ID( ), ELIMINATED LLMT CALL TO LAPSE C MARCH 2011 GLAHN ADDED EXCLUD TO SETCIG, XLAPSE C MARCH 2011 GLAHN ADDED CALL TO VISFRQ C MARCH 2011 GLAHN CHANGED DEFINITION OF SQUEZE TO SQUARE C MARCH 2011 GLAHN ADDED LAKE C APRIL 2011 GLAHN ADDED TO CALL TO SCLCIG AND SCLVIS C APRIL 2011 GLAHN CHANGED NOPTN, LAKE, NOCEAN FOR SPOTRM C APRIL 2011 GLAHN ADDED ICVLM TO CALL TO SCLCIG, SET C ICVLM = 0 UNLESS CVLMPM IS CALLED C APRIL 2011 GLAHN REMOVED ICVLM FROM CALL TO SCLCIG C JUNE 2011 GLAHN ADDED POSTPROCESSING SUBROUTINE ORSMTW C JUNE 2011 GLAHN ADDED IWRITF( ), WRITING POSTPROCESSED C GRIDS TO INTERNAL RA C JUNE 2011 IM CORRECTED CALL TO OPTX C JUNE 2011 GLAHN CHANGED SQUARE IN SPOTRM TO DISTX C JULY 2011 GLAHN ADDED MAXDST TO CALL TO ORSMTW C JULY 2011 GLAHN ADDED LTAGBS( ) C JULY 2011 GLAHN REMOVED MAXRAY FROM CALL TO ORSMTW; C IORST ADDED C JULY 2011 GLAHN INSERTED ID(1,M),IDPARS(1,M) VICE C ID,IDPARS IN CALL TO ORSMTW C JULY 2011 GLAHN ADDED CALL TO ENHANC C AUGUST 2011 GLAHN ADDED CSTSM, FD4, AND FD5 TO CALL TO C ORSMTW C AUGUST 2011 GLAHN ADDED STALAT( ), STALON( ) TO CALL TO C AUGMT2 C AUGUST 2011 GLAHN DIMENSIONED NOTOSS( ) C AUGUST 2011 GLAHN ELIMINATED IAUG AND LTAGBS( ), C CHANGED DEFINITION OF LTAGPT( ); C CHANGED INITIALIZING VALUE OF WTAUG C TO 1. VICE 0.; ADDED NOPTN = CONST( ) C TO CALL TO ORSMTW; REMOVED PREX4, C PREX5 IN CALL TO AUGMT2 C SEPTEMBER 2011 GLAHN ADDED PLOTTING LAMP TOSSED DATA T/TD C AS *; PLOTTED STATION CALL LETTERS C AND NAME IN KFILVO ASCII FILE AFTER C STOP INDICATOR # FOR IMAGEGEN C OCTOBER 2011 GLAHN/IM ADDED CHECK ON IER AFTER EREST AND C MADE STOP AT 503 C OCTOBER 2011 GLAHN/ G.WAGNER KEPT JER FROM BEING SET = 0; C REMOVED STOP 503 C OCTOBER 2011 G.WAGNER ADDED CALL TO CCONSN TO CLIP CONUS C SNOW ANALYSES TO A SMALLER OUTPUT MASK C NOVEMBER 2011 GLAHN STOP(3) INCREMENTED AT 2871 C DECEMBER 2011 GLAHN DEFINED AND USED ERRADJ IN CALL TO BCD C DECEMBER 2011 GLAHN ADDED CALL TO ENHWND C FEBRUARY 2012 GLAHN REMOVED INCORRECT COMMENT ABOUT IWRITF C FEBRUARY 2012 GLAHN CHANGED ASCII TO ASCI, WRITING AT 384 C MARCH 2012 GLAHN ADDED LTAGPT( ) TO CALL TO AUGMT1; C ADDED DDMULT( ), CALL TO DDRAD C MARCH 2012 GLAHN ADDED * FOR MISSING PRINT FOR WIND C MAY 2012 GLAHN ADDED JDATE(4) TO CALL TO CVLMPM C MAY 2012 GLAHN FORMATS 379 AND 3790 INTERCHANGED AND C 3790 MADE 3785 C MAY 2012 GLAHN CORRECTED COMMENT BELOW 372 C JUNE 2012 GLAHN ADDED IPREX1( ) TO CALL TO AUGMT2; C CORRECTED DIAGNOSTIC FORMAT 1295 C JULY 2012 GLAHN ADDED PLOTTING * FOR OBS NEAR 3795 C JULY 2012 GLAHN ADDED NUMAUG, NUMOBS, PREX5(NN) TO C CALL TO AUGMT2 C JULY 2012 GLAHN ADDED CALL TO ANLTOS C AUGUST 2012 GLAHN REMOVED CALL TO ANLTOS, MODIFIED CALL C TO AUGMT2 C JANUARY 2013 IM/GHIRARDELLI FIXED TYPO FROM PLAIN TO C IPLANT IN CALL BCD5() C JANUARY 2013 IM/GHIRARDELLI FIXED TYPO FROM JP(M,2) TO C JP(2,M) C JUNE 2013 IM ADDED PLAIN( ) TO THE CALLING SEQUENCE C FOR ALL CALLS TO PACKGR. C SEPTEMBER 2013 GLAHN CHANGED LAMP SPEED FROM 224325 TO C 224335 IN TWO PLACES IN WRITING KFILVO C SEPTEMBER 2013 GLAHN INSERTED PLOTTING * FOR TOSSED DATA C FOR OBS, LAMP, MOS U AND V; CHANGED C STATEMENT NUMBERS 380, 384 TO 390, 394 C SEPTEMBER 2013 GLAHN ADDED NCAT(NN) TO CALL TO LTAGRD C SEPTEMBER 2013 GLAHN REARRANGING STATEMENT NUMBERS; C ASSURING CALLS TO SUBROUTINES IN ORDER C SEPTEMBER 2013 GLAHN ADDED LTAG( ) TO CALL TO BOGUS C OCTOBER 2013 GLAHN ADDED NTAGPT( ); ADDED ICAUG AND LAMP C FOR CALL TO DDRAD; ADDED NTAGPT TO C CALL TO AUGMT2 C OCTOBER 2013 GLAHN REMOVED NAUGPT( ), ICAUG, LAMP FROM C CALL TO DDRAD C NOVEMBER 2013 GLAHN REMOVED ICAT( ) IN CALL TO LTAGRD C NOVEMBER 2013 GLAHN MODIFIED CALL TO AUGMT2 C DECEMBER 2013 GLAHN ADDED LTAGPT TO CALL TO LTAGRD C DECEMBER 2013 GLAHN ADDED WRITING XDATA TO INTERNAL C STORAGE JUST BEFORE CALL TO BCD5 C DECEMBER 2013 GLAHN INSERTED IDS FOR TOTAL WIND PLOTTING C JANUARY 2014 GLAHN ADDED WRITING XLAPSE TO KFIL10; ADDED C LAPFG=4 CAPABILITY; ADDED TOTAL WIND C TO PLOT WITH DIRECTION C JANUARY 2014 GLAHN IMPLEMENTED LAPUDB C JANUARY 2014 GLAHN ADDED LATG TO CALL TO AUGMT2 C JANUARY 2014 GLAHN ADDED STALAT( ) AND STALON( ) TO CALL C TO BCS5 C FEBRUARY 2014 GLAHN INITIALIZED LTAG( ) = 0 C FEBRUARY 2014 GLAHN ADDED CHECK ON LTAG(K)=4 AT 3423 C FEBRUARY 2014 GLAHN REMOVED ABOVE CHECK C FEBRUARY 2014 GLAHN INSERTED CALL TO LTAGST; TEST INSERTED C AT 3522 TO NOT CONSIDER LTAGPT C FEBRUARY 2014 GLAHN MODIFIED READING OF PRE/POSTPROCESSOR C ROUTINES WITH A TERMINATOR AND NUMBER C UP TO DIMENSION SET BY PARAMETER; C POSTDS ADDED TO CALL TO BCD5; PREPRO C AND NOPRE ADDED TO CALL TO FSTGS5 C FEBRUARY 2014 GLAHN FOR PLOTTING * WITH TOSSED STATIONS, C TEST FOR LTAG( ) .T 0 EXPANDED TO C INCLUDE LTAG( ) GE 4 C FEBRUARY 2014 GLAHN MODIFIED CALL TO LTAGRD C MARCH 2014 GLAHN ADDED JDATE(4) TO CALL TO LAPSUA C APRIL 2014 GLAHN ADDED ITABLE( ,7) TO CALL TO AUGMT2 C APRIL 2014 GLAHN CHANGED ITABLE(1,7) TO ITABLE(1,3) C IN CALL TO AUGMT2 C APRIL 2014 GLAHN MODIFIED USE OF IDPARS(4,M) IN ID C AT 3448 AND 3451 C MAY 2014 GLAHN CHANGED ND2X3 TO ND1 IN CALL TO PACKV C BELOW 3449 PACKING XLAPSE SCALED C MAY 2014 GLAHN ACTIVATED SKPWR2 WHEN ICOMPT = 1 C MAY 2014 GLAHN CHANGED LDPARS TO LDPARS(12) IN CALL C TO PAWGTS WRITING ERROR GRID BELOW 356 C MAY 2014 GLAHN ADDED DIAGNOSTIC TO KFILDO AT 3462; C CHANGED ID FOR WRITING LTAG( ) AT 3461 C MAY 2014 IM/GLAHN ELIMINATED ITABLE(1,3) IN CALL AUGMT2 C MAY 2014 GLAHN ADDED MTAGPT( ) TO CALL AND IN CALL TO C BCD5 AND AUGMT2 C MAY 2014 GLAHN REMOVED CALL TO LTAGST AND LTAGRD C MAY 2014 GLAHN ADDED NCLIPY TO CALL TO EREST C JUNE 2014 GLAHN INSERTED GO TO 500 AFTER FAILED AUGMT2 C IMPROVED ERROR HANDLING AFTER QPF6P6 C SEARCHED ALL NOPROA SLOTS FOR CLIPPING C JUNE 2014 GLAHN CHANGED LD(1)=ITABLE(1,2)+IDPARS(4,M) TO C LD(1)=(ITABLE(1,2)/100)*100+IDPARS(4,M) C ABOVE 2869 C JUNE 2014 GLAHN PUT IN CALLS TO W3TAGE FOR ASSOCIATED C STOPS C JULY 2014 GLAHN PUT IQUAL AND NOPTR INTO CALL TO DDRAD C AUGUST 2014 GLAHN ADDED IWRITA( ) = 2 CAPABILITY C SEPTEMBER 2014 GLAHN CORRECTED PACKV CALL FOR PLAIN LANGUAGE C IN 3 PLACES C SEPTEMBER 2014 GLAHN ADDED VOTNAM TO CALL, AND CAPABILITY TO C PROVIDE SEPARATE ASCII FILES FOR EACH C VARIABLE C OCTOBER 2014 GLAHN CORRECTED CALL TO DIRFUV FOR LAMP SPEED C AND GUSTS C OCTOBER 2014 GLAHN COMPUTED DIR AFTER U ANC V AND REWROTE C ASCII FOR SPEED C NOVEMBER 2014 GLAHN REVISED W3TAG PER JUDY C NOVEMBER 2014 GLAHN SET IWRITA( ) 0 FOR LAMP WIND DIRECTION C NOVEMBER 2014 IM/GLAHN ADDED CAPABILITY OF COPYING VOTNAM C TO VOTNAME; REMOVED VOTNAME IN CALLING C PLATYP C NOVEMBER 2014 IM/GLAHN MADE SOME ID CHANGES; ELIMINATED C SECTION FOR GLAMP SKY PROBABILITY C DECEMBER 2014 IM/GLAHN CLOSED AND REOPENED KFILVO C JANUARY 2015 GLAHN ADDED CCALL TO CALL TO SCLVIS C FEBRUARY 2015 GLAHN DEFINED NOL AND INSERTED IT INTO CALL C TO ORVWSM VICE THIA(NN) C FEBRUARY 2015 GLAHN INSERTED MOSFUL IN CALL TO CVLMPM AND C SCLVIS C MARCH 2015 GLAHN MOVED LOCATION OF GO TO 372 TO ABOVE C ENDIF C MARCH 2015 GHIRARDELLI MODIFIED LOGIC AROUND CALL TO C PACKGR WHEN EREST HAD BEEN CALLED. C MOVED GO TO 372 AND ADDED ADDITIONAL C ONE. C APRIL 2015 GHIRARDELLI MODIFIED OPENING OF VOTNAM FILE C FOR OPERATIONS. ALSO MODIFIED HOW C VOTNAM IS ACQUIRED - VIA A CALL TO C getenv SO THAT VOTNAM=$FORT35. C APRIL 2015 GLAHN MERGED MELD VERSION; ELIMINATED STATEMENT C 3522; ADDED CALL TO PIXRM; ADDED EQNNAM, C MERGE C APRIL 2015 GLAHN CHANGED READING OF MERGE I2 VICE I4 C MAY 2015 IM/GLAHN ADDED GO TO 372 ABOVE 369 CONTINUE C MAY 2015 GLAHN SKIPPED CODE WHEN MERGE NE 0 C MAY 2015 GLAHN MODIFIED PRINT TO IP16 AT 3450 C JUNE 2015 GHIRARDELLI MOVED WRITE 3462 TO BE WITHIN IF C IP16 IS SET AS THE INFORMATION BEING C WRITTEN IS ONLY DEFINED IF IP16 IS SET. C JUNE 2015 GLAHN REMOVED CALL TO PIXRM ADDED CALL TO C PIXSM1 C JUNE 2015 GLAHN CHANGES TO COMBINE UA LAPSE WITH C SURFACE-BASED LAPSE; ADDED ULAPSE( ), C CALL TO CLAPSE, VARIABLES TO CALL C TO BCD5 C JULY 2015 GLAHN SPLIT NTYPE( , ) INTO NTYPE( , ) AND C IFCOR( , ) C JULY 2015 GLAHN SPLIT IVRAD INTO IVRAD AND ICUB; C ICUB TO CALL TO BCD5 C JULY 2015 GLAHN SPLIT NPASS INTO NPASS, NREP, NREPNO; C ADDED NREP, NREPNO, AND FD6( ) TO C CALL TO BCD5 C AUGUST 2015 IM CHANGED 'GO TO 372' TO BELOW 369 C CONTINUE C AUGUST 2015 IM ADDED MOSFUL=0 C SEPTEMBER 2015 GLAHN INSERTED MOSFUL IN CALL TO SCLCIG C OCTOBER 2015 IM/GLAHN INSERTED ASCII CATEGORIES FOR PROB C CEIL, VIS, AND SKY C NOVEMBER 2015 GLAHN CHANGED KFILOG TO KFILIO AND ADDED JER C IN CALL TO MELD; CHANGED CALLD TO C CCALLD IN CALL TO MELD; CHANGED JTOTBY C AND JTOTRC TO NTOTBY AND NTOTRC IN C CALL TO MELD C NOVEMBER 2015 GLAHN ADDED NTOTGB, NTOTGR, AND BMESH TO C CALL TO MELD C DECEMBER 2015 GLAHN CORRECTED NOCEAN AND LAKE FROM C IPREX2(NN) C DECEMBER 2015 GLAHN INSERTED "IF(L.GT.1)IOBS=0" BEFORE C CALL TO AUGMT2 C DECEMBER 2015 GLAHN ADDED CODE IN "DO 2875" LOOP TO SKIP C LOOKING FOR A PROJECTION THIS IS NOT C AVAILABLE; ADDED NUMBER 9287 C JANUARY 2016 GLAHN ADDED MOX MX AND MN FOR ASCII WRITING C FEBRUARY 2016 GLAHN CHANGES FOR ASCII PLOTTING C SEPTEMBER 2016 GLAHN CHANGED ND5 TO ND2X3 IN THREE CALLS C TO PAWGTS C OCTOBER 2016 GLAHN ADDED IP8 AND ICALL TO CALL; ADDED C READING PAIRS OPTION AT NEAR 2855 C OCTOBER 2016 GLAHN ADDED NCLIP TO CALL TO BCD5 C NOVEMBER 2016 GLAHN REPLACED IER=777 WITH DIAGNOSTIC C NOVEMBER 2016 GLAHN ADDED SEALND( ) TO CALL TO CKMAXT C AND CKMINT C NOVEMBER 2016 GLAHN ADDED MOS SKY TO ASCII WRITE C APRIL 2017 GLAHN CHANGED IF(IPOSL+8.LE.60) TO C IF(IPOSL+9.LE.60) BELOW 1285 C JULY 2017 GLAHN ADDED M=N AT 1300 C JULY 2017 GLAHN CORRECTED POSTPROCESSOR CALL TO SCALX C JULY 2017 GLAHN ADDED CHECK FOR 2080502 FOR SCALING C BELOW 375 C DECEMBER 2017 GLAHN REMOVED MERGE CAPAGILITY C DECEMBER 2017 GLAHN ADDED FILE NAME TO PRINT AT 125 C APRIL 2018 GLAHN REINSTATED STOP AT 2884 C APRIL 2018 GLAHN ADDED ORVWSM AS A PREPROCESSOR AT C 2884 (DO 9886) C MAY 2018 GLAHN INSERTED CALL TO ORSMTH AS A C PREPROCESSOR; REMOVED NORUNS LOOP C AROUND CALL TO ORVWMS AS A C PREPROCESSOR C MAY 2018 GLAHN ADDED CALL TO SETFG C SEPTEMBER 2018 GLAHN ADDED PATCH TO READ PORTION OF .CN C FOR VARIABLES IN SEQUENCE C NOVEMBER 2018 GLAHN ADDED SUBROUTINE BOGUSG; DEFINED C NBASTA; ADDED NBASTA AND PREX3 TO C CALL TO BOGUSG C NOVEMBER 2018 GLAHN ADDED SQ ROOT SCALING OF CIG, ADDED C PREX3 TO CALL TO SCLCIG C NOVEMBER 2018 GLAHN ADDED POSTCG TO POSTPROCESSING; C USED POSTCG TO SIGNAL SQUARING OBS C DECEMBER 2018 GLAHN INSERTED EXCLUD=SQRT(EXCLUD) BEFORE C CALL TO SCLCIG WHEN CEILING TO BE C SCALED; ADDED LTAGPT AND NAREA TO C CALL TO LAPSE C FEBRUARY 2019 GLAHN ADDED PREX4 AND GUESS TO BOGUSG CALL C FEBRUARY 2019 GLAHN ADDED VRAD( ) TO CALL TO BOGUSG C FEBRUARY 2019 GLAHN ADDED ELEV( ) AND TELEV( ) TO CALL C TO BOGUSG C FEBRUARY 2019 GLAHN ADDED NAREA TO CALL TO BOGUSG C FEBRUARY 2019 GLAHN CHANGED NSTA TO NSTASV IN CALL TO C LAPSE; INSERTED CALL TO DDRAD2 C MARCH 2019 GLAHN INSERTED DIAGNOSTICS 3762, 3763, 3764 C MARCH 2019 GLAHN MODIFIED DDRAD2 AND CALL TO IT C APRIL 2019 GLAHN MODIFIED TO CALL DDRAD OR DDRAD2 C FOR EACH ANALYSIS C APRIL 2019 GLAHN INSERTED CALL TO RD45CN C APRIL 2019 GLAHN INSERTED (NN) IN CALL TO SETFG C APRIL 2019 GLAHN DEFIED LH AND ADDED TO CALL TO BCD5 C APRIL 2019 GLAHN ADDED 9884 PRINT PROBABILITY LEVEL J C APRIL 2019 GLAHN CORRECTED COMMENT ABOUT N4P C APRIL 2019 GLAHN ADDED NPASRR TO CALL TO BCD5 C APRIL 2019 GLHAN ADDED PREPRO,NOPRE TO CALL TO BCD5 C MAY 2019 GLAHN ADDED CHECK ON FILE NAME AT 110 C JUNE 2019 GLAHN ADDED PIXSM1 AS A PREPROCESSOR AT 9888 C JUNE 2019 GLAHN SUBSTITUTED 130 FOR 888 AT 9887 C JUNE 2019 GLAHN CHANGED DIFFA TO DIFFB FOR PIXSM1 C OCTOBER 2019 GLAHN ADDED NCAT(NN) AND NSCALE(NN) TO CALL C TO BOGUS C DECEMBER 2019 GLAHN ADDED CALL TO SKYOBP C DECEMBER 2019 GLAHN PROCESS TO DEFINE DD FOR DATA TO C ANALYZE MODIFIED BELOW: C 'DO 2875 L=1,NORUNS' ON 12/31/19; C ADDED CALL TO SKYLMP C JANUARY 2020 GLAHN ADDED NSTORE AND LASTD TO CALL TO C FSTGS5 C JANUARY 2020 GLAHN ADDED CALLS TO GFETCH AND LGTVSP; C ADDED FGFULL( , ) C JANUARY 2020 GLAHN ADDED CHECK FOR 'LGTVSP' ABOVE 353 C FEBRUARY 2020 GLAHN REMOVED NORUNS LOOG AROUND CALL BOGUDG C FEBRUARY 2020 GLAHN DEFINED MIXWL AND MIXAB FOR INPUT TO C DDRAD2 C FEBRUARY 2020 GLAHN MOVED BLOCK CALLING DDRAD AND DDRAD2 C DOWN AFTER RUNS COLLAPSED INTO ONE; C CHANGED XDATA(1,2,J) TO XDATA(1,1,J) C IN CALL TO DDRAD AND DDRAD2; CHANGED C FORMAT 1291; CHANGED EQ.9999. TO C LT.9998.5 AT 3427 LOOP C FEBRUARY 2020 GLAHN CHANGED DO 2745 J=1,6 TO C DO 2745 J=1,NOPRE; SET IVRAD=2 WHEN C DDRAD2 CALLED c FEBRUARY 2020 GLAHN CHANGED NSTA TO NSTASV WRITING TO C KFILOV AND KFILQC, 4 PLACES C MARCH 2020 GLAHN PUT CALL TO SETLND HERE AFTER CALL C TO BOGUS TAKEN FROM FSTGS5; INPUT C TO BOGUS IS FD5( ) VICE P( ) C APRIL 2020 HUANG ADDED NAME TO CALL TO EREST. C JANUARY 2023 WAGNER UPDATED HANDLING OF VOTNAME FOR C T/TD/UWND/VWND/WGST TO OPERATE C CORRECTLY FOR LAMP MELD WITH DD 35. C C PURPOSE C PROGRAM U405A ANALYSES CONTINUOUS VARIABLES. ENTRY C INTO U405A WILL PRODUCE AN ANALYSIS OF THE VARIABLE IN C ID( ), WHICH MUST MATCH THE VARIABLE ID READ IN C 'U450AXXXXXXXXX.CN. SEA LEVEL PRESSURE (SLP) AND C SATURATION ARE HOLDOVERS FROM LAMP; SLP MAY BE IMPLEMENTED C AT SOME TIME. SURFACE WINDS CAN BE USED IN SLP ANALYSIS C (NOT YET IMPLEMENTED). C C FATAL ERRORS, IER: C 777 FROM FSTGS5--CANNOT OBTAIN A FIRST GUESS. C 777 FROM EREST --CANNOT COMPUTE ERROR ESTIMATION. C C DATA SET USE C KFILDO - UNIT NUMBER OF OUTPUT (PRINT) FILE. (OUTPUT) C KFIL10 - UNIT NUMBER FOR INTERNAL RANDOM ACCESS STORAGE. C (INPUT/OUTPUT) C KFILIO - UNIT NUMBER FOR WRITING FINAL GRIDPOINT C ANALYSES. (OUTPUT) C KFILOV - UNIT NUMBER OF OUTPUT VECTOR FILE CONTAINING C ALL OBS EXCEPT THOSE TOSSED OR QUESTIONABLE C OBS AS MISSING AND ALSO XLAPSE( ) WHEN C IBKPN NE 99. (OUTPUT) C KFILQC - UNIT NUMBER OF OUTPUT VECTOR FILE CONTAINING C QUALITY CONTROLLED OBS AFTER THE FINAL ANALYSIS C PASS. (OUTPUT) C KFILVO - UNIT NUMBER OF VECTOR OUTPUT ASCII FILE. C ZERO MEANS OUTPUT WILL NOT BE WRITTEN. C (OUTPUT) C KFILAN - UNIT NUMBER FOR READING INDIVIDUAL ANALYSIS C CONTROL FILES. SET TO KFILIN. (INPUT) C KFILCP - UNIT NUMBER FOR VARIABLE CONSTANT FILE. C (INPUT) C KFILRA(J)- HOLDS THE UNIT NUMBERS FOR ACCESSING THE MOS-2000 C EXTERNAL RANDOM ACCESS FILES (J=1,6). (INPUT) C IP8 - UNIT NUMBER FOR WRITING TATION PAIRS IN C REPRS. (OUTPUT) C IP12 - UNIT NUMBER OF LISTING STATIONS. (OUTPUT) C IP14 - UNIT NUMBER FOR LISTING COMPUTED LAPSE C RATES AND PROBLEMS WITH LAPSE RATES. (OUTPUT) C IP16 - UNIT NUMBER FOR INDICATING WHEN A RECORD IS C WRITTEN TO THE SEQUENTIAL OR RANDOM ACCESS C FILE. (OUTPUT) C IP17 - UNIT NUMBER FOR LISTING OF STATIONS, THEIR C X/Y POSITIONS, THEIR DATA VALUES, AND LTAGS. C (OUTPUT) C IP18 - UNIT NUMBER FOR LISTING OF STATIONS, C THEIR X/Y POSITIONS, DATA VALUES, LTAGS, C ANALYSIS (INTERPOLATED) VALUES, AND C DIFFERENCES BETWEEN THE DATA AND THE ANALYSIS C VALUES. (OUTPUT) C IP19 - SAME AS IP18 EXCEPT IT APPLIES TO THE C SMOOTHED ANALYSIS. (OUTPUT) C IP20 - UNIT NUMBER FOR LISTING OF STATIONS, THEIR C X/Y POSITIONS, DATA VALUES, LTAGS, ANALYSIS C (INTERPOLATED) VALUES, AND DIFFERENCES C BETWEEN THE DATA AND THE ANALYSIS VALUES C FOR ONLY THE SUBSETTED AREA FOR GRIDPRINTING. C IF IOPT( ) IS NOT USED, IP(20) IS NOT C ACTIVATED. (OUTPUT) C IP21 - UNIT NUMBER FOR LISTING THE AVERAGE DEGREE C OF FIT BETWEEN THE UNSMOOTHED AND SMOOTHED, C IF SMOOTHED, ANALYSIS AND THE DATA. (OUTPUT) C IP22 - UNIT NUMBER FOR GRIDPRINTING. (OUTPUT) C IP24 - FOR ITYPR = 1: C UNIT NUMBER FOR WRITING FIT TO WITHHELD C STATIONS, IF ANY, AND NON-WITHHELD STATIONS OVER C WHOLE ANALYSIS AREA WHEN NWITH NE 0. A LIST C OF THE WITHHELD STATIONS IS ALSO PROVIDED. C - FOR ITYPR = 2 OR 3: C UNIT NUMBER FOR WRITING PACKED DATA FOR C DIAGNOSING ERRORS IN ANALYSIS. C IP25 - DIFFICULTIES WITH BOGUS STATIONS. C (OUTPUT) C VARIABLES C KFILDI = UNIT NUMBER TO READ INPUT FILE 'U450A.CN'. C (INPUT) C KFILDO = UNIT NUMBER OF OUTPUT (PRINT) FILE. (INPUT) C KFIL10 = UNIT NUMBER FOR INTERNAL RANDOM ACCESS STORAGE. C (INPUT) C KFILOG = UNIT NUMBER OF TDLPACK DISPOSABLE OUTPUT FILE. C THIS IS FOR WRITING THE RESULTS OF THE VARIOUS C PASSES IN THE ANALYSES AND THEIR SMOOTHINGS. C (INPUT) C KFILOV = UNIT NUMBER OF OUTPUT VECTOR FILE CONTAINING C ALL OBS EXCEPT THOSE TOSSED OR QUESTIONABLE C OBS AS MISSING AND ALSO XLAPSE( ) WHEN C IBKPN NE 99. (INPUT) C KFILQC = UNIT NUMBER OF OUTPUT VECTOR FILE CONTAINING C QUALITY CONTROLLED OBS AFTER THE FINAL ANALYSIS C PASS. TOSSED OBS ARE SET TO MISSING. (INPUT) C KFILIO = UNIT NUMBER FOR WRITING FINAL GRIDPOINT C ANALYSES. (INPUT) C KFILVO = UNIT NUMBER OF VECTOR OUTPUT ASCII FILE. C ZERO MEANS OUTPUT WILL NOT BE WRITTEN. (INPUT) C KFILAN = UNIT NUMBER FOR READING INDIVIDUAL ANALYSIS C CONTROL FILES. SET = INLTAB (INPUT) C KFILLP = UNIT NUMBER FOR READING STATION PAIRS. (INPUT) C KFILCP = UNIT NUMBER FOR VARIABLE CONSTANT FILE. THIS C CONTAINS DEFAULT VALUES FOR CERTAIN CONSTANTS C FOR BASIC NMC VARIABLES AND OTHER VARIABLES C SANS THRESHOLDS, ETC. THESE INCLUDE PACKING C CONSTANTS, GRIDPOINT CONSTANTS, AND NAMES. C (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. HOWEVER, IT UNLIKELY U155 WILL NEED C MORE THAN 1 OR 2. (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 NCEPNO = NCEP MODEL NUMBER USED AS DD WHEN RETRIEVING C UPPER AIR DATA FOR LAPSE IN LAPSUA. (INPUT) C IP8 = INDICATES WHETHER (>1) OR NOT (=0) THE C STATIONS AND THEIR PAIRS AS READ ARE C WRITTEN TO IP8. (INPUT) C IP12 = INDICATES WHETHER (>0) OR NOT (=0) C STATIONS ON INPUT FILES WILL BE OUTPUT TO IP12. C (INPUT) C IP14 = UNIT NUMBER FOR LISTING COMPUTED LAPSE C RATES AND PROBLEMS WITH LAPSE RATES. (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,A RANDOM ACCESS FILE IS WRITTEN C THROUGH PAWRAC, OR A FILE IS WRITTEN TO C INTERNAL STORAGE BY GSSTORE. (INPUT) C IP17 = UNIT NUMBER FOR LISTING OF STATIONS, THEIR C X/Y POSITIONS, THEIR DATA VALUES, AND LTAGS. C (INPUT) C IP18 = UNIT NUMBER FOR LISTING OF STATIONS, THEIR C X/Y POSITIONS, DATA VALUES, LTAGS, C ANALYSIS (INTERPOLATED) VALUES, AND C DIFFERENCES BETWEEN THE DATA AND THE ANALYSIS C VALUES. (INPUT) C IP19 = SAME AS IP18 EXCEPT IT APPLIES TO THE C SMOOTHED ANALYSIS. (INPUT) C IP20 = UNIT NUMBER FOR LISTING OF STATIONS, THEIR C X/Y POSITIONS, DATA VALUES, LTAGS, ANALYSIS C (INTERPOLATED) VALUES, AND DIFFERENCES C BETWEEN THE DATA AND THE ANALYSIS VALUES C FOR ONLY THE SUBSETTED AREA FOR GRIDPRINTING. C IF IOPT( ) IS NOT USED, IP(20) IS NOT C ACTIVATED. (INPUT) C IP21 = UNIT NUMBER FOR LISTING THE AVERAGE DEGREE C OF FIT BETWEEN THE UNSMOOTHED AND SMOOTHED, C IF SMOOTHED, ANALYSIS AND THE DATA. (INPUT) C IP22 = UNIT NUMBER FOR GRIDPRINTING OF FIRST GUESS C AND ANALYSES. (INPUT) C IP24 = FOR ITYPR = 1: C UNIT NUMBER FOR WRITING FIT TO WITHHELD C STATIONS, IF ANY, AND NON-WITHHELD STATIONS OVER C WHOLE ANALYSIS AREA WHEN NWITH NE 0. A LIST C OF THE WITHHELD STATIONS IS ALSO PROVIDED. C FOR ITYPR = 2 OR 3: C UNIT NUMBER FOR WRITING PACKED DATA FOR C DIAGNOSING ERRORS IN ANALYSIS. C (INPUT) C IP25 = UNIT NUMBER FOR WRITING PROBLEMS WITH C BOGUS STATIONS. (INPUT) C OUTVEC = NAME OF DATA SET FOR VECTOR DATA IN TDLPACK C FORMAT. (CHARACTER*60) (INPUT) C OUTQCV = NAME OF DATA SET FOR QUALITY CONTROLLED DATA C IN TDLPACK FORMAT. (CHARACTER*60) (INPUT) C VOTNAM = NAME OF DATA SET FOR OUTPUT ASCII DATA IN FORMAT C CORRESPONDING TO UNIT NO. KFILVO. C (CHARACTER*60) (OUTPUT) C IALOC(J) = LOCATIONS IN CCALL( , ) OF THE PAIRED STATIONS C (J=1,ND13), NOPAR(K) VALUES FOR EACH STATION K C (K=1,LSTA). (INPUT) C ADIST(J) = DISTANCES OF BASE STATION OF THE PAIRED STATIONS C (J=1,ND13), NOPAR(K) VALUES FOR EACH STATION K. C (INPUT) C AELEV(J) = ELEVATION DIFFERENCES OF BASE STATION OF THE C PAIRED STATIONS (J=1,ND13), NOPAR(K) VALUES C FOR EACH STATION K. (INPUT) C ND13 = MAXIMUM TOTAL PAIRS OF STATIONS. DIMENSION OF C IALOC( ), ADIST( ), AND AELEV( ). (INPUT) C ELEVLO(K) = THE LOW ELEVATION ASSOCIATED WITH STATION C CCALL(K, ) (K=1,NSTA). SPECIFIC TO ELEMENT. C (INTERNAL) C ELEVHI(K) = THE HIGH ELEVATION ASSOCIATED WITH STATION C CCALL(K, ) (K=1,NSTA). SPECIFIC TO ELEMENT. C (INTERNAL) C ICALL(L,K,J) = 8 STATION CALL LETTERS AS CHARACTERS IN AN C INTEGER VARIABLE (L=1,L3264W) (K=1,NSTA) C (J=1,6). NOTE THAT THIS REQUIRES TWO 32-BIT C WORDS TO HOLD THE DESCRIPTION BUT ONLY ONE C 64-BIT WORD. EQUIVALENCED TO CCALL( , ). C CCALL(K,J) = 8-CHARACTER STATION CALL LETTERS (J=1) AND C 5 POSSIBLE OTHER STATION CALL LETTERS (J=2,6) C THAT CAN BE USED INSTEAD IF THE PRIMARY (J=1) C STATION CANNOT BE FOUND IN AN INPUT DIRECTORY C (K=1,NSTA). ALL STATION DATA ARE KEYED TO C THIS LIST. CONTAINS GRIDPOINT IDS WHEN C "DATA" TO ANALYZE ARE AT GRIDPOINTS. (INPUT) 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 ANALYSIS GRID AREA AT THE CURRENT GRID MESH C LENGTH XMESH. (INTERNAL) C YP(K) = THE Y POSITION FOR STATION K (K=1,NSTA) ON C THE ANALYSIS GRID AREA AT THE CURRENT GRID MESH C LENGTH XMESH. (INTERNAL) C XYP(K,J) = XYP(1,1) EQUIVALENCED TO XP( ) IN DRIVER. C XYP(1,2) EQUIVALENCED TO YP( ) IN DRIVER. C (INPUT) C XPL(K) = THE X POSITION FOR STATION K (K=1,NSTA) ON C THE ANALYSIS GRID AREA AT THE MESH LENGTH C MESHB. (INPUT) C YPL(K) = THE Y POSITION FOR STATION K (K=1,NSTA) ON C THE ANALYSIS GRID AREA AT THE MESH LENGTH C MESHB. (INPUT) C TOSS(K) = CONTAINS TOSSED OBS (K=1,NSTA). ALL OTHER C VALUES ARE 9999. (INTERNAL) C QUEST(K) = CONTAINS QUESTIONABLE OBS (K=1,NSTA). ALL C OTHER VALUES ARE 9999. QUESTIONABLE IS DEFINED C AS MEETING THE ERROR CRITERION, BUT NOT C MEETING X PERCENT OF IT, WHERE X IS HARDWIRED C BY PASS. (INTERNAL) C ISDATA(K) = WORK ARRAY (K=1,ND1). (INTERNAL) C SDATA(K) = WORK ARRAY (K=1,NSTA). (INTERNAL) C WDIR(K) = OBSERVED WIND DIRECTION (K=1,NSTA). THE TOSSED C REPORTS HAVE BEEN SET TO 9999. ON INPUT. THE C DIRECTION IS THEN TURNED WNDTRN DEGREES CLOCKWISE. C (INPUT) C WSPD(K) = OBSERVED WIND SPEED (K=1,NSTA). THE TOSSED C REPORTS HAVE BEEN SET TO 9999. ON INPUT. (INPUT) C LTAG(J) = DENOTES USE OF DATA CORRESPONDING TO CCALL(J). C +4 = TOSSED IN A PREVIOUS OBS RUN AND C MAINTAINED DOWNSTREAM. C +3 = TOSSED IN A PREVIOUS LAMP RUN, AND C MAINTAINED DOWNSTREAM. C +2 = NOT USED FOR ANY PURPOSE. FLTAG SETS C A VALUE +2 WHEN THE STATION LOCATION C IS MISSING. C +1 = PERMANENTLY DISCARDED FOR THE VARIABLE C BEING ANALYZED. INCLUDES DATA FAR C OUTSIDE THE GRID, AS DEFINED BY RMAX C 0 = USE ON CURRENT PASS THROUGH DATA IN BCD. C -1 = ON RETURN FROM BCD, THE DATUM WAS NOT C USED ON THE LAST PASS. C -3 = ACCEPT THIS STATION ON EVERY PASS IN BCD. C (NOT IMPLEMENTED IN U405A) C (INTERNAL) C IQUAL(K,I) = THE QUALITY VALUES FROM THE STATION DICTIONARY C FOR FIVE POSSIBLE DATA TYPES (K=1,ND1) (I=1,5). C (INPUT) C LNDSEA(K) = LAND/SEA INFLUENCE FLAG FOR EACH STATION C (K=1,ND1). C 0 = WILL BE USED FOR ONLY OCEAN WATER (=0) C GRIDPOINTS. C 3 = WILL BE USED FOR ONLY INLAND WATER (=3) C GRIDPOINTS. C 6 = WILL BE USED FOR BOTH INLAND WATER (=3) C AND LAND (=9) GRIDPOINTS. C 9 = WILL BE USED FOR ONLY LAND (=9) GRIDPOINTS. C (INPUT) C ELEV(K) = ELEVATION OF STATIONS IN METERS (K=1,NSTA). C (INPUT) C STALAT(K) = LATITUDE OF STATIONS (K=1,NSTA). (INPUT) C STALON(K) = LONGITUDE OF STATIONS (K=1,NSTA). (INPUT) C NOPAR(K) = NUMBER OF PAIRS FOR STATION K (K=1,MSTA). C (INPUT) C LOCPAR(K) = WHERE IN IALOC( ), ADIST( ), AND AELEV( ) THE C DATA FOR STATION K STARTS (K=1,KSTA). (INPUT) C QUALST(K) = THE QUALITY WEIGHTS TO APPLY FOR THIS VARIABLE C (K=1,KSTA). AUGMT2 MODIFYS THEM. (INTERNAL) C XLAPSE(K) = CALCULATED LAPSE RATE IN UNITS OF THE VARIABLE C BEING ANALYZED PER M. (K=1,KSTA). C VRAD(K,L) = RADII OF INFLUENCE USED AS OVERRIDE TO U405.CN C CONTROL FILE (K=1,NSTA) (L=1,6). NOTE THAT C THIS APPLIES TO THE INDIVIDUAL ELEMENT; ITS C USE IS CONTROLLED BY IVRAD. (INTERNAL) C NSTA = NUMBER OF STATIONS OR LOCATIONS BEING DEALT WITH. C THIS MAY INCLUDED RANDOMLY SAMPLED POINTS FROM C THE FIRST GUESS. (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. (INPUT) C P(I,J) = THE FIRST GUESS FROM FSTGS5 AND THE ANALYSIS C FROM BCD5 (I=1,NXL) (J=1,NYL). (INTERNAL) C FD2(J), FD3(J), ETC = WORK ARRAYS (J=1,ND2X3). THESE CAN BE USED IN C ROUTINES AS 2-DIMENSIONAL ARRAYS, THE ONLY SIZE C RESTRICTION BEING THE TOTAL, NOT THE INDIVIDUAL C GRID DIMENSIONS. (INTERNAL) C U(K) = U-WIND AT STATIONS (K=1,NSTA). OBS TOSSED BY C U405B HAVE BEEN SET TO 9999. WHEN SPEED IS C LT WNDTHR, U(K) IS SET = 9999. LATER, THE C CHANGE IN PRESSURE IN MB PER GRID UNIT IN THE C X DIRECTION FOR GEOSTROPHIC COMPUTATIONS WHEN C SLP IS BEING ANALYZED. THIS IS FD7( ) IN THE C CALLING PROGRAM, DIMENSIONED ND2X3. (INTERNAL) C V(K) = V-WIND AT STATIONS (K=1,NSTA). WHEN SPEED IS C LT WNDTHR, U(K) IS SET = 9999. OBS TOSSED BY C U405B HAVE BEEN SET TO 9999. LATER, THE C CHANGE IN PRESSURE IN MB PER GRID UNIT IN THE C Y DIRECTION FOR GEOSTROPHIC COMPUTATIONS WHEN C SLP IS BEING ANALYZED. THIS IS FD8( ) IN THE C CALLING PROGRAM, DIMENSIONED ND2X3. (INTERNAL) C FDSINS(J) = WORK ARRAY FOR SIN OF THE LATITUDE (J=1,ND2X3). C THIS IS FD9( ) IN THE CALLING PROGRAM. C (INTERNAL) C ND2X3 = THE DIMENSION OF SEVERAL ARRAYS = C MAX(ND1,ND2*ND3) IN DRIVER. (INPUT) C ID(J,N) = THE INTEGER PREDICTOR ID'S (J=1,4) (N=1,ND4). C (INPUT) C IDPARS(J,N) = THE PARSED, INDIVIDUAL COMPONENTS OF THE C PREDICTOR ID'S CORRESPONDING TO ID( ,N) C (J=1,15), (N=1,ND4). (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 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 THRESH(N) = THE BINARY THRESHOLD ASSOCIATED WITH C IDPARS( ,N), (N=1,ND4). (INPUT) C JD(J,N) = THE BASIC INTEGER PREDICTOR ID'S (J=1,4) C (N=1,ND4). (INPUT) 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 JD( , ) IS USED TO IDENTIFY THE BASIC MODEL C FIELDS AS READ FROM THE ARCHIVE. (INPUT) C JP(J,N) = INDICATES WHETHER A PARTICULAR VARIABLE N MAY C HAVE GRIDPRINTS (J=1), INTERMEDIATE TDLPACK C OUTPUT (J=2), OR PRINT OF VECTOR RECORDS IN C PACKV (J=3) (N=1,ND4). PACKV IS FOR THE C DATA SHOWING TOSSED DATA AS MISSING AND C QUESTIONABLE DATA AS MISSING. THIS IS C AN OVERRIDE FEATURE FOR THE PARAMETERS FOR C GRIDPRINTING AND TDLPACKING IN EACH VARIABLE'S C CONTROL FILE. (INPUT) C ICOMPT(N) = SIGNALS WHETHER THE VARIABLE IS TO BE ANALYZED C OR COMPUTED (N=1,ND4). C 0 WHEN THE VARIABLE IS TO BE ANALYZED; THE USUAL C CASE. C 1 WHEN THE VARIABLE IS NOT TO BE ANALYZED BUT TO C BE COMPUTED FROM OTHER ALREADY ANALYZED C VARIABLES. C (INPUT) C ISCALD(N) = THE DECIMAL SCALING CONSTANT TO USE WHEN PACKING C THE DATA (N=1,ND4). (INPUT) C THRESH(N) = THE BINARY THRESHOLD ASSOCIATED WITH C IDPARS( ,N), N=1,ND4). (INPUT) C ANLTAB(N) = THE CONTROL FILE NAME FOR THE VARIABLE DEFINED IN C ID( ), N=1,ND4). (CHARACTER*17) (INPUT) C INLTAB = THE CONTROL FILE UNIT NUMBER FOR THE VARIABLE C DEFINED IN ID( ). (INPUT) C IWRITS(N) = CONTROLS WRITING TO INTERNAL STORAGE (N=1,ND4). C 1 = WRITE GRID (ANALYSIS), C 2 = WRITE LTAG AFTER LAST PASS, C 3 = WRITE BOTH GRID AND LTAG, C 0 = OTHERWISE. (INPUT) C IWRITA(N) = INDICATES WHETHER OR NOT ASCII DATA ARE TO BE C WRITTEN TO FILE VOTNAM ON UNIT NO. KFILVO C (N=1,ND4). C 0 = DO NOT WRITE; C 1 = WRITE WITH * FOR THOSE TOSSED ON LAST PASS; C 2 = WRITE ONLY BASE STATIONS WITH * FOR THOSE C TOSSED ON LAST PASS; C 3 = SAME AS 1, EXCEPT NO *; AND C 4 = SAME AS 1, WITH INDICATORS OF TYPE OF DATA: C b = BOGUS; C ' = 1ST AUGMENTATION; C " = 2ND AUGMENTATION; AND C ^ = AVERAGE OF AUGMENTED VALUES. C (OUTPUT) 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 GRID C 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 CORRECT, C L=4--GRID ORIENTATION IN DEGREES, AND C L=5--LATITUDE OF LL CORNER IN DEGREES, C L=6--LONGITUDE OF LL CORNER IN DEGREES C (INPUT) C ND11 = MAXIMUM NUMBER OF GRID COMBINATIONS THAT CAN BE C DEALT WITH ON THIS RUN. LAST DIMENSION OF C NGRIDC( , ). (INPUT) C NGRIDT(L) = HOLDS WHAT NGRIDC(L, ) HOLDS TO PROVIDE TO C PACKGR. (INTERNAL) C IPLAIN(L,J,N) = 32 CHARACTERS (L=1,L3264W) (J=1,4) OF PLAIN C LANGUAGE DESCRIPTION OF VARIABLES (N=1,ND4). C NOTE THAT THIS REQUIRES TWO 32-BIT WORDS TO HOLD C THE DESCRIPTION BUT ONLY ONE 64-BIT WORD. C EQUIVALENCED TO PLAIN( ) IN DRU155. (INPUT) C PLAIN(N) = THE PLAIN LANGUAGE DESCRIPTION OF THE VARIABLES C IN ID( ,N) (N=1,ND4). EQUIVALENCED TO C IPLAIN( , ,N) IN DRU155. (CHARACTER*32) (INPUT) C ND4 = DIMENSION OF SEVERAL VARIABLES. (INPUT) C PLAINT = ARRAY FOR THE PLAIN LANGUAGE DESCRIPTION TO C FURNISH TO CAKSNO AND CCONSN. EQUIVALENCED C TO IPLANT. (INTERNAL) C PLANT(L,J) = 32 CHARACTERS (L=1,L3264W) (J=1,4) OF PLAIN C LANGUAGE DESCRIPTION USED IN CAKSNO CCONSN. C EQUIVALENCED TO PLAINT. (INTERNAL) C NPRED = THE NUMBER OF VARIABLES IN ID( , ), ETC. (INPUT) C N = INDEX INTO ID( , ) AND OTHER VARIABLES C INDICATING THE VARIABLE BEING DEALT WITH. C (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 DRU155. (INTERNAL) C CCALLD(K) = 8 STATION CALL LETTERS (K=1,NSTA). EQUIVALENCED C TO ICALLD( , ) IN DRU155. (CHARACTER*8) C (INTERNAL) C IPACK(J) = WORK ARRAY (J=1,ND5). (INTERNAL) C DATA(J) = WORK ARRAY FOR OBSERVED DATA (J=1,ND5). C (INTERNAL) C IWORK(J) = WORK ARRAY (J=1,ND5). (INTERNAL) C ND5 = DIMENSION OF IPACK( ), IWORK( ), AND DATA( ). C (INPUT) C MODNO = DD FOR WRITING GRIDS. (INPUT) C NDATE = THE DATE/TIME OF THE RUN. (INPUT) C MODNUM(J) = THE "MODEL" NUMBER CORRESPONDING TO KFILIN(J), C AND NAMIN(J) (J=1,ND6). (INPUT) C ND6 = MAXIMUM NUMBER OF INPUT FILES THAT CAN C BE DEALT WITH IN ONE RUN. DIMENSION OF C MODNUM( ). (INPUT) C NAREA = THE AREA OVER WHICH THE ANALYSIS IS MADE: C 1 = CONUS, C 2 = ALASKA, C 3 = HAWAII, C 4 = PUERTO. C ALATL = NORTH LATITUDE OF LOWER LEFT CORNER POINT C OF A GRID OF THE SIZE NXL, NYL. 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 NXL, NYL. 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 XLAT = NORTH LATITUDE AT WHICH GRIDLENGTH IS SPECIFIED C IN DEGREES. (INPUT) C NXL = THE SIZE OF THE PRIMARY GRID FOR THIS RUN C IN THE X DIRECTION IN MESHB UNITS. (INPUT) C NYL = THE SIZE OF THE PRIMARY GRID FOR THIS RUN C IN THE Y DIRECTION IN MESHB UNITS. (INPUT) C MESHB = THE NOMINAL MESH LENGTH OF THE ANALYSIS GRID C SPECIFIED BY NXL, NYL AT LATITUDE XLAT. C FOR INSTANCE, NOMINAL 80 CORRESPONDS C TO 95.25 KM FOR POLAR STEREOGRAPHIC. FOR C ALL ROUTINES TO WORK, THIS VALUE MUST BE C 1, 3, 5, 10, 20, 40, 80, 160, OR 320. C THE LOWER NUMBERS ARE INTEGERS APPROXIMATING C EVEN FRACTIONS OF BEDIENTS. (INPUT) C BMESH = ACTUAL MESH LENGTH CORRESPONDING TO MESHB. C (INPUT) C MESHL = NOMINAL MESH LENGTH OF QUALITY CONTROL C (SUBSETTED) GRID FOR CONTINUOUS VARIABLES. C (INPUT) C IOPTB(J) = SUBSETTING VALUES USED IN GRIDPRINTING (J=1,8) C IN RELATION TO MESHB. (INPUT) C NCLIPY = 1 WHEN THE NDGD MASK GRID IS AVAILABLE AND C IN CPNDFD( ). C 0 OTHERWISE. C (INPUT) C TELEV(J) = THE TERRAIN ELEVATION FROM THE MOS-2000 EXTERNAL C RANDOM ACCESS FILE (J=1,NXE*NYE). (INPUT) C SEALND(J) = THE LAND/SEA MASK (J=1,NXE*NYE). C 0 = OCEAN WATER GRIDPOINTS; C 3 = INLAND WATER GRIDPOINTS. C 9 = LAND GRIDPOINTS. C (INPUT) C CPNDFD(J) = THE NDFD MASK FROM THE MOS-2000 EXTERNAL C RANDOM ACCESS FILE (J=1,NXE*NYE) AT NOMINAL C MESHLENGTH MESHE. A "1" MEANS WITHIN THE AREA; C A "0" MEANS CLIP IT OUT. (INPUT) C NXE = X-EXTENT OF TELEV( ), SEALND( ), AND CPNDFD( ) C AT MESH LENGTH MESHE. (INPUT) C NYE = Y-EXTENT OF TELEV( ), SEALND( ), AND CPNDFD( ) C AT MESH LENGTH MESHE. (INPUT) C XPE(K) = THE X POSITION FOR STATION K (K=1,NSTA) ON C THE ELEVATION GRID AT THE GRID MESH LENGTH C MESHE. (INPUT) C YPE(K) = THE Y POSITION FOR STATION K (K=1,NSTA) ON C THE ELEVATION GRID AT THE GRID MESH LENGTH C MESHE. (INPUT) C MESHE = THE NOMINAL MESH LENGTH OF THE TERRAIN GRID. C IT IS MANDATORY THE GRID AVAILABLE IS OF THIS C MESH SIZE AND COVER THE SAME AREA SPECIFIED C BY NXL BY NYL, EVEN IF MESHE IS NOT EQUAL C TO MESHB. (INPUT) C EMESH = ACTUAL MESH LENGTH CORRESPONDING TO MESHE. C (INPUT) 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 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 CHARACTERISTICS OF THIS GRID. 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 L=12 --USED INITIALLY IN ESTABLISHING C MSTORE( , ). LATER USED AS A WAY OF C DETERMINING WHETHER TO KEEP THIS VARIABLE. C (INPUT) C LITEMS = THE NUMBER OF ITEMS IN LSTORE( , ). (INPUT) C ND9 = MAXIMUM NUMBER OF FIELDS STORED IN LSTORE( , ). C SECOND DIMENSION OF 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 NBLOCK = BLOCK SIZE IN WORDS OF INTERNAL MOS-2000 DISK C STORAGE. (INPUT) 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 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 MTOTBY = THE TOTAL NUMBER OF BYTES ON THE FILE ASSOCIATED C WITH UNIT NO. KFILOV. (INPUT/OUTPUT) C MTOTRC = THE TOTAL NUMBER OF RECORDS IN THE FILE ON UNIT C NUMBER KFILOV. (INPUT/OUTPUT) C ITOTBY = THE TOTAL NUMBER OF BYTES ON THE FILE ASSOCIATED C WITH UNIT NO. KFILQC. (INPUT/OUTPUT) C ITOTRC = THE TOTAL NUMBER OF RECORDS IN THE FILE ON UNIT C NUMBER KFILQC. (INPUT/OUTPUT) C NTOTBY = THE TOTAL NUMBER OF BYTES ON THE FILE ASSOCIATED C WITH UNIT NO. KFILIO (THE OUTPUT GRIDPOINT FILE). C (INPUT/OUTPUT) C NTOTRC = THE TOTAL NUMBER OF RECORDS IN THE FILE WITH UNIT C NUMBER KFILIO. (INPUT/OUTPUT) C NOTOSS(J) = RUNNING OF COUNT OF TOTAL STATIONS TOSSED ON C LAST PASS (J=1) AND OF BASE STATIONS (J=2). C (INPUT/OUTPUT) C NTOTGR = THE TOTAL NUMBER OF EXTERNAL RANDOM ACCESS C RECORDS WRITTEN TO KFILRA = 42. (INPUT/OUTPUT) C NTOTVO = THE TOTAL NUMBER OF ASCII RECORDS FOR SCRIPT C 'plot.sh' WRITTEN TO FILE KFILVO. (INPUT/OUTPUT) C KTOTBY = THE TOTAL NUMBER OF BYTES ON THE FILE ASSOCIATED C WITH UNIT NO. IP24. (INPUT/OUTPUT) C KTOTRC = THE TOTAL NUMBER OF RECORDS IN THE FILE ON UNIT C NUMBER IP24. (INPUT/OUTPUT) 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 = TOTAL NUMBER OF TIMES A MISSING INDICATOR C HAS BEEN ENCOUNTERED IN UNPACKING GRIDS WHEN C COMPUTING VARIABLES. (INPUT/OUTPUT) C MINPK = MINIMUM GROUP SIZE WHEN PACKING THE DATA. C (INPUT) C ISTA = 1 TO READ STATION DIRECTORY. 0 OTHERWISE. C THE POINTS TO ANALYZE CAN COME FROM THE C DIRECTORY (ISTA=1), FROM RANDOMLY SAMPLED C POINTS (ISTA=0), OR BOTH (ISTA=1). C (NOT CURRENTLY USED; MAY BE IMPLEMENTED WITH C OTHER VARIABLES.) (INPUT) C ISMPL = MAXIMUM NUMBER OF POINTS TO SAMPLE FROM THE C FIRST GUESS FIELD. 0 OTHERWISE. THE POINTS C TO ANALYZE CAN COME FROM THE DIRECTORY ONLY C (ISMPL=0), FROM SAMPLED POINTS (ISMPL GT 0), C OR BOTH (ISMPL GT 0). NSTA FROM THE DIRECTORY C + ISMPL MUST NOT EXCEED ND1 FOR ALL POINTS C TO BE USED. THE RAMDOM POINTS ARE DETERMINED C IN U155 BY CALLING POINTS, BUT THE SAMPLING C IS DONE IN U405A. C ISTOP(J) = ISTOP(1)--IS INCREMENTED BY 1 EACH TIME AN ERROR C OCCURS. C ISTOP(2)--IS INCREMENTED WHEN THERE ARE C FEW DATA FOR AN ANALYSIS. C ISTOP(3)--IS INCREMENTED WHEN A DATA RECORD C COULD NOT BE FOUND. C ISTOP(4)--IS INCREMENTED WHEN A LAPSE RATE COULD C NOT BE COMPUTED OR HAS TOO FEW CASES C TO BE USED. C ISTOP(5)--IS INCREMENTED WHEN NO NON-MISSING C GRIDPOINT AROUND THE DATA POINT IS C OF THE SAME TYPE. C ISTOP(6)--IS INCREMENTED WHEN THERE IS A PROBLEM C WITH MAKING BOGUS STATIONS. C (INPUT/OUTPUT) C IER = STATUS RETURN. C 0 = GOOD RETURN. C 777 = FATAL ERROR C SEE CALLED ROUTINES FOR OTHER VALUES. C ANY NON ZERO VALUE WILL CLOSE OUT THIS C DATE/TIME IN U155. (OUTPUT) C STATE = VARIABLE SET TO STATEMENT NUMBER TO INDICATE C WHERE AN ERROR OCCURRED. (CHARACTER*4) C (INTERNAL) C ITABLE(I,L) = 4-WORD ID OF THE VARIABLES THAT ARE C ACCOMMODATED BY U405A (I=1,4) (L=1,JVAL). C C FOR L = 1: C THE ANALYSIS VARIABLE. 1ST (EXCEPT FOR DD) C AND FOURTH WORD MUST MATCH U155.CN. C NOTE THAT DD = 0 AND WILL BE REPLACED WITH C IDPARS(4) AND TAU WITH IDPARS(12) C C FOR L = 2: C THE IDS OF VARIABLES NEEDED TO ANALYZE THE C FIELD J. THESE VARIABLES CAN BE WRITTEN IN C BCD5. IF THE VARIABLE IS NOT AVAILABLE, IT C CAN BE COMPUTED THROUGH OPTX. FOR WIND C DIRECTION, THIS IS THE GRIDDED U-WIND. C C FOR L = 3: C THIS IS THE FIELD NORMALLY NEEDED FOR THE FIRST C GUESS (WHEN IGUESS=2), AND IS USED IN FSTGS5. C FOR WIND DIRECTION, THIS IS THE GRIDDED V-WIND. C C FOR L = 4: C THIS IS THE FIELD NEEDED FOR THE FIRST GUESS C WHEN IGUESS=3, AND IS USED IN FSTGS5. FOR WIND C DIRECTION, THIS IS THE GRIDDED WIND SPEED. C C FOR L = 5: C THIS IS ID OF THE OBS OF A VARIABLE OTHER THAN C THE ONE BEING ANALYZED TO USE IN COMPUTING THE C LAPSE RATE. FOR INSTANCE, FOR TEMPERATURE C (L = 2) THE DEW POINT MIGHT BE USED (L = 5). C FOR WIND DIRECTION, THIS IS THE MODIFIED SPEED C FOR WRITING. C C FOR L = 6: C THIS IS ID OF A SECOND VARIABLE, OTHER THAN C THE ONE BEING ANALYZED, TO USE IN COMPUTING THE C LAPSE RATE. FOR INSTANCE, THREE VARIABLES C MIGHT BE USED. C C FOR L = 7: C THESE CAN BE USED IN PREPROCESSING OR C POSTPROCESSING, IF NEEDED. C C NORMALLY, THE CCCFFFB, BUT NOT DD IS INDICATED C IN EACH ID. C C FOR VARIABLES THAT ARE COMPUTED (E.G., WIND C DIRECTION), ALL EXCEPT THE FIRST MAY HAVE C DIFFERENT MEANINGS THAN ABOVE. C (INTERNAL) C NPASS = THE NUMBER OF PASSES FOR THIS ANALYSIS. C UP TO 6 ARE ACCOMMODATED. ALSO CONTAINS C NREP AND NREPNO WHEN READ. (INTERNAL) C NREPNO = NUMBER OF TIME TO REPEAT ANALYSIS WHEN SOME C DATA HAVE BEEN TOSSED ON THE LAST PASS. C READ AS PART OF NPASS. (INTERNAL) C NREP = PASS NUMBER TO START REPEAT (SEE NPRENO C ABOVE). (INTERNAL) C NPASSF = THE NUMBER OF THE PASS TO START A C A SPECIFIC ACTION, LIKE INTERPOLATING INTO C THE CURRENT ANALYSIS TO GET STABALIZING C VALUES FOR THE SUBSEQUENT PASSES. A VALUE OF C ZERO WILL BE TREATED AS A NOP. (NO LONGER C USED, BUT LEAVE = 0 FOR BCD5) (INTERNAL) C NPASSP = THE SAME AS NPASSF, SPECIFICALLY FOR SPOTRM. C NPASSR = THE NUMBER OF THE PASS TO SWITCH FROM VARIABLE C RADII TO CONSTANT RADII, UNLESS NPASSR EQ 0. C (INTERNAL) C NPASRR = THE NUMBER OF THE PASS TO USE THE INTERNALLY C COMPUTED RADII BASED ON THE CLOSEST STATION. C (INTERNAL) C NSMNUM = THE NUMBER TO INSERT INTO CALL TO SMOTHG C INDICATING HOW MANY SMOOTHING PASSES TO MAKE C AFTER SPOTRM. TAKEN FROM SPOTRM CONTROL C PARAMETERS. (INTERNAL) C NOCEAN = TAKES ONE OF 5 VALUES DEPENDING ON HOW THE C OCEAN TYPE OF STATION AFFECTS THE TYPE OF C GRIDPOINT. (INTERNAL) C LAKE = TAKES ONE OF 5 VALUES DEPENDING ON HOW THE C LAKE TYPE OF STATION AFFECTS THE TYPE OF C GRIDPOINT. (INTERNAL) C DISTX = VALUE TO MULTIPLY BY RMAX IN SPOTRM = R(1) C IN U405A.CN TO SEARCH FOR CLOSEST STATION C (INTERNAL) C DPOWER = THE POWER OF THE DISTANCE TO USE IN WEIGHTING. C WTAUG = THE WEIGHT OF THE AUGMENTING DATA. THIS WAS C SET UP TO USE WITH AUGMT3, BUT COULD BE USED C WITH OTHER AUGMENTING ROUTINES. INITIALIZED C TO 1. SO UNLESS SET OTHERWISE, AUGMENTING C AND BOGUS DATA WILL BE USED FULL FORCE. C (INTERNAL) C RAY = THE MULTIPLIER OF THE DISTANCE TO THE CLOSEST C STATION TO USE AS THE RADIUS OF THE SMOOTHING C CIRCLE (OR MAJOR AXIS OF ELIPSE). (INTERNAL) C DIFFA = THE MAXIMUM DIFFERENCE IN ELEVATION IN METERS C BETWEEN THE GRIDPOINT BEING SMOOTHED AND THE C GRIDPOINT USED IN SMOOTHING. USED IN SPOTRM. C (INTERNAL) C NOPTN = OPTION NUMBER FOR SPOTRM AND ORSMTW. USED IN BCD5 TO C CHECK WITH NSMTYP. INDICATES OPTION FOR WHICH C DATA TO SMOOTH OUT. COMES FROM U405A.CN IN C CALL TO SPOTRM CONST( ). INITIALIZED TO ZERO. C 1 = SMOOTH OUT BOGUS ONLY C 2 = SMOOTH OUT BOGUS AND 2ND LEVEL AUGMENTATION. C 3 = SMOOTH OUT BOGUS AND ALL AUGMENTATION C 4 = KEEP ALL. C (INPUT) C IBACKN = NUMBER OF 6-H CYCLES TO LOOK BACK FOR FIRST C GUESS WHEN IGUESS = 2. IBACKN = 1 MEANS C CURRENT (MOST RECENT) CYCLE PLUS THE ONE C 6 HOURS BEFORE). NORMALLY, THIS IS 0 FOR C DEVELOPMENT; MAY BE OTHERWISE FOR OPERATIONS. C IN A SIMILAR MANNER, IBACKN IS USED IN LAPSUA C TO GET FIELDS FOR CALCULATION OF LAPSE RATE. C IBACKN IS ALSO USED TO INDICATE IN AUGMT1 HOW C MANY CYCLES TO GO BACK TO FIND AUGMENTATION C DATA. IT IS POSSIBLE THERE COULD BE A CONFLICT C IN THESE USES, BUT NOT LIKELY. (INTERNAL) C IBACKL = NUMBER OF 6-H CYCLES TO LOOK BACK FOR FIRST C GUESS WHEN IGUESS = 3. IBACKL = 1 MEANS C CURRENT (MOST RECENT) CYCLE PLUS THE ONE C 6 HOURS BEFORE). NORMALLY, THIS IS 0 FOR C DEVELOPMENT; MAY BE OTHERWISE FOR OPERATIONS. C (NOTE THAT THIS DOES NOT PROVIDE FOR A BACKUP C FIRST GUESS FROM LAMP AT 1-H INTERVALS. A FIRST C GUESS (LAMP/MOS FORECASTS AT THE HOUR EXPECTED) C CAN BE USED, BUT JUST NOT A BACKUP.) C IN A SIMILAR MANNER, IBACKL IS USED IN LAPSUA C TO GET FIELDS FOR CALCULATION OF LAPSE RATE. C (INTERNAL) C NORUNS = NUMBER OF RUNS OR CYCLES TO INCLUDE IN AN C ANALYSIS, ALL VERIFYING AT THE SAME TIME, C MAXIMUM OF 5. (INTERNAL) C NHRRUN(J) = THE HOURS PRIOR TO THE RUN TIME IN NDATE TO C INCLUDE IN THE ANALYSIS (J=1,NORUNS). (INTERNAL) C WTRUNA(J) = THE WEIGHTS TO USE FOR THE RUN TIMES IN C NHRRUN(J) FOR THE ANALYSIS (J=1,NORUNS). C (INTERNAL) C WTRUNL(J) = THE WEIGHTS TO USE FOR THE RUN TIMES IN C NHRRUN(J) FOR THE LAPSE RATES (J=1,NORUNS). C (INTERNAL) C MSHPAS(J,L) = THE NOMINAL MESH LENGTH FOR EACH PASS (J=1,NPASS) C FOR EACH FIRST GUESS OPTION (L=1,4). C (INTERNAL) C ER1(J,L,M) = ERROR CRITERIA FOR EACH PASS (J=1,NPASS), C FOR EACH FIRST GUESS OPTION (L=1,4), C AND FOR EACH MONTH (M=1,12). C IF AN OBSERVATION IS DIFFERENT FROM THE CURRENT C ANALYSIS BY MORE THAN ER1( , , ), IT IS C PROBABLY NOT USED ON THIS PASS. HOWEVER, C BEFORE A DATUM IS DISCARDED, A BUDDY CHECK C IS MADE. ALSO IF ER1(J,L,M) = 0, IT MEANS THE C CHECK IS NOT PERFORMED ON THIS PASS. (INTERNAL) C NTYPE(J,L) = TYPE OF CORRECTION FOR EACH PASS J (J=1,NPASS) C FOR EACH FIRST GUESS OPTION (L=1,4). C 0 MEANS SKIP THIS PASS C 1 MEANS W = 1 C 2 MEANS W = (R**2 - D**2)/(R**2 + D**2) C 3 MEANS SAME AS 2 EXCEPT SUM OF WEIGHTS IN C DENOMINATOR. C WHEN READ, ALSO INCLUDES IFCOR( , ). C (INTERNAL) C IFCOR(J,L) = CORRECTION FLAG FOR EACH PASS J (J=1,NPASS) C FOR EACH FIRST GUESS OPTION (L=1,4). C 0 = IFULL( , ) IS NOT USED IN CORRECTIONS, C 1 = IFULL( , ) USED FOR + OR - CORRECTIONS, C 2 = IFULL( , ) USED TO EMPHASIZE HIGH WINDS. C THIS IS FOR WHEN MESONET OR OTHER DATA WITH C LESS RELIABILITY THAN METAR ARE TO NOT CARRY C AS MUCH WEIGHT. READ AS PART OF NTYPE( , ) C (INPUT) C R(J,L) = RADIUS OF INFLUENCE FOR EACH PASS J (J=1,NPASS) C FOR EACH FIRST GUESS OPTION (L=1,4) IN TERMS C OF MESH GRID UNITS BEING USED ON THAT PASS. C (INTERNAL) C ITRPLQ(J,L) = TYPE OF INTERPOLATION TO GO FROM ONE MESH C LENGTH TO ONE OF HALF THAT FOR EACH PASS J C (J=1,NPASS), FOR EACH FIRST GUESS OPTION C (L=1,4). C 1 = BILINEAR C 2 = BIQUADRATIC C (INTERNAL) C B(J,L) = SMOOTHING PARAMETER FOR EACH PASS J (J=1,NPASS) C FOR EACH FIRST GUESS OPTION (L=1,4). C B( ) = 0 MEANS NO SMOOTHING. (INTERNAL) C RSTAR(J,L) = MULTIPLICATIVE FACTOR (J=1,NPASS) TO USE WITH C R(J) IN DETERMINING HOW FAR OUTSIDE GRID TO USE C DATA (L=1,4). FOR PASS J AND FIRST PASS GUESS C OPTION L, PROGRAM WILL USE DATA R(J,L)*RSTAR(J,L) C GRID UNITS OUTSIDE GRID. (INTERNAL) C LNDWAT(J,L) = FLAG FOR EACH PASS (J=1,NPASS) AND FIRST C GUESS OPTION (L=1,4) TO DETERMINE HOW THE C SEA/LAND CORRECTIONS WILL BE MADE C 0 = DON'T USE THE DIFFERENCES FEATURE; ALL DATA C WILL BE USED FOR ALL POINTS. C 1 = USE THE DIFFERENCE FEATURE. SEE LNDSEA( ). C 2 = OCEAN POINTS WILL NOT BE CHANGED. C 3 = NEITHER OCEAN NOR INLAND WATER POINTS WILL C BE CHANGED. C (INTERNAL) C IALGOR(J,L) = TYPE OF CORRECTION ALGORITHM TO APPLY FOR EACH C PASS (J=1,NPASS) AND FIRST GUESS OPTION (L=1,4). C 1 = NORMAL TERRAIN C 2 = DISTANCE WEIGHTED TERRAIN C (INTERNAL) C ELCORR(J,L) = FRACTION OF THE ELEVATION CORRECTION TO C APPLY FOR EACH PASS (J=1,NPASS) AND FIRST C GUESS OPTION (L=1,4) FOR THE "USUAL" LAPSE C RATE SIGN. (INTERNAL) C BK(J.L) = THE MAXIMUM RADII IN GRIDPOINTS FOR WHICH C THE LAPSE RATES INDICATED BY IBKPN ARE USED C FOR EACH PASS (J=1,NPASS) AND FIRST GUESS C OPTION (L=1,4). (INTERNAL) C ELCORU(J,L) = FRACTION OF THE ELEVATION CORRECTION TO C APPLY FOR EACH PASS (J=1,NPASS) AND FIRST C GUESS OPTION (L=1,4) FOR THE "UNUSUAL" LAPSE C RATE (THE ONE WITH THE SIGN SPECIFIED IN C IBKPN. (INTERNAL) C IPOINT(J,L) = THE NUMBER OF POINTS SAMPLED FROM THE FIRST C GUESS TO USE FOR EACH PASS (J=1,NPASS) AND FIRST C GUESS OPTION (L=1,4). (INTERNAL) C RWATO(J) = FACTOR BY WHICH TO INCREASE THE RADIUS FOR C OCEAN WATER POINTS WHEN VARIABLE RADII NOT C BEING USED. (J=1,NPASS). (INTERNAL) C RWATI(J) = FACTOR BY WHICH TO INCREASE THE RADIUS FOR C INLAND WATER POINTS WHEN VARIABLE RADII NOT C BEING USED. (J=1,NPASS). (INTERNAL) C SMULT(J) = THE MULTIPLICATIVE FACTOR WHEN CONTOURING OR C GRIDPRINTING THE DATA (J=1,NPASS). C NOTE SMULT( ), SADD( ), ORIGIN( ), CINT( ), C AND UNITS( ), ALTHOUGH NAMED THE SAME AND C PLAYING THE SAME ROLE IN GRIDPRINTING, ARE C NOT THE SAME VARIABLES AS IN THE CALLING C PROGRAM; THEY ARE FILLED HERE AND PERTAIN C TO EACH PASS. (INTERNAL) C SADD(J) = THE ADDITIVE FACTOR WHEN CONTOURING OR C GRIDPRINTING THE DATA (J=1,NPASS). (INTERNAL) C ORIGIN(J) = THE CONTOUR ORIGIN, APPLIES TO THE UNITS IN C UNITS(J) (J=1,NPASS). (INTERNAL) C CINT(J) = THE CONTOUR INTERVAL, APPLIES TO THE UNITS IN C UNITS(J) (J=1,NPASS). (INTERNAL) C NPRT(J) = 1 FOR GRID PRINTING OF ANALYSIS AFTER PASS J C (J=1,NPASS). ZERO FOR NO PRINTING. (INTERNAL) C JPRT(J) = SAME AS ABOVE EXCEPT FOR SMOOTHED ANALYSIS. C (INTERNAL) C NTDL(J) = 1 FOR TDLPACKING AND WRITING ANALYSIS AFTER PASS J C (J=1,NPASS). ZERO FOR NO PACKING. (INTERNAL) C JTDL(J) = SAME AS ABOVE EXCEPT FOR SMOOTHED ANALYSIS. C (INTERNAL) C WNDWT(J,L) = WEIGHT TO APPLY TO WIND OBS CORRECTIONS C RELATIVE TO PRESSURE CORRECTIONS FOR EACH PASS C (J=1,6) FOR EACH FIRST GUESS OPTION (L=1,4). C (INTERNAL) C NSMTYP = TYPE OF SMOOTHING: C 1 = NORMAL, 5-PT C 2 = SAME EXCEPT NO CHANGE IS MADE UNLESS ONE C OF THE POINTS TO CONTRIBUTE TO THE NEW C VALUE HAS BEEN CHANGED. C 3 = 9-POINT SMOOTHING USED ON LAST PASS ONLY, C ANY OTHER PASS DEFAULTS TO NSMTYP = 2. C 4 = FOR PASSES GE 4, SAME AS 2 EXCEPT C A POINT IS NOT CHANGED IF IT IS LOWER THAN C BOTH POINTS ABOVE AND BELOW OR IF IT IS C LOWER THAN BOTH SIDE POINTS. DIAGONALS C ARE ALSO CONSIDERED. FOR THE OTHER C PASSES, DEFAULTS TO 2. C 5 = SPECIAL TERRAIN-FOLLOWING SMOOTHING. C 6 = TWO PASSES OF 5 ABOVE. C 7 = THREE PASSES OF 5 ABOVE. C (INPUT) C WNDTHR = THRESHOLD TO USE FOR WIND SPEED FOR WIND TO BE C USED IN ANALYSIS. (INTERNAL) C WNDTRN = DEGREES TO TURN SURFACE WIND BEFORE APPLYING C GEOSTROPHIC CORRECTION. (INTERNAL) C WNDGRD = PARAMETER FOR CONVERTING WIND SPEED TO SLP C GRADIENTS. (INTERNAL) C I405ADG = 1 = DIAGNOSTIC PRINT TO KFILDO; C 0 OTHERWISE. (INTERNAL) C LAPFG = 0 COMPUTE LAPSE FROM DATA C 1 COMPUTE LAPSE FROM FIRST GUESS. C 2 COMPUTE LAPSE FROM UPPER AIR DATA. C 3 COMPUTE LAPSE FROM SURFACE AND UPPER AIR DATA. C 4 USE LAPSE FROM PREVIOUS VARIABLE (E.G., TOTAL C WIND FROM WIND SPEED) C 5 A COMBINATION OF 0 AND 3 ABOVE. C NOTE IT IS COMBINED WITH LAPUDB IN READING. C (INTERNAL) C LAPUDB = 0 ANY LAPSE WILL BE USED BOTH UP AND DOWN C 1 LAPSE WILL BE USED ONLY IN AN UPWARD MANNER C 2 LAPSE WILL BE USED ONLY IN A DOWNWARD MANNER C THIS WAS ADDED TO KEEP WIND SPEED FROM BEING C VERY LOW IN VALLEYS. NOTE THAT IT IS COMBINED C WITH LAPFG IN READING. (INTERNAL) C LIMITX = THE NUMBER OF TIMES THE CONTROL INFORMATION C FOR THIS VARIABLE (CCCFFF) WILL BE PRINTED. C MULTIPLE TAUS FOR A PARTICULAR CCCFFF WILL C BE PRINTED ONLY IF LIMITX HAS NOT BEEN C EXCEEDED. (INTERNAL) C IVRAD = CONTROLS HOW VRAD( , ) AND THE RADII R( , ) C ARE USED. C 0 = USE R( , ) NORMALLY. C 1 = USE VRAD( , ). C (IF A STATION HAS NO VRAD( , ), USE THE C GENERIC R( , ). C 2 = SAME AS 1 EXCEPT ON LAST PASS ALSO MAKES C TYPE 3 CORRECTION FOR ONLY ONE STATION C WHEN DDRAD2 HAS BEEN CALLED. C WHEN READ, ICUG*100 IS PART OF IVRAD. C (INTERNAL) C IQUALC = THE COLUMN IN IQUAL(K, ) WHERE THE C DATA QUALITY FOR THAT STATION K RESIDES. C (INTERNAL) C QUALWT(J) = THE FRACTIONAL WEIGHTS TO APPLY TO THE THREE C QUALITIES OF DATA (J=1,4). (INTERNAL) C ISETP = FLAG TO INDICATE WHETHER AFTER THE LAST PASS C A GRIDPOINT WILL BE SET TO THE CLOSEST C STATION (=2), TO A VALUE IN THE DIRECTION C OF THE STATION VALUE BUT NOT CROSS AN INTEGER C BOUNDARY (=1), OR NOT (=0). (THIS COULD BE C PARTICULARIZED TO QUALITY OF DATA.) (INPUT) C ILS = FLAG FOR HOW THE SEA/LAND CORRECTIONS ARE C GOING TO BE MADE: C 1 = LAND/WATER TREATED SEPARATELY; C 0 = OTHERWISE. THIS OPERATES IN TANDOM WITH C LNDWAT( , ), BUT ILS CAN OVERRIDE FOR EASY CHANGE. C (INTERNAL) C IBKPN = FLAG TO INDICATE WHETHER TO APPLY BK( , ) TO C POSITIVE OR NEGATIVE LAPSE RATES: C 0 = DON'T OPERATE BK( , ) (ALL LAPSES USED), C +1 = APPLY TO POSITIVE LAPSES (POSITIVE IS ODD C FOR TEMPERATURE), C +2 = APPLY TO POSITIVE LAPSES, BUT DON'T USE C LAPSE AT ALL WHEN ELEDIF LT 0 (THEY ONLY C OPERATE UPWARD), C -1 = APPLY TO NEGATIVE LAPSES (NEGATIVE IS ODD C FOR SNOW), AND C -2 = APPLY TO NEGATIVE LAPSES, BUT DON'T USE C LAPSE AT ALL WHEN ELEDIF LT 0 (THEY ONLY C OPERATE UPWARD). C 99 = DON'T COMPUTE OR USE LAPSE RATES. C (LAPSE RATES WILL ALSO NOT BE USED WHEN KFILLP C IS NOT PROVIDED AND WHEN ELCORR( ) FOR ALL C PASSES = 0.) C (INTERNAL) C LPNO = THE MAXIMUM NUMBER OF DATA POINTS TO USE IN C COMPUTING THE LAPSE. NOTE THAT THERE CAN BE C LPNO*NORUNS ACTUAL VALUES TO SUM. USE C LPNO = 99 TO INDICATE NO LIMIT. IBKPN C NE 99 AND LPNO = 0 ARE INCOMPATIBLE. C THEREFORE, LPNO IS SET = 10000 TO INDICATE C NO LIMIT. NOT USED WHEN LAPFG = 3 OR 4. C (INTERNAL) C HGTTHA = ELEVATION DIFFERENCE IN M BETWEEN A STATION C AND A GRIDPOINT WHICH MUST NOT BE EXCEEDED C FOR THE STATION TO INFLUENCE THE GRIDPOINT. C CONVERTED TO M. (INTERNAL) C HGTTHB = ELEVATION DIFFERENCE IN M BETWEEN A STATION C AND ANY (INTERPOLATED) POINT ON THE ELEVATION C GRID BETWEEN THE STATION AND THE GRIDPOINT C WHICH MUST NOT BE EXCEEDED FOR THE STATION C TO INFLUENCE THE GRIDPOINT. CONVERTED TO M. C (INTERNAL) C IFIRST = COUNTS ENTRIES INTO U405A. THIS ALLOWS (HARD C CODED) CONTROL OF OUTPUT. SET BY DATA C STATEMENT TO ZERO. (INTERNAL) C (THIS IS NOT SAVED; SHOULD IT BE?) C LIMIT(J) = WHEN IFIRST GT LIMIT( ), PRINT OF CONTROL C INFORMATION WILL NOT OCCUR (J=1,NVAL). IT C APPLIES TO EACH ELEMENT SEPARATELY. (INTERNAL) C IGUESS(J) = TYPE OF FIRST GUESS TO USE IN PRIORITY ORDER C (J=1,4) C 1 = CONSTANT. C 2 = PRIMARY GRID (E.G., A MOS FORECAST). C 3 = ALTERNATE GRID. C 4 = AVERAGE OF OBSERVATIONS. C (INTERNAL) C GUESS = THE VALUE TO USE AS CONSTANT WHEN IGUESS(1) IS C ACTIVATED. (INTERNAL) C IFSTGS = CONTROLS GRIDPRINTING AND TDLPACKING AND C WRITING OF FIRST GUESS C 0 = FIRST GUESS IS NEITHER GRIDPRINTED OR C TDLPACKED AND WRITTEN. C 1 = FIRST GUESS IS TO BE GRIDPRINTED. C 2 = FIRST GUESS IS TO BE TDLPACKED AND WRITTEN. C 3 = FIRST GUESS IS TO BE BOTH GRIDPRINTED AND C TDLPACKED AND WRITTEN. C (INTERNAL) C MGUESS = THE TYPE OF FIRST GUESS ACTUALLY USED (SEE C (IGUESS( )). SET IN FSTGS5. (INTERNAL) C IVRBL = 1 = VARIABLE IS SLP. C 2 = OPEN. C 3 = OPEN. C 4 = VARIABLE SATURATION DEFICIT. C 5-NVAL = OPEN. C VALUE DEPENDS ON ID READ. C (INTERNAL) 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 (INTERNAL) C MESH = THE NOMINAL MESH LENGTH OF THE GRID BEING DEALT C WITH WHOSE DIMENSIONS ARE NX AND NY, AND C THE STATION LOCATIONS IN XP( ) AND YP( ) ARE C IN REFERENCE TO. (INTERNAL) C NVAL = NUMBER OF VARIABLES HANDLED IN U405A. SET BY C PARAMETER. (INTERNAL) C JVAL = MAXIMUM NUMBER OF VARIABLES NEEDED IN C ITABLE( , ) TO ANALYZE INDIVIDUAL VARIABLES. C SECOND DIMENSION OF ITABLE( , ). SET BY C PARAMETER. (INTERNAL) C JTABLE(J,L) = TABLE OF IDS (L = 1)THAT HAVE BEEN USED ON C THIS RUN AND COUNT OF THE TIMES USED (L = 2). C THE IVRBL DERIVED IS NEEDED IN BCD5/ESP5 IN C CONTROLLING PRINT. (INTERNAL) C IFILL = THE MAXIMUM OF THE NUMBER OF SLOTS IN C JTABLE( , ) FILLED OR 4. SLOT 4 HAS TO BE C RESERVED FOR SATURATION DEFICIT IN BCD5. C IOPT(J) = SUBSETTING VALUES USED IN GRIDPRINTING (J=1,8) C IN RELATION TO THE SUBSETTED AREA MESH LENGTH C MESHL. COMPUTED ONCE AND SAVED. (INTERNAL) C NSAVDT(J) = DATE FROM JDATE( ) SAVED FOR USE IN NEXT ENTRY C (J=1,4). NORMALLY, THE CONTROL DATA ARE C WRITTEN ONLY ONCE OR A FEW TIMES, AND ARE C THE SAME FOR EACH DATE/TIME. HOWEVER, THE C ERROR CRITERIA VARY BY MONTH, SO IF MULTIPLE C DAYS ARE USED IN ONE RUN, DIFFERENT MONTHS C MAY BE INVOLVED. THE ERROR CRITERIA ARE C WRITTEN OUT EACH TIME A NEW MONTH IS C ENCOUNTERED. (INTERNAL) C ISAVDT = SAVED NDATE FROM ENTRY TO ENTRY. (INTERNAL) C IOPTL(J) = IOPT( ) FOR THE FULL AREA. ONLY USED FOR C CHECKOUT. (INTERNAL) C RACK = FOR HOLDING PLAIN LANGUAGE FOR WRITING. C (CHARACTER*32) (INTERNAL) C JPP(J) = ONLY FOR USE IN PACKV. (INTERNAL) C CORMSH = REAL(MESH)/REAL(MESHB). ADJUSTS GEOSTROPHIC C WIND CORRECTION FOR MESH. (INTERNAL) C IPOPT = INCREMENTED BY 1 ON EACH ENTRY TO CONTROL PRINT C OF IOPT( ). (INTERNAL) C JFIRST(K) = USED IN ESP5 VIA BCD5 TO CONTROL PRINTING C (K=1,NVAL). (INTERNAL) C KFILPR(J) = UNIT NUMBER OF PREPROCESSING ROUTINES C (J=1,NPRE). (INTERNAL) C PREPRO(J) = NAME OF PREPROCESSING ROUTINES (J=1,NPRE). C (CHARACTER*6) (INTERNAL) C NPRE = DIMENSION OF PREPRO( ) AND ASSOCIATED C VARIABLES. (INTERNAL) (SET BY PARAMETER) C NOPRE = NUMBER OF ENTRIES IN PREPRO( ) AND ASSOCIATED C VARIABLES. (INTERNAL) C POSTAR(J) = NAME OF ARCHIVE POSTPROCESSING ROUTINES (J=1,NPRO). C (CHARACTER*6) (INTERNAL) C POSTDS(J) = NAME OF DISPOSABLE POSTPROCESSING ROUTINE C (J=1,NPRO). (CHARACTER*6) (INTERNAL) C NOPROD = THE NUMBER OF ENTRIES IN POSTDS( ). (INTERNAL) C PREPFL(J) = NAME OF FILE USED WITH PROPRO(J) (J=1,NPRE). C (CHARACTER*60) (INTERNAL) C TLOD(J) = LOW THRESHOLD FOR DISPOSABLE GRIDS (J=1,NPRO). C WHEN A LAST PASS GRIDPOINT IS C LT TLOD, IT IS SET TO SETLOD. (INTERNAL) C SETLOD(J) = SEE TLOD (J=1,NPRO). (INTERNAL) C THID(J) = HIGH THRESHOLD FOR DISPOSABLE GRIDS (J=1,NPRO). C WHEN A LAST PASS GRIDPOINT IS C GT THID, IT IS SET TO SETHID. (INTERNAL) C SETHID(J) = SEE THID (J=1,NPRO). (INTERNAL) C CONSTD(J) = ADDITIVE CONSTANT TO FURNISH TO THRESHOLDING C AND SCALING SUBROUTINE FOR DISPOSABLE GRIDS C (J=1,NPRO). (INTERNAL) C NSCALD(J) = SCALING CONSTANT TO FURNISH TO THRESHOLDING C AND SCALING SUBROUTINE FOR DISPOSABLE GRIDS C (J=1,NPRO). (INTERNAL) C EX1D(J) = EXTRA PARAMETER FOR DISPOSABLE GRIDS NOT YET C USED FOR THRESHOLDING (J=1,NPRO). (INTERNAL) C EX2D(J) = EXTRA PARAMETER FOR DISPOSABLE GRIDS NOT YET C USED FOR THRESHOLDING (J=1,NPRO). (INTERNAL) C TLOA(J) = LOW THRESHOLD FOR ARCHIVE GRIDS (J=1,NPRO). C WHEN A LAST PASS GRIDPOINT IS C LT TLOD, IT IS SET TO SETLOD. (INTERNAL) C SETLOA(J) = SEE TLOD (J=1,NPRO). (INTERNAL) C THIA(J) = HIGH THRESHOLD FOR ARCHIVE GRIDS (J=1,NPRO). C WHEN A LAST PASS GRIDPOINT IS C GT THID, IT IS SET TO SETHID. (INTERNAL) C SETHIA(J) = SEE THID (J=1,NPRO). (INTERNAL) C CONSTA(J) = ADDITIVE CONSTANT TO FURNISH TO THRESHOLDING C AND SCALING SUBROUTINE FOR ARCHIVE GRIDS C (J=1,NPRO). (INTERNAL) C NSCALA(J) = SCALING CONSTANT TO FURNISH TO THRESHOLDING C AND SCALING SUBROUTINE FOR ARCHIVE GRIDS C (J=1,NPRO). (INTERNAL) C EX1A(J) = EXTRA PARAMETER FOR ARCHIVE GRIDS NOT YET C USED FOR THRESHOLDING (J=1,NPRO). (INTERNAL) C EX2A(J) = EXTRA PARAMETER FOR ARCHIVE GRIDS NOT YET C USED FOR THRESHOLDING (J=1,NPRO). (INTERNAL) C NCAT(J) = NUMBER OF CATEGORIES FOR SOME PREPROCESSING C ROUTINES, OTHER USES FOR OTHERS (J=1,NPRE). C (INTERNAL) C NSCALE(J) = SCALE FACTOR FOR PREPROCESSING ROUTINES C (J=1,NPRE). (INTERNAL) C CONST(J) = CONSTANT FOR PREPROCESSING ROUTINES C (J=1,NPRE). (INTERNAL) C IPREX1(J) = PREPROCESSING PARAMETER (J=1,NPRE). (INTERNAL) C IPREX2(J) = PREPROCESSING PARAMETER (J=1,NPRE). (INTERNAL) C PREX3(J) = PREPROCESSING PARAMETER (J=1,NPRE). (INTERNAL) C PREX4(J) = PREPROCESSING PARAMETER (J=1,NPRE). (INTERNAL) C PREX5(J) = PREPROCESSING PARAMETER (J=1,NPRE). (INTERNAL) C WHOLD(K) = ARRAY TO HOLD DATA WITHHELD (K=1,NSTA). C (AUTOMATIC) (INTERNAL). C LTAGWH(K) = SAVES LTAG(K) FOR WITHHELD DATA. C (AUTOMATIC) (INTERNAL) C LOCWH(K) = THE LOCATIONS OF THE WITHHELD STATIONS IN C THE LIST IN THE ORDER OF WITHHOLDING. C (AUTOMATIC) (INTERNAL). C NWITH = NUMBER OF STATIONS TO WITHHOLD. (INTERNAL) C ITYPR = TYPE OF WITHHOLDING. C 1 = USE WTHOL1--FOR USE IN VERIFYING FORECATS C IP24 WILL BE USED FOR STATISTICS. C 2 = USE WTHOL2--FOR USE IN STUDYING ERROR C OF ANALYSIS. IP24 WILL BE USED FOR C WRITING PACKED DATA. THIS VALUE WILL C USE ISEED. WILL USE SUBROUTINE WTHOL2. C 3 = USE WTHOL2--FOR USE IN STUDYING ERROR C OF ANALYSIS. IP24 WILL BE USED FOR C WRITING PACKED DATA. THIS VALUE WILL C USE A SEED FROM THE SYSTEM CLOCK. WILL C USE SUBROUTINE WTHOL3. C IWSEED = A NUMBER FROM 1 TO 10 INDICATING WHICH VALUE C OF SEEDT( ) TO USE IN THIS RUN FOR SEED. C (INTERNAL) C SEEDT(J) = 10 VALUES SET BY DATA STATEMENT TO USE AS C THE STARTING SEED FOR THE RANDOM NUMBER C GENERATOR (SEE IWSEED). (INTERNAL) C SEED = THE INITIAL SEED FOR THE RANDOM NUMBER GENERATOR C IN SUBROUTINES WTHOL1 AND WTHOL2. MODIFIED C IN SUBROUTINES WITHOL AND WTHOL2 AND SAVED. C (SEE IWSEED AND SEEDT( ) ABOVE.) (INTERNAL) C IWLOOP = THE NUMBER OF TIMES THE LOOP WITH THE FIXED C SEED WILL BE EXECUTED BEFORE THE RANDOMIZATION C STARTS. THIS GIVES THE OPTION OF CHANGING C THE RANDOM LIST OF STATIONS. (INTERNAL) C NBLEND = DEFINES HOW INPUT GRID FOR IFSTGS = 2 OR 3 IS C POSSIBLY BLENDED WITH A CONSTANT C 0 = DISABLE. C 1 = WHEN IGUESS = 2 OR 3, USE THAT GRID ONLY C OVER WATER AS DEFINED BY THE LAND/SEA MASK C SEALND( , ) = 0, AND USE THE AVERAGE OF THE C DATA TO BE ANALYZED OVER LAND. C 2 = WHEN IGUESS = 2 OR 3, USE THAT GRID ONLY C OVER WATER AND FOR LAND BELOW SAN DIEGO C ON THE GRID. THIS IS TO GIVE A MODEL C FG OVER MEXICO WHERE THERE IS ESSENTIALLY C NO DATA. A MODEL FG OVER CANADA DOES C NOT GIVE AS GOOD AN ANALYSIS AS A CONSTANT. C 3 = THE SAME AS 1 EXCEPT LAND WILL BE THE C CONSTANT "GUESS." C 4 = THE SAME AS 3 EXCEPT SIBERIA IS EXCLDED. C THIS IS FOR THE ALASKA NBM GRID ONLY. C CSTSM = THE SMOOTHING PARAMETER IF ANY POINT HAS WATER C BUT NOT ALL ARE WATER. USE INSTEAD OF BQ. C (CSTSM = 4 WEIGHTS THE AVERAGE OF THE 4 C NEIGHBORING POINTS EQUAL TO THE CENTER C POINT--THE USUAL SITUATION FOR SMOOTHING. WHEN C CSTSM = .4, THE SUM OF THE SURROUNDING POINTS C IS .1 AS MUCH AS THE CENTER VALUE.) C (INTERNAL) C N4P = 4 INDICATES THE SURROUNDING 4 POINTS WILL BE C CHECKED WHEN TRYING TO FIND A GRIDPOINT OF C THE SAME TYPE AS THE DATUM AND INTERPOLATION C CAN'T BE DONE. CURRENTLY, THIS IS ALWAYS C DONE (DOES NOT REQUIRE N4P=4). C 12 SAME AS ABOVE, EXCEPT 12 ADDITIONAL POINTS C WILL BE CHECKED WHEN NONE OF THE 4 POINTS C ARE OF THE CORRECT TYPE. C N4P IS OPERATIVE ONLY WHEN THE SURROUNDING C 4 POINTS ARE OF MIXED TYPE. (INPUT) C NCLIP = 1 TO CLIP THE ARCHIVE OUTPUT GRID TO NDGD SIZE. C 0 OTHERWISE. ALSO CONTROLS SMOOTHING IN C SPOTRM. (INTERNAL) C NSHLN(J) = DETERMINES SMOOTHING AT HIGH AND LOW ELEVATIONS. C A 1 INDICATES: C J=1--HIGH ELEVATION, HIGH VALUE SMOOTHED. C J=2--HIGH ELEVATION, LOW VALUE SMOOTHED. C J=3--HIGH ELEVATION, NOT HIGH OR LOW VALUE C SMOOTHED. C J=4--LOW ELEVATION, HIGH VALUE SMOOTHED. C J=5--LOW ELEVATION, LOW VALUE SMOOTHED. C J=6--LOW ELEVATION, NOT HIGH OR LOW VALUE C SMOOTHED. C A 0 INDICATES NO SMOOTHING FOR THE VALUES OF J. C (INTERNAL) C WTWTL = WEIGHTING FACTOR TO USE FOR OCEAN OR INLAND WATER C POINTS OVER LAND WHEN ILS = 1. OCEAN POINTS C NEVER AFFECT INLAND WATER. (INTERNAL) C WTLTW = WEIGHTING FACTOR TO USE FOR LAND POINTS OVER C OCEAN AND INLAND WATER WHEN ILS = 1. (INTERNAL) C BB = RETURNED VALUE. C (INTERNAL) C JER = 0 UNTIL A MAJOR ERROR OCCURS, THEN IT IS C INCREMENTED BY 1. IT COUNTS THE MAJOR ERRORS C THAT WILL CAUSE EITHER NO GRID OR A 9999 C (MISSING) GRID TO BE OUTPUT. (INTERNAL) C MER = 0 UNTIL AN NON-MAJOR ERROR OCCURS, THEN IT IS C INCREMENTED BY 1. IT COUNTS THE ERRORS THAT C WILL NOT KEEP A GRID FROM BEING PRODUCED. C (INTERNAL) C MAXPT = THE MAXIMUM NUMBER OF POINTS SAMPLED FROM THE C FIRST GUESS TO USE FOR THIS VARIABLE. IT C NEVER EXCEEDS ISMPL. (INTERNAL) C MPAIRS(K) = THE ACTUAL NUMBER OF PAIRS USED IN THE C CALCULATION (K=1,NSTA). IT CAN TAKE THE C FOLLOWING VALUES: C 1) 5555 FOR SOME PAIRS BUT LT 4, C 2) 7777 STATION IS OUTSIDE ANALYSIS BY R (NOTE C THIS MAY BE A LARGER AREA THAN ACTUALLY C USED, C 3) A LEGITIMATE NUMBER OF PAIRS USED IN THE C CALCULATION, OR C 4) 9999 FOR OTHER SITUATIONS (NO PAIR LIST, OB C MISSING, OR NO USABLE PAIRS). (INTERNAL) C (AUTOMATIC) C ELEMOD(K) = ELEVATION OF THE MODEL TERRAIN AT THE LOCATION C OF STATION K (K=1,NSTA). READ FROM RANDOM C ACCESS FILE WHEN NEEDED. (INTERNAL) C (AUTOMATIC) C IBKPR = FLAG INDICATING WHETHER OR NOT BK( , ) WAS C CHANGED TO AGREE WITH R( , ) AND HOW MANY TIMES. C (INTERNAL) C NX = THE X-EXTENT OF THE CURRENT GRID. DEFINED IN C FSTGS5. (INTERNAL) C NY = THE Y-EXTENT OF THE CURRENT GRID. DEFINED IN C FSTGS5. (INTERNAL) C XDATA(K,L,J) = HOLDS THE DATA TO ANALYZE (K=1,NSTA) C (L=1,NORUNS+1) (J=1,LEVELS). C DATA ARE READ INTO COLUMNS L=2,NORUNS. THE C DATA TO ANALYZE ARE PUT INTO COLUMN L=1. C (INTERNAL) (ALLOCATABLE) C LEVELS = THE NUMBER OF PROBABILITY LEVELS TO ANALYZE. C (INTERNAL) C IEXTRA = THE NUMBER OF STATIONS TO PROCESS IN WTHOL2 BUT C TO NOT WITHHOLD. PROBABLY WILL EVENTUALLY BE C ZERO. (SET BY PARAMETER) C MFIRST = 0 TO INDICATE ALLOCATION OF ARRAY ERRANL( , ) C NEED BE DONE. ALSO TO INDICATE SEED NEEDS TO C BE SET. EQUALS 1 OTHERWISE. C DUMCAL(K) = DUMMY CALL LETTERS OF THE STATIONS PROCESSED C (K=1,NWITH+IEXTRA). (CHARACTER*8) (INTERNAL) C ERRANL(K,M) = DATA ASSOCIATED WITH WITHHELD DATA FOR C COMPUTING ERROR ANALYSIS (K=1,NWITH+IEXTRA) C (M=1,IDIM). (ALLOCATABLE) C ID2(M) = THE 2ND WORD ID OF THE VARIABLE M USED IN C ERRANL( , ) FOR THE ERROR DATA (M=1,IDIM). C IT IS COMPOSED OF 3 PARTS XXX97YYYY: C (1) XXX = NUMBER IN SEQUENCE 1-20 (OR MORE), C (2) CONSTANT = 97, C (3) YYYY = THE VALUE USED IN COMPUTING THE C VARIABLE (E.G.,35 WHEN THE VARIABILITY C HAS BEEN COMPUTED OVER 35 GRIDLENGTHS C FROM THE STATION OR GRIDPOINT). C (ALLOCATABLE) C IDIM = 2ND DIMENSION OF ERRANL( , ) AND DIMENSION OF C ID2( ). SET BY PARAMETER. C NROUGH(J) = THE RADII OVER WHICH TO COMPUTE THE ROUGHNESS C IN TERMS OF GRIDLENGTHS (J=1,4). SET BY DATA C STATEMENT. (INTERNAL) C RELVAR(J) = THE RADII OVER WHICH TO COMPUTE THE VARIABILITY C VARIABLES IN TERMS OF GRIDLENGTHS (J=1,4). C ALSO, RELVAR(1) IS THE DISTANCE OVER WHICH TO C SEARCH FOR THE CLOSEST TWO STATIONS. SET BY C DATA STATEMENT. (INTERNAL)) C VARTAB(J,M) = THE MULTIPLYING FACTORS FOR RELVAR( ) FOR C LAND(J=1) AND WATER(2) FOR AREA M (M=1,4). C (INTERNAL) C MESHSV = THE MESH LENGTH SAVED. (INTERNAL) C NXSV = THE X EXTENT SAVED. (INTERNAL) C NYSV = THE Y EXTENT SAVED. (INTERNAL) C LX = THE NUMBER OF GROUPS WHEN PACKING IN PAWGTS. C (INTERNAL) C IOCTET = THE NUMBER OF OCTETS OR BYTES IN THE PACKED C ARRAY IN PAWGTS. (INTERNAL) C FL174 = FILE NAME USED IN RDVRHL AND LAPSUA. C (CHARACTER*60) (INTERNAL) C LASTL = THE LAST LOCATION IN CORE( ) USED. RETURNED C FROM GSTORE. (INTERNAL) C LASTD = TOTAL NUMBER OF PHYSICAL RECORDS ON DISK C IN INTERNAL RANDOM ACCESS STORAGE. RETURNED C FROM GSTORE. (INTERNAL) C JSTTST(J) = NUMBER OF VALUES FOR ANALYSIS THAT IF NOT MET C WILL TRIGGER A DIAGNOSTIC (J=1,4). C J CORRESPONDS TO NAREA VALUES 1 THROUGH 4. C (INTERNAL) C LLMT = MINIMUM NUMBER OF PAIRS TO USE IN LAPSE TO C COMPUTE A LAPSE RATE. (THIS IS NOT CURRENTLY C USED IN U405A, BUT IS SET IN LAPSE BASED ON C VARIABLE ID. IT WAS ORIGINALLY SET = 4 HERE C BEFORE CALL TO LAPSE, THEN WAS CHANGED TO 2 FOR C LAMP. IT HAS BEEN CHANGED BACK TO 4 IN LAPSE. C (INTERNAL) C LTAGPT(K) = FOR STATION K (K=1NSTA), C 1 = AUGMENTED DATA (FIRST PASS) C 2 = AUGMENTED DATA (2ND PASS) C 3 = BOGUS DATA FROM BOGUS C 4 = BOGUS DATA FROM BOGUSG C 0 = EVERYTHING ELSE C (INTERNAL) (AUTOMATIC) C MTAGPT(K) = THE SAME AS LTAGPT( ), EXCEPT A PLACE TO HOLD C LTAGPT( ) FOR SPEED TO USE IN TOTAL WIND. C (INPUT/OUTPUT) C NTAGPT(K) = TAG FOR HOW AUGMENTATION IS MADE (K=1,NSTA). C 0 = NOT AUGMENTED. INCLUDES MISSING AND BASE C VALUES. C 1 = WEIGHTED AVERAGE OF 1ST AND 2ND LEVELS, BUT C ONLY WHEN IPREX5 NE 0. THIS IS FOR LAMP C AVERAGE OF MOS AND OBS. C 2 = 1ST LEVEL, 2ND NOT THERE. THIS COULD BE C OBS FOR OBS ANALYSIS OR MOS FOR LAMP. C 3 = 2ND LEVEL, 1ST LEVEL NOT THERE. THIS IS C OBS FOR EITHER OBS ANALYSIS OR LAMP. C 4 = 1ST LEVEL WHEN IPREX5 = 0. THIS IS OBS C FOR OBS ANALYSIS OR MOS FOR LAMP. C NTOTGB = TOTAL BYTES WRITTEN TO RANDOM ACCESS FILE. C NTOTGR IS THE NUMBER OF RECORDS AND IS C INITIALIZED AND CARRIED BACK TO U155. NTOTGB C IS NOT WRITTEN IN U155. (INTERNAL) C EXCLUD = WHEN NOT 9999, UNLIMITED CEILING (888) SET TO C EXCLUD FOR ANALYSIS. ALSO USED IN C XLAPSE TO EXCLUDE UNLIMITED IN CALCULATION OF C LAPSE RATE. READ WITH PREPROCESSOR SETCIG C FOR COORDINATION WITH SUBROUTINE LAPSE. C IORST = 1 WHEN ORSMTW IS TO BE CALLED, AND SMOTHG IS C TO BE CALLED BEFORE THE CORRECTIONS ON THE LAST C PASS. 0 OTHERWISE. THE PURPOSE IS TO SMOOTH C THE OCEAN WITH A 9-POINT SMOOTHER IN ORDER TO C FORCE A CORRECTION AT AND AROUND A MAX OR MIN C DATUM VALUE. (INTERNAL) C ERRADJ = THROWOUT ADJUSTMENT. NORMALLY = 1. FOR AUGMTX, C CAN BE USED TO ADJUST THROWOUT BASED ON TYPE OF C DATA (OCEAN, LAKE, LAKE/LAND, OR LAND). HAS C BEEN IMPLEMENTED FOR AUGMT2. (INTERNAL) C CPRJ = WILL HOLD ASCII VERSION OF PROJECTION, 3 DITITS. C (CHARACTER*3) C IWIND = 1 WHEN WIND IS BEING PLOTTED; C 0 OTHERWISE. C (INTERNAL) C NOSCII = THE NUMBER OF RECORDS WRITTEN TO ASCII FILE ON C KFILVO. C VOTNAME = ASCII FILE NAME VOTNAM EXTENDED WITH ELEMENT C AND PROJECTION NAME. C MOSFUL = 1 WHEN MOS IS TO BE USED EXCLUSIVELY (TO AUGMENT C LAMP). ZERO OTHERWISE. THIS IS SET IN CVLMPM C AND USED IN SCLVIS AND SCLCIG. C EQNNAM = FILE NAME FOR EQUATIONS IN MELD. (CHARACTER*60) C (INTERNAL) C TELL = LOWER THRESHOLD FOR WT TO BE USED WITH XLAPSE C IN CORBC5. THE WEIGHT FOR ULAPZE IS 1-TELL. C CALCULATED IN CLAPSE. (INTERNAL) C TELH = HIGHER THRESHOLD FOR WT. (SEE TELL ABOVE) C (INTERNAL) C ATEL = CONSTANT FOR THE LINE. (SEE TELL ABOVE) C (INTERNAL) C BTEL = COEFFICIENT FOR THE LINE. (SEE TELL ABOVE) C (INTERNAL) C IOBS = SET FROM CONST( ) FOR AUGMT2. CONTROLS READING C OF LTAG( ) FROM PREVIOUS ANALYSES. (INTERNAL) C ICUB = = 0, USE WT=(R**2-DIST**2)/(R**2+DIST**2) C = 1, USE WT=[(R**3-DIST**3)/(R**3-DIST**3)]**2 C (INTERNAL) C NBASTA = THE NUMBER OF STATIONS BEFORE BOGUSG STATIONS C ARE ADDED. (INTERNAL) C FSFULL(IX,JY) = THE FIRST GUESS BEFOR A PORTION IS SET TO A C CONSTANT FOR ANALYSIS (IX=1,NX) (JY=1,NY). C USED IN SPLICING THE THE TWO AREAS TOGETHER. C (AUTOMATIC) (INTERNAL) C 1 2 3 4 5 6 7 X C C NONSYSTEM SUBROUTINES USED C FSTGS5, BCD5, FLTAGM,IERX, NEWXY1, SIZEGR, c RESTRW, FITWTH, SCALX, SCALX1 TRAIL, SKPWR2, SZGRDM, C SCLQ06, SCLQ12, SCLSNO, SCLSKY, POST, OSMTH, WTHOL1, C WTHOL2, VARI, CLOS2, ROUGH, DIFWH, WRDIR, CONCPR, CONVPR, C DIRSPD, RDVRHL, CKPOP, QPF6P6 C PARAMETER (NVAL=24, 1 NVALX2=NVAL*2, 2 JVAL=7) PARAMETER (NPRE=12, 1 NPRO=12) C PARAMETER (IEXTRA=0) PARAMETER (IDIM=20) C CHARACTER*2 VO CHARACTER*3 CPRJ CHARACTER*4 STATE CHARACTER*6 PREPRO(NPRE),POSTAR(NPRO),POSTDS(NPRO) CHARACTER*8 CCALL(ND1,6) CHARACTER*8 CCALLD(ND5) CHARACTER*8 DUMCAL(ND1) C DUMCAL( ) IS AN AUTOMATIC ARRAY. CHARACTER*8 EIGHT9S CHARACTER*17 ANLTAB(ND4) CHARACTER*20 NAME(ND1) CHARACTER*32 PLAIN(ND4),RACK,PLAINT CHARACTER*40 TITLE/' '/, 1 SIN/'SIN OF LATITUDE '/ CHARACTER*60 RACESS(6),OUTVEC,OUTQCV,VOTNAM,VOTNAME,EQNNAM CHARACTER*60 PREPFL(NPRE),FL174 C DIMENSION XP(ND1),YP(ND1),XPL(ND1),YPL(ND1),XPE(ND1),YPE(ND1), 1 LTAG(ND1),WDIR(ND1),WSPD(ND1),STALAT(ND1),STALON(ND1), 2 TOSS(ND1),QUEST(ND1),ISDATA(ND1),XYP(ND1,2),SDATA(ND1), 3 IQUAL(ND1,5),LNDSEA(ND1),ELEV(ND1), 4 NOPAR(ND1),LOCPAR(ND1),QUALST(ND1),XLAPSE(ND1), 5 VRAD(ND1,6),ELEVHI(ND1),ELEVLO(ND1),ICALL(L3264W,ND1,6) DIMENSION WHOLD(ND1),LTAGWH(ND1),LOCWH(ND1),ERRWH(ND1), 1 MPAIRS(ND1),ELEMOD(ND1),LTAGPT(ND1),MTAGPT(ND1), 2 NTAGPT(ND1),ULAPSE(ND1) C WHOLD( ), LTAGWH( ), LOCWH( ), ERRWH( ), MPAIRS( ), LTAGPT( ), C NTAGPT( ), ELEMOD( ), AND ULAPSE( ) ARE AUTOMATIC ARRAYS. DIMENSION P(ND2X3) DIMENSION FGFULL(ND2X3) C FGFULL( , ) IS AN AUTOMATIC ARRAY. DIMENSION FD2(ND2X3),FD3(ND2X3),FD4(ND2X3),FD5(ND2X3),FD6(ND2X3), 1 U(ND2X3),V(ND2X3),FDSINS(ND2X3) DIMENSION ID(4,ND4),IDPARS(15,ND4),THRESH(ND4),JD(4,ND4), 1 JP(3,ND4),ISCALD(ND4),IWRITS(ND4),IWRITA(ND4), 2 ICOMPT(ND4),INLTAB(ND4) DIMENSION IWRITF(ND4) DIMENSION IPLAIN(L3264W,4,ND4),IPLANT(L3264W,4) DIMENSION IPACK(ND5),DATA(ND5),IWORK(ND5),ICALLD(L3264W,ND5) DIMENSION MODNUM(ND6) DIMENSION IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7) DIMENSION LSTORE(12,ND9) DIMENSION CORE(ND10) DIMENSION DIR(ND1,2,ND11),NGRIDC(6,ND11),NGRIDT(6) DIMENSION IALOC(ND13),ADIST(ND13),AELEV(ND13) DIMENSION TELEV(NXE*NYE),SEALND(NXE*NYE),CPNDFD(NXE*NYE) DIMENSION MSHPAS(6,4),ER1(6,4,12),NTYPE(6,4),B(6,4),R(6,4), 1 ITRPLQ(6,4),RSTAR(6,4),WNDWT(6,4),LNDWAT(6,4), 2 IALGOR(6,4),ELCORR(6,4),BK(6,4),ELCORU(6,4),IPOINT(6,4), 3 IFCOR(6,4),RWATO(6),RWATI(6) DIMENSION SMULT(6),SADD(6),ORIGIN(6),CINT(6), 1 NPRT(6),JPRT(6),NTDL(6),JTDL(6) DIMENSION IGUESS(4),LD(4),LDPARS(15),KFILRA(6),ISTOP(6) DIMENSION IOPTB(8),IOPT(8),IOPTL(8),IRACK(8), 1 JDATE(4),NSAVDT(4),JPP(3),QUALWT(4), 2 NHRRUN(5),WTRUNA(5),WTRUNL(5),NSHLN(6) DIMENSION NCAT(NPRE),NSCALE(NPRE),CONST(NPRE),IPREX1(NPRE), 1 IPREX2(NPRE),PREX3(NPRE),PREX4(NPRE),PREX5(NPRE), 2 KFILPR(NPRE) DIMENSION TLOA(NPRO),SETLOA(NPRO),THIA(NPRO),SETHIA(NPRO), 1 CONSTA(NPRO),NSCALA(NPRO),EX1A(NPRO),EX2A(NPRO) DIMENSION TLOD(NPRO),SETLOD(NPRO),THID(NPRO),SETHID(NPRO), 1 CONSTD(NPRO),NSCALD(NPRO),EX1D(NPRO),EX2D(NPRO) DIMENSION NROUGH(4),RELVAR(4),VARTAB(2,4),JSTTST(4),SEEDT(10) DIMENSION ITABLE(4,JVAL),LIMIT(NVAL),JFIRST(NVAL),JTABLE(NVAL,2) DIMENSION NOTOSS(2),DDMULT(6) C EQUIVALENCE (RACK,IRACK) C ALLOCATABLE XDATA(:,:,:) ALLOCATABLE ERRANL(:,:) ALLOCATABLE ID2(:) DATA SEEDT/.1234567, .1250001, .7776661, .8887773, .9992225, 1 .6788761, .5678911, .9876543, .3333333, .4327897/ C SEED IS MODIFIED BY SUBROUTINES WTHOL1 AND WTHOL2 AND SAVED C FOR THE NEXT ITERATION. DATA JFIRST/NVAL*0/ DATA IWIND/0/ DATA IFIRST/0/, 1 MFIRST/0/ DATA KDUMMY/100/ DATA IOPTL/8*0/ DATA JPP/3*0/ DATA IPOPT/0/ DATA EIGHT9S/'99999999'/ DATA JTABLE/NVALX2*0/ DATA ISAVDT/99999999/ DATA IFILL/4/ DATA NTOTGB/0/ DATA JSTTST/1000,100,10,2/ DATA NROUGH/8,4,2,1/, 1 RELVAR/110.,90.,70.,54./, 2 VARTAB/1.,2., 3 1.,2., 4 1.,2., 5 1.,2./ C THE TWO VALUES PER ROW ARE FOR LAND AND WATER, RESPECTIVELY. C THE 4 ROWS ARE FOR THE FOUR AREAS, CONUS, ALASKA, HAWAII, AND C PUERTO RICO RESPECTIVELY. DATA NSMNUM/0/,DIFFA/0./,NOCEAN/0/,DISTX/1./, 1 WTAUG/1./ C SAVE NSAVDT,ISAVDT,IOPT,SEED,ERRANL,ID2,JFIRST,MFIRST C EVEN THOUGH ERRANL( , ) AND ID2( ) DO NOT HAVE TO BE C REALLOCATED, THE CONTENTS ARE NOT RETAINED WITHOUT BEING C IN A SAVE STATEMENT. SAVE NXSV,NYSV,MESHSV C NX, NY, AND MESH ARE SAVED SO THAT A COMPUTED VARIABLE C WILL HAVE THEM. C CALL TIMPR(KFILDO,KFILDO,'START U405A ') IER=0 JER=0 C JER IS SET = 1 WHEN A MAJOR ERROR OCCURS BUT THERE IS NOT C A HARD STOP. MER=0 C MER IS INCREMENTED BY 1 WHEN A MINOR ERROR OCCURS. JTABLE(1,1)=001120 C THIS IS SEA LEVEL PRESSURE ID. THIS LOCATION IN JTABLE( , ) C IS NECESSARY. JTABLE(4,1)=003410 C THIS IS SATURATION DEFICIT ID. THIS LOCATION IN JTABLE( , ) C IS NECESSARY. NSTASV=NSTA C NSTA MAY BE ALTERED IN U405A, AND IS RESET ON EXIT. IPOPT=IPOPT+1 C IOPT CONTROLS PRINT. NOSCII=0 C NOSCII COUNTS THE ASCII RECORDS WIRTTEN IN PLATYP FOR THIS C VARIABLE. NPASSF=0 NPASSP=0 NPASSR=0 NOPTN=0 RAY=0. C NAPSSF, NPASSP, NOPTN, AND RAY MAY BE SET FROM THE U405A.CN C FILE, BUT SHOULD NOT CARRY OVER FROM THE PREVIOUS CLL TO U405A. ERRADJ=1. EXCLUD=9999. C D WRITE(KFILDO,100) D100 FORMAT(' ') C D WRITE(KFILDO,1045)N,ND1,NSTA,IOPTB D1045 FORMAT(/' AT 1045 IN U405A--N,ND1,NSTA,IOPTB',20I6) C C INITIALIZE VARIABLE IN CASE ALL VALUES ARE NOT READ AND C MAP IS PRINTED. C DO 102 J=1,4 DO 101 I=1,6 MSHPAS(I,J)=0 NTYPE(I,J)=0 B(I,J)=0. R(I,J)=0. ITRPLQ(I,J)=0 RSTAR(I,J)=0. WNDWT(I,J)=0. LNDWAT(I,J)=0 C 101 CONTINUE 102 CONTINUE C DO 103 J=1,6 SMULT(J)=0. SADD(J)=0. ORIGIN(J)=0. CINT(J)=0. NPRT(J)=0 JPRT(J)=0 NTDL(J)=0 JTDL(J)=0 103 CONTINUE C DO 104 L=1,12 DO 1040 J=1,4 DO 1041 I=1,6 ER1(I,J,L)=0. 1041 CONTINUE 1040 CONTINUE 104 CONTINUE C C UPDATE ISAVDT WHEN THERE IS A NEW NDATE. PURPOSE IS C TO INCREMENT IFIRST ONLY FOR A NEW DATE. C IF(NDATE.NE.ISAVDT)THEN ISAVDT=NDATE IFIRST=IFIRST+1 ENDIF C KFILAN=INLTAB(N) C THE UNIT NUMBER FOR READING THE INDIVIDUAL .CN FILES CAN C BE THE SAME AS KFILDI, BECAUSE ALL OTHER USE OF KFILDI IS C OVER. C C PARSE THE DATE INTO ITS FOUR COMPONENTS. C CALL DATPRS(KFILDO,NDATE,JDATE) C IF(IFIRST.EQ.1)THEN C NORMALLY THIS SAVING IS DONE AT THE END, BUT MUST BE DONE C ON FIRST ENTRY TO KEEP FROM PRINTING TWICE. NSAVDT(1)=JDATE(1) NSAVDT(2)=JDATE(2) NSAVDT(3)=JDATE(3) NSAVDT(4)=JDATE(4) C C COMPUTE IOPT( ) FROM IOPTB( ) SO IOPT( ) REFERS TO C THE SUBSETTED AREA MESH LENGTH MESHL. THIS IS DONE ONLY C ONCE AND IOPT( ) SAVED. C IF(IOPTB(1).EQ.0)THEN C DO 105 J=1,8 IOPT(J)=0 105 CONTINUE C ELSE IOPT(1)=IOPTB(1) RATIO=REAL(MESHB)/MESHL C IF(MESHB.EQ.MESHL)THEN IOPT(2)=IOPTB(2) IOPT(3)=IOPTB(3) IOPT(4)=IOPTB(4) IOPT(5)=IOPTB(5) ELSE IOPT(2)=NINT((IOPTB(2)-1)*RATIO+1) IOPT(3)=NINT((IOPTB(3)-1)*RATIO+1) IOPT(4)=NINT((IOPTB(4)-1)*RATIO+1) IOPT(5)=NINT((IOPTB(5)-1)*RATIO+1) ENDIF C IOPT(6)=IOPTB(6) IOPT(7)=IOPTB(7) IOPT(8)=IOPTB(8) C IF(IPOPT.EQ.1)THEN WRITE(KFILDO,107)MESHL,(IOPT(J),J=2,5) 107 FORMAT(/' SUBSETTED AREA AT NOMINAL MESH LENGTH =',I5, 1 ' IS NX FROM',I5,' TO',I5,' AND', 2 ' NY FROM',I5,' TO',I5,'.') ENDIF C ENDIF C ENDIF C NBASTA=NSTA C NBASTA IS THE NUMBER OF STATIONS BEFORE BOGUSG STATIONS C ARE ADDED (THOSE AT GRIDPOINTS). C C READ CONTROL INFORMATION ACCORDING TO THE VARIABLE TO BE C ANALYZED. C C MAKE SURE .CN READ IS FOR U405A. C IF(ANLTAB(N)(1:4).NE.'U405')THEN WRITE(KFILDO,110)ANLTAB(N) 110 FORMAT(/' ****IINCORRCT CONTROL FILE NAME =',2X,A17, 1 '. STOP IN U405A AT 110.') STOP 110 ENDIF C STATE='120 ' COPS OPEN(UNIT=KFILAN,FILE=ANLTAB(N),STATUS='OLD', COPS 1 IOSTAT=IOS,ERR=900) C C READ AND WRITE ANALYSIS SPECIFIC CONTROL PARAMETERS. THE C CONTENT OF THE FIRST RECORD IS DIFFERENT FOR SLP C THAN FOR OTHER VARIABLES. C STATE='1245' C READ(KFILAN,1245,IOSTAT=IOS,ERR=900)NPASS,IFSTGS, 1 (IGUESS(J),J=1,4),IBACKN,IBACKL,GUESS,TITLE(1:16), 2 NSMTYP,I405ADG,LAPFG,LIMITX,IVRAD 1245 FORMAT(8I4,F8.0,1X,A16,5I4) WRITE(KFILDO,1246)TITLE(1:16),(JDATE(J),J=1,4) 1246 FORMAT(/' STARTING ANALYSIS FOR ',A16,' FOR DATE/TIME ', 1 I5,2I3,I3.2,'00.', 2 ' $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$') C WRITE(KFILDO,123)(ID(J,N),J=1,4),TITLE(1:16) 123 FORMAT(/' ANALYSIS SPECIFIC CONTROL PARAMETERS FOR ', 1 3I10.9,I10.3,3X,A16) WRITE(KFILDO,125)NPASS,IFSTGS, 1 (IGUESS(J),J=1,4),IBACKN,IBACKL,GUESS,TITLE(1:16), 2 NSMTYP,I405ADG,LAPFG,LIMITX,IVRAD,ANLTAB(N) 125 FORMAT(/' NPASS, IFSTGS, IGUESS(1-4), IBACKN, IBACKL,', 1 ' GUESS, TITLE NSMTYP I405ADG', 2 ' LAPFG LIMIT IVRAD FILE NAME'/ 3 I7,I8,I7,3I2,I8,I10,F11.2,4X,A16,I7,I10,I7,2I6,3X, 4 A17) C C SEPARATE IVRAD INTO IVRAD AND ICUB. C ICUB=IVRAD/100 IVRAD=IVRAD-ICUB*100 C C SEPARATE NPASS INTO NPASS, NREP, AND NREPNO. C NREP=NPASS/100 NPASS=NPASS-NREP*100 NREPNO=NPASS/10 NPASS=NPASS-NREPNO*10 C CCCC WRITE(KFILDO,1255)NPASS,NREP,NREPNO CCCC 1255 FORMAT(/' NPASS,NREP,NREPNO =',3I3) C NPASS=MIN(NPASS,6) C NPASS IS LIMITED TO 6 BY DIMENSION OF VARIABLES. C SEPARATE LAPFG INTO LAPFG AND LAPUDB. C LAPUDB=LAPFG/100 LAPFG=LAPFG-LAPUDB*100 C C THIS APPLIES TO BOTH SLP AND OTHER. THIS IS THE COLUMN C IN THE STATION DICTIONARY WHERE THE DATA QUALITY C FOR THAT LOCATION RESIDES, AND THE POSSIBLE WEIGHTS. C READ(KFILAN,126)IQUALC,(QUALWT(J),J=1,4),ISETP,ILS,IBKPN,LPNO, 1 HGTTHA,HGTTHB,NWITH,IWSEED,ITYPR,NBLEND,CSTSM, 2 N4P,NCLIP,(NSHLN(J),J=1,6),WTWTL,WTLTW 126 FORMAT(I4,4F6.2,4I3,2F6.0,I4,2I2,I4,F4.0,2I4,2X,6I1,2F4.0) WRITE(KFILDO,127)IQUALC, 1 (QUALWT(J),J=1,4),ISETP,ILS,IBKPN,LPNO, 2 HGTTHA,HGTTHB,NWITH,IWSEED,ITYPR,NBLEND,CSTSM, 3 N4P,NCLIP,(NSHLN(J),J=1,6),WTWTL,WTLTW 127 FORMAT(/' QUAL COL QWT1 QWT2 QWT3 QWT4 ISETP ILS IBKPN LPNO', 1 ' HGTTHA HGTTHB NWITH IWSEED ITYPR NBLEND CSTSM N4P ', 2 'NCLIP NSHLN WTWTL WTLTW',/, 3 I9,F9.2,3F5.2,I4,I5,I5,I6,1X,2F7.0,I5,I6,I6,I7,F7.2,I5,I4, 4 3X,6I1,2F6.3) C C CHECK LEGITIMATE VALUES OF IQUALC. C IF(IQUALC.LT.1.OR.IQUALC.GT.5)THEN WRITE(KFILDO,1275)IQUALC 1275 FORMAT(/' ****IQUALC =',I4,' NOT IN RANGE TO 1 OR 5.', 1 ' SET TO 1. PROCEEDING.') IQUALC=1 ISTOP(1)=ISTOP(1)+1 ENDIF C C CHECK LEGITIMATE VALUE OF IWSEED. C IF(NWITH.GT.0.AND.(IWSEED.LT.1.OR.IWSEED.GT.10))THEN C WHEN NWITH = 0, IWSEED WON'T BE USED. WRITE(KFILDO,1276)IWSEED 1276 FORMAT(/' ****INCORRECT VALUE OF IWSEED. SET TO 1') IWSEED=1 ISTOP(1)=ISTOP(1)+1 ENDIF C C SET SEED ONLY ON FIRST ENTRY FOR THIS RUN. C IF(MFIRST.EQ.0)THEN SEED=SEEDT(IWSEED) ENDIF C CHECK LEGITIMATE VALUE OF ITYPR. C IF(NWITH.GT.0.AND.(ITYPR.LT.1.OR.ITYPR.GT.3))THEN C WHEN NWITH = 0, ITYPR WON'T BE USED. WRITE(KFILDO,1277)ITYPR 1277 FORMAT(/' ****INCORRECT VALUE OF ITYPR =',I4, 1 '. SET TO 1') ITYPR=1 ISTOP(1)=ISTOP(1)+1 ENDIF C C CHECK ILS FOR VALID VALUES OF 0 AND 1. C IF(ILS.NE.0.AND.ILS.NE.1)THEN WRITE(KFILDO,1278)ILS 1278 FORMAT(/' ****INCORRECT VALUE OF ILS =',I4, 1 '. ANALYSIS FOR THIS VARIABLE ABORTED.') JER=JER+1 GO TO 500 ENDIF C C READ THE RUN TIMES AND WEIGHTS FOR THEM. C STATE='128 ' READ(KFILAN,128,IOSTAT=IOS,ERR=900)NORUNS, 1 (NHRRUN(J),J=1,5),(WTRUNA(J),J=1,5),(WTRUNL(J),J=1,5) 128 FORMAT(I4,5I6,/,(4X,5F6.0)) C C ENSURE THAT NORUNS NE 0. C IF(NORUNS.LE.0.OR.NORUNS.GT.5)THEN WRITE(KFILDO,1280) 1280 FORMAT(/' ****INCORRECT VALUE OF NORUNS. SET TO 1') ISTOP(1)=ISTOP(1)+1 NORUNS=1 NHRRUN(1)=0 WTRUNA(1)=1. WTRUNL(1)=1. ENDIF C C ENSURE THAT IBKPN AND LPNO ARE COMPATIBLE. C IF(LPNO.EQ.0)THEN C IF(IBKPN.NE.99)THEN WRITE(KFILDO,1282) 1282 FORMAT(/' ****LPNO = 0 AND IBKPN NE 99 ARE INCOMPATIBLE.', 1 ' SET LPNO = 10000. PROCEEDING.') LPNO=100000 ISTOP(1)=ISTOP(1)+1 ENDIF C ENDIF C C ADD THE ELEMENT AND PROJECTION TO THE ASCII FILE NAME WHEN C THE FILE IS TO BE WRITTEN. C IF(IWRITA(N).NE.0)THEN C IN OPERATIONS, GET VOTNAM FROM THE ENVIRONMENTAL VARIABLE FORT35 C IN OPERATIONS, REQUIRE THE ASCII FILE BE EXPORTED TO FORT35 C WRITE(VO,'(I2.2)') KFILVO CALL getenv("FORT"//VO,VOTNAM) C WRITE(CPRJ,'(I3.3)')IDPARS(12,N) C THIS PUTS THE PROJECTION IN ASCII IN CPRJ. VOTNAME=VOTNAM IPOS=60 C 1284 IF(IPOS.LE.0)THEN C THE ASCII FILE NAME VOTNAM IS ALL BLANKS. WRITE(KFILDO,1285)VOTNAM 1285 FORMAT(/' ****THE ASCII FILE NAME IS ALL BLANKS.', 1 ' DO NOT WRITE TO UNIT NUMBER KFILVO. ', 2 A60) IWRITA(N)=0 ELSEIF(VOTNAM(IPOS:IPOS).EQ.' ')THEN IPOSL=IPOS C IPOSL WILL BE THE FIRST NON BLANK IN VOTNAM. IPOS=IPOS-1 GO TO 1284 ELSE C THE FILE NAME IN VOTNAM ENDS AT POSITION IPOSL. C ADD THE REST OF THE NAME SANS THE ELEMENT DESIGNATION. C IF(IPOSL+9.LE.60)THEN C CHANGED +8 TO +9 4/26/16 VOTNAME(IPOSL:IPOSL+4)='. .f' VOTNAME(IPOSL+5:IPOSL+7)=CPRJ(1:3) C THE FILE NAME IN VOTNAME IS COMPLETE EXCEPT FOR THE C ELEMENT DESIGNATION IN POSITIONS IPOSL+1 C AND IPOSL+2. CCCC WRITE(KFILDO,1286)IDPARS(12,N),CPRJ,VOTNAM,VOTNAME CCCC 1286 FORMAT(/' AT 1286--CPRJ,VOTNAM,VOTNAME ',I6,2X,A3,/, CCCC 1 A60,/,A60) ELSE WRITE(KFILDO,1287)VOTNAM 1287 FORMAT(/' ****ASCII FILE NAME READ IS TOO LONG TO', 1 ' ACCOMMODATE ELEMENT AND PROJECTION', 2 ' EXTENSION. SHORTEN TO LE 52 CHARACTERS.'/ 3 ' DO NOT WRITE TO FILE',A60) IWRITA(N)=0 ENDIF C ENDIF C ENDIF C WRITE(KFILDO,129)NORUNS 129 FORMAT(/' NHRRUN, WTRUNA, AND WTRUNL FOR ',I3,' RUNS') WRITE(KFILDO,1290)(NHRRUN(J),J=1,NORUNS) 1290 FORMAT(' ',5I6) WRITE(KFILDO,1291)(WTRUNA(J),J=1,NORUNS) 1291 FORMAT(' ',5F6.4,/) WRITE(KFILDO,1291)(WTRUNL(J),J=1,NORUNS) C C READ THE IDS OF THE ANALYSIS ELEMENT, AND OTHER IDS. C WRITE(KFILDO,1293) 1293 FORMAT(' ANALYSIS AND DATA ELEMENTS') C STATE='1296 ' C DO 130 L=1,JVAL READ(KFILAN,1294,IOSTAT=IOS,ERR=900)(ITABLE(J,L),J=1,4) 1294 FORMAT(4I10) C IF(L.EQ.1)THEN WRITE(KFILDO,1295)(ITABLE(J,L),J=1,4) 1295 FORMAT(' ',4I10,' ANALYSIS ID') ELSEIF(L.EQ.2)THEN WRITE(KFILDO,1296)(ITABLE(J,L),J=1,4) 1296 FORMAT(' ',4I10,' DATA TO ANALYZE') ELSEIF(L.EQ.3)THEN WRITE(KFILDO,1297)(ITABLE(J,L),J=1,4) 1297 FORMAT(' ',4I10,' PRIMARY FIRST GUESS (IF USED)') ELSEIF(L.EQ.4)THEN WRITE(KFILDO,1298)(ITABLE(J,L),J=1,4) 1298 FORMAT(' ',4I10,' SECONDARY FIRST GUESS (IF USED)') ELSE WRITE(KFILDO,1299)(ITABLE(J,L),J=1,4) 1299 FORMAT(' ',4I10,' IF NEEDED') ENDIF C 130 CONTINUE C c CHECK CCCFFFB OF 1ST ID WORD AND THE 4TH ID WORD (THRESHOLD) C OF "ANALYSIS VARIABLE" READ WITH INCOMING ID( ). NOTE THAT C THIS DOES NOT CHECK THE 2ND WORD, SO THE PROBABILITY LEVEL, C MEAN, AND STANDARD DEVIATION OF ENSEMBLES CAN USE THE SAME C U405 CONTROL FILE. C IF(ID(1,N)/100.NE.ITABLE(1,1)/100.OR. 1 ID(4,N).NE.ITABLE(4,1))THEN WRITE(KFILDO,1300)ITABLE(1,1)/100,ITABLE(4,1), 1 ID(1,N)/100,ID(4,N) 1300 FORMAT(/,' ****IDS OF ANALYSIS VARIABLE READ IN U405A.CN', 1 ' DO NOT MATCH ANALYSIS DESIRED FROM U155.CN',/, 2 ' CCCFFFB AND 4TH ID READ HERE ARE ',I8,I11,/, 3 ' CCCFFFB AND 4TH ID FROM U155.CN ARE ',I8,I11,/, 4 ' U405 DID NOT COMPLETE.') JER=JER+1 M=N C M=N ADDED 7/15/17 GO TO 500 ENDIF C C SET IVRBL. THIS IS A HOLDOVER FROM THE LAMP ANALYSIS CODE. C SEA LEVEL PRESSURE CAN BE TREATED DIFFERENTLY BY USING WINDS C IN THE ANALYSIS. PROBABLY SATURATION DEFICIT WILL NOT BE C NEEDED HERE, BUT IS LEFT IN. C IF(ITABLE(1,1)/1000.EQ.JTABLE(1,1))THEN C THIS IS FOR SEA LEVEL PRESSURE. JTABLE(1,1) HAS BEEN C PRELOADED. ITABLE(1,1) CONTAINS THE CCCFFF OF THE C VARIABLE TO ANALYZE. IVRBL=1 JTABLE(1,2)=JTABLE(1,2)+1 C JTABLE( ,2) CONTROLS PRINT IN BCD5/EPS5. LIMIT(IVRBL)=LIMITX ELSEIF(ITABLE(1,1)/1000.EQ.JTABLE(4,1))THEN C THIS IS FOR SATURATION DEFICIT. JTABLE(4,1) HAS BEEN C PRELOADED. ITABLE(1,1) CONTAINS THE ID OF THE C VARIABLE TO ANALYZE. IVRBL=4 JTABLE(4,2)=JTABLE(4,2)+1 C JTABLE( ,2) CONTROLS PRINT IN BCD5/EPS5. LIMIT(IVRBL)=LIMITX ELSE C DO 1301 J=1,IFILL C IF(ITABLE(1,1)/1000.EQ.JTABLE(J,1))THEN IVRBL=J C THE ENTRY IS ALREADY IN THE TABLE. JTABLE(J,2)=JTABLE(J,2)+1 C JTABLE( ,2) CONTROLS PRINT IN BCD5/EPS5. LIMIT(IVRBL)=LIMITX GO TO 1306 ENDIF C 1301 CONTINUE C DO 1303 J=2,NVAL C JTABLE(1,1) HAS BEEN PRELOADED WITH SLP ID. C IF(JTABLE(J,1).EQ.0)THEN JTABLE(J,1)=ITABLE(1,1)/1000 IVRBL=J JTABLE(J,2)=JTABLE(J,2)+1 LIMIT(IVRBL)=LIMITX IFILL=MAX(J,4) C IFILL CANNOT EXCEED NVAL, THE FIRST DIMENSION OF C JTABLE( , ). IF(J.EQ.NVAL)THEN WRITE(KFILDO,1302)NVAL 1302 FORMAT(/' ****JTABLE( , ) IS FULL. PROBABLE ERROR.', 1 ' INDICATES NVAL =,',I4,' CCCFFF''S USED.') ENDIF C GO TO 1306 ENDIF C 1303 CONTINUE C WRITE(KFILDO,1305) 1305 FORMAT(/' ****JTABLE( ,NVAL) FULL. COULD NOT DEFINE', 1 ' IVAL. U405A ABORTED.') JER=JER+1 GO TO 500 ENDIF C CHECK THRESHOLD OF INPUT VARIABLE WITH THE C C READ NOMINAL MESH LENGTH TO USE FOR EACH PASS FOR EACH C POSSIBILITY OF FIRST GUESS. C 1306 STATE='1308' C DO 135 L=1,4 READ(KFILAN,1308,IOSTAT=IOS,ERR=900)(MSHPAS(J,L),J=1,NPASS) 1308 FORMAT(6I8) C IF(JTABLE(IVRBL,2).LE.LIMIT(IVRBL))THEN IF(L.EQ.1)WRITE(KFILDO,131)NPASS 131 FORMAT(' MSHPAS FOR ',I3,' PASSES') WRITE(KFILDO,132)L,(MSHPAS(J,L),J=1,NPASS) 132 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6I8) ENDIF C C CHECK LEGITIMACY OF MSHPAS( ,L) FOR PROJECTION NPROJ. C DO 134 J=1,NPASS CALL ACTUAL(KFILDO,MSHPAS(J,L),XDUM,XDUM,NPROJ,IER) C IF(IER.NE.0)THEN WRITE(KFILDO,133)MSHPAS(J,L),NPROJ 133 FORMAT(' INCORRECT VALUE OF MSHPAS( , ) =',I6,/, 1 ' FATAL ERROR IN U405A. STOP AT 133.') CALL W3TAGE('U405A') STOP 133 ELSEIF(MSHPAS(J,L).NE.MESHB)THEN WRITE(KFILDO,1335)MSHPAS(J,L),MESHB 1335 FORMAT(/' ****MSHPAS( , ) =',I3,' NE MESHB =',I3, 1 '. THIS IS UNUSUAL.', 2 ' PROCEEDING WITH ISTOP(1) INCREMENTED.') ISTOP(1)=ISTOP(1)+1 ENDIF C 134 CONTINUE C 135 CONTINUE C C READ ERROR CRITERIA TO USE FOR EACH PASS FOR EACH POSSIBILITY C OF FIRST GUESS. C STATE='140 ' C DO 146 M=1,12 DO 145 L=1,4 READ(KFILAN,140,IOSTAT=IOS,ERR=900)(ER1(J,L,M),J=1,NPASS) 140 FORMAT(6F8.0) C C WHEN NBLEND NE 0, THEN THE ERROR CRITERIA ARE C CHANGED FROM THE NORMAL FOR THE MODEL FIRST GUESS TO C THAT FOR THE CONSTANT. C IF(NBLEND.NE.0)THEN C IF(L.EQ.2.OR.L.EQ.3)THEN C DO 1405 J=1,NPASS ER1(J,L,M)=ER1(J,1,M) 1405 CONTINUE C ENDIF C ENDIF C IF(JTABLE(IVRBL,2).LE.LIMIT(IVRBL))THEN IF(L.EQ.1.AND.M.EQ.JDATE(2))WRITE(KFILDO,141)NPASS,M 141 FORMAT(' ER1 FOR ',I3,' PASSES FOR MONTH',I3) C C PRINT THE CRITERIA ONLY FOR THE ANALYSIS MONTH. C IF(M.EQ.JDATE(2))THEN WRITE(KFILDO,142)L,(ER1(J,L,M),J=1,NPASS) 142 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6F8.2) ENDIF C ENDIF C 145 CONTINUE 146 CONTINUE C C ASSURE THAT THE ERROR CRITERIA GET WRITTEN FOR THE ANALYSIS C MONTH. C IF(JDATE(2).NE.NSAVDT(2))THEN C DO 148 L=1,4 C IF(L.EQ.1)THEN WRITE(KFILDO,147)NPASS,JDATE(2) 147 FORMAT(/' ER1 FOR ',I3,' PASSES FOR MONTH',I3) ENDIF C IF(IGUESS(1).EQ.L.OR. 1 IGUESS(2).EQ.L.OR. 2 IGUESS(3).EQ.L.OR. 3 IGUESS(4).EQ.L)THEN C THIS WILL WRITE FOR ONLY THE OPTIONS POSSIBLE. WRITE(KFILDO,142)L,(ER1(J,L,JDATE(2)),J=1,NPASS) ENDIF C 148 CONTINUE C ENDIF C READ TYPE OF CORRECTION TO USE FOR EACH PASS FOR EACH C POSSIBILITY OF FIRST GUESS. C STATE='150 ' C DO 155 L=1,4 READ(KFILAN,1308,IOSTAT=IOS,ERR=900)(NTYPE(J,L),J=1,NPASS) C IF(JTABLE(IVRBL,2).LE.LIMIT(IVRBL))THEN IF(L.EQ.1)WRITE(KFILDO,151)NPASS 151 FORMAT(' NTYPE FOR ',I3,' PASSES') WRITE(KFILDO,152)L,(NTYPE(J,L),J=1,NPASS) 152 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6I8) ENDIF C C BREAK OUT IFCOR( , ) FROM NTYPE( , ). C DO 154 J=1,NPASS IFCOR(J,L)=NTYPE(J,L)/100 NTYPE(J,L)=NTYPE(J,L)-IFCOR(J,L)*100 154 CONTINUE C 155 CONTINUE C C READ SMOOTHING PARAMETER TO USE FOR EACH PASS FOR EACH C POSSIBILITY OF FIRST GUESS. C STATE='160 ' C DO 165 L=1,4 READ(KFILAN,140,IOSTAT=IOS,ERR=900)(B(J,L),J=1,NPASS) C IF(JTABLE(IVRBL,2).LE.LIMIT(IVRBL))THEN IF(L.EQ.1)WRITE(KFILDO,161)NPASS 161 FORMAT(' B FOR ',I3,' PASSES') WRITE(KFILDO,162)L,(B(J,L),J=1,NPASS) 162 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6F8.2) ENDIF C 165 CONTINUE C C READ RADIUS OF INFLUENCE TO USE FOR EACH PASS FOR EACH C POSSIBILITY OF FIRST GUESS. C STATE='170 ' C DO 175 L=1,4 READ(KFILAN,140,IOSTAT=IOS,ERR=900)(R(J,L),J=1,NPASS) C IF(JTABLE(IVRBL,2).LE.LIMIT(IVRBL))THEN IF(L.EQ.1)WRITE(KFILDO,171)NPASS 171 FORMAT(' R FOR ',I3,' PASSES') WRITE(KFILDO,172)L,(R(J,L),J=1,NPASS) 172 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6F8.2) ENDIF C 175 CONTINUE C C READ TYPE OF INTERPOLATION TO USE IN COMPUTING C THE NEXT GRID FOR EACH PASS FOR EACH POSSIBILITY C OF FIRST GUESS. ITRPLQ = 1 FOR BILINEAR AND C ITRPLQ = 2 FOR BIQUADRATIC INTERPOLATION. THIS C WILL HAVE MEANING ONLY IF THE GRID NEEDS TO BE C INTERPOLATED FROM A PREVIOUS GRID. C FOR INSTANCE, ITRPLQ(2,1) = 1 MEANS BILINEAR WILL C BE USED IN ARRIVING AT THE FIRST GUESS C (THAT IS, THE FIELD FOR THE FIRST PASS), IF C INTERPOLATION IS NEEDED, FOR FIRST GUESS TYPE 2. C ITRPLQ(2,2) = 2 MEANS THAT BIQUADRATIC WILL BE C USED IN ARRIVING AT THE GRID TO USE FOR PASS 2, C FOR FIRST GUESS TYPE 2. C STATE='180 ' C DO 185 L=1,4 READ(KFILAN,1308,IOSTAT=IOS,ERR=900)(ITRPLQ(J,L),J=1,NPASS) C IF(JTABLE(IVRBL,2).LE.LIMIT(IVRBL))THEN IF(L.EQ.1)WRITE(KFILDO,181)NPASS 181 FORMAT(' ITRPLQ FOR ',I3,' PASSES') WRITE(KFILDO,182)L,(ITRPLQ(J,L),J=1,NPASS) 182 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6I8) ENDIF C 185 CONTINUE C C READ RSTAR, THE FRACTION OF THE RADIUS OF INFLUENCE C TO USE DATA OUTSIDE THE ANALYSIS AREA FOR EACH PASS C FOR EACH POSSIBILITY OF FIRST GUESS. C STATE='190 ' C DO 193 L=1,4 READ(KFILAN,140,IOSTAT=IOS,ERR=900)(RSTAR(J,L),J=1,NPASS) C IF(JTABLE(IVRBL,2).LE.LIMIT(IVRBL))THEN IF(L.EQ.1)WRITE(KFILDO,191)NPASS 191 FORMAT(' RSTAR FOR ',I3,' PASSES') WRITE(KFILDO,192)L,(RSTAR(J,L),J=1,NPASS) 192 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6F8.2) ENDIF C 193 CONTINUE C C READ FLAGS TO DETERMINE HOW THE LAND/SEA CORRECTIONS C WILL BE MADE. C STATE='197 ' C DO 199 L=1,4 READ(KFILAN,1308,IOSTAT=IOS,ERR=900)(LNDWAT(J,L),J=1,NPASS) C IF(JTABLE(IVRBL,2).LE.LIMIT(IVRBL))THEN IF(L.EQ.1)WRITE(KFILDO,197)NPASS 197 FORMAT(' LNDWAT FOR ',I3,' PASSES') WRITE(KFILDO,198)L,(LNDWAT(J,L),J=1,NPASS) 198 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6I8) ENDIF C 199 CONTINUE C C READ TYPE OF CORRECTION ALGORITHM TO APPLY. C STATE='1991' C DO 1993 L=1,4 READ(KFILAN,1308,IOSTAT=IOS,ERR=900)(IALGOR(J,L),J=1,NPASS) C IF(JTABLE(IVRBL,2).LE.LIMIT(IVRBL))THEN IF(L.EQ.1)WRITE(KFILDO,1991)NPASS 1991 FORMAT(' IALGOR FOR ',I3,' PASSES') WRITE(KFILDO,1992)L,(IALGOR(J,L),J=1,NPASS) 1992 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6I8) ENDIF C 1993 CONTINUE C C READ FRACTION OF ELEVATION CORRECTION TO APPLY TO C USUAL, OR EXPECTED, LAPSE RATES. C STATE='1995' C DO 200 L=1,4 READ(KFILAN,140,IOSTAT=IOS,ERR=900)(ELCORR(J,L),J=1,NPASS) C IF(JTABLE(IVRBL,2).LE.LIMIT(IVRBL))THEN IF(L.EQ.1)WRITE(KFILDO,1995)NPASS 1995 FORMAT(' ELCORR FOR ',I3,' PASSES') WRITE(KFILDO,1996)L,(ELCORR(J,L),J=1,NPASS) 1996 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6F8.2) ENDIF C 200 CONTINUE C C READ THE MAXIMUM DISTANCE IN GRID LENGTHS TO WHICH C TO APPLY THE POSITIVE (IBKPN = +1) OR NEGATIVE C (IBKPN = -1) LAPSE RATES. C STATE='2003' IBKPR=0 C DO 201 L=1,4 READ(KFILAN,140,IOSTAT=IOS,ERR=900)(BK(J,L),J=1,NPASS) C C MAKE SURE BK( , ) IS CONSISTENT WITH R( , ). NO VALUE C OF BK( , ) SHOULD BE GREATER THAN THE CORRESPONDING C VALUE OF R( , ). C C THIS WAS DISABLED. R( , ) REFERS TO THE TOTAL RADIUS. C BK( , ) IS DISTANCE WEIGHTED AND IF LIMITED TO R( , ) C CAN HAVE TOO REDUCED AN EFFECT. C CCC DO 2001 J=1,NPASS C CCC IF(BK(J,L).GT.R(J,L))THEN CCC BK(J,L)=R(J,L) CCC IBKPR=IBKPR+1 CCC ENDIF C CCC 2001 CONTINUE C IF(JTABLE(IVRBL,2).LE.LIMIT(IVRBL))THEN IF(L.EQ.1)WRITE(KFILDO,2003)NPASS 2003 FORMAT(' BK FOR ',I3,' PASSES') WRITE(KFILDO,2005)L,(BK(J,L),J=1,NPASS) 2005 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6F8.2) ENDIF C 201 CONTINUE C C READ FRACTION OF ELEVATION CORRECTION TO APPLY TO C UNUSUAL LAPSE RATES. THIS IS THE ONE WITH THE C SIGN SPECIFIED IN IBKPN AND TO WHICH BK( , ) IS C APPLIED C STATE='2015' C DO 202 L=1,4 READ(KFILAN,140,IOSTAT=IOS,ERR=900)(ELCORU(J,L),J=1,NPASS) C IF(JTABLE(IVRBL,2).LE.LIMIT(IVRBL))THEN IF(L.EQ.1)WRITE(KFILDO,2015)NPASS 2015 FORMAT(' ELCORU FOR ',I3,' PASSES') WRITE(KFILDO,2016)L,(ELCORU(J,L),J=1,NPASS) 2016 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6F8.2) ENDIF C 202 CONTINUE C C READ THE R-FACTOR FOR INCREASING THE RADIUS FOR C OCEAN WATER POINTS WHEN VARIABLE RADII NOT BEING C USED. C STATE='2021' READ(KFILAN,140)(RWATO(J),J=1,NPASS) WRITE(KFILDO,2021)NPASS,(RWATO(J),J=1,NPASS) 2021 FORMAT(' RWATO FOR ',I3,' PASSES',10X,6F8.2) C C READ THE R-FACTOR FOR INCREASING THE RADIUS FOR C LAKE WATER POINTS. C STATE='2022' READ(KFILAN,140)(RWATI(J),J=1,NPASS) WRITE(KFILDO,2022)NPASS,(RWATI(J),J=1,NPASS) 2022 FORMAT(' RWATI FOR ',I3,' PASSES',10X,6F8.2) C C READ THE (MAXIMUM) NUMBER OF POINTS SAMPLED FROM THE C FIRST GUESS TO USE IN THE ANALYSIS. C STATE='2023' C DO 203 L=1,4 READ(KFILAN,1308,IOSTAT=IOS,ERR=900)(IPOINT(J,L),J=1,NPASS) C IF(JTABLE(IVRBL,2).LE.LIMIT(IVRBL))THEN IF(L.EQ.1)WRITE(KFILDO,2023)NPASS 2023 FORMAT(' IPOINT FOR ',I3,' PASSES') WRITE(KFILDO,2025)L,(IPOINT(J,L),J=1,NPASS) 2025 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6I8) ENDIF C 203 CONTINUE C C READ MULTIPLICATIVE FACTOR FOR GRIDPRINTING. C STATE='209 ' READ(KFILAN,140,IOSTAT=IOS,ERR=900)(SMULT(J),J=1,NPASS) IF(JTABLE(IVRBL,2).LE.LIMIT(IVRBL))WRITE(KFILDO,209)NPASS, 1 (SMULT(J),J=1,NPASS) 209 FORMAT(' SMULT FOR ',I3,' PASSES',10X,6F8.2) C C READ ADDITIVE FACTOR FOR GRIDPRINTING. C STATE='210' READ(KFILAN,140,IOSTAT=IOS,ERR=900)(SADD(J),J=1,NPASS) IF(JTABLE(IVRBL,2).LE.LIMIT(IVRBL))WRITE(KFILDO,211)NPASS, 1 (SADD(J),J=1,NPASS) 211 FORMAT(' SADD FOR ',I3,' PASSES',10X,6F8.2) C C READ ORIGIN FOR GRIDPRINTING. C STATE='220 ' READ(KFILAN,140,IOSTAT=IOS,ERR=900)(ORIGIN(J),J=1,NPASS) IF(JTABLE(IVRBL,2).LE.LIMIT(IVRBL))WRITE(KFILDO,221)NPASS, 1 (ORIGIN(J),J=1,NPASS) 221 FORMAT(' ORIGIN FOR ',I3,' PASSES',10X,6F8.2) C C READ CONTOURING INTERVAL FOR GRIDPRINTING. C STATE='230 ' READ(KFILAN,140,IOSTAT=IOS,ERR=900)(CINT(J),J=1,NPASS) IF(JTABLE(IVRBL,2).LE.LIMIT(IVRBL))WRITE(KFILDO,231)NPASS, 1 (CINT(J),J=1,NPASS) 231 FORMAT(' CINT FOR ',I3,' PASSES',10X,6F8.2) C C READ GRIDPRINTING OPTION FOR UNSMOOTHED GRID GRIDPRINTING. C STATE='240 ' READ(KFILAN,1308,IOSTAT=IOS,ERR=900)(NPRT(J),J=1,NPASS) IF(JTABLE(IVRBL,2).LE.LIMIT(IVRBL))WRITE(KFILDO,241)NPASS, 1 (NPRT(J),J=1,NPASS) 241 FORMAT(' NPRT FOR ',I3,' PASSES',10X,6I8) C C READ GRIDPRINTING OPTION FOR SMOOTHED GRID GRIDPRINTING. C STATE='250 ' READ(KFILAN,1308,IOSTAT=IOS,ERR=900)(JPRT(J),J=1,NPASS) IF(JTABLE(IVRBL,2).LE.LIMIT(IVRBL))WRITE(KFILDO,251)NPASS, 1 (JPRT(J),J=1,NPASS) 251 FORMAT(' JPRT FOR ',I3,' PASSES',10X,6I8) C C READ TDLPACKING OPTION FOR UNSMOOTHED PACKING. C STATE='260 ' READ(KFILAN,1308,IOSTAT=IOS,ERR=900)(NTDL(J),J=1,NPASS) IF(JTABLE(IVRBL,2).LE.LIMIT(IVRBL))WRITE(KFILDO,261)NPASS, 1 (NTDL(J),J=1,NPASS) 261 FORMAT(' NTDL FOR ',I3,' PASSES',10X,6I8) C C READ TDLPACKING OPTION FOR SMOOTHED PACKING. C STATE='270 ' READ(KFILAN,1308,IOSTAT=IOS,ERR=900)(JTDL(J),J=1,NPASS) IF(JTABLE(IVRBL,2).LE.LIMIT(IVRBL))WRITE(KFILDO,271)NPASS, 1 (JTDL(J),J=1,NPASS) 271 FORMAT(' JTDL FOR ',I3,' PASSES',10X,6I8) C C READ THE PRE-PROCESSING SUBROUTINE NAMES AND PARAMETERS. C NPRE ARE PROVIDED FOR, NPRE SET BY PARAMETER. C STATE=' 275 ' C DO 274 J=1,NPRE READ(KFILAN,272)PREPRO(J),KFILPR(J),PREPFL(J), 1 NCAT(J),NSCALE(J),CONST(J),IPREX1(J), 2 IPREX2(J),PREX3(J),PREX4(J),PREX5(J) 272 FORMAT(A6,I3,1X,A60,/,2I8,F8.0,2I8,3F8.0) C IF(PREPRO(J).EQ.'999999')THEN WRITE(KFILDO,2725)PREPRO(J) 2725 FORMAT(' ',A6,66X,'TERMINATOR FOR PREPROCESSING ROUTINES.'/) NOPRE=J-1 GO TO 2741 ENDIF C WRITE(KFILDO,273)PREPRO(J),KFILPR(J),PREPFL(J),J, 1 NCAT(J),NSCALE(J),CONST(J),IPREX1(J), 2 IPREX2(J),PREX3(J),PREX4(J),PREX5(J) 273 FORMAT(' ',A6,I3,1X,A60,' PREPROCESSING SUBROUTINE NO. ',I2, 1 ' AND FILE NAME: ',/,2I8,F8.3,2I8,3F8.3) 274 CONTINUE C WRITE(KFILDO,2740) 2740 FORMAT(/' ****TERMINATOR NOT FOUND FOR PREPROCESSING ROUTINES.', 1 ' TREAT AS FATAL ERROR. STOP IN U405A AT 2735.') CALL W3TAGE('U405A') STOP 2740 C C IF IVRAD NE 0, THEN THE PREPROCESSING ROUTINE RDVRHL MUST BE C SPECIFIED. C 2741 IF(IVRAD.NE.0)THEN C DO 2745 J=1,NOPRE IF(PREPRO(J).EQ.'RDVRHL')GO TO 2749 2745 CONTINUE C WRITE(KFILDO,2746) 2746 FORMAT(/,' ****IVRAD NE 0, BUT PREPROCESSING ROUTINE RDVRHL', 1 ' IS NOT CALLED. U405A DID NOT COMPLETE.') JER=JER+1 GO TO 500 C ENDIF C C READ THE POST-PROCESSING SUBROUTINE NAME AND PARAMETERS C FOR ARCHIVE GRIDS. NPRO ARE PROVIDED FOR, NPRO SET BY C PARAMETER. C 2749 IORST=0 C DO 277 J=1,NPRO READ(KFILAN,275)POSTAR(J), 1 TLOA(J),SETLOA(J),THIA(J),SETHIA(J), 2 CONSTA(J),NSCALA(J),EX1A(J),EX2A(J) 275 FORMAT(A6,/,5F8.0,I8,2F8.0) C IF(POSTAR(J).EQ.'999999')THEN WRITE(KFILDO,2755)POSTAR(J) 2755 FORMAT(' ',A6,66X,'TERMINATOR FOR ARCHIVE POSTPROCESSING', 1 ' ROUTINES.'/) NOPROA=J-1 GO TO 2771 ENDIF C WRITE(KFILDO,276)POSTAR(J),J, 1 TLOA(J),SETLOA(J),THIA(J),SETHIA(J), 2 CONSTA(J),NSCALA(J),EX1A(J),EX2A(J) 276 FORMAT(' ',A6,64X,' ARCHIVE POSTPROCESSING SUBROUTINE', 1 ' NO. ',I2,/,5F8.3,I8,2F8.3) C IF(POSTAR(J).EQ.'ORSMTW' )THEN IORST=1 ENDIF C 277 CONTINUE C C READ THE POST-PROCESSING SUBROUTINE NAME AND PARAMETERS C FOR DISPOSABLE GRIDS. NPRO ARE PROVIDED FOR, NPRO SET BY C PARAMETER. C 2771 DO 280 J=1,NPRO READ(KFILAN,278)POSTDS(J), 1 TLOD(J),SETLOD(J),THID(J),SETHID(J), 2 CONSTD(J),NSCALD(J),EX1D(J),EX2D(J) 278 FORMAT(A6,/,5F8.0,I8,2F8.0) C IF(POSTDS(J).EQ.'999999')THEN WRITE(KFILDO,2785)POSTDS(J) 2785 FORMAT(' ',A6,66X,'TERMINATOR FOR DISPOSABLE POSTPROCESSING', 1 ' ROUTINES.'/) NOPROD=J-1 GO TO 2805 ENDIF C WRITE(KFILDO,279)POSTDS(J),J, 1 TLOD(J),SETLOD(J),THID(J),SETHID(J), 2 CONSTD(J),NSCALD(J),EX1D(J),EX2D(J) 279 FORMAT(' ',A6,64X,' DISPOSABLE POSTPROCESSING SUBROUTINE', 1 ' NO. ',I2,/,5F8.3,I8,2F8.3) C 280 CONTINUE C C READ WEIGHTS OF WIND OBS TO APPLY RELATIVE TO HEIGHT OBS C FOR SLP ONLY. C 2805 IF(ID(1,N)/1000.EQ.001201)THEN STATE='280 ' C DO 285 L=1,4 READ(KFILAN,140,IOSTAT=IOS,ERR=900)(WNDWT(J,L),J=1,NPASS) C IF(JTABLE(IVRBL,2).LE.LIMIT(IVRBL))THEN IF(L.EQ.1)WRITE(KFILDO,281)NPASS 281 FORMAT(' WNDWT FOR ',I3,' PASSES') WRITE(KFILDO,282)L,(WNDWT(J,L),J=1,NPASS) 282 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6F8.2) ENDIF C 285 CONTINUE C ELSE C C INITIALIZE WNDWT( , ) FOR OTHER THAN SLP ANALYSIS. C DO 2852 J=1,NPASS DO 2851 L=1,4 WNDWT(J,L)=0. 2851 CONTINUE 2852 CONTINUE C ENDIF C C READ PAIRS LIST WHEN INDICATED IN U405A.CN. IF NO C ENTRY IN THE .CN, THEN THE LAST ONE READ WILL BE USED, C WHETHER FROM U155 OR U405A. C DO 2858 NN=1,NOPRE C IF(PREPRO(NN).EQ.'RDPAIR')THEN KFILLP=KFILPR(NN) C THE PAIRS FILE MAY NOT HAVE BEEN READ IN U155, AND C KFILLP = 0. IF IT WERE USED, IT WILL NOT BE USED C AGAIN, EXCEPT IT MUST NOT BE ZERO IN LAPSE OR THE C LAPSE WILL NOT BE CALCUALTED. SET KFILLP=KFILPR(NN) C C CLOSE THE FILE THAT MAY HAVE BEEN READ IN U155 AND C IN U405A, AND REOPEN AND READ THE FILE. C IF(KFILLP.NE.0)CLOSE(UNIT=KFILLP) C IF THE PAIRS FILE WAS NOT READ IN U155, KFILLP = 0. IF(KFILPR(NN).NE.0)CLOSE(UNIT=KFILPR(NN)) C PRESUMABLY KFILPR(NN) WILL NOT BE ZERO AT THIS POINT. OPEN(UNIT=KFILPR(NN),FILE=PREPFL(NN),FORM='UNFORMATTED', 1 STATUS='OLD',IOSTAT=IOS,ERR=2853) GO TO 2856 C THIS IS A GOOD OPEN. SKIP ERROR DIAGNOSTIC. C 2853 WRITE(KFILDO,2864)KFILPR(NN),IOS,PREPFL(NN) 2854 FORMAT(/' ****TROUBLE OPENING OLD FILE ON UNIT NO.',I3, 1 '. IOSTAT =',I5,3X,A60/ 2 ' FATAL ERROR. STOP IN U405A AT 2856.') CALL W3TAGE('U405A') STOP 2857 C 2856 CALL RDPRS(KFILDO,KFILLP,IP8,ICALL,CCALL,NAME,NSTA, 1 NOPAR,LOCPAR,ND1, 2 IALOC,ADIST,AELEV,ND13,ICALLD,CCALLD,ND5,L3264W, 3 ISTOP,IER) C WHEN KFILLP = 0, RDPRS IS A DO NOTHING ROUTINE. C IF(IER.EQ.777)THEN WRITE(KFILDO,2857) 2857 FORMAT(/' ****ERROR READING PAIRS. FATAL ERROR.', 1 ' STOP IN U405A AT 2857.') CALL W3TAGE('U405A') STOP 2857 ENDIF C ENDIF C 2858 CONTINUE C C FILL LTAG( ), LTAGPT( ) AND NTAGPT( ) WITH ZEROS. C DO NOT ALTER MTAGPT( ); IT IS CARRIED FROM WIND SPEED C TO TOTAL WIND. C DO 2859 K=1,ND1 LTAG(K)=0 LTAGPT(K)=0 NTAGPT(K)=0 2859 CONTINUE C CLOSE(UNIT=KFILAN) C C PRINT DIAGNOSTIC WHEN BK( , ) WAS MODIFIED. THIS IS C COUNTED AS AN ERROR. C IF(IBKPR.NE.0)THEN C NOTE THAT THE DISABLEMENT AT DO 2001, IBKPR ALWAYS = 0. WRITE(KFILDO,286)IBKPR 286 FORMAT(/' ****BK( , ) WAS MODIFIED.',I4,' VALUES WERE', 1 ' CHANGED TO AGREE WTIH R( , ).') ISTOP(1)=ISTOP(1)+1 ENDIF C c IDENTIFY IP14 WITH DATE AND VARIABLE. C IF(IP14.NE.0.AND.IP14.NE.KFILDO)THEN WRITE(IP14,2861)(ID(J,N),J=1,4),NDATE 2861 FORMAT(/' STARTING ANALYSIS FOR VARIABLE',3(1X,I9.9),1X,I10.3, 1 ' FOR DATE',I12) ENDIF C C DETERMINE THE NUMBER OF PROBABILITY LEVELS AND C ALLOCATE XDATA(NSTA,NORUNS+1,LEVELS). THE PROBABILITY C LEVELS OF A VARIABLE IN EKDMOS IS INDICATED BY IDPARS(6). C THE LEVELS WITH CUMULATIVE OR DISCRETE PROBABILITIES FOR C CATEGORICAL VARIABLES LIKE CEILING HEIGHT, VISIBILITY, AND C CLOUD AMOUNT ARE INDICATED BY 1, 2, OR 3 IN IDPARS(3) AND C A CORRESPONDING CHANGE IN THRESH( ). C NS=N C NS IS INTERNAL VALUE OF N AND THE START OF THE C PROBABILITY SEQUENCE IF THESE ARE PROBABILITY C LEVELS. NE=N C NE IS THE END OF THE SEQUENCE OF VARIABLES TO C DEAL WITH WITHIN U405A WITHOUT RETURNING TO U155. C IF THIS IS A PROBABILITY SEQUENCE, THEN IT WILL C BE THE END OF THE SEQUENCE. OTHERWISE, NE WILL C REMAIN = NS = N. C IF(NS.EQ.NPRED)GO TO 2863 C THIS IS THE END OF THE LIST; ONLY ONE IN SEQUENCE. NE=N+1 C 2862 IF(IDPARS(1,NE).EQ.IDPARS(1,NS).AND. 1 IDPARS(2,NE).EQ.IDPARS(2,NS).AND. 2 IDPARS(4,NE).EQ.IDPARS(4,NS).AND. 3 IDPARS(12,NE).EQ.IDPARS(12,NS))THEN C THE CCC, FFF, DD, AND TAU ARE THE SAME. ALL THAT IS C NOW REQUIRED IS THAT B = 1, 2, OR 3, OR A PROBABILITY C LEVEL IS INDICATED IN IDPARS(6, ). C IF(((IDPARS(6,NE).GT.0.AND.IDPARS(6,NE).LT.100).AND. 1 (IDPARS(6,NS).GT.0.AND.IDPARS(6,NS).LT.100).AND. 2 (IDPARS(6,NS).NE.IDPARS(6,NE))).OR. 3 (IDPARS(3,NS).NE.0.AND.IDPARS(3,NS).EQ.IDPARS(3,NE).AND. 4 THRESH(NS).NE.THRESH(NE)))THEN C IF(NE.EQ.NPRED)THEN C THE END OF THE LIST OF VARIABLES HAS BEEN REACHED. GO TO 2863 ELSE NE=NE+1 GO TO 2862 ENDIF C ENDIF C ELSE NE=NE-1 C NE IS THE END OF THE PROBABILITY SEQUENCE. NOTE THAT C THE PROBABILITY LEVELS ARE NOT TESTED FOR INCREASING C OR DECREASING; THE LEVELS DON'T HAVE TO BE IN ORDER C FOR A CUMULATIVE LAPSE TO BE COMPUTED, BUT THEY MAY C NOT BE ABLE TO BE CHECKED FOR CONSISTENCY IF THEY ARE C NOT IN ORDER. ENDIF C 2863 LEVELS=NE-NS+1 C LEVELS IS THE NUMBER OF PROBABILITY LEVELS IN THE C SEQUENCE. IF IT IS NOT A PROBABILITY SEQUENCE, LEVELS = 1. C DEALLOCATE(XDATA,STAT=IOS) C XDATA( , , ) IS DEALLOCATED BECAUSE NORUNS AND LEVELS C MAY NOT BE THE SAME FROM ENTRY TO ENTRY. AN ERROR RETURN C OF 1 INDICATES XDATA( , , ) HAD NOT BEEN ALLOCATED. THIS C WOULD HAPPEN ON THE FIRST ENTRY, BUT SHOULD NOT CAUSE HARM. ALLOCATE (XDATA(ND1,NORUNS+1,LEVELS),STAT=IOS) C IF(IOS.EQ.1)THEN WRITE(KFILDO,2864) 2864 FORMAT(/' ****ALLOCATION OF XDATA FAILED IN U405A AT 2864.', 1 ' ARRAY ALREADY ALLOCATED.') CALL W3TAGE('U405A') STOP 2864 ELSEIF(IOS.EQ.2)THEN WRITE(KFILDO,2865) 2865 FORMAT(/' ****ALLOCATION OF XDATA FAILED IN U405A AT 2865.', 1 ' ARRAY NOT ALLOCATED.') CALL W3TAGE('U405A') STOP 2865 ENDIF C C SET XDATA( , , ) TO MISSING IN CASE IT IS NOT FILLED. C XDATA(K,L,J) = HOLDS THE DATA TO ANALYZE (K=1,NSTA) C (L=1,NORUNS+1) (J=1,LEVELS). DO 2868 J=1,LEVELS DO 2867 L=1,NORUNS+1 DO 2866 K=1,NSTA XDATA(K,L,J)=9999. 2866 CONTINUE 2867 CONTINUE 2868 CONTINUE C C INITIALIZE QUALST( ). (STATEMENTS 8883 AND 8884 ARE OUT C OF ORDER.) C DO 8884 K=1,NSTA C IF(IQUAL(K,IQUALC).EQ.0)THEN QUALST(K)=0. C ELSEIF(IQUAL(K,IQUALC).LE.4)THEN QUALST(K)=QUALWT(IQUAL(K,IQUALC)) C ELSE WRITE(KFILDO,8883)IQUAL(K,IQUALC),K,CCALL(K,1) 8883 FORMAT(/' ****QUALITY CONTROL VARIABLE IN IQUAL( , ) =',I4, 1 ' NOT ZERO AND NOT WITHIN RANGE 1 TO 4 FOR STATION', 2 ' NO.',I6,2X,A8,/, 2 ' QUALITY WEIGHT SET = 0 IN U405 AND PROCEEDING.') QUALST(K)=0. ISTOP(1)=ISTOP(1)+1 ENDIF C 8884 CONTINUE C C WHEN VARIABLE IS NOT TO BE ANALYZED BUT COMPUTED, SKIP C DOWN TO 2883. IF(ICOMPT(N).NE.0)THEN MESH=MESHSV NX=NXSV NY=NYSV C MESH, NX, AND NY ARE RESTORED FROM LAST ENTRY. THIS C IS DONE BECAUSE THEY ARE USUALLY SET IN FSTGS5, WHICH C IS NOT ENTERED FOR A COMPUTED VARIABLE. GO TO 2883 ENDIF C C GET THE DATA TO ANALYZE IN XDATA( , , ), ASSUMES THE ITABLE C HAS ALL THE INFORMATION, EXCEPT ENTRIES CAN APPLY TO ANY C MODEL (DD) (MODIFIED 12/31/19, SEE BELOW) AND PROJECTION C (TAU = IDPARS(12)). C ACCOMMODATES UP TO 5 RUN TIMES, WITH FORECASTS VERIFYING C AT THE SAME TIME. C HOWEVER, WHEN THE DATA TO ANALYZE ARE OBSERVATIONS C (CCC = 7XX), DD IS NOT ADDED. C DO 2877 J=1,LEVELS C FILL XDATA( , ,J) WITH J PROBABILITY LEVELS. THESE ARE C PROBABILITY LEVELS TO ANALYZE, NOT THE PROBABILITIES C TO USE IN SCALING A CATEGORICAL VARIABLE. M=NS+J-1 C M IS INDEX INTO VARIABLES LIKE ID( , ). C DO 2875 L=1,NORUNS C C FILL XDATA( ,L, ) WITH EACH RUN. IF A LEVEL CANNOT C BE FOUND, NORUNS IS REDUCED FOR THE NEXT TIME C THROUGH LOOKING FOR LEVELS. HOWEVER, A MISSING LEVEL C WILL BE INTERPRETED AS A REDUCTION IN NUMBER OF C CYCLES BECAUSE THE ERROR RETURNS DO NOT INDICATE C WHY THE DATA WERE NOT FOUND. THE PROGRAM SHOULD C RUN WITHOUT ALL THE RUNS (CYCLES) DESIRED, BUT C ALL LEVELS OUGHT TO BE THERE, OR THE NUMBER OF C CYCLES WILL BE REDUCED. A LEVEL CAN BE MISSING, BUT C THE NUMBER OF CYCLES MAY BE REDUCED FROM THEN ON. C IF(ITABLE(1,2)/100000000.EQ.7)THEN C FOR HOURLY ANALYSIS, USE ITABLE( , ) VALUE. LD(1)=ITABLE(1,2) ELSE C IF DD NE 00 IS PRESENT, USE IT. OTHERWISE, USE C IDPARS(4,M). IF((ITABLE(1,2)-(ITABLE(1,2)/100)*100).EQ.0)THEN LD(1)=(ITABLE(1,2)/100)*100+IDPARS(4,M) C THIS USES MODEL DD FROM THE ANALYSIS TO BE PRODUCED. C (THIS MOD MADE FOR SKY AMOUNT 12/31/19.) ELSE LD(1)=ITABLE(1,2) C USE THE DD WITH THE VALUE IN ITABLE(1,2). ENDIF C ENDIF C C CHECK CONSISTENCY OF MODNO WITH DD TO WRITE. C CCC WRITE(KFILDO,9876)J,LEVELS,L,NORUNS,NS,M,(ID(MMM,M),MMM=1,4) CCC 9876 FORMAT(/' AT 9876--J,LEVELS,L,NORUNS,NS,M,(ID(MMMM,M),MMM=1,4)', CCC 1 6I4,4I12) C IF(MODNO.NE.IDPARS(4,M))THEN WRITE(KFILDO,2869)MODNO,IDPARS(4,M) 2869 FORMAT(/,' ****MODNO =',I3.2,' DOES NOT EQUAL DD =',I3.2, 1 ' IN ID(1). PROGRAM WILL RUN, BUT IS1(15) IN', 2 ' PACKED DATA WILL BE MODNO AND NOT AGREE WITH', 3 ' DD.') ISTOP(1)=ISTOP(1)+1 ENDIF C LD(2)=ITABLE(2,2)+IDPARS(6,M)*10000 C THIS ACCOMMODATES THE MEAN AND PROBABILITY LEVELS. C IF(ITABLE(1,2)/100000000.EQ.7)THEN LD(3)=ITABLE(3,2) C FOR HOURLY ANALYSIS, THE PROJECTION IS ZERO AND IS C NOT INCREASED ELSE LD(3)=ITABLE(3,2)+IDPARS(12,M)+NHRRUN(L) C THE PROJECTION IS INCREASED BY NHRRUN(L) HOURS. C IF(L.GT.1)THEN NTAU=MOD(LD(3),1000) C IF(NTAU.GT.192)THEN C MOS HAS PROJECTIONS EVERY 3 HOUR UNTIL 192, THEN C SWITCHES TO EVERY 6 HOURS. THERE ARE SOME PROJECTIONS C THAT DO NOT HAVE A MATCHING PROJECTION FROM A PREVIOUS C RUN (L.GT.1). THIS SKIPS TRYING TO RETIREVE IT. C IF(MOD(NTAU,6).NE.0)THEN CALL UPDAT(NDATE,-NHRRUN(L),MPDATE) WRITE(KFILDO,2870)(LD(JJ),JJ=1,4),MPDATE GO TO 9287 ENDIF C ENDIF C ENDIF C ENDIF C LD(4)=ID(4,M) CALL PRSID1(KFILDO,LD,LDPARS) CALL UPDAT(NDATE,-NHRRUN(L),MDATE) C THE DATE/TIME IS DECREASED BY NHRRUN(L) HOURS. ITAU=0 MCAT=0 C C CALL PREPROCESSOR CVLMPM WHEN NEEDED. THIS WILL GET THE C NEEDED DATA RATHER THAN RETVEC OR OPTX. C ICVLM=0 MOSFUL=0 C DO 287 NN=1,NOPRE C IF(PREPRO(NN).EQ.'CVLMPM')THEN ICVLM=NN ENDIF C 287 CONTINUE C IYES=0 C IYES INDICATES WHETHER OR NOT CVLMPM HAS BEEN CALLED. C IF(ICVLM.NE.0)THEN C IF(IDPARS(12,M).GT.IPREX1(ICVLM))THEN C IPREX1(NN) IS IBSTRT IN CVLMPM (AND SCLCIG). C CVLMPM MERGES LAMP AND MOS FORECASTS OF C CEILING HEIGHT OR VISIBILITY. IYES=1 CALL CVLMPM(KFILDO,KFIL10,IP16,NDATE,LD,LDPARS,LD,JDATE(4), 1 ITABLE(1,6),XDATA(1,L+1,J),FD2,FD3,ND1,NSTA, 2 IPREX1(ICVLM),IPREX2(ICVLM),MOSFUL, 3 LSTORE,ND9,LITEMS, 4 IS0,IS1,IS2,IS4,ND7, 5 IPACK,IWORK,DATA,ND5, 6 CORE,ND10,NBLOCK,NSTORE,NFETCH, 7 L3264B,ISTOP,IER) ENDIF C ENDIF C IF(IYES.EQ.0)THEN C EITHER CVLMPM OR RETVEC MUST BE CALLED. ICVLM=0 C NOTE THAT ICVLM IS SET TO ZERO UNLESS CVLMPM IS CALLED. C C NDATE, MDATE, ITAU, AND MCAT SHOULD NOT BE NEEDED BY RETVEC. CALL RETVEC(KFILDO,KFIL10,IP12,KFILRA,RACESS,NUMRA, 1 LD,LDPARS,LD,ITAU, 2 NDATE,MDATE,CCALL,ISDATA,XDATA(1,L+1,J),ND1,NSTA, 3 ICALLD,CCALLD,IPACK,IWORK,DATA,ND5, 4 LSTORE,ND9,LITEMS,CORE,ND10, 5 NBLOCK,NFETCH, 6 IS0,IS1,IS2,IS4,ND7, 7 L3264B,L3264W,IER) C THE L+1 COLUMN IS NOW FILLED IN XDATA( , , ). C CCCC WRITE(KFILDO,9998)(K,CCALL(K,1),XDATA(K,L+1,J),K=1,NSTA) CCCC 9998 FORMAT(/' AT 9998 IN U405A--(K,CCALL(1,K),XDATA(K,L+1,J),', CCCC 1 'K=1,NSTA)',/,(' ',I6,2X,A8,F10.3)) C IF(IER.NE.0)THEN C IER NE 0 MEANS DATA TO ANALYZE WERE NOT OBTAINED. C TRY TO COMPUTE IN OPTX. C C BECAUSE OPTX HAS A RATHER GENERIC CALL TO OPFCST FOR C CCC = 2XX, A TEST WAS PUT HERE TO KEEP OUT OF OPTX. C IF(LDPARS(1).NE.208)THEN C CCC = 208 IS A "MOISTURE" ID AND INCLUDES CEILING, C VISIBILITY, SKY, PRECIP. THIS MAY HAVE TO BE MADE C MORE SPECIFIC. CALL OPTX(KFILDO,KFIL10,IP12,KFILRA,RACESS,NUMRA, 1 LD,LDPARS,THRESH(M),JD(1,M),ITAU, 2 NDATE,MDATE,CCALL,ISDATA,XDATA(1,L+1,J),ND1, 3 MCAT,NSTA,ICALLD,CCALLD,IPACK,IWORK,DATA,ND5, 4 LSTORE,ND9,LITEMS,CORE,ND10, 5 LASTL,LASTD,NBLOCK,NSTORE,NFETCH, 6 IS0,IS1,IS2,IS4,ND7, 7 L3264B,L3264W,ISTAB,IER) C THRESH WILL LIKELY NOT BE USED IN OPTX. C ITAU IS USED AS 0; NO LOOKAHEAD. C AN ERROR IN OPTX WILL GENERATE A DIAGNOSTIC. C CCC WRITE(KFILDO,9996)IER,J,L,NDATE,MDATE CCC 9996 FORMAT(/' IN U450 OUT OF OPTX,IER,J,L,NDATE,MDATE--' CCC 1 ,3I5,2I12) C IF(IER.EQ.120)THEN IER=0 C THIS IS JUST A MISSING STATION, NOT FATAL. ENDIF C ENDIF C ENDIF C ENDIF C 9287 IF(IER.NE.0)THEN JER=JER+1 WRITE(KFILDO,2870)(LD(JJ),JJ=1,4),NDATE 2870 FORMAT(/,' ****DATA FOR ANALYSIS =',3(1X,I9.9),1X,I10.3, 1 ' COULD NOT BE OBTAINED IN U405A FOR DATE',I12,/, 2 ' INPUT VARIABLE LIKELY DOES NOT EXIST', 3 ' ON INPUT OR RANDOM ACCESS FILE AND COULD', 4 ' NOT BE COMPUTED IN OPTX.') C C PROGRAM MUST NOT STOP UNLESS L = 1. C IF(L.EQ.1)THEN ISTOP(1)=ISTOP(1)+1 C SUBROUTINES RETVEC AND OPTX AND THEIR POSSIBLE CALLS C TO CONST WILL LIKELY HAVE PRODUCED MORE THAN ONE **** C DIAGNOSTIC, BUT ONLY HERE WILL STOP(1) BE INCREMENTED-- C ONE PER FAILURE. WRITE(KFILDO,2871) 2871 FORMAT(' THE MISSING DATA ARE FROM THE CURRENT', 1 ' CYCLE, AND THE ANALYSIS CANNOT BE MADE.') ISTOP(3)=ISTOP(3)+1 C THIS IS ALSO COUNTED AS A MISSING DATA RECORD. JER=JER+1 GO TO 500 ELSE ISTOP(3)=ISTOP(3)+1 C BECAUSE THIS WILL NOT STOP THE PROGRAM, AND TO C REDUCE THE NUMBER OF ISTOP(1) ERRORS, A MISSING C DATA RECORD IS TREATED HERE AS SUCH AND ISTOP(3) C INCREMENTED. NORUNS=L-1 C FROM NOW ON, NORUNS EQUALS THE NUMBER OF DATA SETS C AVAILABLE. WRITE(KFILDO,2872) 2872 FORMAT(' HOWEVER, THE MISSING DATA ARE FROM A', 1 ' PRIOR CYCLE, AND THE ANALYSIS CAN STILL BE', 2 ' MADE.',/, 3 ' FOR PROBABILITIES IN SEQUENCE, THIS', 4 ' CYCLE WILL NOT BE LOOKED FOR AGAIN.') ISTOP(1)=ISTOP(1)+1 MER=MER+1 GO TO 2877 ENDIF C ENDIF C C DO ANY PREPROCESSING ON INPUT DATA NECESSARY. C PROCESSING ON A FIRST GUESS IS DONE IN FSTGS5. C NOTE: IF AUGMT1 IS PUT IN THE CONTROL FILE FIRST, C THEN ALL FORECASTS, INCLUDING THE AUGMENTED ONES, C WILL HAVE ANY FOLLOWING PROCESSING DONE. IF C AUGMT1 FOLLOWS ANOTHER PREPROCESSING ROUTINE, THEN C ONLY THE ORIGINAL DATA WILL BE PROCESSED. C DO 2874 NN=1,NOPRE C IF(PREPRO(NN).EQ.'AUGMT1')THEN C THIS AUGMT1 IS FOR MOST AUGMENTATION, EXCEPT LAMP. IF(PREX3(NN).NE.0.)THEN C WHEN THE PREPROCESSING VARIABLE PREX3 IS NE 0, THE C LAPSE CALCULATED FROM ONLY THE BASE (LAMP) VARIABLE C ARE USED TO ADJUST THE AUGMENTING DATA FROM THE C MODEL TERRAIN TO THE ACTUAL TERRAIN. HAVE TO C READ THE MODEL TERRAIN INTERPOLATED TO STATIONS. LD(1)=409390000 LD(2)=0 LD(3)=0 LD(4)=200 CALL PRSID1(KFILDO,LD,LDPARS) MDATE=NDATE ITAU=0 MCAT=0 C MDATE, NDATE, ITAU, AND MCAT SHOULD NOT BE NEEDED C RETVEC. CALL RETVEC(KFILDO,KFIL10,IP12,KFILRA,RACESS,NUMRA, 1 LD,LDPARS,JD(1,M),ITAU, 2 NDATE,MDATE,CCALL,ISDATA,ELEMOD,ND1,NSTA, 3 ICALLD,CCALLD,IPACK,IWORK,DATA,ND5, 4 LSTORE,ND9,LITEMS,CORE,ND10, 5 NBLOCK,NFETCH, 6 IS0,IS1,IS2,IS4,ND7, 7 L3264B,L3264W,IER) C RLAP=R(1,1)*RSTAR(1,1) C RLAP IS THE RADIUS TO USE IN LAPSE. MGUESS IS NOT YET C KNOWN, SO USE 1, THE FIRST OPTION. C C THIS CALL TO LAPSE IS TO CALCULATE THE LAPSE BASED C ON ONLY NON-AUGMENTED STATIONS. PUT IN TO ACCOMMODATE C LAMP AUGMENTED BY SREF. NOT ALL DATA ARE AVAILABLE C YET. TREAT AS ONLY ONE LEVEL AND ONE RUN. IF THERE C ARE MULTIPLE RUNS, THE FIRST ONE WILL BE COMPUTED C AGAIN. THIS MAY NOT BE DESIRABLE FOR MULTIPLE C PROBABILITY LEVELS. C CCCCCCCCC LLMT=2 CCCC ONLY TWO PAIRS ARE NECESSARY TO COMPUTE A LAPSE. CCCC NOTE THAT THIS WAS CHANGED APRIL 2011, AND HAS THE C DEFAULT VALUE OF 4 IN LAPSE. (NOT SURE WHAT THIS C IS USED FOR. IF IT NEEDS TO BE SPECIFIC, IT CAN C BE SET IN LAPSE BASED ON THE ID( ). C AT THIS POINT, EXCLUD WILL BE 9999. C CALL LAPSE(KFILDO,KFILLP,IP14,CCALL,NAME,LNDSEA,ELEV, 1 NOPAR,LOCPAR,XDATA(1,1,1),XLAPSE,MPAIRS, 2 LTAGPT,NSTA,ND1, 3 NXL,NYL,XPL,YPL,RLAP,XP,YP, 4 ELCORR(1,1),NPASS,WTRUNL,1,1, 5 IALOC,ADIST,AELEV,ND13,EXCLUD,NAREA, 6 SEALND,TELEV,NXE,NYE,MESHE,P,NX,NY,MESH, 7 ID(1,M),IBKPN,LPNO,LAPFG,1,N4P,ISTOP,IER) IF(IER.NE.0)THEN JER=JER+1 GO TO 500 ENDIF C A DIAGNOSTIC WILL HAVE BEEN WRITTEN IN LAPSE WHEN IT C IS ENTERED WITH LAPFG NE LEGITIMATE VALUES. ENDIF C CALL AUGMT1(KFILDO,KFIL10,KFILPR(NN),PREPFL(NN),NAREA,JDATE(4), 1 MDATE,ID(1,M),IDPARS(1,M),JD(1,M),IBACKN,NHRRUN(L), 2 CCALL,NAME,XDATA(1,L+1,J),LNDSEA,XLAPSE, 3 ELEMOD,ELEV,LTAGPT,NSTA,ND1,IPREX2(NN),PREX3(NN), 4 LSTORE,ND9,LITEMS, 5 IS0,IS1,IS2,IS4,ND7, 6 IPACK,IWORK,DATA,ND5, 7 CORE,ND10,NBLOCK,NFETCH, 8 L3264B,ISTOP,IER) C ELSEIF(PREPRO(NN).EQ.'AUGMT2')THEN C THIS AUGMT2 IS FOR MOST AUGMENTATION, AND MAY EVENTUALLY C REPLACE AUGMT1. ERRADJ = PREX4(NN) IS USED IN CALL TO BCD5 C TO POSSIBLY ADJUST THROWOUT CRITERIA. C 0. = DISREGARD--THE DEFAULT C 1. = NO CHANGE TO THROWOUT C X. = FRACTION OF THROWOUT TO APPLY TO FIRST LEVEL OF C AUGMENTATION. (CAN GIVE PREFERENCE TO BASE STATIONS.) C NUMAUG=NCAT(NN) C NUMAUG IS THE NUMBER OF AUGMENTATIONS TO MAKE, 1 TO 3. NUMOBS=NSCALE(NN) C NUMOBS IS THE NUMBER OF AUGMENTATION POINTS REQUIRED FOR C AUGMENTATION FOR 1ST LEVEL WEIGHTS TO BE SCALED BACK FROM 1. IOBS=NINT(CONST(NN)) C IOBS = 0 WHEN LTAGS( ) FROM A PREVIOUS RUN ARE C NOT NEEDED (ONLY OBS TEMP AND SPEED); C 1 = WHEN ONE SET OF LTAGS( ) IS NEEDED; AND C 2 - WHEN TWO SETS ARE NEEDED. THIS IS C LIMITED AT PRESENT TO TOTAL WIND AND C DEWPOINT. C NORMALLY, FOR OBS, IOBS = 0 FOR S AND T; IOBS = 1 C FOR U,V,TW, AND DP, FOR LAMP, IOBS = 1 FOR S,U,V,T; C IOBS = 2 FOR TW AND DP. IF(L.GT.1)IOBS=0 C IF MORE THAN ONE CYCLE IS USED, THE LTAGS SHOULD BE C RETRIEVED ONLY ONCE. ERRADJ=PREX4(NN) CALL AUGMT2(KFILDO,KFIL10,IP16,KFILPR(NN),PREPFL(NN),NAREA, 1 JDATE(4),MDATE,ID(1,M),IDPARS(1,M),JD(1,M), 2 PLAIN(M),IBACKN,NHRRUN(L),JDATE(3),JDATE(2), 3 CCALL,NAME,XDATA(1,L+1,J),LNDSEA,STALAT,STALON, 4 QUALST,LTAG,LTAGPT,MTAGPT,NTAGPT,SDATA,NSTA,ND1, 5 NUMAUG,NUMOBS,IOBS, 6 IPREX1(NN),IPREX2(NN),PREX3(NN),PREX5(NN), 7 MESHB,XPL,YPL,NXL,NYL, 8 R(1,IGUESS(1)),RSTAR(1,IGUESS(1)), 9 LSTORE,ND9,LITEMS, A IS0,IS1,IS2,IS4,ND7, B IPACK,IWORK,DATA,ND5, C CORE,ND10,NBLOCK,NSTORE,NFETCH, D L3264B,ISTOP,IER) C IF(IER.NE.0)THEN C IF(IER.EQ.666)THEN C IER = 666 SIGNALS THAT THE ADJUSTMENT OVER NORTH C CANADA AND OVER WATER COULD NOT BE DONE, AND THE C AUGMENTED VALUES WERE SET MISSING. MER=MER+1 ELSE JER=JER+1 GO TO 500 ENDIF C ENDIF C ELSEIF(PREPRO(NN).EQ.'AUGMT3')THEN C THIS AUGMT3 IS FOR AUGMENTING LAMP WITH SREF. PRECX3 SHOULD C BE ZERO OR ONE. (ABANDONED AS OF MARCH 18, 2010, FOR CIG; C STILL USED FOR TEMP/DP.) IF(PREX3(NN).NE.0.)THEN C WHEN THE PREPROCESSING VARIABLE PREX3 IS NE 0, THE C ADJUSTMENT CALCULATED IN AUGMT3 NEEDS THE ELEVATIONS C OF SREF AT THE STATION LOCATIONS. RETRIEVE THEM C IN ELEMOD( ). LD(1)=409390000 LD(2)=0 LD(3)=0 LD(4)=200 CALL PRSID1(KFILDO,LD,LDPARS) MDATE=NDATE ITAU=0 MCAT=0 C MDATE, NDATE, ITAU, AND MCAT SHOULD NOT BE NEEDED C RETVEC. CALL RETVEC(KFILDO,KFIL10,IP12,KFILRA,RACESS,NUMRA, 1 LD,LDPARS,JD(1,M),ITAU, 2 NDATE,MDATE,CCALL,ISDATA,ELEMOD,ND1,NSTA, 3 ICALLD,CCALLD,IPACK,IWORK,DATA,ND5, 4 LSTORE,ND9,LITEMS,CORE,ND10, 5 NBLOCK,NFETCH, 6 IS0,IS1,IS2,IS4,ND7, 7 L3264B,L3264W,IER) IF(IER.NE.0)THEN ISTOP(3)=ISTOP(3)+1 ISTOP(1)=ISTOP(1)+1 JER=JER+1 GO TO 500 ENDIF C ENDIF C CALL AUGMT3(KFILDO,KFIL10,IP16,KFILPR(NN),PREPFL(NN), 1 NAREA,JDATE(4), 2 MDATE,ID(1,M),IDPARS(1,M),JD(1,M),IBACKN,NHRRUN(L), 3 CCALL,NAME,PLAIN(M),XDATA(1,L+1,J),LNDSEA, 4 XLAPSE,ELEMOD,ELEV,LTAGPT,NSTA,ND1, 5 IPREX2(NN),PREX3(NN), 6 LSTORE,ND9,LITEMS, 7 IS0,IS1,IS2,IS4,ND7, 8 IPACK,IWORK,DATA,ND5, 9 CORE,ND10,LASTL,LASTD,NBLOCK,NSTORE,NFETCH, A L3264B,ISTOP,IER) WTAUG=PREX4(NN) C IF(IER.NE.0)THEN C IF(IER.EQ.666)THEN C IER = 666 SIGNALS THAT THE ADJUSTMENT OVER NORTH C CANADA AND OVER WATER COULD NOT BE DONE, AND THE C AUGMENTED VALUES WERE SET MISSING. MER=MER+1 ELSE JER=JER+1 GO TO 500 ENDIF C ENDIF C ELSEIF(PREPRO(NN).EQ.'SWITCH')THEN C THIS SWITCH IS FOR SWITCHING FROM VARIABLE RADII C TO THE CONSTANT RADII IN THE U405A.CN FILE NPASSR=NCAT(NN) C C ELSEIF(PREPRO(NN).EQ.'SPOTRM')THEN C THIS SPOTRM IS FOR SMOOTHING TO REMOVE "HOLES" OR C "SPOTS." THE ONLY THING DONE HERE IS TO DEFINE SOME C VARIABLES FOR EASIER RECOGNITION FOR USE IN BCD5. NPASSP=NCAT(NN) NSMNUM=NSCALE(NN) NOPTN=NINT(CONST(NN)) DIFFA=IPREX1(NN) LH=IPREX2(NN)/1000 LAKE=(IPREX2(NN)-LH*1000)/10 NOCEAN=IPREX2(NN)-LH*1000-LAKE*10 DISTX=PREX3(NN) DPOWER=PREX4(NN) RAY=PREX5(NN) C ELSEIF(PREPRO(NN).EQ.'SETCIG')THEN EXCLUD=PREX3(NN) C EXCLUD IS THE VALUE TO SET UNLIMITED (888) VALUES TO C FOR ANALYSIS. ALSO MAY BE USED IN XLAPSE. C DEFAULT VALUE OF 9999. SET ON ENTRY TO U405. CALL SETCIG(KFILDO,XDATA(1,L+1,J),NSTA,EXCLUD,IER) C THE ABOVE CALL TO SETCIG WILL SET ANY VALUE OF 888 C (SIGNIFYING UNLIMITED OR > 12,000 FT) TO EXCLUD. C ELSEIF(PREPRO(NN).EQ.'SCALX ')THEN CALL SCALX(KFILDO,XDATA(1,L+1,J),NSTA,CONST(NN),NSCALE(NN),IER) C THE ABOVE CALL TO SCALX WILL MULTIPLY THE INPUT C DATA IN XDATA( , , ) BY CONST*10**NSCALE C ELSEIF(PREPRO(NN).EQ.'SCALXI')THEN C THIS IS FOR POP. THE INCOMING IS IN THOUSANDTHS; ROUND, C TO WHOLE PERCENT CALL SCALXI(KFILDO,XDATA(1,L+1,J),NSTA,CONST(NN),NSCALE(NN), 1 IER) C THE ABOVE CALL TO SCALX WILL MULTIPLY THE INPUT C DATA IN XDATA( , , ) BY CONST*10**NSCALE, THEN ROUNDED C TO THE NEAREST WHOLE NUMBER. C ELSEIF(PREPRO(NN).EQ.'SCLSNO')THEN C SNOW IS SCALED TO TENTHS OF INCHES. C THERE ARE 6 SNOW CATEGORIES. NZERO=0 C NZERO USED TO SIGNAL VECTOR DATA TO SCLSNO. ITRPX=0 C SEVERAL VARIABLES PERTAINING TO GRIDS, INCLUDING C ITRPX, ARE NOT USED IN THIS CALL TO SCLSNO. THE C USE OF VECTOR DATA IS SIGNALED BY NX=NZERO=0. LD(1)=ITABLE(1,2)+IDPARS(4,M) LD(2)=ITABLE(2,2) LD(3)=ITABLE(3,2)+IDPARS(12,M)+NHRRUN(L) C THE PROJECTION IS INCREASED BY NHRRUN(L) HOURS. LD(4)=ITABLE(4,2) CALL PRSID1(KFILDO,LD,LDPARS) MESHX=99 C MESH HAS NOT BEEN DEFINED UP TO THIS POINT, AND C IS NOT USED IN THIS CALL TO SCLSNO FOR VECTOR DATA. C MESHX IS SET TO 99 HERE AS A SAFEGUARD FOR SCLSNO. CALL SCLSNO(KFILDO,KFIL10,MDATE,LD,LDPARS,JD(1,M), 1 XDATA(1,L+1,J),FD2,ND1,NSTA,NZERO,NZERO, 2 NCAT(NN),CONST(NN),NSCALE(NN),PREX3(NN), 3 NPROJ,ALAT,ALON,ORIENT,XLAT,MESHX,ITRPX, 4 LSTORE,ND9,LITEMS, 5 IS0,IS1,IS2,IS4,ND7, 6 IPACK,IWORK,DATA,ND5, 7 CORE,ND10,NBLOCK,NFETCH,MISTOT, 8 L3264B,ISTOP,IER) C THE ABOVE CALL TO SCLSNO WILL SCALE THE C VALUES IN EACH SNOWFALL CATEGORY TO THE FULL C RANGE OF THE CATEGORY ACCORDING TO THE LOWEST C AND HIGHEST PROBABILITY OCCURRING FOR THIS C CASE OVER THE ANALYSIS AREA. NOTE THAT C THIS CALL IS FOR THE VECTOR DATA AND THE GRID C VARIABLES (I.E., MESH) ARE NOT USED IN SCLSNO. C IF(IER.NE.0)THEN JER=JER+1 C IF(L.EQ.1)THEN ISTOP(1)=ISTOP(1)+1 JER=JER+1 GO TO 500 ELSE NORUNS=L-1 WRITE(KFILDO,2872) GO TO 2877 ENDIF C ENDIF C ELSEIF(PREPRO(NN).EQ.'SCLQ06')THEN C QPF IS SCALED TO HUNDREDTHS OF INCHES. C THERE ARE 6 CATEGORIES FOR QPF06. NZERO=0 C NZERO USED TO SIGNAL VECTOR DATA TO SCLSNO. ITRPX=0 C SEVERAL VARIABLES PERTAINING TO GRIDS, INCLUDING C ITRPX, ARE NOT USED IN THIS CALL TO SCLSNO. THE C USE OF VECTOR DATA IS SIGNALED BY NX=NZERO=0. LD(1)=ITABLE(1,2)+IDPARS(4,M) LD(2)=ITABLE(2,2) LD(3)=ITABLE(3,2)+IDPARS(12,M)+NHRRUN(L) C THE PROJECTION IS INCREASED BY NHRRUN(L) HOURS. LD(4)=ITABLE(4,2) CALL PRSID1(KFILDO,LD,LDPARS) MESHX=99 C MESH HAS NOT BEEN DEFINED UP TO THIS POINT, AND C IS NOT USED IN THIS CALL TO SCLSNO FOR VECTOR DATA. C MESHX IS SET TO 99 HERE AS A SAFEGUARD FOR SCLSNO. CALL SCLQ06(KFILDO,KFIL10,MDATE,LD,LDPARS,JD(1,M), 1 XDATA(1,L+1,J),FD2,ND1,NSTA, 2 NZERO,NZERO,NCAT(NN),CONST(NN),NSCALE(NN), 3 NPROJ,ALAT,ALON,ORIENT,XLAT,MESHX,ITRPX, 4 LSTORE,ND9,LITEMS, 5 IS0,IS1,IS2,IS4,ND7, 6 IPACK,IWORK,DATA,ND5, 7 CORE,ND10,NBLOCK,NFETCH,MISTOT, 8 L3264B,ISTOP,IER) C THE ABOVE CALL TO SCLQ06 WILL SCALE THE C VALUES IN EACH QPF CATEGORY TO THE FULL C RANGE OF THE CATEGORY ACCORDING TO THE LOWEST C AND HIGHEST PROBABILITY OCCURRING FOR THIS C CASE OVER THE ANALYSIS AREA. NOTE THAT C THIS CALL IS FOR THE VECTOR DATA AND THE GRID C VARIABLES (I.E., MESH) ARE NOT USED IN SCLQ06. C IF(IER.NE.0)THEN JER=JER+1 C IF(L.EQ.1)THEN ISTOP(1)=ISTOP(1)+1 GO TO 500 ELSE NORUNS=L-1 WRITE(KFILDO,2872) GO TO 2877 ENDIF C ENDIF C ELSEIF(PREPRO(NN).EQ.'SCLQ12')THEN C QPF IS SCALED TO HUNDREDTHS OF INCHES. C THERE ARE 7 CATEGORIES FOR QPF12. NZERO=0 C NZERO USED TO SIGNAL VECTOR DATA TO SCLSNO. ITRPX=0 C SEVERAL VARIABLES PERTAINING TO GRIDS, INCLUDING C ITRPX, ARE NOT USED IN THIS CALL TO SCLSNO. THE C USE OF VECTOR DATA IS SIGNALED BY NX=NZERO=0. LD(1)=ITABLE(1,2)+IDPARS(4,M) LD(2)=ITABLE(2,2) LD(3)=ITABLE(3,2)+IDPARS(12,M)+NHRRUN(L) C THE PROJECTION IS INCREASED BY NHRRUN(L) HOURS. LD(4)=ITABLE(4,2) CALL PRSID1(KFILDO,LD,LDPARS) MESHX=99 C MESH HAS NOT BEEN DEFINED UP TO THIS POINT, AND C IS NOT USED IN THIS CALL TO SCLSNO FOR VECTOR DATA. C MESHX IS SET TO 99 HERE AS A SAFEGUARD FOR SCLSNO. CALL SCLQ12(KFILDO,KFIL10,MDATE,LD,LDPARS,JD(1,M), 1 XDATA(1,L+1,J),FD2,ND1,NSTA, 2 NZERO,NZERO,NCAT(NN),CONST(NN),NSCALE(NN), 3 NPROJ,ALAT,ALON,ORIENT,XLAT,MESHX,ITRPX, 4 LSTORE,ND9,LITEMS, 5 IS0,IS1,IS2,IS4,ND7, 6 IPACK,IWORK,DATA,ND5, 7 CORE,ND10,NBLOCK,NFETCH,MISTOT, 8 L3264B,ISTOP,IER) C THE ABOVE CALL TO SCLQ12 WILL SCALE THE C VALUES IN EACH QPF CATEGORY TO THE FULL C RANGE OF THE CATEGORY ACCORDING TO THE LOWEST C AND HIGHEST PROBABILITY OCCURRING FOR THIS C CASE OVER THE ANALYSIS AREA. NOTE THAT C THIS CALL IS FOR THE VECTOR DATA AND THE GRID C VARIABLES (I.E., MESH) ARE NOT USED IN SCLQ12. C IF(IER.NE.0)THEN JER=JER+1 C IF(L.EQ.1)THEN ISTOP(1)=ISTOP(1)+1 GO TO 500 ELSE NORUNS=L-1 WRITE(KFILDO,2872) GO TO 2877 ENDIF C ENDIF C ELSEIF(PREPRO(NN).EQ.'SCLSKY')THEN C SKY IS SCALED TO CATEGORICAL AMOUNTS * 100. C THERE ARE 5 SKY CATEGORIES. NZERO=0 C NZERO USED TO SIGNAL VECTOR DATA TO SCLSKY. ITRPX=0 C SEVERAL VARIABLES PERTAINING TO GRIDS, INCLUDING C ITRPX, ARE NOT USED IN THIS CALL TO SCLSKY. THE C USE OF VECTOR DATA IS SIGNALED BY NX=NZERO=0. LD(1)=ITABLE(1,2)+IDPARS(4,M) LD(2)=ITABLE(2,2) LD(3)=ITABLE(3,2)+IDPARS(12,M)+NHRRUN(L) C THE PROJECTION IS INCREASED BY NHRRUN(L) HOURS. LD(4)=ITABLE(4,2) CALL PRSID1(KFILDO,LD,LDPARS) MESHX=99 C MESH HAS NOT BEEN DEFINED UP TO THIS POINT, AND C IS NOT USED IN THIS CALL TO SCLSNO FOR VECTOR DATA. C MESHX IS SET TO 99 HERE AS A SAFEGUARD FOR SCLSNO. C CALL SCLSKY(KFILDO,KFIL10,MDATE,LD,LDPARS,JD(1,M), 1 ITABLE(1,7),XDATA(1,L+1,J),XP,YP,FD2,FD3, 2 CCALL,ND1,NSTA,R(1,1), 3 NZERO,NZERO,NCAT(NN),CONST(NN),NSCALE(NN), 4 NPROJ,ALAT,ALON,ORIENT,XLAT,MESHX,ITRPX, 5 LSTORE,ND9,LITEMS, 6 IS0,IS1,IS2,IS4,ND7, 7 IPACK,IWORK,DATA,ND5, 8 CORE,ND10,NBLOCK,NFETCH,MISTOT, 9 L3264B,ISTOP,IER) C THE ABOVE CALL TO SCLSKY WILL SCALE THE C VALUES IN EACH CLOUD CATEGORY TO THE FULL C RANGE OF THE CATEGORY ACCORDING TO THE LOWEST C AND HIGHEST PROBABILITY OCCURRING FOR THIS C CASE OVER THE ANALYSIS AREA. THE FIRST 2 CATEGORIES C ARE SCALED TOWARD THE LOW END; THE HIGHEST 2 CATEGORIES C ARE SCALED TOWARD THE HIGH END; THE MIDDLE CATEGORY C GOES BOTH WAYS. IT IS ASSUMED THE FIRST GUESS WILL C BE A CONSTANT,HENCE R(1,1); HOWEVER, USUALLY R(1, ) C ARE USUALLY ALL THE SAME, SO IT WON'T MATTER. C IF(IER.NE.0)THEN JER=JER+1 C IF(L.EQ.1)THEN ISTOP(1)=ISTOP(1)+1 GO TO 500 ELSE NORUNS=L-1 WRITE(KFILDO,2872) GO TO 2877 ENDIF C ENDIF C ELSEIF(PREPRO(NN).EQ.'SCLCIG')THEN C CEILING IS SCALED TO FRACTIONS OF CATEGORIES, THEN C TRANSFORMED INTO ACTUAL HEIGHTS. THERE ARE 8 CIG C CATEGORIES. LD(1)=ITABLE(1,2)+IDPARS(4,M) LD(2)=ITABLE(2,2) LD(3)=ITABLE(3,2)+IDPARS(12,M)+NHRRUN(L) C THE PROJECTION IS INCREASED BY NHRRUN(L) HOURS. LD(4)=ITABLE(4,2) CALL PRSID1(KFILDO,LD,LDPARS) C C IF THE CEILINGS ARE SCALED (BY SQRT) SIGNALED BY C PREX3( ) = 1., THEN EXCLUD FOR LAPSE IS ALSO C SCALED. C CCCC IF(NINT(PREX3(NN)).EQ.1.AND.EXCLUD.LT.9998.9)THEN CCCC EXCLUD=SQRT(EXCLUD-.1) CCCC ENDIF C CCCC DO 8871 K=1,NSTA C CCCC IF(CCALL(K,1).EQ.'KFHR ')THEN CCCC WRITE(KFILDO,8870)K,CCALL(K,1),NAME(K),XDATA(K,L+1,J) CCCC 8870 FORMAT(' AT 8870 IN U405A BEFORE SCLCIG--', CCCC 1 'K,CCALL(K,1),XDATA(K,L+1,J)',I6,2X,A8,A20,F10.4) CCCC ENDIF C CCCC 8871 CONTINUE C CALL SCLCIG(KFILDO,KFIL10,IP16,MDATE,LD,LDPARS,JD(1,M), 1 ITABLE(1,7),XDATA(1,L+1,J),FD2,FD3,ND1,NSTA, 2 NCAT(NN),CONST(NN),NSCALE(NN), 3 IPREX1(NN),IPREX2(NN),PREX3(NN),PREX4(NN),MOSFUL, 4 LSTORE,ND9,LITEMS, 5 IS0,IS1,IS2,IS4,ND7, 6 IPACK,IWORK,DATA,ND5, 7 CORE,ND10,NBLOCK,NSTORE,NFETCH, 8 L3264B,ISTOP,IER) C THE ABOVE CALL TO SCLCIG WILL SCALE THE C VALUES IN EACH CEILING HEIGHT CATEGORY TO THE FULL C RANGE OF THE CATEGORY ACCORDING TO THE LOWEST C AND HIGHEST PROBABILITY OCCURRING FOR THIS CASE OVER C THE ANALYSIS AREA. ERROR CHECKING AND INCREMENTING C OF ISTOP( ) IS TAKEN CARE OF IN SCLCIG. RETURN IS C CEILING HEIGHT IN HUNDREDS OF FEET. C CCCC DO 8873 K=1NSTA C CCCC IF(CCALL(K,1).EQ.'KFHR ')THEN CCCC WRITE(KFILDO,8872)K,CCALL(K,1),NAME(K),XDATA(K,L+1,J) CCCC 8872 FORMAT(' AT 8872 IN U405A AFTER SCLCIG--', CCCC 1 'K,CCALL(K,1),XDATA(K,L+1,J)',I6,2X,A8,A20,F10.4) CCCC ENDIF C CCCC 8873 CONTINUE C IF(IER.NE.0)THEN JER=JER+1 C IF(L.EQ.1)THEN ISTOP(1)=ISTOP(1)+1 GO TO 500 ELSE NORUNS=L-1 WRITE(KFILDO,2872) GO TO 2877 ENDIF C ENDIF C ELSEIF(PREPRO(NN).EQ.'SCLVIS')THEN C VISIBILITY IS SCALED TO FRACTIONS OF CATEGORIES, THEN C TRANSFORMED INTO ACTUAL VISIBILITIES. THERE ARE 7 C VISIBILITY CATEGORIES. LD(1)=ITABLE(1,2)+IDPARS(4,M) LD(2)=ITABLE(2,2) LD(3)=ITABLE(3,2)+IDPARS(12,M)+NHRRUN(L) C THE PROJECTION IS INCREASED BY NHRRUN(L) HOURS. LD(4)=ITABLE(4,2) CALL PRSID1(KFILDO,LD,LDPARS) C CCCC DO 9872 KK=1,NSTA CCCC IF(CCALL(K,1).EQ.'KEOK ')THEN CCCC WRITE(KFILDO,9871)KK,CCALL(KK,1),XDATA(1,L+1,J) CCCC 9871 FORMAT(/' +++++++++++++',I8,2X,A8,F10.3) CCCC ENDIF CCCC 9872 CONTINUE C CALL SCLVIS(KFILDO,KFIL10,MDATE,LD,LDPARS,JD(1,M), 1 ITABLE(1,7),CCALL,XDATA(1,L+1,J),FD2,FD3,ND1,NSTA, 2 NCAT(NN),CONST(NN),NSCALE(NN), 3 IPREX1(NN),IPREX2(NN),PREX3(NN),MOSFUL, 4 LSTORE,ND9,LITEMS, 5 IS0,IS1,IS2,IS4,ND7, 6 IPACK,IWORK,DATA,ND5, 7 CORE,ND10,NBLOCK,NFETCH, 8 L3264B,ISTOP,IER) C THE ABOVE CALL TO SCLVIS WILL SCALE THE C VALUES IN EACH VISIBILITY CATEGORY TO THE FULL C RANGE OF THE CATEGORY ACCORDING TO THE LOWEST C AND HIGHEST PROBABILITY OCCURRING FOR THIS CASE OVER C THE ANALYSIS AREA. ERROR CHECKING AND INCREMENTING C OF ISTOP( ) IS TAKEN CARE OF IN SCLVIS. NOTE C THAT THIS CALL IS FOR THE VECTOR DATA, AND THE GRID C VARIABLES (I.E., MESH) ARE NOT USED IN SCLVIS. C RETURN IS VISIBILITY IN MILES. C CCCC DO 9874 KK=1,NSTA CCCC IF(CCALL(KK,1).EQ.'KARB ')THEN CCCC WRITE(KFILDO,9873)KK,CCALL(KK,1),XDATA(KK,L+1,J) CCCC 9873 FORMAT(/' +++++++++++++',I8,2X,A8,F10.3) CCCC ENDIF CCCCC CCCC 9874 CONTINUE C IF(IER.NE.0)THEN C IF(IER.EQ.666)THEN MER=MER+1 IER=0 ELSE JER=JER+1 ENDIF C ENDIF C IF(IER.NE.0)THEN C IF(L.EQ.1)THEN ISTOP(1)=ISTOP(1)+1 GO TO 500 ELSE NORUNS=L-1 WRITE(KFILDO,2872) GO TO 2877 ENDIF C ENDIF C ELSEIF(PREPRO(NN).EQ.'VISFRQ')THEN CALL VISFRQ(KFILDO,XDATA(1,L+1,J),NSTA,ISTOP,IER) C THE ABOVE CALL COMPUTES FREQUENCIES OF OBSERVATIONS C OF VISIBILITY. C ELSEIF(PREPRO(NN).EQ.'CIGFRQ')THEN C CALL CIGFRQ(KFILDO,XDATA(1,L+1,J),NSTA,ISTOP,IER) C THE ABOVE CALL COMPUTES FREQUENCIES OF OBSERVATIONS C OF CEILING HEIGHT. IT ALSO CAPS NON-MISSING VALUES TO C 130 (HARDWIRED). THIS IS A DANGEROUS PLACE TO DO THIS. C IN A REVISION, PUT IT IN SETCIG. C ELSEIF(PREPRO(NN).EQ.'CIGOBC')THEN C CALL CIGOBC(KFILDO,XDATA(1,L+1,J),NSTA,IER) C THE ABOVE CALL TO CIGOBC WILL PUT CEILING HEIGHTS IN C HUNDREDS OF FEET INTO SCALED CATEGORIES. AN ERROR C WILL RETURN IER = 666. C IF(IER.EQ.666)THEN MER=MER+1 ENDIF C ELSEIF(PREPRO(NN).EQ.'SKYOBC')THEN CALL SKYOBC(KFILDO,XDATA(1,L+1,J),NSTA,IER) C THE ABOVE CALL TO SKYOBC WILL PUT SKY CATEGORIES C INTO 5 CATEGORIES. AN ERROR WILL RETURN IER = 666. C IF(IER.EQ.666)THEN MER=MER+1 ENDIF C ELSEIF(PREPRO(NN).EQ.'SKYOBP')THEN CALL SKYOBP(KFILDO,XDATA(1,L+1,J),NSTA,IER) C THE ABOVE CALL TO SKYOBP WILL PUT OBSERVED SKY C CATEGORIES INTO PERCENT. AN ERROR WILL RETURN C IER = 666. C IF(IER.EQ.666)THEN MER=MER+1 ENDIF C ELSEIF(PREPRO(NN).EQ.'SKYLMP')THEN CALL SKYLMP(KFILDO,XDATA(1,L+1,J),NSTA,IER) C THE ABOVE CALL TO SKYLMP WILL PUT FORECAST C CATEGORIES INTO PERCENT. AN ERROR WILL RETURN C IER = 666. C IF(IER.EQ.666)THEN MER=MER+1 ENDIF C ENDIF C 2874 CONTINUE C 2875 CONTINUE C 2877 CONTINUE C THIS PROVIDES FOR A TRANSFER OUT OF LOOP. C CCCC WRITE(KFILDO,2878)(K,CCALL(K,1),XDATA(K,2,1),K=1,NSTA) CCCC 2878 FORMAT(/' AT 2878 IN U405A--(K,CCALL(1,K),XDATA(K,L+1,J),', CCCC 1 'K=1,NSTA)',/,(' ',I6,2X,A8,F10.3)) C C THE ABOVE APPLIES TO ALL CALLS TO PREPROCESSORS. C ALL CYCLES AND ALL LEVELS OF DATA ARE IN XDATA( , , ), C BUT THEY HAVE NOT BEEN COMBINED. C C SET XDATA(K, , ) TO MISSING WHEN QUALST( ) = 0. (NOTE C THAT THIS LOOP WAS SPLIT, AND STATEMENT NUMBERS 2883 AND C 2884 ARE USED ABOVE OUT OF SEQUENCE.) C DO 2882 K=1,NSTA C IF(QUALST(K).EQ.0)THEN C DO 2881 J=1,LEVELS C DO 2880 L=2,NORUNS+1 XDATA(K,L,J)=9999. C XDATA( ,L,J) SET TO MISSING SO VALUE WON'T BE BE CONSIDERED C IN ANY PHASE OF THE ANALYSIS OR WRITTEN FOR PLOTTING. 2880 CONTINUE C 2881 CONTINUE C ENDIF C 2882 CONTINUE C LOOP FOR ALL LEVELS. C 2883 DO 400 J=1,LEVELS C GET THE FIRST GUESS. ALL INFORMATION IS AVAILABLE C FOR INGESTING NEEDED GRIDS. THIS FIRST GUESS C WILL BE USED FOR THE FIRST PASS. EACH PASS C OF THE ANALYSIS WILL USE THE GRID FROM THE PREVIOUS C PASS. ONLY THE FIRST VALUE IN CINT( ), ORIGIN( ), C SMULT( ), AND SADD( ) WILL BE USED IN FSTGS5. C THAT IS, THE VALUES READ FOR THE FIRST PASS C ANALYSIS WILL ALSO BE USED FOR THE FIRST GUESS. C ANY PROCESSING OF AN INPUT FIELD WILL BE DONE IN C FSTGS5. M=NS+J-1 C M IS INDEX INTO VARIABLES LIKE ID( , ). C IF(ICOMPT(M).EQ.1)GO TO 3436 C C NOTE THAT ONLY THE 2ND COLUMN OF DATA IN XDATA( , , ) C IS FURNISHED. THIS IS OK FOR THE AVERAGE, BUT MAY C NEED TO BE MODIFIED FOR SNOW AND OTHER SIMILARLY C TREATED VARIABLES. FLTAG IS CALLED IN FSTGS5 TO C SET LTAG( ). C C********************************************************************** C C PATCH TO ACCOMMODATE A FIRST GUESS THRESHOLD TO NOT BE C THE SEAME AS THE ONE ANALYZED. THIS WAS A MELD VIS PROBLEM. C IF(J.GT.1)THEN N=N+1 KFILAN=INLTAB(N) C WRITE(KFILDO,9884)J 9884 FORMAT(/' STARTING PROBABILITY LEVEL NO. ',I3,/) C STATE='8883' COPS OPEN(UNIT=KFILAN,FILE=ANLTAB(M),STATUS='OLD', COPS 1 IOSTAT=IOS,ERR=900) C SKIP DOWN TO THE 4TH ITABLE ENTRY, THEN READ THE FIRST C GUESS ENTRY. READ(KFILAN,1245) READ(KFILAN,126) READ(KFILAN,128) READ(KFILAN,128) READ(KFILAN,128) READ(KFILAN,1294) READ(KFILAN,1294) READ(KFILAN,1294) STATE='8884' READ(KFILAN,1294,IOSTAT=IOS,ERR=900)(ITABLE(JJJ,4),JJJ=1,4) CLOSE(UNIT=KFILAN) C C FOR ALL LEVELS AFTER THE FIRST, CALL RD45CN TO READ C ELCORR( , ). THE FULL U405A.CN IS READ ON ONLY THE C FIRST LEVEL. ALL VARIABLES IN THE FILE FOR LEVEL ONE C ARE USED FOR ALL LEVLES, EXCEPT FOR ELCORR( , ). C C CALL TIMPR(KFILDO,KFILDO,'CALLING RD45CN ') C C CALL RD45CN(KFILDO,KFILAN, C 1 ID(1,M),IDPARS(1,M),JD(1,M), C 2 ELCORR,ANLTAB(M),NPASS,IER) ENDIF C C********************************************************************** C CALL FSTGS5(KFILDO,KFIL10,KFILOG,KFILRA,RACESS,NUMRA,IP16,IP22, 1 NDATE,ID(1,M),IDPARS(1,M),JD(1,M),JP(1,M),ISCALD(M), 2 NGRIDC,ND11,XDATA(1,2,J),XP,YP,XPL,YPL,LTAG, 3 ND1,NSTA,ITABLE,JVAL,PREPRO,NOPRE, 4 POSTDS,NOPROD,NCAT,NSCALE,CONST, 5 IPREX1,IPREX2,PREX3,PREX4,PREX5, 6 TLOD,SETLOD,THID,SETHID,CONSTD,NSCALD,EX1D,EX2D, 7 P,FD2,FD3,FD4,FD5,FD6,ND2X3, 8 SEALND,CPNDFD,NXE,NYE,MESHE, 9 MODNO,NPROJ,ORIENT,XLAT, A NXL,NYL,ALATL,ALONL,MESHB,MESHL, B NX,NY,MESH,MSHPAS,ITRPLQ,NSMTYP,B,NPASS, C IBACKN,IBACKL,IGUESS,MGUESS,GUESS,IFSTGS,NBLEND, D LSTORE,ND9,LITEMS, E IS0,IS1,IS2,IS4,ND7, F IPLAIN(1,1,M),PLAIN(M), G IPACK,IWORK,DATA,ND5,MINPK, H CORE,ND10,NBLOCK,NFETCH,MISTOT,NSLAB, I NSTORE,LASTD, J CINT(1),ORIGIN(1),SMULT(1),SADD(1),TITLE,IOPT, K JTOTBY,JTOTRC,L3264B,L3264W,ISTOP,IER) C NOTE THAT NX AND NY ARE DEFINED IN FSTGS5; THEY ARE NOT C DEFINED PREVIOUSLY. C IF(IER.NE.0)THEN WRITE(KFILDO,2884) 2884 FORMAT(' FATAL ERROR IN FSTGS5') CALL W3TAGE('U405A') STOP 2884 ENDIF C CCCC WRITE(KFILDO,9999)(CCALL(K,1),XDATA(K,2,J),XDATA(K,3,J),K=1,NSTA) CCCC 9999 FORMAT(/' AT 9999 IN U405A--(CCALL(K,1),XDATA(K,2-3,J),K=1,NSTA)', CCCC 1 (/,2X,A8,2F9.2)) C DO 9885 NN=1,NOPRE C NOTE THIS IS ALSO CALLED IN FSTGS5. IT COULD BE REMOVED IN C ONE OF THE PLACES IF(PREPRO(NN).EQ.'ORSMTH')THEN IOCEXT=NINT(PREX4(NN)) IOCINC=NINT(PREX5(NN)) CALL ORSMTH(KFILDO,P,NX,NY,MESH, 1 SEALND,NXE,NYE,MESHE, 2 IOCEXT,IOCINC,ISTOP,IER) C THE ABOVE SMOOTHS THE WATER POINTS WTIH THE PARAMETERS C PREX1( ) AND PREX2( ) AS RAYS FROM THE CENTER, C STOPPING WHEN A MISSING OR LAND IS ENCOUNTERED. ENDIF C 9885 CONTINUE C DO 9886 NN=1,NOPRE C IF(PREPRO(NN).EQ.'ORVWSM')THEN C C THIS ROUTINE SMOOTHS THE FIRST GUESS OVER WATER. IOCEXT=NINT(PREX4(NN)) IOCINC=NINT(PREX5(NN)) CONSTB=PREX3(NN) SHOREA=NCAT(NN) SHOREB=NSCALE(NN) NOL=NINT(CONST(NN)) CALL ORVWSM(KFILDO,KFIL10,P,NX,NY,MESH, 1 SEALND,NXE,NYE,MESHE,NPROJ, 2 SHOREA,SHOREB,NOL,FLOAT(IPREX1(NN)), 3 FLOAT(IPREX2(NN)),CONSTB,IOCEXT,IOCINC, 4 LSTORE,ND9,LITEMS,NTIMES, 5 IS0,IS1,IS2,IS4,ND7, 6 IPACK,IWORK,DATA,ND5, 7 CORE,ND10,NBLOCK,NFETCH, 8 L3264B,ISTOP,IER) C WHEN RETURN IER = 777, GRID IS NOT SMOOTHED. C THE ABOVE SMOOTHS THE WATER POINTS WTIH THE PARAMETERS C IPREX1( ) AND IPREX2( ) AS RAYS FROM THE CENTER, C STOPPING WHEN A MISSING OR LAND IS ENCOUNTERED. C SMOOTHING IS LIGHT NEAR SHORE, AND HEAVY AWAY FROM C THE COAST. C IF(IER.NE.0)THEN MER=MER+1 ENDIF C ENDIF C 9886 CONTINUE C DO 9888 NN=1,NOPRE C IF(PREPRO(NN).EQ.'PIXSM1')THEN C C THIS ROUTINE PIXEL SMOOTHS THE FIRST GUESS. FOR C THIS APPLICATION, THE LAND (SANS SIBERIA) WILL BE C REPLACED WITH A CONSTANT. ISPOT=NCAT(NN) MTIMES=NSCALE(NN) DIFFV=CONST(NN) DIFFB=IPREX1(NN) CALL PIXSM1(KFILDO,ID(1,M),IDPARS(1,M),JD(1,M), 1 ISPOT,MTIMES,DIFFV,DIFFB, 2 P,NX,NY,TELEV,NXE,NYE,FD4,ND2X3, 3 L3264B,ISTOP,IER) C PIXSM1 REMOVES BLOCKINESS OF RAP. USED WITH MELD. C C PIX AND PIX1 INSERT 888 FOR "UNLIMITED" CEILINGS. C THIS IS CORRECT WHEN USED AS A POSTPROCESSOR, BUT C WHEN USED AS A PREPROCESSOR IN U155, THOSE VALUES C SHOULD BE 130. SO SET THEM NOW. IF(ID(1,M).EQ.728000085)THEN C 728000085 IS OBS CEILING HEIGHT ANALYSIS. C DO 9887 JX=1,NX*NY C IF(P(JX).LT.9998.5.AND.P(JX).GE.887.)THEN P(JX)=130. ENDIF C 9887 CONTINUE C ENDIF C ENDIF C 9888 CONTINUE C C CALL BOGUS IF NECESSARY. NOTE THAT IT HAS TO BE AFTER C FSTGS5 BECAUSE IT MAY USE THE FIRST GUESS IN P( ). C IT IS DONE FOR EACH CYCLE BECAUSE SOME BOGUS STATIONS C MAY BE OVER LAND WHERE THERE ARE NOT DATA FOR ALL CYCLES. C DO 2886 NN=1,NOPRE C IF(PREPRO(NN).EQ.'BOGUS')THEN C DO 2885 L=1,NORUNS C THIS ROUTINE IS TO FURNISH BOGUS VALUES. SOME CAN BE FROM C THE FIRST GUESS, AND SOME CAN BE WEIGHTED AVERAGES OF OTHER C POINTS. THE FIRST GUESS IS IN FD5( ) FROM FSTGS5. LAND C HAS NOT BEEN SET TO GUESS IN FD5( ) BUT IT HAS IN P( ). C CALL BOGUS(KFILDO,IP14,IP25,KFILPR(NN),PREPFL(NN), 1 ID(1,M),IDPARS(1,M),JD(1,M),NCAT(NN),NSCALE(NN), 2 CCALL,XPL,YPL,LNDSEA,XDATA(1,L+1,J),LTAG,LTAGPT, 3 NSTA,FD5,NXL,NYL,MESHB,SEALND,NXE,NYE,MESHE,N4P, 4 NAREA,ISTOP,IER) C AN ERROR IN BOGUS HAS A DIAGNOSTIC. NOT TREATED C AS A FATAL ERROR, BUT ISTOP(5) OR ISOPT(6) HAS BEEN C INCREMENTED. C IF(IER.NE.0)THEN MER=MER+1 ENDIF C 2885 CONTINUE C ENDIF C 2886 CONTINUE C DO 8889 NN=1,NOPRE C IF(PREPRO(NN).EQ.'BOGUSG')THEN PREX3BOG=PREX3(NN) C PREX3BOG SAVES PREX3 FROM BOGUSG ENTRY FOR RDVRHL. WTAUG=PREX4(NN) C THIS ALLOWS THE WEIGHT ON THIS TYPE OF BOGUS TO BE C OTHER THAN 1. NOTE THIS CAPABILITY IS SHARED WITH C AUGMT3, SO BOTH AUGMT3 AND BOGUSG WOULD NOT BE USED. C C THIS ROUTINE IS TO FURNISH BOGUS VALUES AT GRIDPONTS C FROM THE FIRST GUESS THIS IS PRIMARILY OVER WATER C (INCLUDES SIBERIA) DEVOID OF DATA WITH A DECENT C FIRST GUESS. NSTA=NBASTA C NSTA MUST BE THE SAME ON EACH ENTRY (WHEN NORUNS > 1). CALL BOGUSG(KFILDO,KFIL10,ID(1,M),IDPARS(1,M),JD(1,M),NDATE, 1 CCALL,XP,YP,LNDSEA,QUALST,NAREA, 2 XDATA(1,2,J),LTAG,LTAGPT,VRAD,ELEV,NSTA,ND1, 3 P,NX,NY,SEALND,TELEV,NXE,NYE,MESHE,NPROJ, 4 NCAT(NN),NSCALE(NN),CONST(NN),IPREX1(NN), 5 IPREX2(NN),PREX3(NN),PREX4(NN),GUESS, 6 IS0,IS1,IS2,IS4,ND7, 7 LSTORE,ND9,LITEMS,IPACK,IWORK,ND5, 8 CORE,ND10,NBLOCK, 9 L3264B,ISTOP,IER) C AN ERROR IN BOGUSG CAUSES A STOP. C BOGUSG INCRESES NSTA. NSTASV IS ORIGINAL VALUE. C ENDIF C 8889 CONTINUE C C IN ORDER TO INTERPOLATE BOGUS VALUES FREOM THE FIRST C GUESS, SETTING VALUES TO GUESS HAS TO BE DONE AFTER C BOGUS. PUT HERE FOR SKY FROM FSTGS5 3/10/20 FOR C NBLEND = 3. C IF(NBLEND.NE.0)THEN CALL SETLND(KFILDO,P,NX,NY,MESH, 1 SEALND,NXE,NYE,MESHE,CONST,IER) C IF(IER.NE.0)THEN MER=MER+1 ENDIF C ENDIF C DO 2887 NN=1,NOPRE C IF(PREPRO(NN).EQ.'SETFG ')THEN C THIS ROUTINE IS TO SET ONE OR MORE OF THE FIRST GUESS C GRIDPOINTS TO A CONSTANT. iT DISTINGUISHES OCEAN (SET TO C NCAT)FROM LAKES (SET TO NSCALE) FROM LAND (SET TO CONST). C CALL SETFG(KFILDO,P,NX,NY,MESH, 1 SEALND,NXE,NYE,MESHE, 2 NCAT(NN),NSCALE(NN),CONST(NN),ISTOP(1),IER) C (THE (NN) IN CAT, NSCALE, AND CONST INSERTED 4/13/19.) C IF(IER.NE.0)THEN MER=MER+1 ENDIF C ENDIF C 2887 CONTINUE C DO 2889 NN=1,NOPRE C IF(PREPRO(NN).EQ.'ENHANC')THEN C THIS ROUTINE IS TO ENHANCE BOGUS WIND SPEEDS FOR WHICH C THE BOGUS VALUES ARE INTERPOLATIONS FROM THE FIRST GUESS C SPEED. THIS IS FOR THE SO-CALLED GUST (OR TOTAL WIND C SPEED) ANALYSIS. C DO 2888 L=1,NORUNS CALL ENHANC(KFILDO,IP14,KFIL10,KFILPR(NN),PREPFL(NN), 1 NDATE,ID(1,M),IDPARS(1,M),JD(1,M), 2 CCALL,LTAG,XP,YP,LNDSEA,XDATA(1,L+1,J),NSTA, 4 LSTORE,ND9,LITEMS, 5 IS0,IS1,IS2,IS4,ND7, 6 IPACK,IWORK,DATA,ND5, 7 CORE,ND10,NBLOCK,NFETCH, 8 L3264B,ISTOP,IER) C IF(IER.NE.0)THEN MER=MER+1 ENDIF C 2888 CONTINUE C ENDIF C 2889 CONTINUE C DO 2922 NN=1,NOPRE C IF(PREPRO(NN).EQ.'ENHWND')THEN C THIS ROUTINE IS TO ENHANCE BOGUS WIND SPEEDS FOR WHICH C THE BOGUS VALUES ARE INTERPOLATIONS FROM THE FIRST GUESS C SPEED. THIS IS FOR THE SO-CALLED GUST (OR TOTAL WIND C SPEED) ANALYSIS. C DO 2920 L=1,NORUNS CALL ENHWND(KFILDO,IP14,KFIL10,KFILPR(NN),PREPFL(NN), 1 NDATE,ID(1,M),IDPARS(1,M),JD(1,M), 2 CCALL,LTAG,XP,YP,LNDSEA,XDATA(1,L+1,J),NSTA, 4 LSTORE,ND9,LITEMS, 5 IS0,IS1,IS2,IS4,ND7, 6 IPACK,IWORK,DATA,ND5, 7 CORE,ND10,NBLOCK,NFETCH, 8 L3264B,ISTOP,IER) C IF(IER.NE.0)THEN MER=MER+1 ENDIF C 2920 CONTINUE C ENDIF C 2922 CONTINUE C DO 2925 NN=1,NOPRE C IF(PREPRO(NN).EQ.'RDVRHL'.AND.IVRAD.NE.0)THEN C C READ VARIABLE RADIUS LIST AND HIGH AND LOW C ELEVATIONS FROM UNIT KFILSL. THIS HAS TO BE AFTER C FIRST GUESS SO THAT IT IS KNOWN WHICH GUESS IS USED. C CALL RDVRHL(KFILDO,KFILPR(NN),PREPFL(NN),IP14, 1 CCALL,NAME,VRAD,ELEVLO,ELEVHI,R(1,MGUESS), 2 NPROJ,ORIENT,BMESH,XLAT,ALATL,ALONL, 3 ND1,NSTA,NBASTA,PREX3BOG,ISTOP,IER) C IF(IER.NE.0)THEN WRITE(KFILDO,2924) 2924 FORMAT(' FATAL ERROR IN RDVRHL', 1 ' IN U405A NEAR 2924.') CALL W3TAGE('U405A') STOP 2924 ELSE FL174=PREPFL(NN) C THE NAME OF THE FILE PREPARED BY U174 IS SAVED C FOR LAPSUA. ENDIF C ENDIF C 2925 CONTINUE C IER=0 C IER COULD BE NON-ZERO FROM A ROUTINE ABOVE. C C DETERMINE WHETHER OR NOT LAPSE RATES WILL BE NEEDED. C ASSUME THE FIRST GUESS DESIRED IS USED. SOME VALUE C OF ELCORR( ,L), L=1,NPASS MUST BE GT 0 AND C COMPUTE THE LAPSE RATE FOR EACH STATION INDICATED BY C THE DATA IN XDATA( , , ) AND THE PAIRS OF STATIONS. C NOTE THAT ALL CYCLES OF DATA ARE USED IN LAPSE. C (IF DATA IN XDATA( , , ) WERE COMBINED BEFORE THIS, THE C OPTION OF WEIGHTING CYCLES FOR COMPUTING THE LAPSE C IS NO LONGER AVAILABLE.) C IF(J.EQ.1)THEN C THE LAPSE IS CALCULATED FOR ALL CYCLES AND LEVELS C COMBINED ON THE FIRST ENTRY. SO DO IT ONLY ONCE. C C IF LAPSE IS NOT NEEDED, DON'T CALCULATE IT, BUT C SET XLAPSE( ) AND ULAPSE( ) = 0. FOR SAFETY AND C FOR POSSIBLE DIAGNOSTIC PRINT. C IF(LAPFG.LT.0.OR.LAPFG.GT.5)THEN WRITE(KFILDO,2927) 2927 FORMAT(/' ****LAPFG DOES NOT HAVE A VALUE OF 0, 1, 2,', 1 ' 3, 4, OR 5. ERROR IN U405A AT 2927.') ISTOP(1)=ISTOP(1)+1 JER=JER+1 GO TO 500 ENDIF C IF(IBKPN.EQ.99)THEN C DO 2928 K=1,NSTA XLAPSE(K)=0. ULAPSE(K)=0. 2928 CONTINUE C GO TO 2930 ENDIF C IF(LAPFG.LE.1.OR.LAPFG.EQ.5)THEN RLAP=R(1,MGUESS)*RSTAR(1,MGUESS) C RLAP IS THE RADIUS TO USE IN LAPSE. C AT THIS POINT, EXCLUD WILL BE 9999, UNLESS SETCIG HAS C BEEN CALLED, THEN IT WILL BE PREX3( ) OF THAT CALL. CALL LAPSE(KFILDO,KFILLP,IP14,CCALL,NAME,LNDSEA,ELEV, 1 NOPAR,LOCPAR,XDATA(1,1,J),XLAPSE,MPAIRS, 2 LTAGPT,NSTASV,ND1, 3 NXL,NYL,XPL,YPL,RLAP,XP,YP, 4 ELCORR(1,MGUESS),NPASS,WTRUNL,NORUNS,LEVELS, 5 IALOC,ADIST,AELEV,ND13,EXCLUD,NAREA, 6 SEALND,TELEV,NXE,NYE,MESHE,P,NX,NY,MESH, 7 ID(1,M),IBKPN,LPNO,LAPFG,MGUESS,N4P,ISTOP,IER) C CHANGED NSTA TO NSTASV IN CALL 2/26/19. IF(IER.NE.0)THEN JER=JER+1 GO TO 500 ENDIF C A DIAGNOSTIC WILL HAVE BEEN WRITTEN IN LAPSE WHEN IT C IS ENTERED WITH LAPFG NE 0 OR 1. THIS IS A SAFETY. C ELSEIF(LAPFG.EQ.2.OR.LAPFG.EQ.3.OR.LAPFG.EQ.4)THEN C THE INCOMING UA GRIDS MUST BE ON THE SAME MAP C PROJECTION, BUT THE OTHER CHARACTERISTIC CAN C BE DIFFERENT. CALL LAPSUA(KFILDO,KFIL10,IP14,ID(1,N),IDPARS(1,N),NCEPNO, 1 CCALL,NAME,LNDSEA, 2 DIR,NGRIDC,ND11,LAPFG,FL174, 3 XDATA,XLAPSE,ELEVLO,ELEVHI,ELEV,NSTA,ND1, 4 ALATL,ALONL,XPL,YPL,NXL,NYL,BMESH, 5 NORUNS,LEVELS,MGUESS,IBACKN,IBACKL, 6 LSTORE,ND9,LITEMS,NDATE,JDATE(4), 7 IS0,IS1,IS2,IS4,ND7, 8 IPACK,IWORK,DATA,ND5, 9 CORE,ND10,NBLOCK,NFETCH,MISTOT,NSLAB, A NPROJ,ORIENT,XLAT,L3264B,ISTOP,IER) IF(IER.NE.0)THEN JER=JER+1 GO TO 500 ENDIF C ENDIF C IF(LAPFG.EQ.5)THEN C THE INCOMING UA GRIDS MUST BE ON THE SAME MAP C PROJECTION, BUT THE OTHER CHARACTERISTIC CAN C BE DIFFERENT. THIS CALL IS FOR WHEN THE SURFACE C BASED LAPSE IS COMBINED WITH SURFACE/UP LAPSE. CALL LAPSUA(KFILDO,KFIL10,IP14,ID(1,N),IDPARS(1,N),NCEPNO, 1 CCALL,NAME,LNDSEA, 2 DIR,NGRIDC,ND11,LAPFG,FL174, 3 XDATA,ULAPSE,ELEVLO,ELEVHI,ELEV,NSTA,ND1, 4 ALATL,ALONL,XPL,YPL,NXL,NYL,BMESH, 5 NORUNS,LEVELS,MGUESS,IBACKN,IBACKL, 6 LSTORE,ND9,LITEMS,NDATE,JDATE(4), 7 IS0,IS1,IS2,IS4,ND7, 8 IPACK,IWORK,DATA,ND5, 9 CORE,ND10,NBLOCK,NFETCH,MISTOT,NSLAB, A NPROJ,ORIENT,XLAT,L3264B,ISTOP,IER) IF(IER.NE.0)THEN JER=JER+1 GO TO 500 ENDIF C A DIAGNOSTIC WILL HAVE BEEN WRITTEN IN LAPSUA. C C CALCULATE IN CLPASE THE VARIABLES WITH WHICH TO C COMBINE XLAPSE( ) AND ULAPSE( ) IN CORBC5. C CALL CLAPSE(KFILDO,NAREA,TELL,TELH,ATEL,BTEL,ISTOP,IER) ENDIF C CCCC WRITE(KFILDO,9293)(K,CCALL(K,1),XLAPSE(K),ULAPSE(K), CCCC 1 K=1,NSTA) CCCC 9293 FORMAT(/' AT 9293 IN U405A--', CCCC 1 '(K,CCALL(K,1),XLAPSE(K),ULAPSE(K)K=1,NSTA)',/ CCCC 2 (3(I8,2X,A8,2F10.4))) C ENDIF C C NOTE THAT FSTGS5 HAS FILLED TITLE( ,25:40) WITH DATE. C A FATAL ERROR OF IER = 777 IS RETURNED WHEN A FIRST C GUESS COULD NOT BE OBTAINED OR WHEN A PROBLEM C WITH WRITING TO KFILOG OCCURRED. OTHERWISE, IER = 0. C C MAKE SURE XP( ) AND YP( ) CONFORM THE THE CURRENT FIRST C GUESS GRID. MESH WAS DEFINED IN FSTGS5; THIS IS JUST C A SAFETY CHECK. C 2930 IF(MESH.NE.MSHPAS(1,MGUESS))THEN CALL NEWXY1(KFILDO,MESH,XP,YP,MSHPAS(1,MGUESS),XP,YP, 1 NPROJ,NSTA) C MSHPAS(1,MGUESS) IS FOR THE FIRST PASS AND GUESS C OPTION MGUESS. WRITE(KFILDO,2932)MESH,MSHPAS(1,MGUESS) 2932 FORMAT(/' ****UNEXPECTED CALL TO NEWXY1 IN U405A AT 2932.', 1 ' MESH =',I8,' MSHPAS(1,MGUESS) =',I8) ISTOP(1)=ISTOP(1)+1 C C IF THIS CALL TO NEWXY1 IS MADE, THEN THE CALL TO C FLTAG BETTER BE MADE ALSO. THIS IS AN ERROR. C CALL FLTAGM(KFILDO,XDATA(1,1,J),ND1,NORUNS,XP,YP,LTAG,NSTA, 1 NX,NY,0.) ENDIF C C FLTAG WITH RMAX = 0. AND LTAG( ) WAS USED IN FSTGS5. NOW C COUNT THE STATIONS IN THE ANALYSIS AREA. C JSTAAN=0 C DO 2934 K=1,NSTA IF(LTAG(K).EQ.0)JSTAAN=JSTAAN+1 2934 CONTINUE C C SAMPLE POINTS FROM THE FIRST GUESS IF DESIRED. FIRST C DETERMINE THE MAXIMUM NUMBER THAT WILL, OR MIGHT BE, C USED. NORMALLY, ONLY OPTION 2 WILL HAVE NON ZERO VALUES, C BUT IT IS POSSIBLE OPTION 3 COULD. OPTION 1 (A CONSTANT) C AND OPTION 4 (AN AVERAGE) SHOULD NOT BE SAMPLED, AND C ARE NOT ALLOWED. WHEN SAMPLING IS DONE, IN ORDER FOR C THE POINTS TO BE EFFECTIVE, A FIRST GUESS OTHER THAN C THE SAMPLED FIELD IS NEEDED, SO SET IT TO GUESS. C MAXPT=0 C IF(ISMPL.NE.0)THEN C DO 2937 JJ=1,NPASS DO 2936 L=1,4 C IF(L.EQ.1.OR.L.EQ.4)THEN IPOINT(JJ,L)=0 C THIS IS A SAFETY FEATURE. ELSE MAXPT=MAX(MAXPT,IPOINT(JJ,L)) ENDIF C 2936 CONTINUE 2937 CONTINUE C C ******CAREFUL--SAMPLE HAS NOT BEEN USED AFTER C MULTIPLE CYCLES AND LEVELS WERE INTRODUCED.***** C MAXPT=MIN(MAXPT,ISMPL) C IF(MAXPT.NE.0)THEN CALL SAMPLE(KFILDO,IP14,P,NX,NY,CCALL,XP,YP,LNDSEA,XLAPSE, 1 XDATA,NSTA,ISMPL,MAXPT,SEALND,NXE,NYE, 2 MESH,MESHE,GUESS,N4P,ISTOP,IER) C NOTE THAT THIS CHANGES THE FIRST GUESS IN P( ) TO GUESS. C THERE IS NO NON-ZERO ERROR RETURN. ENDIF C ENDIF C NSTA=NSTA-ISMPL+MAXPT C FROM NOW ON, NSTA INCLUDES THE ORIGINAL DATA PLUS C THE SAMPLED POINTS FOR THIS VARIABLE, NO MATTER WHAT C ISMPL IS. THIS ALLOWS U155 TO DETERMINE THE MAXIMUM C RANDOM POINT LOCATIONS NEEDED IN THE RUN, AND ONLY C THAT PORTION NEEDED FOR THIS VARIABLE IS USED. NSTA C IS RESET TO NSTASV ON EXIT. C D WRITE(KFILDO,2939)NSTA,ISMPL,MAXPT,MESH,MESHE D2939 FORMAT(' IN U405A AT 2939--NSTA,ISMPL,MAXPT,MESH,MESHE', D 1 5I10) C C FIRST COMPUTE THE MAXIMUM RADIUS R FOR ANY PASS FOR C THIS FIRST GUESS. C RMAX=0. C DO 294 JJ=1,NPASS IF(NTYPE(JJ,MGUESS).NE.0)THEN RMAX=MAX(RMAX,R(JJ,MGUESS)*RSTAR(JJ,MGUESS)) ENDIF C 294 CONTINUE C C SET LTAG( ). WHEN LTAG( ) = 1 or 2, THAT STATION'S C VALUE WILL NEVER BE USED. THEREFORE, THE MAXIMUM VALUE OF C R( )*RSTAR( ) FOR THE FIRST GUESS OPTION USED MUST BE C USED IN FLTAG. THIS JUST HAS THE EFFECT OF PERMANENTLY C DISCARDING THE STATIONS FAR OUTSIDE THE GRID. THIS C DISCARDING IS IN RELATION TO THE FIRST GUESS GRIDLENGTH C MESH. THE FIRST GUESS GRIDLENGTH IS NORMALLY AT C LEAST AS LARGE AS ANY OTHER GRIDLENGTH, SO STATIONS C NEEDED ARE NOT DISCARDED; IN ANY CASE THIS JUST AFFECTS C DATA OUTSIDE THE ANALYSIS GRID. XDATA( ,1,J) HOLDS THE DATA. C FOR FLTAG, XP, YP, NX, AND NY REFER TO THE CURRENT C FIRST GUESS GRID. AT THIS POINT, LTAG( ) HAS ONLY C VALUES 0, 1, OR 2. WHEN A DATUM IN XDATA( ,1,J) IS C MISSING, LTAG( ) IS SET = 1. C CALL FLTAGM(KFILDO,XDATA(1,1,J),ND1,NORUNS,XP,YP,LTAG,NSTA, 1 NX,NY,RMAX) C JSTA=0 C DO 300 K=1,NSTA IF(LTAG(K).EQ.0)JSTA=JSTA+1 300 CONTINUE C C CHECK NUMBER OF STATIONS AGAINST A VALUE THAT C VARIES BY NAREA, SET BY DATA STATEMENT. C IF(JSTAAN.EQ.0)THEN WRITE(KFILDO,310) 310 FORMAT(/' ****NO STATIONS WITH DATA AVAILABLE', 1 ' WITHIN THE ANALYSIS AREA.') JER=JER+1 GO TO 500 C ELSEIF(JSTAAN.LT.JSTTST(NAREA))THEN WRITE(KFILDO,311)JSTAAN 311 FORMAT(/' ****WARNING, ONLY ',I4,' STATIONS WITH DATA', 1 ' WITHIN THE ANALYSIS AREA. PROCEEDING.') ISTOP(2)=ISTOP(2)+1 ENDIF C WRITE(KFILDO,321)JSTA,RMAX 321 FORMAT(/' ',I7,' POINTS WITH DATA', 1 ' THAT MAY BE USED ON ONE OR MORE PASSES', 2 ' AT MAXIMUM R =',F6.1,' OUTSIDE GRID.') C C TURN THE SURFACE WINDS CLOCKWISE BY WNDTRN DEGREES C WHEN SLP IS BEING ANALYZED. C IF(ID(1,N)/1000.NE.001201)GO TO 3423 C C THE SECTION BELOW IS FOR SEA LEVEL PRESSURE TO PREPARE C FOR USING WINDS IN THE ANALYSIS. C IF(WNDGRD.EQ.0.)GO TO 3423 C WHEN WNDGRD = 0, WIND WILL NOT BE USED. C C TURN WIND DIRECTION WNDTRN DEGREES CLOCKWISE. C CALL TRNWND(KFILDO,WDIR,WNDTRN,NSTA) C C*********************************** C THIS SECTION FOR WRITING TURNED WIND FOR VIEWING. C C*** LD(1)=794200000 C*** LD(2)=88*10000 C*** LD(3)=0 C*** LD(4)=0 C*** CALL PRSID1(KFILDO,LD,LDPARS) C***C PRSID1 FILLS LDPARS( ) ACCORDING TO LD( ). C*** RACK='OBSERVED WINDS TURNED WNDTRN DEG' C*** CALL PACKV(KFILDO,KFILOV,LD,LDPARS, C*** 1 JPP,0,0, C*** 2 IRACK,RACK,NDATE,JDATE(1),JDATE(2),JDATE(3),JDATE(4), C*** 3 CCALL,FD6,WDIR,NSTA,NSTA,IPACK,ND5,MINPK, C*** 4 IS0,IS1,IS2,IS4,ND7,9999.,0., C*** 5 IP18,NWORDS,MTOTBY,MTOTRC, C*** 6 L3264B,L3264W,ISTOP,IER) C***C FD6( ) IS WORK ARRAY FOR PACKV. IP18 IS USED TO LIST VALUES. C***C ISCALD IS USED AS ZERO FOR WIND DIRECTION. C***C C*** IF(IP16.NE.0)THEN C*** WRITE(IP16,341)(LD(JJ),JJ=1,4),RACK,NDATE C*** 341 FORMAT(/' WRITING DATA TO UNIT KFILOV',3I10.9,I10.3,3X, C*** 1 A32,' FOR DATE',I12) C*** ENDIF C***C C***C THIS SECTION FOR WRITING TURNED WIND FOR VIEWING. C***C C*** LD(1)=794210000 C*** LD(2)=88*10000 C*** LD(3)=0 C*** LD(4)=0 C*** CALL PRSID1(KFILDO,LD,LDPARS) C***C PRSID1 FILLS LDPARS( ) ACCORDING TO LD( ). C*** RACK='OBSERVED WIND SPEED ' C*** CALL PACKV(KFILDO,KFILOV,LD,LDPARS, C*** 1 JPP,0,0, C*** 2 IRACK,RACK,NDATE,JDATE(1),JDATE(2),JDATE(3),JDATE(4), C*** 3 CCALL,FD6,WSPD,NSTA,NSTA,IPACK,ND5,MINPK, C*** 4 IS0,IS1,IS2,IS4,ND7,9999.,0., C*** 5 IP18,NWORDS,MTOTBY,MTOTRC, C*** 6 L3264B,L3264W,ISTOP,IER) C***C FD6( ) IS WORK ARRAY FOR PACKV. IP18 IS USED TO LIST VALUES. C***C ISCALD IS USED AS ZERO FOR WIND DIRECTION. C***C C*** IF(IP16.NE.0)THEN C*** WRITE(IP16,342)(LD(JJ),JJ=1,4),RACK,NDATE C*** 342 FORMAT(/' WRITING DATA TO UNIT KFILOV',3I10.9,I10.3,3X, C*** 1 A32,' FOR DATE',I12) C*** ENDIF C*********************************** C C CONVERT SPEED AND DIRECTION INTO GRID ORIENTED U C AND V-COMPONENTS IN U( ) AND V( ), RESPECTIVELY. C ALL ARE IN KT. U( ) AND V( ) ARE DIMENSIONED ND2X3 IN C THE CALLING PROGRAM. ND2X3 GUARANTEED TO BE GE ND1 IN DRU155. C****************MODIFY FOR NO NXPL******************* CCC CALL DIRTUV(KFILDO,WDIR,WSPD,XPL,YPL,U,V,NSTA, CCC 1 REAL(NXPL),REAL(NYPL)) C C COMPUTE THE SINE OF THE LATITUDE IN FDSINS( ). C CALL PSMAPF(KFILDO,BMESH*1000.,ORIENT,XLAT,ALATL,ALONL, 1 FDSINS,FD2,NXL,NYL,IER) C MESH LENGTH FOR PSMAPF HAS TO BE IN M, NOT KM. C C PRINT SINE OF THE LATITUDE FOR CHECKOUT. C C***D CALL PRTGR(KFILDO,FDSINS,NXL,NYL, C***D 1 CINT,ORIGIN,100.,0.,IOPTL,SIN,IER) C C CALCULATE THE CHANGE IN PRESSURE IN MB PER GRID UNIT IN THE C X AND Y DIRECTIONS; U( ) AND V( ) ARE USED FOR THIS PURPOSE. C WNDGRD IS THE EMPIRICAL FACTOR TO ACCOUNT FOR NON-GEOSTROPHIC C SPEED EFFECTS; THE DIRECTION HAS ALREADY BEEN ACCOUNTED FOR C BY TURNING THE SURFACE WIND CLOCKWISE WNDTRN DEGREES. C IF THE SPEED IS LT WNDTHR, SET U( ) AND V( ) TO MISSING. C CORMSH=REAL(MESH)/REAL(MESHB) C THE CORRECTION IN MB PER GRID UNIT DEPENDS ON THE GRID C MESH. THE SMALLER THE MESH, THE SMALLER THE CORRECTION C PER UNIT MESH. CORMSH IS USED BELOW TO ADJUST FROM THE C CONSTANTS CALCULATED ON THE BASIS OF 1/4 BEDIENT = MESHB. C******************CAREFUL, NOT ADJUSTED FOR MESHB NE 1/4 B********* C DO 3421 K=1,NSTA C IF(NINT(WSPD(K)).EQ.9999.OR.WSPD(K).LT.WNDTHR)THEN U(K)=9999. V(K)=9999. ELSE CALL ITRP(FDSINS,NXL,NYL,XPL(K),YPL(K),SINLAT) C SINLAT IS THE SINE OF THE LATITUDE AT STATION K C INTERPOLATED FROM FDSINS( , ). FAC=SINLAT*(1.+SINLAT)*CORMSH C FAC IS (SINPHI)(1+SINPHI) OF THE STATION. U(K)=-.16*WNDGRD*FAC*U(K) V(K)= .16*WNDGRD*FAC*V(K) C WITH SPEED IN KT, THE GEOSTROPHIC MB CHANGE PER NOMINAL C 80 KM GRID UNIT IS C 1.47 M/GRID UNIT * 1 MB/9M = .16 MB/GRID UNIT ENDIF C 3421 CONTINUE C C ALL DATA ARE IN AND PROCESSED. NOW SET COLUMN 1 IN C XDATA( , ,J) TO THE WEIGHTED AVERAGE OF THE NORUNS RUNS. C WHEN NORUNS = 1, THE FIRST COLUMN IN XDATA( , ) JUST BECOMES C THE SECOND COLUMN. C 3423 CONTINUE C C AT THIS POINT, LTAG( ) MAY BE 4 INDICATING THE STATION C WAS TOSSED IN THE ANALYSIS OF OBS, BUT CAN BE USED FOR C LAMP. OTHER + VALUES OF LTAG( ) INDICATE DATA SHOULD NOT C BE USED. C CCCC WRITE(KFILDO,3425)(K,J,CCALL(K,1),NORUNS, CCCC 1 XDATA(K,1,J),XDATA(K,2,J),LTAG(K),K=1,NSTA) CCCC 3425 FORMAT(' AT 3425 IN U405A--K,J,CCALL(K,1),NORUNS', CCCC 1 'XDATA(K,1,J),XDATA(K,2,J),LTAG(K)',2I6,2X,A8,I2,2F8.1,I4) C DO 3428 K=1,NSTA C CCCC IF(K.LE.NBASTA+10)THEN CCCC WRITE(KFILDO,9342)K,CCALL(K,1),LTAG(K), CCCC 1 (XDATA(K,L,J),L=1,NORUNS+1) CCCC 9342 FORMAT(' AT 9342--)K,CCALL(K,1),LTAG(K),', CCCC 1 '(XDATA(K,L,J),L=1,NORUNS+1)',I6,2X,A8,I4,6F8.2) CCCC ENDIF C CCCCC IF(LTAG(K).LE.0)THEN C DEACTIVATED 2/17/20. LTAG( ) HAS BEEN SET IN FSTGS5 BUT C ONLY CONSIDERING ONE RUN. C IF(NORUNS.EQ.1)THEN XDATA(K,1,J)=XDATA(K,2,J) C NO AVERAGE IS NECESSARY WHEN THERE IS ONLY ONE RUN. ELSE WT=0 XDATA(K,1,J)=0. C DO 3427 L=2,NORUNS+1 C IF(XDATA(K,L,J).LT.9998.5)THEN XDATA(K,1,J)=XDATA(K,1,J)+XDATA(K,L,J)*WTRUNA(L-1) WT=WT+WTRUNA(L-1) ENDIF C 3427 CONTINUE C IF(WT.EQ.0.)THEN C XDATA(K,1,J) = 0 COULD BE LEGITIMATE, WT = 0 IS NOT. XDATA(K,1,J)=9999. C THIS SHOULD NOT HAPPEN BUT IS A SAFETY. ELSE XDATA(K,1,J)=XDATA(K,1,J)/WT C THIS DIVISION BY THE SUM OF THE WEIGHTS IS NECESSARY C BECAUSE THERE MAY BE MISSING DATA. NOTE THAT THE C DATA TO ANALYZE IN XDATA( ,1,J) IS THE WEIGHTED C AVERAGE OF THE NON-MISSING VALUES. ENDIF C ENDIF C IF(XDATA(K,1,J).GE.9998.5)THEN LTAG(K)=1 ENDIF C WITHOUT THE ABOVE, A TOSSED OB WITH LTAG( ) = 4 MAY BE TREATED C AS A GOOD VALUE. IT WOULD BE TOSSED, BUT KEEP IT OUT OF BCD5. C CCCCC ENDIF C 3428 CONTINUE C CCCC WRITE(KFILDO,3420)(K,J,CCALL(K,1),NORUNS, CCCC 1 XDATA(K,1,J),XDATA(K,2,J),LTAG(K),K=1,NSTA) CCCC 3420 FORMAT(' AT 3420 IN U405A--K,J,CCALL(K,1),NORUNS', CCCC 1 'XDATA(K,1,J),XDATA(K,2,J),LTAG(K)',2I6,2X,A8,I2,2F8.1,I4) C C MODIFY RADII IF DESIRED. MOVED FROM ABOVE TO AFTER RUNS C WERE MERGED. PREVIOUS VERSION DATED 2/17/20. C DO 2926 NN=1,NOPRE C IF(PREPRO(NN).EQ.'DDRAD '.AND.IVRAD.NE.0)THEN C DDRAD MODIFIES THE VARIABLE RADII FROM WHAT ARE C PROVIDED IN RDVRHL. THE LEVELS REFER TO PROBABILITY C LEVELS. C NPASR=NCAT(NN) NOPTR=NSCALE(NN) C NOPTR IS THE CRITERION FOR TOSSING DUPLICATE C STATIONS*1000+FLAG FOR ALTERNATE EQUATION. LAUGBO=NINT(CONST(NN)) DDMULT(1)=25. C DDMULT(1) IS NOT USED. DDMULT(2)=IPREX1(NN) DDMULT(3)=IPREX2(NN) DDMULT(4)=PREX3(NN) DDMULT(5)=PREX4(NN) DDMULT(6)=PREX5(NN) CALL DDRAD(KFILDO,CCALL,XP,YP,LTAG,LTAGPT,NOPTR, 1 LNDSEA,XDATA(1,1,J),NSTASV,ND1,R(1,MGUESS),IQUAL, 2 NPASS,NPASR,LAUGBO,DDMULT,VRAD,IER) C CHANGED NSTA TO NSTASV IN CALL 2/26/19. C DDRAD IS ONLY CALLED ONCE, AND THE DATA FOR LEVEL 1 C IS IN XDATA( ,2, ). IF THERE IS MORE THAN ONE LEVEL, C THE MISSINGS SHOULD BE THE SAME FOR ALL LEVELS. C THERE IS NO NON-ZERO IER RETURN. C ELSEIF(PREPRO(NN).EQ.'DDRAD2'.AND.IVRAD.NE.0)THEN C DDRAD MODIFIES THE VARIABLE RADII FROM WHAT ARE C PROVIDED IN RDVRHL. THE LEVELS REFER TO PROBABILITY C LEVELS, AND IF ONE HAS DATA, THE OTHERS WILL ALSO, C SO NO NEED TO ENTER DDRAD MORE THAN ONCE. DO IT C FOR J = 1. R( , ) IS ONLY READ ONCE FOR ALL LEVELS. C NPASRR=NCAT(NN) LAUGBO=NINT(CONST(NN)) MIXWL=IPREX1(NN) MIXAB=IPREX2(NN) CALL DDRAD2(KFILDO,CCALL,XP,YP,LTAG,LTAGPT, 1 LNDSEA,XDATA(1,1,J),NSTASV,ND1,R(1,MGUESS),IQUAL, 2 NPASS,NPASRR,LAUGBO,MIXWL,MIXAB,VRAD,IER) C DDRAD IS ONLY CALLED ONCE, AND THE DATA FOR LEVEL 1 C IS IN XDATA( ,2, ). IF THERE IS MORE THAN ONE LEVEL, C THE MISSINGS SHOULD BE THE SAME FOR ALL LEVELS. C THERE IS NO NON-ZERO IER RETURN. IVRAD=2 C IVRAD2=2 IS A FLAG TO USE TYPE 3 CORRECTION IN CORBC5 C EVEN THOUGH THERE IS ONLY ONE STATION TO CORRECT FOR. ENDIF C 2926 CONTINUE C C SET LAPSE = 0 WHEN SNOW OR QPF FORECAST IS ZERO OR NEGATIVE. C IT IS PUT HERE AFTER THE CYCLES HAVE BEEN MERGED. C IF(ID(1,M)/100000.EQ.2284.OR.ID(1,M)/10000.EQ.22327)THEN C CORRECTED 23227 TO 22327 7/28/09 C DO 3429 K=1,NSTA C IF(XDATA(K,1,J).LE.0.)THEN C THE CHECK ON LE RATHER THAN EQ IS MADE BECAUSE THE C ZERO AMOUNTS MAY BE SET TO NEGATIVE FOR THE ANALYSIS. XLAPSE(K)=0. ENDIF C 3429 CONTINUE C ENDIF C C FOR SNOW ANALYSIS, SET ZERO VALUES TO SOME NEGATIVE C VALUE TO PRESERVE ZERO LINE. ROUTINE IS PUT HERE AFTER C THE CYCLES HAVE BEEN MERGED. C DO 3430 NN=1,NOPRE C IF(PREPRO(NN).EQ.'STSNOZ')THEN CALL STSNOZ(KFILDO,KFILPR(NN),PREPFL(NN),NAREA, 1 ID(1,M),IDPARS(1,M),JD(1,M), 2 CCALL,NAME,XDATA(1,1,J),LNDSEA,NSTA,ND1, 3 L3264B,ISTOP,IER) IF(IER.NE.0)THEN MER=MER+1 C THIS IS TREATED AS A MINOR ERROR; AN ANALYSIS CAN C BE MADE EVEN IF THE ZERO LINE IS NOT GOOD. ENDIF C ELSEIF(PREPRO(NN).EQ.'AVGLAP')THEN CALL AVGLAP(KFILDO,KFILPR(NN),PREPFL(NN),NAREA, 1 ID(1,M),IDPARS(1,M),JD(1,M), 2 CCALL,NAME,XDATA(1,1,J),LNDSEA,XLAPSE,NSTA,ND1, 3 L3264B,ISTOP,IER) IF(IER.NE.0)THEN MER=MER+1 C THIS IS TREATED AS A MINOR ERROR; AN ANALYSIS CAN C BE MADE EVEN IF THE ZERO LINE IS NOT GOOD. ENDIF ENDIF C 3430 CONTINUE C C ARRANGE TO WITHHOLD SOME DATA IF NEEDED. C IF(NWITH.NE.0.AND.ITYPR.EQ.1)THEN C THIS IS THE TYPE OF WITHHOLDING TO VERIFY GMOS FORECASTS. C THE FIRST CYCLE DATA ARE USED IN XDATA( , , ). CALL WTHOL1(KFILDO,IP24,ID(1,M),NDATE,CCALL,XDATA(1,1,J),ND1, 1 LTAG,LNDSEA,WHOLD,LTAGWH,XP,YP,NSTA,NX,NY,MESH, 2 CPNDFD,NXE,NYE,MESHE,NCLIPY, 3 SEED,NWITH,ISTOP(1),IER) C THE CURRENT DATA ARE IN XDATA( ,2,J). WITHHOLD STATIONS C BASED ON THIS, SO A MATCHED SET IS ASSURED, WHEN ONE OF C THE SETS IS TO BE THE CURRENT DATA. C THERE IS NO NON-ZERO ERROR RETURN. C IF(IP24.EQ.0)THEN WRITE(KFILDO,3431) 3431 FORMAT(/' ****STATIONS ARE BEING WITHHELD, BUT IP24 = 0.', 1 ' NO STATISTICS WILL BE PROVIDED.') ISTOP(1)=ISTOP(1)+1 ENDIF C MFIRST=1 C THE USE OF MFIRST ASSUMES BOTH WTHOL1 AND WTHOL2 WILL C NOT BE USED IN THE SAME U155 RUN. THIS KEEPS THE RANDOM C NUMBER ISEED FROM BEING RESET ON EACH ENTRY. C ELSEIF(NWITH.NE.0.AND.(ITYPR.EQ.2.OR.ITYPR.EQ.3))THEN C THIS IS THE TYPE OF WITHHOLDING TO JUDGE QUALITY OF C ANALYSIS. THE DATA TO ANALYZE ARE USED IN XDATA( , , ). C IF(MFIRST.EQ.0)THEN C ALLOCATE THE ARRAY FOR THE DATA TO BE COMPUTED. C THE COLUMNS ARE: C 1,2 -- THE DISTANCE TO THE TWO CLOSEST STATIONS C 3,4 -- NOT USED C 5-8 -- THE 4 TERRAIN ROUGHNESS VARIABLES, C 9-12 -- THE 4 DATA VARIABILITY VARIABILITY VARIABLES C 13-16 -- THE WEIGHTED DIFFERENCES BETWEEN THE STATION C AND ITS NEIGHBORS, ACCOUNTING FOR XLAPSE( ) C 17 -- ABSOLUTE DIFFERENCE IN ELEVATION BETWEEN C STATION AND ITS CLOSEST NEIGHBOR C 18 -- ABSOLUTE DIFFERENCE BETWEEN STATION DATA C VALUE AND VALUE OF NEIGHBOR AFTER LAPSE C APPLIED C 19 -- THE PRODUCT OF 17 AND 1 C 20 -- THE "ERROR," THE DIFFERENCE BETWEEN THE C ACTUAL VALUE AND THE INTERPOLATED VALUE C FROM THE ANALYSIS ALLOCATE (ERRANL(NWITH+IEXTRA,IDIM),ID2(IDIM),STAT=IOS) MFIRST=1 C SETTING MFIRST = 1 KEEPS ALLOCATION FROM BEING DONE C AGAIN. THE ARRAY IS NOT DEALLOCATED; THERE IS NO C REASON TO. ALSO, THIS KEEPS THE RANDOM NUMBER ISEED C FROM BEING RESET ON EACH ENTRY. C IF(IOS.EQ.1)THEN WRITE(KFILDO,3432) 3432 FORMAT(/' ****ALLOCATION OF ERRANL( , ) AND ID2( )', 1 ' FAILED IN U405A AT 3432.', 2 ' ARRAYS ALREADY ALLOCATED.') CALL W3TAGE('U405A') STOP 3432 ELSEIF(IOS.EQ.2)THEN WRITE(KFILDO,3433) 3433 FORMAT(/' ****ALLOCATION OF ERRANL( , ) AND ID2( )', 1 ' FAILED IN U405A AT 3433.', 2 ' ARRAYS NOT ALLOCATED.') CALL W3TAGE('U405A') STOP 3433 ENDIF C ENDIF C C SET THE ARRAY ERRANL( , ) TO MISSING. C DO 3435 MMM=1,IDIM DO 3434 NNN=1,NWITH+IEXTRA ERRANL(NNN,MMM)=9999. 3434 CONTINUE 3435 CONTINUE C IF(ITYPR.EQ.2)THEN CALL WTHOL2(KFILDO,IP24,ID(1,M),NDATE,CCALL,NAME,XDATA,ND1, 1 LTAG,LNDSEA,ELEV,WHOLD,LTAGWH,LOCWH,XP,YP, 2 DUMCAL,XLAPSE,NSTA, 3 CPNDFD,SEALND,TELEV,NXE,NYE,MESHE,NCLIPY, 4 NX,NY,MESH,SEED,NWITH,IEXTRA, 5 NROUGH,RELVAR,VARTAB(1,NAREA), 6 ERRANL,ID2,IDIM,L3264B,L3264W,ISTOP,IER) C WTHOL2 HAS STOPS, BUT ONLY IER=0 RETURN. THIS IS NOT C USED IN OPERATIONS. ELSE CALL WTHOL3(KFILDO,IP24,ID(1,M),NDATE,CCALL,NAME,XDATA,ND1, 1 LTAG,LNDSEA,ELEV,WHOLD,LTAGWH,LOCWH,XP,YP, 2 DUMCAL,XLAPSE,NSTA, 3 CPNDFD,SEALND,TELEV,NXE,NYE,MESHE,NCLIPY, 4 NX,NY,MESH,SEED,NWITH,IEXTRA, 5 NROUGH,RELVAR,VARTAB(1,NAREA), 6 ERRANL,ID2,IDIM,L3264B,L3264W,ISTOP,IER) C WTHOL2 HAS STOPS, BUT ONLY IER=0 RETURN. THIS IS NOT C USED IN OPERATIONS. ENDIF C ENDIF C C AT THIS POINT, P( ) CONTAINS THE FIRST GUESS, AND XDATA( ,1,J) C CONTAINS THE DATA TO ANALYZE. NOTE THAT THE TYPE OF FIRST C GUESS IS USED TO REDUCE THE DIMENSIONALITY OF SEVERAL VARIABLES, C AND THE MONTH, JDATE(2), IS FURTHER USED TO REDUCE THE C DIMENSIONALITY OF ER1( , , ). C C USE SKPRW2 WRITE THE CALL LETTERS RECORD ON DISPOSABLE C FILES. RECORDS ARE NOT SKIPPED ON THESE DISPOSABLE FILES. C INITIALIZATION IS DONE FOR ICOMPT = 1 EVEN THOUGH DATA C RECORDS MAY NOT BE WRITTEN, BECAUSE A TRAILER IS. ALSO, C IN CASE DATA RECORDS ARE WRITTEN, THAT WILL BE OK. C 3436 IF(KFILOV.NE.0)THEN KCHECK=1 KWRITE=1 C SINCE RECORDS ARE NOT TO BE SKIPPED, KCHECK AND KWRITE C DON'T MATTER. MSKIP=0 WRITE(KFILDO,3437)OUTVEC 3437 FORMAT(/' INITIALIZE FILE ',A60) CALL SKPWR2(KFILDO,KFILOV,MSKIP,KWRITE,KCHECK, 1 CCALL,ND1,NSTASV, 2 CCALLD,ND5,IPACK,ND5, 3 MTOTBY,MTOTRC,L3264B,L3264W,IER) C IF(IER.NE.0)THEN WRITE(KFILDO,3438) 3438 FORMAT(/,' ****FILE KFILOV COULD NOT BE INITIALIZED', 1 ' WITH CALL LETTERS. WRITING TO KFILOV', 2 ' WILL NOT BE DONE. PROCEEDING.') ISTOP(1)=ISTOP(1)+1 KFILOV=0 MER=MER+1 ENDIF C ENDIF C IF(KFILQC.NE.0)THEN KCHECK=1 KWRITE=1 C SINCE RECORDS ARE NOT TO BE SKIPPED, KCHECK AND KWRITE C DON'T MATTER. MSKIP=0 WRITE(KFILDO,3440)OUTQCV 3440 FORMAT(/' INITIALIZE FILE ',A60) CALL SKPWR2(KFILDO,KFILQC,MSKIP,KWRITE,KCHECK, 1 CCALL,ND1,NSTASV, 2 CCALLD,ND5,IPACK,ND5, 3 ITOTBY,ITOTRC,L3264B,L3264W,IER) C IF(IER.NE.0)THEN WRITE(KFILDO,3441) 3441 FORMAT(/,' ****FILE KFILQC COULD NOT BE INITIALIZED', 1 ' WITH CALL LETTERS. WRITING TO KFILQC', 2 ' WILL NOT BE DONE. PROCEEDING.') ISTOP(1)=ISTOP(1)+1 KFILQC=0 MER=MER+1 ENDIF C ENDIF C IF(ICOMPT(M).EQ.1)GO TO 3465 C C WRITE XLAPSE( ) TO INTERNAL STORAGE. C LD(1)=(ITABLE(1,2)/100)*100+IDPARS(4,M) LD(2)=980000 C LD(2) INDICATES THIS IS LAPSE RATES. LD(3)=ITABLE(3,2)+IDPARS(12,M) LD(4)=ITABLE(4,2) CALL PRSID1(KFILDO,LD,LDPARS) C PRSID1 FILLS LDPARS( ) ACCORDING TO LD( ). C IF(IP18.NE.0.AND.JP(3,M).NE.0)THEN WRITE(IP18,3443) 3443 FORMAT(/' COMPUTED LAPSE RATES WRITTEN TO FILE KFIL10.') ENDIF C CALL GSTORE(KFILDO,KFIL10,LD,0,LSTORE,ND9,LITEMS, 1 XLAPSE,NSTA,1,0,NDATE, 2 CORE,ND10,LASTL,NBLOCK,LASTD,NSTORE,L3264B,IER) C "NSLAB" IS STORED AS ZERO SIGNIFYING VECTOR DATA. C IF(IER.EQ.0)THEN C IF(IP16.NE.0)THEN RACK(1:32)=PLAIN(M)(1:32) RACK(27:32)='XLAPSE' WRITE(IP16,3444)(LD(JJ),JJ=1,4), 1 RACK,NDATE 3444 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 MER=MER+1 C WRITING ERROR IS NOT CONSIDERED FATAL. IF DATA ARE C NEEDED AND CANNOT BE READ, IT MAY BE FATAL. WRITE(KFILDO,3445)(LD(JJ),JJ=1,4) 3445 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.') ENDIF C C PACK AND WRITE THE VECTOR DATA IN XLAPSE( ) CONTAINING C THE COMPUTED LAPSE RATES WHEN KFILOV NE 0 AND WHEN C IBKPN NE 99. C IF(KFILOV.NE.0.AND.IBKPN.NE.99)THEN C DON'T WRITE WHEN KFILOV = 0 C C LAPSE REATES ARE USUALLY THOUSANDTHS. SCALE FOR C PLOTTING. C DO 3448 K=1,NSTA FD4(K)=NINT(XLAPSE(K)*1000.) 3448 CONTINUE C XMISSP=9999.0 XMISSS=0. C LD(1)=(ITABLE(1,2)/100)*100+IDPARS(4,M) LD(2)=980000 C LD(2) INDICATES THIS IS LAPSE RATES. LD(3)=ITABLE(3,2)+IDPARS(12,M) LD(4)=ITABLE(4,2) CALL PRSID1(KFILDO,LD,LDPARS) C PRSID1 FILLS LDPARS( ) ACCORDING TO LD( ). C IF(IP18.NE.0.AND.JP(3,M).NE.0)THEN WRITE(IP18,3449) 3449 FORMAT(/' COMPUTED LAPSE RATES WRITTEN TO FILE KFILOV.') ENDIF C C MEANINGFUL PRECISION OF DATA ARE GENERALLY THOUSANDTHS. C ROUND TO THOUSANDTHS FOR PLOTTING. C ISCLAP=0 ISCALE=0 C CCCC WRITE(KFILDO,9449)LD,ND1,NSTA,ND2X3,ND5, CCCC 1 (CCALL(K,1),FD4(K),K=1,100) CCCC 9449 FORMAT(/' AT 9449 IN U405A--LD,ND1,NSTA,ND2X3,ND5,', CCCC 1 '(CCALL(K,1),FD4(K),K=1,100)',4I11,4I7/ CCCC 2 (5(' ',A8,F8.2))) C CALL PACKV(KFILDO,KFILOV,LD,LDPARS, 1 JP,ISCLAP,ISCALE,IPLAIN(1,1,M),PLAIN(M), 2 NDATE,JDATE(1),JDATE(2),JDATE(3),JDATE(4), 3 CCALL,FD5,FD4,ND1,NSTASV,IPACK,ND5,MINPK, 4 IS0,IS1,IS2,IS4,ND7,XMISSP,XMISSS, 5 IP18,NWORDS,MTOTBY,MTOTRC, 6 L3264B,L3264W,ISTOP,IER) C IP18 IS USED TO LIST VALUES. IF THERE WAS AN ERROR, IT C IS COUNTED BY ISTOP, BUT IS NOT CONSIDERED FATAL. C IF(IER.NE.0)THEN MER=MER+1 ENDIF C IF(IP16.NE.0)THEN WRITE(IP16,3450)(LD(JJ),JJ=1,4), 1 RACK,NDATE 3450 FORMAT(/' WRITING DATA TO UNIT KFILOV',3I10.9,I10.3,3X, 1 A32,' FOR DATE',I12) ENDIF C ENDIF C C PACK AND WRITE THE VECTOR DATA IN XDATA( ,1) TO KFILOV. C THIS IS SO THE FULL DATA SET, INCLUDING ANY POSSIBLE C THROWOUTS, IS AVAILABLE FOR PLOTTING. ON THIS FILE, C IT WILL HAVE THE NORMAL ID FOR THE VARIABLE WRITTEN. C IF(KFILOV.NE.0)THEN C DON'T WRITE WHEN KFILOV = 0 XMISSP=9999.0 XMISSS=0. C IF(IP18.NE.0.AND.JP(3,M).NE.0)THEN WRITE(IP18,3451) 3451 FORMAT(/' FULL DATA SET WRITTEN TO FILE KFILOV.') ENDIF C ISCLAP=0 ISCALE=0 LD(1)=(ITABLE(1,2)/100)*100+IDPARS(4,M) LD(2)=ID(2,M) LD(3)=ITABLE(3,2)+IDPARS(12,M) LD(4)=ITABLE(4,2) C THE DATA, A REDUCED SET TO INCOMING, HAS THE SAME ID. CALL PRSID1(KFILDO,LD,LDPARS) C PRSID1 FILLS LDPARS( ) ACCORDING TO LD( ). C CALL PACKV(KFILDO,KFILOV,LD,LDPARS, 1 JP,ISCLAP,ISCALE,IPLAIN(1,1,M),PLAIN(M), 2 NDATE,JDATE(1),JDATE(2),JDATE(3),JDATE(4), 3 CCALL,FD5,XDATA,ND2X3,NSTASV,IPACK,ND5,MINPK, 4 IS0,IS1,IS2,IS4,ND7,XMISSP,XMISSS, 5 IP18,NWORDS,MTOTBY,MTOTRC, 6 L3264B,L3264W,ISTOP,IER) C IP18 IS USED TO LIST VALUES. IF THERE WAS AN ERROR, C IT IS COUNTED BY ISTOP, BUT IS NOT CONSIDERED FATAL. C IF(IER.NE.0)THEN MER=MER+1 ENDIF C IF(IP16.NE.0)THEN WRITE(IP16,3452)(LD(JJ),JJ=1,4), 1 ((IPLAIN(I,JJ,M),I=1,L3264W),JJ=1,4),NDATE 3452 FORMAT(/' WRITING DATA TO UNIT KFILOV',3I10.9,I10.3, 1 3X,8A4,' FOR DATE',I12) ENDIF C ENDIF C C WRITE XDATA( ,1,1) TO INTERNAL STORAGE. THIS IS THE C AUGMENTED WIND SPEED DATA FOR USE AS BASE IN TOTAL WIND. C LD(1)=ID(1,M) LD(2)=950000 LD(3)=ID(3,M) LD(4)=ID(4,M) CALL GSTORE(KFILDO,KFIL10,LD,0,LSTORE,ND9,LITEMS, 1 XDATA(1,1,1),NSTA,1,0,NDATE, 2 CORE,ND10,LASTL,NBLOCK,LASTD,NSTORE,L3264B,IER) C "NSLAB" IS STORED AS ZERO SIGNIFYING VECTOR DATA. C THE RECORD WRITTEN WILL HAVE THE SAME ID AS THE C GRID EXCEPT THE 2ND WORD = 950000. C IF(IER.EQ.0)THEN C IF(IP16.NE.0)THEN RACK(1:32)=PLAIN(M)(1:32) RACK(28:32)='XDATA' WRITE(IP16,3453)(LD(JJ),JJ=1,4), 1 RACK,NDATE 3453 FORMAT(/' WRITING DATA TO UNIT KFIL10',3I10.9,I10.3,3X, 1 A32,' FOR DATE',I12) ENDIF C C*********************************************** C WRITE(KFILDO,2001)NDATE,((LSTORE(L,M),L=1,12),M=1,LITEMS) C 2001 FORMAT(/' LSTORE IN U405 AT 2001 FOR DATE',I12/ C 1 (' ',3I10,I11,2I8,I3,I12,2I3,I5,I12)) C*********************************************** ELSE C A DIAGNOSTIC WILL HAVE OCCURRED IN GSTORE. ISTOP(1)=ISTOP(1)+1 JER=JER+1 WRITE(KFILDO,3454)(LD(JJ),JJ=1,4) 3454 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.') ENDIF CCCC WRITE(KFILDO,9163)(P(IXY),IXY=1,NY) CCCC 9163 FORMAT(/,' IN U405A AT 9163--P(IXY)',/,(15F8.2)) C CALL BCD5(KFILDO,KFILOG,KFILRA,RACESS,NUMRA,KFILOV,KFILQC, 1 IP14,IP16,IP17,IP18,IP19,IP20,IP21,IP22,I405ADG, 2 ID(1,M),IDPARS(1,M),JP(1,M),IVRBL,MODNO, 3 ISCALD(M),JFIRST(IVRBL), 4 NDATE,JDATE,XDATA(1,1,J),CCALL,NAME,XP,YP,XYP, 5 STALAT,STALON,XPL,YPL,XPE,YPE,SDATA, 6 TOSS,QUEST,LTAG,LNDSEA,ELEV,QUALST, 7 LAPFG,XLAPSE,ULAPSE,LAPUDB,TELL,TELH,ATEL,BTEL, 8 VRAD,NSTA,NBASTA,ND1,ISETP,LTAGPT,MTAGPT,ILS, 9 WTWTL,WTLTW,HGTTHA,HGTTHB, A P,FD2,FD3,FD4,FD5,FD6,ND2X3,NX,NY, B IPACK,DATA,IWORK,ND5,MINPK, C TELEV,SEALND,CPNDFD,NXE,NYE,MESHE,EMESH, D IS0,IS1,IS2,IS4,ND7, E ITABLE(1,2),IPLAIN(1,1,M),PLAIN(M),PLAINT,IPLANT, F NAREA,ALATL,ALONL,NPROJ,ORIENT, G MESH,MESHB,MESHL,XLAT, H MSHPAS(1,MGUESS),ER1(1,MGUESS,JDATE(2)), I NTYPE(1,MGUESS),B(1,MGUESS),CSTSM,R(1,MGUESS), J RSTAR(1,MGUESS),LNDWAT(1,MGUESS),ITRPLQ(1,MGUESS), K IALGOR(1,MGUESS),ELCORR(1,MGUESS),IBKPN,BK(1,MGUESS), L ELCORU(1,MGUESS),IFCOR(1,MGUESS),RWATO,RWATI,IVRAD, M TLOD,SETLOD,THID,SETHID,CONSTD,NSCALD,EX1D,EX2D, N IALOC,ADIST,AELEV,ND13,N4P,NSHLN,ICUB, O NSMTYP,U,V,WNDWT(1,MGUESS),WNDGRD,WNDTHR,WNDTRN, P NPRT,JPRT,NTDL,JTDL,NPASS,NREP,NREPNO,MGUESS, Q ERRADJ,NPASSP,NPASSF,NSMNUM,NPASRR,NPASSR,IORST, R NCLIP,PREPRO,NOPRE, S NOPTN,DIFFA,NOCEAN,LAKE,DISTX,DPOWER,WTAUG,RAY,LH, T CINT,ORIGIN,SMULT,SADD,TITLE,IOPT,POSTDS,NOPROD, U JTOTBY,JTOTRC,MTOTBY,MTOTRC,ITOTBY,ITOTRC,NOTOSS, V L3264B,L3264W,ISTOP,IER) JER=JER+IER C CCCC WRITE(KFILDO,9998)JER,MER,IER CCCC 9998 FORMAT(/' AT 9998--JER,MER,IER=',3I4) CCCCC IER IS RETURNED AS THE NUMBER OF ERRORS IN BCD5. CCCC WRITE(KFILDO,9164)(P(IXY),IXY=1,NY) CCCC 9164 FORMAT(/,' IN U405A AT 9164--P(IXY)',/,(15F8.2)) C C SAVE MESH, NX, AND NY. THESE ARE THE 4TH PASS VALUES C FROM BCD5 AND SHOULD BE THE VALUES NEEDED FOR A COMPUTED C VARIABLE THAT DOES NOT REQUIRE ENTERING FSTGS5 (WHERE MESH, C NX, AND NY ARE NORMALLY SET). C MESHSV=MESH NXSV=NX NYSV=NY C C DO A LOGIT SPLICE IF NECESSARY. C DO_9349: DO 9349 NN=1,NPRO C IF(POSTAR(NN).EQ.'LGTVSP')THEN C FETCH THE FIRST GUESS TO SPLICE WITH THE ANALYSIS. LD(1)=ID(1,N) LD(2)=ID(2,N)+99*10000 LD(3)=ID(3,N) LD(4)=ID(4,N) CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,FGFULL,NX*NY, 2 NWORDS,NPACK,NDATE,NTIMES,CORE,ND10, 3 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B,1,IER) IF(IER.NE.0)THEN WRITE(KFILDO,9341)(LD(L),L=1,4) 9341 FORMAT(/,' ****COULDN''T FETCH GRID ',4I10, C 1 ' FROM INTERNAL STORAGE IN U405A.',/, 2 ' LOGIT SPLICE NOT DONE.') ISTOP(1)=ISTOP(1)+1 ISTOP(3)=ISTOP(3)+1 IER=666 C NOT COUNTED AS FATAL, BUT FLAGGED AS A PROBLEM. EXIT DO_9349 ENDIF C PROB1=TLOA(NN) LAP=NINT(SETLOA(NN)) C PROB1 AND LAP COME IN VIA LGTVSP. C CALL LGTVSP(KFILDO,P,FGFULL,SEALND,NX,NY,PROB1,LAP,IER) C THE SPLICE IS COMPLETE. MORE THAN ONE CAN BE DONE IN C LGTVSP, BUT SURROUNDING ONE AREA. ENDIF C 9349 END DO DO_9349 C C WHEN NWITH NE 0 AND IP24 NE 0, COMPUTE THE FIT AT THE C WITHHELD STATIONS, THE NON-WITHHELD STATIONS, AND THE TOTAL C SET. THE OUTPUT IS TO IP24 WITHIN THE ROUTINE; C NO RETURN DATA ARE PROVIDED. C IF(IP24.NE.0.AND.ITYPR.EQ.1.AND.NWITH.NE.0)THEN CALL FITWTH(KFILDO,IP24,ID(1,M),NDATE,CCALL,XP,YP, 1 XDATA(1,1,J),ND1,WHOLD,LNDSEA,ELEV,NSTA,NWITH, 2 P,NX,NY,MESH,SEALND,NXE,NYE,MESHE,N4P,ISTOP,IER) C FITWTH HAS STOPS, BUT IS NOT USED IN OPERATIONS. C IF(IER.NE.0)THEN ISTOP(1)=ISTOP(1)+1 MER=MER+1 ENDIF C CALL RESTRW(KFILDO,XDATA(1,1,J),WHOLD,LTAG,LTAGWH,NSTA,IER) C THERE IS NO IER NON-ZERO RETURN FROM RESTRW. C ELSEIF(IP24.NE.0.AND.(ITYPR.EQ.2.OR.ITYPR.EQ.3). 1 AND.NWITH.NE.0)THEN C C COMPUTE THE DIFFERENCE BETWEEN THE DATA VALUE AND THE C ANALYZED VALUE. C CALL DIFWH(KFILDO,CCALL,XP,YP,WHOLD,LOCWH,ERRANL(1,IDIM), 1 LNDSEA,NWITH,IEXTRA,NSTA, 2 P,NX,NY,MESH,SEALND,NXE,NYE,MESHE,N4P, 3 ISTOP,IER) C THERE IS NO IER NON-ZERO RETURN FROM DIFWH. C WRITE(KFILDO,3455)NDATE, 1 ((ERRANL(K,JJ),JJ=1,20),K=1,NWITH) 3455 FORMAT(/' THE PREDICTORS AND PREDICTAND FOR DATE',I12,/, 1 (18F6.1,2F8.1)) C C RESTORE THE WITHHELD DATA. C CALL RESTWH(KFILDO,XDATA(1,1,J),LTAG,NSTA, 1 WHOLD,LTAGWH,LOCWH,NWITH,IER) C THERE IS NO IER NON-ZERO RETURN FROM RESTRW. C C PACK AND WRITE THE DATA FOR ERROR ANALYSIS THAT ARE C IN ERRWH( , ) TO FTN24. C XMISSP=9999.0 XMISSS=0. C DO 3457 JJ=1,IDIM ISCLAP=3 C PACK TO 3 DECIMAL PLACES. ISCALE=0 LD(1)=ITABLE(1,2) C NOTE THAT NO MODEL NUMBER IS USED. LD(2)=ID2(JJ) C THE 2ND WORD HAS BEEN FORMED IN WTHOL2. C 97 IN LD(2) INDICATES THIS IS THE ERROR VARIABLES, C AND A SEQUENCE NUMBER PRECEDES THAT. FOLLOWING THE 97 C ARE FOUR DIGITS WHICH WAS THE UUUU POSITION. THIS ASSUMES C THE ORIGINAL VARIABLE IN LD(2) = 0. THREE DIGITS ARE C LEFT FOR SEQUENCING, SO THE NUMBER OF WITHHELD COULD C GO UP TO 999. LD(3)=ITABLE(3,2)+IDPARS(12,M) LD(4)=ITABLE(4,2) CALL PRSID1(KFILDO,LD,LDPARS) C PRSID1 FILLS LDPARS( ) ACCORDING TO LD( ). C CALL PACKV(KFILDO,IP24,LD,LDPARS, 1 JP,ISCLAP,ISCALE,IPLAIN(1,1,M),PLAIN(M), 2 NDATE,JDATE(1),JDATE(2),JDATE(3),JDATE(4), 3 DUMCAL,FD5,ERRANL(1,JJ),ND1,NWITH+IEXTRA,IPACK,ND5,MINPK, 4 IS0,IS1,IS2,IS4,ND7,XMISSP,XMISSS, 5 IP18,NWORDS,KTOTBY,KTOTRC, 6 L3264B,L3264W,ISTOP,IER) C IP18 IS USED TO LIST VALUES. IF THERE WAS AN ERROR, C IT IS COUNTED BY ISTOP, BUT IS NOT CONSIDERED FATAL. C IF(IER.NE.0)THEN MER=MER+1 ENDIF C IF(IP16.NE.0)THEN WRITE(IP16,3456)(LD(JJJ),JJJ=1,4), 1 ((IPLAIN(I,JJJ,M),I=1,L3264W),JJJ=1,4),NDATE 3456 FORMAT(/' WRITING DATA TO FL withheld',3I10.9,I10.3, 1 3X,8A4,' FOR DATE',I12) ENDIF C 3457 CONTINUE C ENDIF C C WRITE LTAG( ) TO INTERNAL STORAGE WHEN IWRITS = 2 OR 3. C THIS CAN BE USED BY A FOLLOWING ANALYSIS TO INDICATE C WHAT WAS TOSSED BY THIS ANALYSIS (E.G., U- AND V-WIND C PROBABLY SHOULDN'T USE AN OBSERVATION THAT WAS TOSSED C FOR SPEED. C IF(IWRITS(M).EQ.2.OR.IWRITS(M).EQ.3)THEN C C INTEGER ARRAY LTAG( ) MUST BE MADE REAL FOR STORING C IN INTERNAL STORAGE. C DO 3460 K=1,NSTA DATA(K)=LTAG(K) C VALUES IN LTAG( ) THAT ARE NOT USED ON THIS PASS ARE C -1. THE ONES THAT HAVE BEEN DISCARDED PREVIOUSLY, C EITHER BECAUSE THEY ARE OUTSIDE THE GRID, ARE MISSING, C OR HAVE BEEN PREVIOUSLY TOSSED HAVE LTAG( ) = 4. 3460 CONTINUE C CCCC WRITE(KFILDO,3461)(K,CCALL(K,1),DATA(K),K=1,NSTA) CCCC 3461 FORMAT(/'AT 3461 IN U405A--K,CCALL(K,1),DATA(K)'/ CCCC 1 (I7,2X,A8,F7.1)) CCC LD(1)=ID(1,M) LD(1)=(ITABLE(1,2)/1000000)*1000000+IDPARS(2,M)*1000 1 +IDPARS(3,M)*100+IDPARS(4,M) C THIS ID FOR WRITING LTAG( ) IS THE SAME AS THE ID C FOR THE ANALYSIS EXCEPT THE CCC IS FOR THE INPUT C DATA. THE ID IS THE SAME AS WRITTEN IN BCD5, EXCEPT C WORD 2 IS 970000 VICE 940000. LD(2)=970000 LD(3)=ID(3,M) LD(4)=ID(4,M) CALL GSTORE(KFILDO,KFIL10,LD,0,LSTORE,ND9,LITEMS, 1 DATA,NSTA,1,0,NDATE, 2 CORE,ND10,LASTL,NBLOCK,LASTD,NSTORE,L3264B,IER) C "NSLAB" IS STORED AS ZERO SIGNIFYING VECTOR DATA. C THE RECORD WRITTEN WILL HAVE THE SAME ID AS THE C GRID EXCEPT THE 2ND WORD = 970000. C IF(IER.EQ.0)THEN C IF(IP16.NE.0)THEN RACK(1:32)=PLAIN(M)(1:32) RACK(29:32)='LTAG' WRITE(IP16,3462)(LD(JJ),JJ=1,4), 1 RACK,NDATE 3462 FORMAT(/' WRITING DATA TO UNIT KFIL10',3I10.9,I10.3,3X, 1 A32,' FOR DATE',I12) WRITE(KFILDO,3462)(LD(JJ),JJ=1,4), 1 RACK,NDATE C WRITE DIAGNOSTIC TO KFILDO. ENDIF C ELSE C A DIAGNOSTIC WILL HAVE OCCURRED IN GSTORE. ISTOP(1)=ISTOP(1)+1 MER=MER+1 WRITE(KFILDO,3463)(LD(JJ),JJ=1,4) 3463 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.') ENDIF C ENDIF C C COMPUTED VARIABLES ARE PUT HERE SO THEY WILL BE CLIPPED C AND WRITTEN TO INTERNAL STORAGE (IF DESIRED). C 3465 IF(ICOMPT(M).NE.0)THEN C WHEN ICOMPT( ) NE 0, MESH, NX, AND NY HAVE NOT BEEN SET. C DO 3468 NN=1,NOPROA C IF(POSTAR(NN).EQ.'DIRSPD')THEN CALL DIRSPD(KFILDO,KFIL10,KFILIO,IP16,KFILRA,RACESS,NUMRA, 1 ID,IDPARS,JD,ISCALD,IWRITS,ITABLE,JVAL,MODNO, 2 IPLAIN,PLAIN,ND4,M, 3 P,FD3,FD4,FD2,NX,NY, 4 ALATL,ALONL,NPROJ,ORIENT,XLAT, 5 MESHB,BMESH,MESH, 6 CPNDFD,NXE,NYE,MESHE,NCLIP,NCLIPY, 7 LSTORE,ND9,LITEMS,NDATE,JDATE, 8 IS0,IS1,IS2,IS4,ND7, 9 IPACK,IWORK,DATA,ND5, A CORE,ND10,NBLOCK,NFETCH,NSLAB, B NTOTBY,NTOTRC,NTOTGB,NTOTGR, C MINPK,L3264B,L3264W,ISTOP,IER) C THIS IS TO POSTPROCESS U- AND V-WIND AND SPEED FOR U155. C PERFORMS THE FOLLOWING: C 1) CALCULATES DIRECTION FROM U AND V C 2) SETS DIRECTION AND SPEED TO ZERO WHEN BOTH C U AND V LT 0.1 KT. C 3) SETS DIRECTION AND SPEED TO ZERO WHEN C SPEED .LT 1.0 KT. C 4) SETS DIRECTION TO 0 WHEN SPEED = LE 1. C IF(IER.NE.0)THEN JER=JER+1 ENDIF C IF(JER.NE.0)THEN GO TO 500 ELSE GO TO 3469 ENDIF C C ONLY ONE COMPUTATION ROUTINE IS ALLOWED HERE. C ELSEIF(POSTAR(NN).EQ.'QPF6P6')THEN CALL QPF6P6(KFILDO,KFIL10,P,FD4,FD5,NX,NY,ND2X3,TLOA(NN), 1 ID(1,M),LSTORE,ND9,LITEMS,NWORDS,NDATE, 2 IS0,IS1,IS2,IS4,ND7, 3 IPACK,IWORK,ND5, 4 CORE,ND10,NBLOCK,NFETCH,L3264B,ISTOP,IER) C THE ABOVE COMPUTES THE 12-H QPF FROM THE TWO 6-H QPFS C COVERING THE SAME PERIOD. C IF(IER.NE.0)THEN JER=JER+1 ENDIF C IF(JER.NE.0)THEN GO TO 500 ELSE GO TO 3469 ENDIF C C ONLY ONE COMPUTATION ROUTINE IS ALLOWED HERE. ELSE WRITE(KFILDO,3467)POSTAR(NN) 3467 FORMAT(/' ****POSTPROCESSING ROUTINE SPECIFIED', 1 ' IN U405A.CN FILE = ',A6,' FOR COMPUTING', 2 ' GRIDS NOT AVAILABLE IN U405A',/, 3 ' OR NONE SPECIFIED.') C A ROUTINE MUST BE AVAILABLE AND USED WHEN ICOMPT( ) NE 0. ISTOP(1)=ISTOP(1)+1 JER=JER+1 GO TO 400 ENDIF C 3468 CONTINUE C ENDIF C C PREPARE FOR PACKING AND WRITING DATA. THERE ARE FOUR C POSSIBLE FORMS, THE FIRST 3 ARE GRIDS AND THE 4TH IS VECTOR: C (1) - INTERNAL STORAGE (WHEN IWRITS(M) =1 OR 3 AND C KFIL10 NE 0). THIS IS USED ONLY IF THE VARIABLE IS C NEEDED FOR COMPUTATION WITH ANOTHER VARIABLE C (E.G., POSTPROCESSING). KFIL10 IS UNIVERSAL FOR C THE RUN, BUT IWRITS(M) IS READ FROM U155.CN WITH C EACH VARIABLE. C (2) - SEQUENTIAL (ARCHIVE)(WHEN KFILIO NE 0). C (3) - RANDOM ACCESS (ARCHIVE) (WHEN KFILRA( ) EQ 42). C (4) - ASCII FOR GMOS_PLOT (WHEN KFILVO NE 0). C THE FIRST THREE OF THESE INDEPENDENTLY PACK THE DATA WITH C PACK2D, SO WRITE ONLY WHAT IS NECESSARY. UNDOUBTEDLY, C AT LEAST ONE OF THESE WILL BE WRITTEN. USUALLY (1) WILL C NOT BE NECESSARY AND ONLY ONE OF (2) OR (3). C 3469 ITAUM=0 NSEQ=0 NCHAR=32 C 32 CHARACTERS OF PLAIN LANGUAGE ARE PACKED. XMISSP=9999. XMISSS=0. C THESE ARE ANALYSES, BUT THERE MAY BE MISSING VALUES C NEAR THE BORDERS, SO SET XMISSP = 9999. NOTE THAT THE C ID IN ID( ,N) IS USED, WHICH WOULD NORMALLY HAVE THE C SMOOTHING VARIABLE S = 0, NO MATTER WHETHER THE ANALYSIS C HAS BEEN SMOOTHED OR NOT. C C PACK THE ANALYSIS AT THE MESH LENGTH = MESH, WHICH WILL BE C MSHPAS( , ) FOR THE LAST PASS, WHEN EITHER IWRITS(M) = 1 OR 3 C OR KFILIO NE 0. THIS WILL BE AT THE UNITS ANALYZED, C NOT POSTPROCESSED FOR ARCHIVAL. C IF(IWRITS(M).EQ.1.OR.IWRITS(M).EQ.3)THEN D WRITE(KFILDO,347)ALATL,ALONL,MESH,MESHB,NX,NY,NPROJ D347 FORMAT(/' AT 347 IN U405A--ALATL,ALONL,MESH,MESHB,NX,NY,NPROJ', D 1 2F10.5,5I6) C C GSTORE WRITES TO INTERNAL STORAGE ON FILE KFIL10 WHEN C IWRITS(M) =1 OR 3. MESH LENGTH IS MESH, THAT USED FOR C THE LAST PASS, BUT THE DATA ARE NOT PACKED AND NOT C TREATED AS PACKED GRIDDED DATA. NOTE THAT THIS IS NOT C CLIPPED AS IT MAY BE FOR OUTPUT TO OTHER MEDIA. C THIS TO ALLOW FOR THE POSSIBILITY IT IS TO BE USED FOR C COMPUTATION WITH ANOTHER GRID THAT MAY NOT BE TIGHTLY C CLIPPED. C LD(1)=ID(1,M) LD(2)=ID(2,M) LD(3)=ID(3,M) LD(4)=ID(4,M) CALL GSTORE(KFILDO,KFIL10,LD,0,LSTORE,ND9,LITEMS, 1 P,NX*NY,1,0,NDATE, 2 CORE,ND10,LASTL,NBLOCK,LASTD,NSTORE,L3264B,IER) C "NSLAB" IS STORED AS ZERO SIGNIFYING THE DATA ARE NOT C PACKED AND CAN BE TREATED AS VECTOR DATA. C IF(IER.EQ.0)THEN C IF(IP16.NE.0)THEN WRITE(IP16,3475)(ID(JJ,M),JJ=1,4), 1 ((IPLAIN(I,JJ,M),I=1,L3264W),JJ=1,4),NDATE 3475 FORMAT(/' WRITING DATA TO UNIT KFIL10',3I10.9,I10.3,3X, 1 8A4,' FOR DATE',I12) ENDIF C ELSE C A DIAGNOSTIC WILL HAVE OCCURRED IN PAWLPM. ISTOP(1)=ISTOP(1)+1 MER=MER+1 WRITE(KFILDO,348)(ID(JJ,M),JJ=1,4) 348 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.') ENDIF C ENDIF C C THE GRID TO WRITE IN P( , ) IS AT MESH LENGTH MESH, WHICH IS C THE MESH LENGTH OF THE LAST PASS. C IF(NCLIP.EQ.1)THEN C NOTE THAT CAKSNO HAS TO BE IN ONE OF THE FIRST 3 SLOTS. C DO 3482 NN=1,NOPROA C IF(POSTAR(NN).EQ.'CAKSNO'.AND.NAREA.EQ.2)THEN C THE ALASKA SNOW GRIDS HAVE A SPECIAL CLIPPING MASK. C IT IS ACCESSED AND CLIPPING IS DONE IN CAKSNO. C OTHER ALASKA GRIDS CAN USE THE SAME CLIPPING C PROVIDED ROUTINE CAKSNO IS PROVIDED IN POSTAR( ). JBDUM=0 JTDUM=0 C THE NUMBER OF INPUT BYTES OR RECORDS FROM THIS C SPECIALIZED CLIPPING GRID ARE NOT COUNTED. CALL CAKSNO(KFILDO,KFILOG,KFILRA,RACESS,NUMRA, 1 IP16,IP22,FD4,ND2X3, 2 P,NX,NY,MESH,IPACK,DATA,IWORK,ND5, 3 MODNO,NDATE,PLAINT,IPLANT, 4 ALATL,ALONL,NPROJ,ORIENT,XLAT,IOPTB, 5 NXE,NYE,MESHE,EMESH,MESHL, 6 IS0,IS1,IS2,IS4,ND7, 7 JBDUM,JTDUM, 8 L3264B,L3264W,MINPK,ISTOP(1),IER) C IER = 0 UPON RETURN. IF THE GRID COULD NOT BE CLIPPED, C A DIAGNOSTIC IS PROVIDED AND ISTOP(1) IS INCREASED. GO TO 3521 C ELSEIF(POSTAR(NN).EQ.'CCONSN'.AND.NAREA.EQ.1)THEN C THE CONUS SNOW GRIDS HAVE A SPECIAL CLIPPING MASK. C IT IS ACCESSED AND CLIPPING IS DONE IN CCONSN. C OTHER CONUS GRIDS CAN USE THE SAME CLIPPING C PROVIDED ROUTINE CCONSN IS PROVIDED IN POSTAR( ). CALL CCONSN(KFILDO,KFILOG,KFILRA,RACESS,NUMRA, 1 IP16,IP22,FD4,ND2X3, 2 P,NX,NY,MESH,IPACK,DATA,IWORK,ND5, 3 MODNO,NDATE,PLAINT,IPLANT, 4 ALATL,ALONL,NPROJ,ORIENT,XLAT,IOPTB, 5 NXE,NYE,MESHE,EMESH,MESHL, 6 IS0,IS1,IS2,IS4,ND7, 7 JBDUM, JTDUM, 8 L3264B,L3264W,MINPK,ISTOP(1),IER) C IER = 0 UPON RETURN. IF THE GRID COULD NOT BE CLIPPED, C A DIAGNOSTIC IS PROVIDED AND ISTOP(1) IS INCREASED. GO TO 3521 ENDIF C 3482 CONTINUE C IF(NCLIPY.EQ.1)THEN C IF(MESH.EQ.MESHE)THEN C WHEN MESH = MESHE, NXE*NYE = NX*NY. THIS SHOULD C NORMALLY BE THE CASE. C WRITE(KFILDO,349) 349 FORMAT(/,' CLIPPING ARCHIVE GRID.') C DO 350 JJ=1,NX*NY C IF(CPNDFD(JJ).LT..5)THEN P(JJ)=9999. ENDIF C 350 CONTINUE C ELSE C CALL CLIP(KFILDO,P,NX,NY,MESH,CPNDFD,NXE,NYE,MESHE,IER) C WHEN MESH NE MESHE, THE DOUBLE INDEXING HAS TO BE DONE C IN A SUBROUTINE. NOTE THAT MESHE MUST NOT BE GREATER C THAN MESH. ALSO, MESH MUST BE EQUAL TO MESHE*2**M, C WHERE M IS A LOW (POSITIVE) INTEGER. C IF(IER.NE.0)THEN C A DIAGNOSTIC IS PRODUCED IN CLIP. THIS IS NOT A C FATAL ERROR, BUT THE GRID WILL NOT BE CLIPPED. ISTOP(1)=ISTOP(1)+1 ENDIF C ENDIF C ELSE WRITE(KFILDO,352) 352 FORMAT(' ****CLIPPING OF THE GRID TO NDGD AREA DESIRED', 1 ' BUT CLIPPING GRID NOT AVAILABLE. PROCEEDING.') ISTOP(1)=ISTOP(1)+1 ENDIF C 3521 IF(IER.NE.0)THEN MER=MER+1 ENDIF C ENDIF C D WRITE(KFILDO,9994)JER,MER D9994 FORMAT(/' AT 9994--JER,MER=',2I4) C C DO ANY POSTPROCESSING ON ARCHIVE OUTPUT NECESSARY. C THIS IS DONE ON THE MESH LENGTH OF THE LAST PASS. C ICKGR=0 C ICKGR IS SET GT 0 WHEN A CHANGE GRID IS PRODUCED. FOR C INSTANCE, WHEN DP > TEMP, AND DP SET = TEMP. C (THIS IS FOR CHECKOUT AND HAS NOT BEEN IMPLEMENTED IN ALL C THE SUBROUTINES.) IER=0 C DO 354 NN=1,NOPROA C C THE ORDER THE POSTPROCESSING ROTINES ARE DONE IS THE C ORDER IN THE U405A.CN FILE. C IF(POSTAR(NN).NE.' ')THEN C IF(POSTAR(NN).EQ.'POST ')THEN CALL POST(KFILDO,P,NX*NY,TLOA(NN),SETLOA(NN),THIA(NN), 1 SETHIA(NN),CONSTA(NN),NSCALA(NN),EX1A(NN),EX2A(NN), 2 IER) C THERE IS NO NONZERO IER RETURN. C IF A POSTPROCESSING ROUTINE OTHER THAN POST IS C NEEDED, PUT CHECK AND CALL HERE. C ELSEIF(POSTAR(NN).EQ.'POSTPM')THEN CALL POSTPM(KFILDO,P,NX*NY,TLOA(NN),SETLOA(NN),THIA(NN), 1 SETHIA(NN),CONSTA(NN),NSCALA(NN),EX1A(NN),EX2A(NN), 2 IER) C THERE IS NO NONZERO IER RETURN. C THE ABOVE IS FOR POSTPROCESSING VISIBILITY OBS AND LAMP C OVER THE CONUS. C ELSEIF(POSTAR(NN).EQ.'POSTVA')THEN CALL POSTVA(KFILDO,P,NX,NY,SEALND,NXE,NYE, 1 TLOA(NN),SETLOA(NN),THIA(NN),SETHIA(NN),IER) C THERE IS NO NONZERO IER RETURN. C THE ABOVE IS FOR POSTPROCESSING VISIBILITY OBS OVER C ALASKA. C ELSEIF(POSTAR(NN).EQ.'POST88')THEN CALL POST88(KFILDO,P,NX*NY,TLOA(NN),SETLOA(NN),THIA(NN), 1 SETHIA(NN),CONSTA(NN),NSCALA(NN),EX1A(NN),EX2A(NN), 2 IER) C THERE IS NO NONZERO IER RETURN. C THE ABOVE IS FOR POSTPROCESSING OBS CEILING HEIGHT WHEN C ANALYZED IN UNITS HDS FT. C ELSEIF(POSTAR(NN).EQ.'POSTCG')THEN CALL POSTCG(KFILDO,P,NX*NY,TLOA(NN),SETLOA(NN),THIA(NN), 1 SETHIA(NN),CONSTA(NN),NSCALA(NN),EX1A(NN),EX2A(NN), 2 IER) C THERE IS NO NONZERO IER RETURN. C THE ABOVE IS FOR POSTPROCESSING OBS CEILING HEIGHT WHEN C ANALYZED AS SQUARE ROOT OF HDS FT. C ELSEIF(POSTAR(NN).EQ.'OSMTH ')THEN IOCEXT=NINT(EX1A(NN)) IOCINC=NINT(EX2A(NN)) CALL OSMTH(KFILDO,P,NX,NY,MESH, 1 SEALND,NXE,NYE,MESHE, 2 IOCEXT,IOCINC,ISTOP,IER) C WHEN RETURN IER = 777, GRID IS NOT SMOOTHED. C THE ABOVE SMOOTHS THE OCEAN (ONLY) WTIH THE PARAMETERS C EX1A( ) AND EX2A( ) OVER A SQUARE 2*IOCEXT ON A SIDE. C ELSEIF(POSTAR(NN).EQ.'OSMTH1')THEN IOCEXT=NINT(EX1A(NN)) IOCINC=NINT(EX2A(NN)) CALL OSMTH1(KFILDO,P,NX,NY,MESH, 1 SEALND,NXE,NYE,MESHE, 2 IOCEXT,IOCINC,ISTOP,IER) C WHEN RETURN IER = 777, GRID IS NOT SMOOTHED. C THE ABOVE SMOOTHS THE OCEAN (ONLY) WTIH THE PARAMETERS C EX1A( ) AND EX2A( ) OVER A CIRCLE WITH RADIUS 2*IOCEXT. C ELSEIF(POSTAR(NN).EQ.'ORSMTH')THEN IOCEXT=NINT(EX1A(NN)) IOCINC=NINT(EX2A(NN)) CALL ORSMTH(KFILDO,P,NX,NY,MESH, 1 SEALND,NXE,NYE,MESHE, 2 IOCEXT,IOCINC,ISTOP,IER) C THE ABOVE SMOOTHS THE WATER (ONLY) WTIH THE PARAMETERS C IPREX1( ) AND IPREX2( ) AS RAYS FROM THE CENTER, C STOPPING WHEN A MISSING OR LAND IS ENCOUNTERED. C ELSEIF(POSTAR(NN).EQ.'ORSMTW')THEN IOCINC=NINT(SETHIA(NN)) MAXDST=NINT(THIA(NN)) NOPTN=NINT(CONSTA(NN)) DPOWER=EX1A(NN) RAY=EX2A(NN) CALL ORSMTW(KFILDO,KFILOG,IP16, 1 CCALL,XP,YP,LNDSEA,NOPTN,LTAG,LTAGPT,NSTA, 2 ID(1,M),IDPARS(1,M),P,MESH,FD4,FD5,NX,NY, 3 TELEV,SEALND,CPNDFD,NXE,NYE,MESHE, 4 IPACK,DATA,IWORK,ND5, 5 MODNO,NDATE, 6 ALATL,ALONL,NPROJ,ORIENT,XLAT,ISCALD, 7 IOCINC,DPOWER,RAY,MAXDST,CSTSM, 8 IS0,IS1,IS2,IS4,ND7, 9 JTOTBY,JTOTRC,PLAINT,IPLANT, A L3264B,L3264W,MINPK,ISTOP,IER) C WHEN RETURN IER = 777, GRID IS NOT SMOOTHED. C THE ABOVE SMOOTHS THE OCEAN (ONLY) WTIH RAYS FROM C THE CENTER, STOPPING WHEN A MISSING OR LAND IS C ENCOUNTERED. IT USES THE SPOTRM METHOD TO DETERMINE C RAY LENGTH. LTAGPT( ) INDICATES THE BOGUS STATIONS, C AND LTAG( ) INDICATES THE TOSSED DATA ON THE LAST C PASS. C ELSEIF(POSTAR(NN).EQ.'ORVWSM')THEN IOCEXT=NINT(EX1A(NN)) IOCINC=NINT(EX2A(NN)) CONSTB=NSCALA(NN) SHOREA=TLOA(NN) SHOREB=SETLOA(NN) NOL=NINT(THIA(NN)) CALL ORVWSM(KFILDO,KFIL10,P,NX,NY,MESH, 1 SEALND,NXE,NYE,MESHE,NPROJ, 2 SHOREA,SHOREB,NOL,SETHIA(NN), 3 CONSTA(NN),CONSTB,IOCEXT,IOCINC, 4 LSTORE,ND9,LITEMS,NTIMES, 5 IS0,IS1,IS2,IS4,ND7, 6 IPACK,IWORK,DATA,ND5, 7 CORE,ND10,NBLOCK,NFETCH, 8 L3264B,ISTOP,IER) C WHEN RETURN IER = 777, GRID IS NOT SMOOTHED. C THE ABOVE SMOOTHS THE OCEAN (ONLY) WTIH THE PARAMETERS C IPREX1( ) AND IPREX2( ) AS RAYS FROM THE CENTER, C STOPPING WHEN A MISSING OR LAND IS ENCOUNTERED. C SMOOTHING IS LIGHT NEAR SHORE, AND HEAVY AWAY FROM C THE COAST. C ELSEIF(POSTAR(NN).EQ.'PIXSM1')THEN ISPOT=NINT(TLOA(NN)) MTIMES=NINT(SETLOA(NN)) DIFFV=THIA(NN) DIFFB=SETHIA(NN) CALL PIXSM1(KFILDO,ID(1,M),IDPARS(1,M),JD(1,M), 1 ISPOT,MTIMES,DIFFV,DIFFB, 2 P,NX,NY,TELEV,NXE,NYE,FD4,ND2X3, 3 L3264B,ISTOP,IER) C PIXSM1 REMOVES ISOLATED PIXELS, USED WITH C MELD. ELSEIF(POSTAR(NN).EQ.'HSMTH ')THEN IOCEXT=NINT(EX1A(NN)) IOCINC=NINT(EX2A(NN)) CALL HSMTH(KFILDO,P,NX,NY, 1 IOCEXT,IOCINC,ISTOP,IER) C WHEN RETURN IER = 777, GRID IS NOT SMOOTHED. C THE ABOVE SMOOTHS ALL POINTS WTIH THE PARAMETERS C EX1A( ) AND EX2A( ). C ELSEIF(POSTAR(NN).EQ.'CKTDP ')THEN CALL CKTDP(KFILDO,KFIL10,P,FD4,FD6,NX,NY,ND2X3, 1 ID(1,M),LSTORE,ND9,LITEMS,NWORDS,NDATE, 2 IS0,IS1,IS2,IS4,ND7, 3 IPACK,IWORK,ND5, 4 CORE,ND10,NBLOCK,NFETCH,L3264B,ISTOP,IER) C NO NONZERO IER RETURN, BUT GRID MIGHT NOT BECHEKED C THE ABOVE CHECKS TO MAKE ALL DEW POINTS LE C TEMPERATURE. ICKGR=ICKGR+1 C ELSEIF(POSTAR(NN).EQ.'CKPOP ')THEN CALL CKPOP(KFILDO,KFIL10,P,FD4,FD5,FD6,NX,NY,ND2X3, 1 ID(1,M),LSTORE,ND9,LITEMS,NWORDS,NDATE, 2 IS0,IS1,IS2,IS4,ND7, 3 IPACK,IWORK,ND5, 4 CORE,ND10,NBLOCK,NFETCH,L3264B,ISTOP,IER) C NO NONZERO IER RETURN, BUT GRID MIGHT NOT BECHEKED C THE ABOVE CHECKS TO MAKE THE 12-H POP CONSISTENT C WITH THE TWO 6-H POPS COVERING THE SAME PERIOD. ICKGR=ICKGR+1 C ELSEIF(POSTAR(NN).EQ.'CKQPF ')THEN CALL CKQPF(KFILDO,KFIL10,IP16,P,FD4,FD6,NX,NY,ND2X3, 1 TLOA(NN),ID(1,M),IPLAIN(1,1,M),PLAIN(M), 2 LSTORE,ND9,LITEMS,NWORDS,NDATE, 3 IS0,IS1,IS2,IS4,ND7, 4 IPACK,IWORK,ND5, 5 CORE,ND10,NBLOCK,NFETCH,L3264B,L3264W, 6 ISTOP,IER) C NO NONZERO IER RETURN, BUT GRID MIGHT NOT BECHEKED C THE ABOVE CHECKS TWO QPF FIELDS, ONE ANALYZED C WITHOUT THE LAPSE CORRECTION TO ELIMINATE UNWANTED C PERIPHERAL AREAS. VALUES GT. TLOA(NN) ARE SET TO 0. C FOR 6-H QPF (CCCFFF=223270), THE RESULT IS WRITTEN C TO INTERNAL STORAGE WITH CCCFFF = 223272. ICKGR=ICKGR+1 C ELSEIF(POSTAR(NN).EQ.'CKWNDG')THEN CALL CKWNDG(KFILDO,KFIL10,P,FD4,FD6,NX,NY,ND2X3, 1 ID(1,M),LSTORE,ND9,LITEMS,NWORDS,NDATE, 2 IS0,IS1,IS2,IS4,ND7, 3 IPACK,IWORK,ND5, 4 CORE,ND10,NBLOCK,NFETCH,L3264B,ISTOP,IER) C NO NONZERO IER RETURN, BUT GRID MIGHT NOT BECHEKED C THE ABOVE CHECKS TO MAKE ALL WND GUSTS GE C WIND SPEED. ICKGR=ICKGR+1 C ELSEIF(POSTAR(NN).EQ.'EREST ')THEN IOCEXT=NINT(CONSTA(NN)) IOCINC=NSCALA(NN) CALL EREST(KFILDO,ID(1,M),CCALL, 1 XP,YP,XDATA(1,1,J),LTAG,LNDSEA,ELEV,XLAPSE,NSTA, 2 P,FD4,FD5,FD3,NX,NY,MESH, 3 CPNDFD,SEALND,TELEV,NXE,NYE,MESHE,NCLIPY, 4 RELVAR,VARTAB(1,NAREA), 5 EX1A(NN),NINT(EX2A(NN)),NAME, 6 IOCEXT,IOCINC, 7 L3264B,L3264W,ISTOP,IER) C THE RETURN FROM EREST IS AN ESTIMATED ERROR GRID C IN FD3( , ) PERTAINING TO THE ANALYSIS BEING DONE C IN THE GRID UNITS OF THE ANALYSIS. THE ERROR GRID C WILL BE WRITTEN TO UNIT NO. KFILIO. THE ASCII DATA C WILL BE THE DATA ANALYZED (AN ERROR ESTIMATE DOES C NOT EXIST AT THE ANALYSIS POINTS, ONLY AT GRIDPOINTS) C THE ERRROR GRID CANNOT BE CALCULATED IF CPNDFD( , ) C IS MISSING, IN WHICH CASE, NCLIPY = 0. C IF(IER.NE.0)THEN C IF IER NE 0, A MISSING GRID IS RETURNED IN ERROR( , ) JER=JER+1 ENDIF C ELSEIF(POSTAR(NN).EQ.'CATEQ ')THEN C THIS IS TO MAKE SURE THE CLOSEST GRIDPOINT TO A STATION C MATCHES THE CATEGORICAL VALUE. C C***************MAY NEED TO INCLUDE LTAGPT( ) ALSO. CALL CATEQ(KFILDO,P,FD4,FD3,NX,NY, 1 CCALL,NAME,XP,YP,XDATA,LTAG,NSTA,IER) C THERE IS NO NONZERO IER RETURN. C FD3( ) IS ALSO USED IN EREST, BUT ONLY FOR TEMP/DP. C ELSEIF(POSTAR(NN).EQ.'CIGFT ')THEN CALL CIGFT(KFILDO,P,NX*NY, 1 TLOA(NN),SETLOA(NN),THIA(NN),SETHIA(NN), 2 CONSTA(NN),NSCALA(NN),EX1A(NN),EX2A(NN),IER) C THERE IS NO NONZERO IER RETURN. C THIS IS TO CHANGE LAMP CEILING HEIGHT IN CATEGORIES C TO HUNDREDS OF FT. C ELSEIF(POSTAR(NN).EQ.'SETVMI')THEN CALL SETVMI(KFILDO,P,FD4,NX,NY, 1 CCALL,NAME,XP,YP,XDATA,NSTA,IER) C THERE IS NO NONZERO IER RETURN. C THIS IS TO MAKE SURE THE CLOSEST GRIDPOINT TO A STATION C IN THE VISIBILITY ANALYSIS MATCHES THE CATEGORICAL C VALUE. C ELSEIF(POSTAR(NN).EQ.'SKYAMT')THEN CCCC WRITE(KFILDO,9165)(P(IXY),IXY=1,NY) CCCC 9165 FORMAT(/,' IN U405A AT 9165--P(IXY)',/,(15F8.2)) CALL SKYAMT(KFILDO,P,NX*NY, 1 TLOA(NN),SETLOA(NN),THIA(NN),SETHIA(NN), 2 CONSTA(NN),NSCALA(NN),EX1A(NN),EX2A(NN),IER) C THERE IS NO NONZERO IER RETURN. C THIS IS TO CHANGE LAMP SKY COVER IN CATEGORIES C TO PERCENT OF COVERAGE. C ELSEIF(POSTAR(NN).EQ.'SKYAMP')THEN CALL SKYAMP(KFILDO,P,NX*NY, 1 TLOA(NN),SETLOA(NN),THIA(NN),SETHIA(NN), 2 CONSTA(NN),NSCALA(NN),EX1A(NN),EX2A(NN),IER) C THERE IS NO NONZERO IER RETURN. C THIS IS TO CHANGE CUBE ROOT OF LAMP SKY COVER IN C PERCENT BACK TO PERCENT OF COVERAGE. C ELSEIF(POSTAR(NN).EQ.'SCALX ')THEN CALL SCALX(KFILDO,P,NX*NY,THIA(NN),NINT(SETLOA(NN)),IER) C THERE IS NO NONZERO IER RETURN. C THE ABOVE CALL TO SCALX WILL MULTIPLY THE INPUT C DATA IN P(,) BY CONST*10**NSCALE C ELSEIF(POSTAR(NN).EQ.'CONCPR')THEN CALL CONCPR(KFILDO,KFIL10,IP16,ID(1,M),IDPARS(1,M), 1 P,NX,NY, 2 LSTORE,ND9,LITEMS,NDATE, 3 IS0,IS1,IS2,IS4,ND7, 4 IPACK,IWORK,DATA,ND5, 5 CORE,ND10,NBLOCK,NFETCH,NSLAB, 6 IPLAIN(1,1,M),L3264W,L3264B,ISTOP,JER,IER) C A NON ZERO IER MAY OCCUR, IER = 666. C JER = 1 WHEN ERROR WRITING TO INTERNAL STORAGE OCCURRED. C THIS IS FOR MAKING CUMULATIVE CEILING PROBABILITY C GRIDS CONSISTENT (NON DECREASING FOR HIGHER THRESHOLDS). C THE "CONSISTENT" GRID WILL BE WRITTEN BY CONCPR WITH C IDPARS(15) = 1 SO IT WILL BE AVAILABLE FOR CHECKING C WITH THE NEXT HIGHER LEVEL. C ELSEIF(POSTAR(NN).EQ.'CONVPR')THEN CALL CONVPR(KFILDO,KFIL10,IP16,ID(1,M),IDPARS(1,M), 1 P,NX,NY, 2 LSTORE,ND9,LITEMS,NDATE, 3 IS0,IS1,IS2,IS4,ND7, 4 IPACK,IWORK,DATA,ND5, 5 CORE,ND10,NBLOCK,NFETCH,NSLAB, 6 IPLAIN(1,1,M),L3264W,L3264B,ISTOP,JER,IER) C A NON ZERO IER MAY OCCUR, IER = 666. C JER = 1 WHEN ERROR WRITING TO INTERNAL STORAGE OCCURRED. C THIS IS FOR MAKING CUMULATIVE VISIBILITY PROBABILITY C GRIDS CONSISTENT (NON DECREASING FOR HIGHER THRESHOLDS). C ELSEIF(POSTAR(NN).EQ.'CONSPR')THEN CALL CONSPR(KFILDO,KFIL10,IP16,ID(1,M),IDPARS(1,M), 1 P,NX,NY, 2 LSTORE,ND9,LITEMS,NDATE, 3 IS0,IS1,IS2,IS4,ND7, 4 IPACK,IWORK,DATA,ND5, 5 CORE,ND10,NBLOCK,NFETCH,NSLAB, 6 IPLAIN(1,1,M),L3264W,L3264B,ISTOP,JER,IER) C A NON ZERO IER MAY OCCUR, IER = 666. C JER = 1 WHEN A WRITING TO INTERNAL STORAGE OCCURRED. C THIS IS FOR MAKING CUMULATIVE SKY COVER PROBABILITY C GRIDS CONSISTENT. (NON DECREASING FOR HIGHER THRESHOLDS). C ELSEIF(POSTAR(NN).EQ.'CONEKD')THEN CALL CONEKD(KFILDO,KFIL10,ID(1,M),IDPARS(1,M), 1 P,NX,NY, 2 LSTORE,ND9,LITEMS,NDATE, 3 IS0,IS1,IS2,IS4,ND7, 4 IPACK,IWORK,DATA,ND5, 5 CORE,ND10,NBLOCK,NFETCH,NSLAB, 6 L3264B,ISTOP,IER) C A NON ZERO IER MAY OCCUR, IER = 666. C THIS IS FOR MAKING CUMULATIVE EKDMOS GRIDS CONSISTENT C (NON DECREASING FOR HIGHER PROBABILITY LEVELS). C ELSEIF(POSTAR(NN).EQ.'CKMAXT')THEN CALL CKMAXT(KFILDO,KFIL10,P,FD6,NX,NY,NAREA, 1 ID(1,M),IDPARS(1,M),LSTORE,ND9,LITEMS, 2 NWORDS,NDATE,JDATE, 3 MESH,MESHE,NCLIPY,CPNDFD,SEALND,NXE,NYE, 4 ALATL,ALONL,ORIENT,XLAT,NPROJ, 5 IS0,IS1,IS2,IS4,ND7, 6 IPACK,IWORK,ND5, 7 CORE,ND10,NBLOCK,NFETCH,L3264B,ISTOP,IER) C THERE IS NO NONZERO IER RETURN. C THIS IS FOR MAKING THE DAYTIME MAX TEMPERATURE C AT LEAST AS HIGH AS THE APPROPRIATE 3-H TEMPERATURES. C IF THERE ARE ERRORS, GRID MAY NOT BE CHECKED. ICKGR=ICKGR+1 C ELSEIF(POSTAR(NN).EQ.'CKMINT')THEN CALL CKMINT(KFILDO,KFIL10,P,FD6,NX,NY,NAREA, 1 ID(1,M),IDPARS(1,M),LSTORE,ND9,LITEMS, 2 NWORDS,NDATE,JDATE, 3 MESH,MESHE,NCLIPY,CPNDFD,SEALND,NXE,NYE, 4 ALATL,ALONL,ORIENT,XLAT,NPROJ, 5 IS0,IS1,IS2,IS4,ND7, 6 IPACK,IWORK,ND5, 7 CORE,ND10,NBLOCK,NFETCH,L3264B,ISTOP,IER) C THERE IS NO NONZERO IER RETURN. C THIS IS FOR MAKING THE NIGHTTIME MIN TEMPERATURE C AT LEAST AS LOW AS THE APPROPRIATE 3-H TEMPERATURES. C IF THERE ARE ERRORS, GRID MAY NOT BE CHECKED. ICKGR=ICKGR+1 C ELSEIF(POSTAR(NN).EQ.'CAKSNO')THEN C THE POSTPROCESSING SUBROUTINE CAKSNO HAS BEEN USED C TO CLIP THE ALASKA SNOW GRID. THIS TEST IS HERE C TO KEEP DIAGNOSTIC BELOW FROM OCCURRING. C ELSEIF(POSTAR(NN).EQ.'CCONSN')THEN C THE POSTPROCESSING SUBROUTINE CCONSN HAS BEEN USED C TO CLIP THE CONUS SNOW GRID. THIS TEST IS HERE C TO KEEP DIAGNOSTIC BELOW FROM OCCURRING. C ELSEIF(POSTAR(NN).EQ.'SKYCIG')THEN CALL SKYCIG(KFILDO,KFIL10,ID(1,M),IDPARS(1,M), 1 P,NX,NY,TLOA(NN),SETLOA(NN), 2 LSTORE,ND9,LITEMS,NDATE, 3 IS0,IS1,IS2,IS4,ND7, 4 IPACK,IWORK,DATA,ND5, 5 CORE,ND10,NBLOCK,NFETCH,NSLAB, 6 L3264B,ISTOP,IER) C A NON ZERO IER MAY OCCUR, IER = 666. C THIS IS FOR MAKING SURE THE SKY GRID IS AT LEAST C EQUAL TO CONST(NN) WHEN THERE IS A CEILING. C ELSE C IF(ICOMPT(M).EQ.0.AND.POSTAR(NN).NE.'LGTVSP')THEN C IF THIS IS A COMPUTED VARIABLE, THE ROUTINE IS C USED ABOVE. LGTVSP HAS BEEN USED AVOVE. WRITE(KFILDO,353)POSTAR(NN) 353 FORMAT(/' ****POSTPROCESSING ROUTINE SPECIFIED', 1 ' IN U405A.CN FILE = ',A6,' FOR ARCHIVE', 2 ' GRID NOT AVAILABLE IN U405A. PROCEEDING.') ISTOP(1)=ISTOP(1)+1 ENDIF ENDIF C ENDIF C IF(IER.EQ.666)THEN MER=MER+1 ELSEIF(IER.NE.0)THEN JER=JER+1 ENDIF C 354 CONTINUE C C IN THE ABOVE POSTPROCESSING LOOP, ERRORS CAN OCCUR AND IER C MAY NE 0, 666, OR 777. THE POSTPROCESSING MAY NOT ALWAYS BE C POSSIBLE. THIS DOES NOT STOP U155, AND THE GRID MAY BE C OUTPUT AS MISSING OR UNPOSTPROCESSED. IF THRE IS AN C ERROR, A DIAGNOSTIC IS PROVIDED AND ISTOP(1) INCREMENTED. C C ANY WRITING TO THE SEQUENTIAL OR RANDOM ACCESS FILE C WILL BE AT THE MESH LENGTH MESHB. C CALL SZGRDM(KFILDO,P,NX,NY,MESH,MESHB,ITRPLQ(NPASS,MGUESS), 1 ND2X3) C MGUESS IS THE NUMBER OF THE GUESS OPTION ACTUALLY USED C AND NPASS IS THE NUMBER OF THE LAST PASS. C C IF A CHANGE GRID HAS BEEN COMPUTED, ICKGR GT 1. C WRITE THE GRID TO THE DISPOSABLE FILE WHEN KFILOG NE 0 C AND JP(2,M) NE 0. C IF(KFILOG.GT.0.AND.JP(2,M).NE.0.AND.ICKGR.NE.0)THEN LD(1)=ID(1,M) LD(2)=960000+IDPARS(7,M) C THE LLLL IN ID(2,M) IS SET TO 96 TO INDICATE THIS IS C A CHANGE GRID. IDPARS(7) MAINTAINS THE LEVEL. LD(3)=ID(3,M) LD(4)=(ID(4,M)/1000)*1000 C THE FINAL ANALYSIS HAS ISG = 0 NO MATTER HOW IT WAS DONE. ITAUM=0 NSEQ=0 NCHAR=32 C 32 CHARACTERS OF PLAIN LANGUAGE ARE PACKED. XMISSP=9999. XMISSS=0. C THE CHANGE GRIDS ARE COMPUTED ON A CLIPPED GRID, SO THERE C WILL BE MISSING VALUES. RACK(1:32)=PLAIN(M)(1:32) RACK(29:32)='CHNG' C CALL PAWGTS(KFILDO,KFILOG,'KFILOG',IP16,NDATE, 1 LD,IDPARS(12,M),ITAUM,MODNO,NSEQ,ISCALD(M), 2 NPROJ,ALATL,ALONL,ORIENT,MESHB,XLAT,NX,NY, 3 FD6,DATA,IWORK,IPACK,ND2X3,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 DIAGNOSTIC TO IP16. C IF(IER.NE.0)THEN ISTOP(1)=ISTOP(1)+1 MER=MER+1 C AN ERROR IN PAWGTS IS NOT CONSIDERED FATAL. ENDIF C ENDIF C C NOW PACK AND WRITE THE ANALYSIS GRID TO THE ARCHIVE UNIT C KFILIO AT MESH LENGTH MESHB UNLESS KFILIO = 0. C IF(KFILIO.NE.0)THEN CALL PAWGTS(KFILDO,KFILIO,'KFILIO',IP16,NDATE, 1 ID(1,M),IDPARS(12,M),ITAUM,MODNO,NSEQ,ISCALD(M), 2 NPROJ,ALATL,ALONL,ORIENT,MESH,XLAT,NX,NY, 3 P,DATA,IWORK,IPACK,ND2X3,MINPK, 4 IS0,IS1,IS2,IS4,ND7, 5 IPLAIN(1,1,M),PLAIN(M),NCHAR, 6 XMISSP,XMISSS,LX,IOCTET, 7 NTOTBY,NTOTRC,L3264B,L3264W,IER) C IF(IER.NE.0)THEN WRITE(KFILDO,355) 355 FORMAT(/' ****ERROR IN PAWGTS IN U405A AT 355.') C THE FINAL ANALYSIS CANNOT BE WRITTEN TO KFILIO. ISTOP(1)=ISTOP(1)+1 JER=JER+1 ENDIF C WRITE(KFILDO,356)(ID(JJ,M),JJ=1,4),NDATE,PLAIN(M) 356 FORMAT(/' WRITING GRIDPOINT RECORD FOR',3(1X,I9.9),1X,I10.3, 1 ' TO KFILIO, DATE ',I11,1X,A32) C C IF AN ERROR ESTIMATE HAS BEEN CALCULATED IN FD3( , ) AS C A POSTPROCESSING ROUTINE, PACK AND WRITE IT TO THE ARCHIVE C UNIT KFILIO. C DO 358 NN=1,NOPROA C IF(POSTAR(NN).EQ.'EREST ')THEN XMISSP=9999.0 XMISSS=0. ISCLAP=3 C PACK TO 3 DECIMAL PLACES. ISCALE=0 LD(1)=ITABLE(1,1) LD(2)=ITABLE(2,1)-((ITABLE(2,1)/10000))*10000+ 1 50970000 C THE 97 IN LD(2) INDICATES THIS IS THE ERROR VARIABLES, C AND THE SEQUENCE JJ PRECEDES THAT. THIS ASSUMES C THE ORIGINAL VARIABLE IN LD(2) HAS 'VLLLL' = 0; C THREE DIGITS ARE LEFT FOR SEQUENCING, SO THE NUMBER C OF WITHHELD COULD GO UP TO 999. HOWEVER, 50 IS USED C HERE FOR THE ERROR GRID. IF A DIFFERENT VERSION OF C ERROR IS PRODUCED, THE 50 COULD BE CHANGED TO REFLECT C THE DIFFERENCE. NOTE THAT THIS LEAVES THE UUUU INTACT. LD(3)=ITABLE(3,2)+IDPARS(12,M) LD(4)=ITABLE(4,2) CALL PRSID1(KFILDO,LD,LDPARS) C PRSID1 FILLS LDPARS( ) ACCORDING TO LD( ). C CALL PAWGTS(KFILDO,KFILIO,'KFILIO',IP16,NDATE, 1 LD,LDPARS(12),ITAUM,MODNO,NSEQ,ISCLAP, 2 NPROJ,ALATL,ALONL,ORIENT,MESH,XLAT,NX,NY, 3 FD3,DATA,IWORK,IPACK,ND2X3,MINPK, 4 IS0,IS1,IS2,IS4,ND7, 5 IPLAIN(1,1,M),PLAIN(M),NCHAR, 6 XMISSP,XMISSS,LX,IOCTET, 7 NTOTBY,NTOTRC,L3264B,L3264W,IER) C NOTE THAT THIS MAY NEED TO BE WRITTEN TO THE RANDOM C ACCESS FILE. C IF(IER.NE.0)THEN WRITE(KFILDO,357) 357 FORMAT(/' ****ERROR IN PAWGTS IN U405A AT 357', 1 ' WRITING THE ERROR ANALYSIS.') C THIS IS THE ERROR ANALYSIS. ISTOP(1)=ISTOP(1)+1 JER=JER+1 ENDIF C ENDIF C 358 CONTINUE C ENDIF C C NOW PACK AND WRITE THE GRID AND THE ERROR GRID, IF COMPUTED, C TO THE ARCHIVE RANDOM ACCESS FILE AT MESH LENGTH MESHB, C WHEN KFILRA = 42 C DO 370 JJ=1,6 C IF(KFILRA(JJ).EQ.42)THEN C 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 C (FOR 5-KM CONUS GRID). 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 NOTE THAT ARRAY P( ) CONTAINS THE PACKED DATA. C THE IBM VERSION OF PACKGR IS PACKGR_OPER C CALL PACKGR(KFILDO,KFILRA(JJ),RACESS(JJ),ID(1,M),IDPARS(1,M), 1 ISCALD(M),ISCALE,NGRIDT, 2 IPLAIN(1,1,M),PLAIN(M),NDATE,NYR,NMO,NDA,NHR, 3 FD2,P,ND2X3,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,362)(ID(MMM,M),MMM=1,4),KFILRA(JJ),IER,MINPK 362 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 GO TO 3645 ENDIF C IF(IP16.NE.0)THEN WRITE(IP16,364)(ID(MMM,M),MMM=1,4),PLAIN(M),NDATE, 1 NX,NY,MESHB,ALATL,ALONL 364 FORMAT(/' WRITING DATA TO UNIT KFILRA',3I10.9,I10.3,3X,A32, 1 ' FOR DATE',I12,/, 2 77X,'NX,NY,MESH,ALAT,ALON =',3I5,2F9.4) ENDIF C C IF AN ERROR ESTIMATE HAS BEEN CALCULATED IN FD3( , ) AS C A POSTPROCESSING ROUTINE, PACK AND WRITE IT TO THE RANDOM C ACCESS FILE. C 3645 DO 369 NN=1,NOPROA C IF(POSTAR(NN).EQ.'EREST ')THEN XMISSP=9999.0 XMISSS=0. C ISCLAP=3 C PACK TO 3 DECIMAL PLACES. ISCALE=0 LD(1)=ITABLE(1,1) LD(2)=ITABLE(2,1)-((ITABLE(2,1)/10000))*10000+ 1 50970000 C THE 97 IN LD(2) INDICATES THIS IS THE ERROR VARIABLES, C AND THE SEQUENCE JJ PRECEDES THAT. THIS ASSUMES C THE ORIGINAL VARIABLE IN LD(2) HAS 'VLLLL' = 0; C THREE DIGITS ARE LEFT FOR SEQUENCING, SO THE NUMBER C OF WITHHELD COULD GO UP TO 999. HOWEVER, 50 IS USED C HERE FOR THE ERROR GRID. IF A DIFFERENT VERSION OF C ERROR IS PRODUCED, THE 50 COULD BE CHANGED TO REFLECT C THE DIFFERENCE. NOTE THAT THIS LEAVES THE UUUU INTACT. LD(3)=ITABLE(3,2)+IDPARS(12,M) LD(4)=ITABLE(4,2) CALL PRSID1(KFILDO,LD,LDPARS) C PRSID1 FILLS LDPARS( ) ACCORDING TO LD( ). C CALL PACKGR(KFILDO,KFILRA(JJ),RACESS(JJ),LD,LDPARS, 1 ISCALD(M),ISCALE,NGRIDT, 2 IPLAIN(1,1,M),PLAIN(M),NDATE,NYR,NMO,NDA,NHR, 3 FD2,FD3,ND2X3,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,365)(LD(MMM),MMM=1,4),KFILRA(JJ),IER,MINPK 365 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 GO TO 372 ENDIF C IF(IP16.NE.0)THEN WRITE(IP16,366)(LD(MMM),MMM=1,4),PLAIN(M),NDATE, 1 NX,NY,MESHB,ALATL,ALONL 366 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 GO TO 372 C ENDIF C 369 CONTINUE C GO TO 372 C ENDIF C 370 CONTINUE C WRITE(KFILDO,371) 371 FORMAT(/' RANDOM ACCESS FILE UNIT NO. 42 NOT AVAILABLE FOR', 1 ' WRITING ANALYSES AND/OR ERROR GRID.', 2 ' NOT COUNTED AS AN ERROR. PROCEEDING.') C 372 IF(IWRITF(M).EQ.1)THEN C C GSTORE WRITES TO INTERNAL STORAGE ON FILE KFIL10 WHEN C IWRITF(M) =1. MESH LENGTH IS MESH, THAT USED FOR C THE LAST PASS, BUT THE DATA ARE NOT PACKED AND NOT C TREATED AS PACKED GRIDDED DATA. NOTE THAT THIS IS THE C CLIPPED GRID. C LD(1)=ID(1,M) LD(2)=ID(2,M) LD(3)=ID(3,M) LD(4)=ID(4,M)+1 C THIS IS THE POSTPROCESSED GRID. IT IS DISTINGUISHED C FROM THE UNPOSTPROCESSED GRID BY A "1" IN TH "G" POSITION. CALL GSTORE(KFILDO,KFIL10,LD,0,LSTORE,ND9,LITEMS, 1 P,NX*NY,1,0,NDATE, 2 CORE,ND10,LASTL,NBLOCK,LASTD,NSTORE,L3264B,IER) C "NSLAB" IS STORED AS ZERO SIGNIFYING THE DATA ARE NOT C PACKED AND CAN BE TREATED AS VECTOR DATA. C IF(IER.EQ.0)THEN C IF(IP16.NE.0)THEN WRITE(IP16,373)(LD(JJ),JJ=1,4), 1 ((IPLAIN(I,JJ,M),I=1,L3264W),JJ=1,4),NDATE 373 FORMAT(/' WRITING DATA TO UNIT KFIL10',3I10.9,I10.3,3X, 1 8A4,' FOR DATE',I12) ENDIF C ELSE C A DIAGNOSTIC WILL HAVE OCCURRED IN PAWLPM. WRITE(KFILDO,374)(LD(JJ),JJ=1,4) 374 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.') ISTOP(1)=ISTOP(1)+1 MER=MER+1 ENDIF C ENDIF C C THE GRID TO WRITE IN P( , ) IS AT MESH LENGTH MESH, WHICH IS C THE MESH LENGTH OF THE LAST PASS. C C WRITE THE DATA ON WHICH THE ANALYSIS IS BASED IN ASCII FOR C GMOS_PLOT INPUT WHEN KFILVO NE 0 AND IWRITA(N) NE 0. C IF(KFILVO.NE.0)THEN C IF(IWRITA(N).NE.0)THEN REWIND KFILVO IWIND=0 C THIS IS THE KEY FOR PLATYP TO NOT PLOT WIND. C FOR WIND, IT WILL BE CHANGED BELOW. C C SET DATA( ) TO MISSING. THIS IS A SAFETY AND SHOULD C NOT BE NECESSARY. DATA( ) IS USED IN PLATYP, BUT C ONLY FOR WIND, AND WIND WILL GIVE EITHER A GOOD C VALUE OR MISSING. C DO 375 K=1,NSTA DATA(K)=9999. 375 CONTINUE C IF((ITABLE(1,2)/100.EQ.2080702.OR. 2 ITABLE(1,2)/100.EQ.2080432).AND.ICOMPT(M).EQ.0)THEN C THIS IS A CEILING HEIGHT PROBABILITY. NEEDS TO BE C SCALED TO BE PLOTTED. THE ICOMPT( ) IS LIKELY NOT C NECESSARY. C******************************************************** CALL POST(KFILDO,XDATA(1,1,J),NSTA,0.,0.,1., 1 1.,1.,2,DUM,DUM,IER) C THERE IS NO NONZERO IER RETURN. C******************************************************** VOTNAME(IPOSL+1:IPOSL+2)='PC' !PROB CEILING C INSERTS PC FOR PROBABILITY OF CEILING. C IF(IPOSL+10.GT.60)THEN C IINSERTION BELOW WOULD OVERFLOW VOTNAME. WRITE(KFILDO,3762)KFILVO,VOTNAME 3762 FORMAT(/' ****FILE NAME VOTNAME ON UNIT KFILVO =',I4, 1 ' IS TOO LONG AT 3762. FILE NOT WRITTEN.',/, 2 ' SHORTEN FILE VOTNAM = ',A60) ISTOP(1)=ISTOP(1)+1 C ELSEIF(ID(4,M).EQ.150001000)THEN VOTNAME(IPOSL+8:IPOSL+10)='.C1' ELSEIF(ID(4,M).EQ.450001000)THEN VOTNAME(IPOSL+8:IPOSL+10)='.C2' ELSEIF(ID(4,M).EQ.950001000)THEN VOTNAME(IPOSL+8:IPOSL+10)='.C3' ELSEIF(ID(4,M).EQ.195002000)THEN VOTNAME(IPOSL+8:IPOSL+10)='.C4' ELSEIF(ID(4,M).EQ.305002000)THEN VOTNAME(IPOSL+8:IPOSL+10)='.C5' ELSEIF(ID(4,M).EQ.655002000)THEN VOTNAME(IPOSL+8:IPOSL+10)='.C6' ELSEIF(ID(4,M).EQ.120503000)THEN VOTNAME(IPOSL+8:IPOSL+10)='.C7' ENDIF C ELSEIF(ITABLE(1,2)/100.EQ.2081302.AND.ICOMPT(M).EQ.0)THEN C THIS IS A VISIBILITY PROBABILITY. NEEDS TO BE C SCALED TO BE PLOTTED. THE ICOMPT( ) IS LIKELY NOT C NECESSARY. CALL TIMPR(KFILDO,KFILDO,'PROB ASCII VIS 375 ') C******************************************************** CALL POST(KFILDO,XDATA(1,1,J),NSTA,0.,0.,1., 1 1.,1.,2,DUM,DUM,IER) C THERE IS NO NONZERO IER RETURN. C******************************************************** VOTNAME(IPOSL+1:IPOSL+2)='PV' !PROB VISIBILITY C INSERTS PV FOR PROBABILITY OF VISIBILITY. C IF(IPOSL+10.GT.60)THEN C IINSERTION BELOW WOULD OVERFLOW VOTNAME. WRITE(KFILDO,3763)KFILVO,VOTNAME 3763 FORMAT(/' ****FILE NAME VOTNAME ON UNIT KFILVO =',I4, 1 ' IS TOO LONG AT 3762. FILE NOT WRITTEN.',/, 2 ' SHORTEN FILE VOTNAM = ',A60) ISTOP(1)=ISTOP(1)+1 C ELSEIF(ID(4,M).EQ.495000000)THEN VOTNAME(IPOSL+8:IPOSL+10)='.C1' ELSEIF(ID(4,M).EQ.950000000)THEN VOTNAME(IPOSL+8:IPOSL+10)='.C2' ELSEIF(ID(4,M).EQ.195001000)THEN VOTNAME(IPOSL+8:IPOSL+10)='.C3' ELSEIF(ID(4,M).EQ.295001000)THEN VOTNAME(IPOSL+8:IPOSL+10)='.C4' ELSEIF(ID(4,M).EQ.505001000)THEN VOTNAME(IPOSL+8:IPOSL+10)='.C5' ELSEIF(ID(4,M).EQ.605001000)THEN VOTNAME(IPOSL+8:IPOSL+10)='.C6' ENDIF C ELSEIF(ITABLE(1,2)/100.EQ.2083802.AND.ICOMPT(M).EQ.0)THEN C THIS IS A SKY COVER PROBABILITY. NEEDS TO BE C SCALED TO BE PLOTTED. THE ICOMPT( ) IS LIKELY NOT C NECESSARY. C******************************************************** CALL POST(KFILDO,XDATA(1,1,J),NSTA,0.,0.,1., 1 1.,1.,2,DUM,DUM,IER) C THERE IS NO NONZERO IER RETURN. C******************************************************** VOTNAME(IPOSL+1:IPOSL+2)='PK' !PROB SKY C INSERTS PK FOR PROBABILITY OF OPAQUE SKY. C IF(IPOSL+10.GT.60)THEN C IINSERTION BELOW WOULD OVERFLOW VOTNAME. WRITE(KFILDO,3764)KFILVO,VOTNAME 3764 FORMAT(/' ****FILE NAME VOTNAME ON UNIT KFILVO =',I4, 1 ' IS TOO LONG AT 3762. FILE NOT WRITTEN.',/, 2 ' SHORTEN FILE VOTNAM = ',A60) ISTOP(1)=ISTOP(1)+1 C ELSEIF(ID(4,M).EQ.150001000)THEN VOTNAME(IPOSL+8:IPOSL+10)='.C1' ELSEIF(ID(4,M).EQ.250001000)THEN VOTNAME(IPOSL+8:IPOSL+10)='.C2' ELSEIF(ID(4,M).EQ.400001000)THEN VOTNAME(IPOSL+8:IPOSL+10)='.C3' ELSEIF(ID(4,M).EQ.700001000)THEN VOTNAME(IPOSL+8:IPOSL+10)='.C4' ENDIF C ELSEIF(ITABLE(1,2)/1000.EQ.438044.AND.ICOMPT(M).EQ.0)THEN C THIS IS A SNOW REL FREQ. NEEDS TO BE SCALED TO BE C PLOTTED. THIS IS ANALYSIS FOR DEVELOPMENT, AND C WON'T BE NEEDED IN OPERATIONS. THE ICOMPT( ) IS C LIKELY NOT NECESSARY. HIGH VALUES ARE NOT TRUNCATED C FOR QC. THEY CAN BE FOR FINAL IF DESIRED. SCALE C 10**2 CALL POST(KFILDO,XDATA(1,1,J),NSTA,0.,0.,9999., 1 9999.,1.,2,DUM,DUM,IER) C THERE IS NO NONZERO IER RETURN. VOTNAME(IPOSL+1:IPOSL+2)='PS' !PROB SNOW C INSERTS PS FOR PROBABILITY (RF) OF SNOW. C ELSEIF(ID(1,M).EQ.224020005.OR. !LAMP U 1 ID(1,M).EQ.224020035.OR. !LAMP U 2 ID(1,M).EQ.724020085.OR. !OBS U 3 ID(1,M).EQ.224060008)THEN !MOS U VOTNAME(IPOSL+1:IPOSL+2)='WU' C INSERTS WU FOR U-WIND. C ELSEIF(ID(1,M).EQ.224120005.OR. !LAMP V 1 ID(1,M).EQ.224120035.OR. !LAMP V 2 ID(1,M).EQ.724120085.OR. !OBS V 3 ID(1,M).EQ.224160008)THEN !MOS V VOTNAME(IPOSL+1:IPOSL+2)='WV' C INSERTS WV FOR V-WIND. C ELSEIF(ID(1,M).EQ.728306085.OR. !OBS SKY 1 ID(1,M).EQ.228375005.OR. !LAMP SKY 2 ID(1,M).EQ.228395008)THEN !MOS SKY VOTNAME(IPOSL+1:IPOSL+2)='SK' C INSERTS SK FOR OPAQUE SKY COVER IN DECIMAL. C ELSEIF(ID(1,M).EQ.222030005.OR. !LAMP TEMP 1 ID(1,M).EQ.222030035.OR. !LAMP TEMP 2 ID(1,M).EQ.222020008.OR. !MOS TEMP 3 ID(1,M).EQ.722030085)THEN !OBS TEMP VOTNAME(IPOSL+1:IPOSL+2)='TT' C INSERTS TT FOR TEMPERATURE. C ELSEIF(ID(1,M).EQ.223030005.OR. !LAMP DP 1 ID(1,M).EQ.223030035.OR. !LAMP DP 2 ID(1,M).EQ.223020008.OR. !MOS DP 3 ID(1,M).EQ.723130085)THEN !OBS DP VOTNAME(IPOSL+1:IPOSL+2)='TD' C INSERTS TD FOR DEW POINT. C ELSEIF(ID(1,M).EQ.222120008)THEN !MOS MX TEMP VOTNAME(IPOSL+1:IPOSL+2)='MX' C INSERTS MX FOR MAX TEMP. C ELSEIF(ID(1,M).EQ.222220008)THEN !MOS MN TEMP VOTNAME(IPOSL+1:IPOSL+2)='MN' C INSERTS MN FOR MAX TEMP. C ELSEIF(ID(1,M).EQ.228080005.OR. !LAMP CIG 1 ID(1,M).EQ.728000085)THEN !OBS CIG VOTNAME(IPOSL+1:IPOSL+2)='CG' C INSERTS CG FOR CEILING. C ELSEIF(ID(1,M).EQ.228160005.OR. !LAMP VIS 1 ID(1,M).EQ.728100085)THEN !OBS VIS VOTNAME(IPOSL+1:IPOSL+2)='VS' C INSERTS VS FOR CEILING. C CCCCC ELSEIF(ID(1,M)/1000.EQ.724230.OR. !OBS WIND DIR CCCCC 1 ID(1,M)/1000.EQ.224235.OR. !LAMP WIND DIR CCCCC 2 ID(1,M)/1000.EQ.224250)THEN !MOS WIND DIR CCCCC IWRITA(N)=0 C DIRECTION IS NOT WRITTEN, EXCEPT AS SPEED C COMBINATION. NORMALLY IWRITA( ) = 0, BUT C THIS IS A SAFETY. ELSEIF(ID(1,M)/1000.EQ.224360.OR. !MOS WIND SPEED 1 ID(1,M)/1000.EQ.224390.OR. !LAMP WIND GUST 2 ID(1,M)/1000.EQ.224385.OR. !MOS WIND GUST 3 ID(1,M)/1000.EQ.724390.OR. !OBS WIND GUST 4 ID(1,M)/1000.EQ.224335.OR. !LAMP WIND SPEED 5 ID(1,M)/1000.EQ.724330.OR. !OBS WIND SPEED 6 ID(1,M)/1000.EQ.224235.OR. !LAMP WIND DIRECTION 7 ID(1,M)/1000.EQ.224250)THEN !MOS WIND DIRECTION C WRITE(KFILDO,3755)ID(1,M) 3755 FORMAT(/' AT 3755 IN U405A--ID(1,M)',I11) C C THE VECTOR DIRECTION MUST BE COMPUTED FROM U C AND V. JD( , ) IS USED IN DIRFUV ONLY FOR PRINT. C THE DIRECTION, COMPUTED FROM THE OBSERVED U AND V, C AND THE OBSERVED SPEED DO NOT INCLUDE BOGUS VALUES. C THERE IS NO EASY WAY TO INCLUDE THESE. THE BOGUS C SPEED CAN BE PLOTTED WHEN WRITTEN FROM SPEED ANALYSIS. C C BECAUSE SPEED IS ANALYZED BEFORE U AND V, AND U AND V C ARE NEEDED TO COMPUTE DIRECTION PLOTTED WITH THE C SPEED, THE ASCII FOR SPEED IS REDONE IN THE DIRECTON C COMPUTATION. LTAG( ), LTAGPT( ) AND NTAGPT( ) FOR C SPEED MUST BE SAVED AND RETIREVED FOR THE C RECOMPUTATION. C IF(ID(1,M).EQ.224390005.OR. !LAMP WIND GUST 1 ID(1,M).EQ.224390035.OR. !LAMP WIND GUST 2 ID(1,M).EQ.724390085.OR. !OBS WIND GUST 3 ID(1,M).EQ.224385008)THEN !MOS WIND GUST C THIS IS OBS, LAMP, OR GFS MOS GUST. VOTNAME(IPOSL+1:IPOSL+2)='WG' C INSERTS WG FOR GUSTS. ELSEIF(ID(1,M)/1000.EQ.224235.OR. !LAMP WIND DIRECTION 1 ID(1,M)/1000.EQ.224250)THEN !MOS WIND DIRECTION C LAMP WND SPEED WILL NOT HAVE DIRECTION FOR THE C NON BASE STATIONS UNLESS U AND V HAVE BEEN RUN. C THE ASCII FILE FOR WIND SPEED IS DONE HERE AS C PART OF THE WIND DIRECTION. C IF(ID(1,M)/1000.EQ.224235)THEN ICFFF=335 C THIS IS FOR LAMP. ELSE ICFFF=360 C THIS IS FOR MOS. ENDIF C LD(1)=224*1000000+ICFFF*1000+IDPARS(4,M) !LAMP OR MOS WIND SPEED LD(2)=000950000 !00095 LD(3)=IDPARS(12,M) LD(4)=0 CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,XDATA(1,1,J),NSTA, 2 NWORDS,NPACK,NDATE,NTIMES,CORE,ND10, 3 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B,0,IER) C THIS GETS THE WIND SPEED INTO XDATA( , ,J). C IF(IER.NE.0)THEN WRITE(KFILDO,378) 378 FORMAT(' DATA NOT AVAILABLE.', 1 ' ABORT PLOTTING.') JER=JER+1 GO TO 400 ENDIF C LD(1)=204*1000000+ICFFF*1000+IDPARS(4,M) !LAMP OR MOS STATION WIND SPEED LD(2)=000970000 !00097 LD(3)=IDPARS(12,M) LD(4)=0 CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,DATA,NSTA, 2 NWORDS,NPACK,NDATE,NTIMES,CORE,ND10, 3 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B,0,IER) C THIS GETS THE WIND SPEED LTAG INTO LTAG( ). C IF(IER.NE.0)THEN WRITE(KFILDO,378) JER=JER+1 GO TO 400 ENDIF C DO 3775 K=1,NSTA LTAG(K)=NINT(DATA(K)) 3775 CONTINUE C LD(1)=224*1000000+ICFFF*1000+IDPARS(4,M) !LAMP OR MOS WIND SPEED LD(2)=000930000 !00093 LD(3)=IDPARS(12,M) LD(4)=0 CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,DATA,NSTA, 2 NWORDS,NPACK,NDATE,NTIMES,CORE,ND10, 3 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B,0,IER) C THIS GETS THE WIND SPEED LTAGPT( ). C IF(IER.NE.0)THEN WRITE(KFILDO,378) JER=JER+1 GO TO 400 ENDIF C DO 3776 K=1,NSTA LTAGPT(K)=NINT(DATA(K)) 3776 CONTINUE C LD(1)=224*1000000+ICFFF*1000+IDPARS(4,M) !LAMP OR MOS WIND SEED LD(2)=000920000 !00092 LD(3)=IDPARS(12,M) LD(4)=0 CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,DATA,NSTA, 2 NWORDS,NPACK,NDATE,NTIMES,CORE,ND10, 3 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B,0,IER) C THIS GETS THE WIND SPEED NTAGPT( ). C IF(IER.NE.0)THEN WRITE(KFILDO,378) JER=JER+1 GO TO 400 ENDIF C DO 3777 K=1,NSTA NTAGPT(K)=NINT(DATA(K)) 3777 CONTINUE C VOTNAME(IPOSL+1:IPOSL+2)='WS' ELSEIF(ID(1,M)/1000.EQ.224360.OR. !MOS WIND SPEED 1 ID(1,M)/1000.EQ.224335)THEN !LAMP WIND SPEED C C INTEGER ARRAY LTAG( ) MUST BE MADE REAL FOR STORING C IN INTERNAL STORAGE. C DO 376 K=1,NSTA DATA(K)=LTAGPT(K) C VALUES IN LTAGPT( ) HAVE TO BE MADE REAL FOR C STORING. 376 CONTINUE LD(1)=ID(1,M) !MOS OR LAMP WIND SPEED LD(2)=930000 !00093 LD(3)=IDPARS(12,M) LD(4)=0 CALL GSTORE(KFILDO,KFIL10,LD,0,LSTORE,ND9,LITEMS, 1 DATA,NSTA,1,0,NDATE, 2 CORE,ND10,LASTL,NBLOCK,LASTD,NSTORE,L3264B,IER) C "NSLAB" IS STORED AS ZERO SIGNIFYING VECTOR DATA. C THIS STORES LTAGPT FOR SPEED TO BE USED WHEN DOING C DIRECTION. C IF(IER.EQ.0)THEN C IF(IP16.NE.0)THEN RACK(1:32)=PLAIN(M)(1:32) RACK(27:32)='LTAGPT' WRITE(IP16,3760)(LD(JJ),JJ=1,4), 1 RACK,NDATE 3760 FORMAT(/' WRITING DATA TO UNIT KFIL10',3I10.9, 1 I10.3,3X,A32,' FOR DATE',I12) ENDIF C ELSE C A DIAGNOSTIC WILL HAVE OCCURRED IN GSTORE. ISTOP(1)=ISTOP(1)+1 MER=MER+1 C WRITING ERROR IS NOT CONSIDERED FATAL. IF C DATA ARE NEEDED AND CANNOT BE READ, IT MAY C BE FATAL. WRITE(KFILDO,3761)(LD(JJ),JJ=1,4) 3761 FORMAT(' ERROR WRITING VARIABLE',3(1X,I9.9), 1 1X,I10.3,' TO INTERNAL STORAGE.',/, 2 ' SOME COMPUTATIONS (PRE- OR POST-', 3 'PROCESSING) MAY NOT BE ABLE TO BE MADE.', 4 ' PROCEEDING.') ENDIF C DO 377 K=1,NSTA DATA(K)=NTAGPT(K) C VALUES IN NTAGPT( ) HAVE TO BE MADE REAL FOR C STORING. 377 CONTINUE LD(1)=ID(1,M) !MOS OR LAMP WIND SPEED LD(2)=920000 !00092 LD(3)=IDPARS(12,M) LD(4)=0 CALL GSTORE(KFILDO,KFIL10,LD,0,LSTORE,ND9,LITEMS, 1 DATA,NSTA,1,0,NDATE, 2 CORE,ND10,LASTL,NBLOCK,LASTD,NSTORE,L3264B,IER) C "NSLAB" IS STORED AS ZERO SIGNIFYING VECTOR DATA. C THIS STORES NTAGPT FOR SPEED TO BE USED WHEN DOING C DIRECTION. VOTNAME(IPOSL+1:IPOSL+2)='WS' C IF(IER.EQ.0)THEN C IF(IP16.NE.0)THEN RACK(1:32)=PLAIN(M)(1:32) RACK(27:32)='NTAGPT' WRITE(IP16,3770)(LD(JJ),JJ=1,4), 1 RACK,NDATE 3770 FORMAT(/' WRITING DATA TO UNIT KFIL10',3I10.9, 1 I10.3,3X,A32,' FOR DATE',I12) ENDIF C ELSE C A DIAGNOSTIC WILL HAVE OCCURRED IN GSTORE. ISTOP(1)=ISTOP(1)+1 MER=MER+1 C WRITING ERROR IS NOT CONSIDERED FATAL. IF C DATA ARE NEEDED AND CANNOT BE READ, IT MAY WRITE(KFILDO,3771)(LD(JJ),JJ=1,4) 3771 FORMAT(' ERROR WRITING VARIABLE',3(1X,I9.9), 1 1X,I10.3,' TO INTERNAL STORAGE.',/, 2 ' SOME COMPUTATIONS (PRE- OR POST-', 3 'PROCESSING) MAY NOT BE ABLE TO BE MADE.', 4 ' PROCEEDING.') ENDIF C INSERTS WS FOR WIND SPEED. C ELSE VOTNAME(IPOSL+1:IPOSL+2)='WS' C INSERTS WS FOR WIND SPEED. ENDIF C IWIND=1 C THIS IS THE KEY FOR PLATYP TO PLOT WIND. C IF(ITABLE(1,6).NE.0)THEN C IF DIRECTION IS TO BE PLOTTED, ITABLE( , 6) MUST C CONTAIN THE ID. IF THE ID IS ZERO, THE DATA WILL C BE PLOTTED BUT WITHOUT THE DIRECTION. ITAUM=0 C C DIRECTION IS NOT POLOTTED WITH GUSTS C IF(ID(1,M)/1000.EQ.724330.OR. !OBS WIND SPEED 1 ID(1,M)/1000.EQ.724390)THEN !OBS WIND GUSTS C ABOVE FOR OBS SPEED AND GUSTS. LD(1)=ITABLE(1,6) LD(2)=ITABLE(2,6) ELSEIF(ID(1,M)/1000.EQ.224335.OR. !LAMP WIND SPEED 1 ID(1,M)/1000.EQ.224390)THEN !LAMP WIND GUSTS C ABOVE FOR LAMP SPEED AND GUSTS. LD(1)=ITABLE(1,6)+IDPARS(4,M) LD(2)=ITABLE(2,6) ELSEIF(ID(1,M)/1000.EQ.224360.OR. !MOS WIND SPEED 1 ID(1,M)/1000.EQ.224385)THEN !MOS WIND GUSTS C ABOVE FOR LAMP SPEED AND GUSTS. LD(1)=ITABLE(1,6)+IDPARS(4,M) LD(2)=ITABLE(2,6) ELSEIF(ID(1,M)/1000.EQ.224235.OR. !LAMP WIND DIRECTION 1 ID(1,M)/1000.EQ.224250)THEN !MOS WIND DIRECTION LD(1)=ITABLE(1,6)+IDPARS(4,M) LD(2)=ITABLE(2,6) C ABOVE FOR LAMP OR MOS DIRECTION. MUST BE C DONE AFTER U AND V TO HAVE NEEDED DATA C IN INTERNAL STORAGE. ENDIF C LD(3)=ID(3,M) LD(4)=ID(4,M) CALL PRSID1(KFILDO,LD,LDPARS) C LD SUBSTITUTED FOR JD( , ) IN CALL TO GET THE 2ND C WORD. DIRFUV USES JD VICE ID. CALL DIRFUV(KFILDO,KFIL10,IP12,KFILRA,RACESS,NUMRA, 1 LD,LDPARS,LD,ITAUM, 2 NDATE,NDATE,CCALL,ISDATA,DATA,ND1,NSTA, 3 ICALLD,CCALLD,IPACK,IWORK,DATA,ND5, 4 LSTORE,ND9,LITEMS,CORE,ND10, 5 NBLOCK,NFETCH, 6 IS0,IS1,IS2,IS4,ND7, 7 L3264B,L3264W,IER) C IF(IER.NE.0)THEN ISTOP(1)=ISTOP(1)+1 C IF(IER.NE.102)THEN ISTOP(3)=ISTOP(3)+1 C ANY IER NOT 102 MEANS A GRID COULD NOT BE C OBTAINED. C C IF DIRECTION CANNOT BE COMPUTED, DATA( ) C IS RETURNED MISISNG, AND CAN BE USED IN C PLATYP. HOWEVER, THIS IS CAOUNTED AS A MAJOR C ERROR JER=JER+1 ENDIF C ENDIF C ENDIF C ENDIF C C WRITE THE LONGITUDE AS NEGATIVE, LATITUDE, ASCII C DATA TO PLOT. C*********************************************** CWRITE CALL LETTERS FOR GUST. THIS IS SHORT LIST FOR U179 C CCCC IF(ID(1,M).EQ.224385008)THEN CCCC REWIND IP17 C CCCC DO 9876 K=1,NSTA C CCCC IF(XDATA(K,1,J).LE.9998.)THEN CCCC WRITE(IP17,9875)CCALL(K,1) CCCC 9875 FORMAT(A8) CCCC ENDIF C CCCC 9876 CONTINUE C CCCC ENDIF C*********************************************** C IF(IWRITA(N).NE.0)THEN C C THE BELOW INSERTED 11/27/18 IS TO SQUARE CIG HGTS C THAT WERE ANALYZED AS SQ ROOT, SCALED IN POSTCG. C DO 385 NN=1,NOPROA C IF(POSTAR(NN).EQ.'POSTCG')THEN C DO 384 K=1,NSTA C IF(XDATA(K,1,J).LT.9998.)THEN XDATA(K,1,J)=XDATA(K,1,J)**2 ENDIF C 384 CONTINUE C ENDIF C 385 CONTINUE C DO 390 K=1,NSTA C IF(STALAT(K).NE.0..OR.STALON(K).NE.0.)THEN C WILL NOT ATTEMPT TO PLOT A VALUE AT (0,0); C SOME BOGUS STATIONS, SET BY BOGUSG, MAY HAVE C LAT = LON =0. CALL PLATYP(KFILDO,KFILVO,CCALL(K,1),NAME(K), 1 XDATA(K,1,J),DATA(K),STALAT(K),STALON(K), 2 LTAG(K),LTAGPT(K),NTAGPT(K),IWRITA(N), 3 IWIND,ITABLE(1,6),NOSCII,ISTOP,IER) ENDIF C 390 CONTINUE C CLOSE(UNIT=KFILVO) C THE FILE IS CLOSED SO THAT THE BUFFERS WILL BE DUMPED TO C IT BEFORE COPYING BELOW. C CALL SYSTEM('cp -p '//VOTNAM//' '//VOTNAME) COPS OPEN(UNIT=KFILVO,FILE=VOTNAM,FORM='FORMATTED', COPS 1 STATUS='OLD') OPEN(UNIT=KFILVO,FORM='FORMATTED',STATUS='OLD') C REOPEN THE CLOSED FILE. C ENDIF C 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)=(ITABLE(1,2)/100)*100+IDPARS(4,M) C VECTOR BEING ANALYZED IS IN ITABLE( ,2). C SOMETIMES THE DD IS THERE (E.G. TOTAL WIND) AND C SOMETIMES NOT. LD(2)=ITABLE(2,2) LD(3)=ITABLE(3,2)+IDPARS(12,M) LD(4)=ITABLE(4,2) WRITE(IP16,394)(LD(MMM),MMM=1,4),PLAIN(M),NDATE 394 FORMAT(/' WRITING ASCI TO UNIT KFILVO',3I10.9,I10.3, 1 3X,A32,' FOR DATE',I12) ENDIF C ENDIF C ENDIF C 400 CONTINUE C IF(IWRITA(N).EQ.1.OR.IWRITA(N).EQ.4)THEN WRITE(KFILDO,401)NOSCII 401 FORMAT(/' NUMBER OF ASCII RECORDS WRITTEN TO KFILVO =',I7, 1 '.',/,' THIS IS THE NUMBER OF POINTS ACTUALLY USED', 2 ' IN THE ANALYSIS, INCLUDING THOSE TOSSED ON THE', 3 ' LAST PASS.') ELSEIF(IWRITA(N).EQ.2.OR.IWRITA(N).EQ.3)THEN WRITE(KFILDO,402)NOSCII 402 FORMAT(/' NUMBER OF ASCII RECORDS WRITTEN TO KFILVO =',I7, 1 '.',/,' THIS IS THE NUMBER OF BASE (ONLY) POINTS', 2 ' ACTUALLY USED IN THE ANALYSIS, INCLUDING THOSE', 3 ' TOSSED ON THE LAST PASS.') ENDIF 500 CONTINUE C CCCCC WRITE(KFILDO,501)JER,MER,JDATE,M,PLAIN(M) CCCCC 501 FORMAT('AT 501--JER,MER',2I4,4I6,I8,2X,A32) C IF(JER.EQ.0.AND.MER.EQ.0)THEN WRITE(KFILDO,502)(JDATE(JJ),JJ=1,4),PLAIN(M) 502 FORMAT(/' U405A HAS SUCCESSFULLY COMPLETED FOR DATE/TIME ', 1 I5,3I3.2,'00, VARIABLE ',A32, 2 ' OUTPUT SHOULD BE CORRECT.') ELSEIF(JER.NE.0)THEN WRITE(KFILDO,503)JER,(JDATE(JJ),JJ=1,4),PLAIN(M) 503 FORMAT(/' U405A HAS COMPLETED WITH',I3,' MAJOR ERRORS FOR', 1 ' DATE/TIME ',I5,3I3.2,'00, VARIABLE ',A32,/, 2 74X,'EITHER NO GRID OR A 9999 GRID WAS WRITTEN.') C IF(MER.NE.0)THEN WRITE(KFILDO,504)MER 504 FORMAT(' IN ADDITION, THERE WERE',I4,' MINOR ERRORS.'/) ENDIF C ELSE WRITE(KFILDO,506)MER,(JDATE(JJ),JJ=1,4),PLAIN(M) 506 FORMAT(/' U405A HAS COMPLETED WITH',I3,' MINOR ERRORS FOR', 1 ' DATE/TIME ',I5,3I3.2,'00, VARIABLE ',A32,/, 2 74X,'A GRID WAS PRODUCED BUT MAY HAVE SOME ERROR.'/) ENDIF C GO TO 700 C 600 IER=777 ISTOP(1)=ISTOP(1)+1 C C SAVE JDATE( ) IN NSAVDT( ) FOR USE ON NEXT ENTRY. C 700 NSAVDT(1)=JDATE(1) NSAVDT(2)=JDATE(2) NSAVDT(3)=JDATE(3) NSAVDT(4)=JDATE(4) NSTA=NSTASV C NSTA IS RESET TO THE ENTRY VALUE. C C WRITE TRAILER RECORD TO THIS VECTOR FILE UNLESS C KFILOV = 0. IF THERE IS AN ERROR, TRAIL WILL PRODUCE C A DIAGNOSTIC. U155 WILL WRITE AN EOF AT COMPLETION C OF RUN. C IF(KFILOV.NE.0)THEN CALL TRAIL(KFILDO,KFILOV,L3264B,L3264W,MTOTBY,MTOTRC,IER) C IER WILL OVERWRITE ANY PREVIOUS IER. ENDIF C C WRITE TRAILER RECORD TO THIS VECTOR FILE UNLESS C KFILQC = 0. IF THERE IS AN ERROR, TRAIL WILL PRODUCE C A DIAGNOSTIC. U155 WILL ALSO AT THE END WRITE A TRAILER C RECORD AND AN EOF. C IF(KFILQC.NE.0)THEN CALL TRAIL(KFILDO,KFILQC,L3264B,L3264W,ITOTBY,ITOTRC,IER) C IER WILL OVERWRITE ANY PREVIOUS IER. ENDIF C C CLOSE RANDOM ACCESS FILE NO. 42. EVEN THOUGH C A CLOSE IS ALSO IN U155, IT IS DONE HERE SO THAT ANY C RECORDS WRITTEN IN U405A FOR ONE VARIABLE WILL BE C AVAILABLE EVEN IF U155 DID NOT COMPLETE. C***********THIS SHOULD HAVE OPENED IF NEEDED AGAIN, BUT C***********BUT EVIDENTLY DIDN'T. CCCCC DO 710 J=1,6 CCCCC IF(KFILRA(J).EQ.42)THEN CCCCC CALL CLFILM(KFILDO,KFILRA(J),IER) CCCCC ENDIF CCCCCC CCCCC 710 CONTINUE C CALL TIMPR(KFILDO,KFILDO,'END U405A ') C IER UPON RETURN DOES NOT AFFECT CALLING U155. U155 C WILL PROCEED. IER=JER+MER C THE TOTAL OF MAJOR AND MINOR ERRORS ARE RETURNED FOR C SUMMATION AND PRINTING IN U155. C CCCC WRITE(KFILDO,711)IER,JER,MER CCCC 711 FORMAT(/' LEAVING U405A WITH IER =',I4,' JER =',I4,' MER =',I4) C RETURN C C ERROR STOP BELOW IS FOR ERRORS OF CONTROL INFORMATION INPUT. 900 CALL IERX(KFILDO,KFILDO,IOS,'U405A ',STATE) CALL W3TAGE('U405A') STOP 900 END