SUBROUTINE U45415M(KFILDI,KFILDO,KFIL10,KFILOG,KFILRA,RACESS, 1 NUMRA,IP16,IP22, 2 FD1,U,V,U51,V51,XPOS,YPOS,FD7,FD9,ND2X3, 3 ID,IDPARS,JD,INCDD,JP,ISCALD, 4 IPLAIN,PLAIN,NPRED,ND4, 5 IPACK,DATA,IWORK,ND5, 6 NCEPNO,LAMPNO,NDATE, 7 ALATL,ALONL,NPROJ,ORIENT,XLAT, 8 NXL,NYL,NXPL,NYPL,MESHB,MESHD,IOPTB, 9 IS0,IS1,IS2,IS4,ND7, A LSTORE,LITEMS,ND9, B CORE,ND10,NBLOCK, C JTOTBY,JTOTRC, D L3264B,L3264W,MISTOT,MINPK,ISTOP,IER) C C AUGUST 2001 GLAHN TDL LAMP-2000 C AUGUST 2001 GLAHN PUT DATE/TIME INTO TITLT C SEPTEMBER 2001 GLAHN ADDED CHECK FOR TAU NE 0 TO EXECUTE; C ADDED IUSED( ), MODIFIED CALL C TO FORCST; CHANGED ITAUH TO LP IN C SOME CALLS TO PAWOTG C SEPTEMBER 2001 GLAHN ADDED TEMPERATURE AND DEW POINT C SEPTEMBER 2001 GLAHN MODIFIED SEARCH AT DO 399 LOOP C SEPTEMBER 2001 GLAHN ADDED DEFINITION OF ALATD, ALOND C SEPTEMBER 2001 GLAHN RATIO RR INVERTED TO MESHB/MESH C SEPTEMBER 2001 GLAHN ADDED LOOP 275 AND FORMAT 276 C SEPTEMBER 2001 GLAHN ADDED CHECK FOR MESH AT 278 C OCTOBER 2001 GLAHN REMOVED ZEROING PMA( ) C OCTOBER 2001 GLAHN ADDED RADAR CAPABILITY C OCTOBER 2001 GLAHN CHANGED LD TO LP IN CALL TO PAWING C OCTOBER 2001 GLAHN CHANGED NX,NY TO NXG,NYG IN ALL CALLS C TO PRTGR; ADJUSTED CONTOUR INTERVAL C IN PRTGR FOR TRAJECTORY END POINTS C FOR MESH LENGTH; USED CINT( , ), ETC. C IN PRTGR; ADDED GRIDPRINT OF 0-HR C OCTOBER 2001 GLAHN CHANGED LOCATION OF NCHAR=, ETC. C OCTOBER 2001 GLAHN ADDED 9 BIN CLOUD LAYER CAPABILITY; C CHANGED PRINTING ORIGIN TO TWO PLACES C OCTOBER 2001 GLAHN REVISED TO ADVECT FIELDS SEPARATELY; C ADDED 700-, 850-MB AND 1000-MB LAMP C NOVEMBER 2001 GLAHN ADDED BIN 10 OBSCURATION C NOVEMBER 2001 GLAHN MODIFED ID FOR TOP CLOUD BIN C NOVEMBER 2001 GLAHN INITIALIZED LCOMBO AND COMB( , ) C NOVEMBER 2001 GLAHN CORRECTED IF TEST AND REDEFINED NXD C AGAIN BEFORE CALL TO PAWOTG C DECEMBER 2001 GLAHN ADDED MESH LENGTH FOR WIND, MESHW C JANUARY 2002 GLAHN ADDED LASTMS TO CALL TO AWND; CHANGED C PMA TO FD1 IN CALLS TO GETELD, PAWING C APRIL 2002 GLAHN ADDED "NOMINAL" IN MESHW DEFINITION; C CHANGED PMA( ) TO SINPHI( ) C MAY 2002 GLAHN SET IDCUR( ) = 0 BELOW 2877 WHEN C MESHW NE MESH C MAY 2002 GLAHN INSERTED SAVING OF XPOS( ) AND YPOS( ) C INSTEAD OF SETTING IDCUR( ) =0 C MAY 2002 GLAHN ADDED PRINT OF FINAL PARAMETERS AT C 279; DIAGNOSTIC AFTER GETFLD AND C GETRAD C MAY 2002 GLAHN MADE DD = 5 FOR WRITING DISPOSABLE C FILE C MAY 2002 GLAHN MADE MESH, ITRPLQ, I454DG VARIABLE BY C ELEMENT TO FORECAST; WRITES OUT C INITIAL TWO RADAR GRIDS C MAY 2002 GLAHN MODIFIED TO READ .CN FILES ONLY ONCE; C WROTE XPOS( )/YPOS( ) BEFORE SCALING; C ADDED ISAME; WRITES INITIAL TWO RADAR C GRIDS TO INTERNAL STORAGE; CHANGED C ITAUH TO LP IN 2 CALLS TO PAWING; C ADDED MESHSV C MAY 2002 GLAHN ADDED ISTOP TO CALL TO GETRAD C MAY 2002 GLAHN REMOVED NRATIO C JUNE 2002 GLAHN ADDED TESTS ON JP( ,N) FOR INITIAL C DIAGNOSTICS FOR RADAR FIELD C JUNE 2002 GLAHN ADDED I454DG TO SAVE LIST C JUNE 2002 GLAHN ADDED INCDD TO CALL AND PAWOTG LD(1) C JULY 2002 GLAHN ADDED TEST ON IP22 = 0 BEFORE PRTGR C JULY 2002 GHIRARDELLI MODIFIED CALL TO AWND. SEE AWND C DOCUMENTATION FOR DETAILS. ALSO REMOVED C SINPHI AND LASTMS C DECEMBER 2002 RUDACK MODIFIED FORMAT STATEMENTS TO ADHERE C TO THE F90 COMPILER STANDARDS FOUND ON C THE IBM SYSTEM C DECEMBER 2002 GLAHN INCLUDED U51( ) AND V51( ) IN CALL AND C ELIMINATED XPOS1( ) AND YPOS1( ) C DECEMBER 2002 GLAHN CHANGED PACKING OF XPOS( ), YPOS( ) C AND RADAR GRID TO USE ONE LARGE GROUP C RATHER THAN MINPK; ADDED I7076 AND C I7077 C RUDACK 2002 RUDACK CORRECTED THE FORMAT TYPE OF TWO ELEMENTS C READ IN FROM THE U454 CONTROL FILES; C CORRECTED FORMAT STATEMENT 500 TO ADHERE C TO THE IBM FORMAT STANDARDS. C FEBRUARY 2003 GLAHN MADE IBACKN COMMENT THE SAME AS IN C FIRST GUESS ROUTINES; SPELL CHECK C APRIL 2003 GLAHN MODIFIED XPOS( ) AND YPOS( ) FOR RADAR C TO ACCOUNT FOR HOW GRID IS IDENTIFIED; C CHECKS ON RADAR MODIFID TO USE ANY ONE C OF THE 4 RADAR GRIDS AS THE PRIMARY, C HOWEVER, OTHER ROUTINES IN U150 ASSUME C 707645 OR 707745 C MAY 2003 LIANG CHANGED THE FOURTH AND THE FIFTH CLOUD C BIN IDS TO ACCOMMODATE THE REDEFINED C TAF CATEGORIES. C JUNE 2003 WIEDENFELD ADDED 3 ELEMENTS FOR ADVECTION C PTYPE, OCCURRENCE OF PRECP, OBV C MARCH 2004 WIEDENFELD CHANGED RADAR REF. ID'S IN ITABLE C TO HAVE THE QC'ED FFF OF 646, 631, 616, 601. C CHANGED CCC AND DD OF BOTH RADAR IDS C TO HAVE 007 AND 05. THE FINAL ID WILL BE C WRITTEN OUT WITH THOSE IDS, INSTEAD OF C A CCC OF 707. ALSO CHANGED VARIABLES C I7076 AND I7077 TO BE I0077 AND I0077. C CHANGED IF NEAR CALL TO GETRAD AND DO 327 C TO BE 007 INSTEAD OF 707. TOOK OUT IF STATMENTS C REGARDING CHANGING 04 DD TO 05 FOR PACKING C PURPOSES. THESE CHECKS ARE NO LONGER NEEDED. C MARCH 2004 WIEDENFELD ADDED LIGHTNING FOR ADVECTION. ADDED CALL C TO GETLTG TO PUT LIGHTNING ON THE LAMP GRID. C SEPTEMBER 2004 GLAHN ADDED CALL TO INTRLN C SEPTEMBER 2004 GHIRARDELLI MERGED GLAHN AND WIEDENFELD VERSIONS C JANUARY 2005 WIEDENFELD MODIFIED FOR OPERATIONS SO IF RADAR C AND LIGHTNING ARE MISSING THE REST OF C THE ELEMENTS CAN STILL BE PROCESSED. C MAY 2005 WIEDENFELD ADDED VARIABLE RMISS(IVRBL). THIS IS C THE VALUE THAT MISSING POINTS WILL BE C SET TO. C AUGUST 2005 WIEDENFELD MODIFIED FOR OPERATIONS. TOOK OUT C STOP 9999 REPLACED WITH IER=9999 C U150 WILL GIVE ERROR STATEMENT C AUGUST 2005 WIEDENFELD MODIFIED GO TO 600'S WHEN ERRORS FROM C LIGHTNING AND RADAR ADVECTION OCCUR. CODE C WILL NOW SET IER=0 AND GO TO 399 INSTEAD. C NOVEMBER 2012 GHIRARDELLI MODIFIED TO PASS PLAIN/IPLAINT TO PAWING C WHICH WAS MODIFIED FOR INTEL CHANGES C SEPTEMBER 2015 SAMPLATSKY ADDED MRMS/TL VARIABLES TO C ARRAYS IN THE DATA STATEMENTS. ALSO C REPLACED CALL TO GETLTG WITH C GETRADLTG. ULTIMATELY THE CALL TO C GETRAD COULD PROBABLY BE REMOVED. C SEPTEMBER 2015 SAMPLATSKY HAD RMISS INCORRECTLY DEFINED C FOR MRMS/TL VARIABLES. CORRECTION C IS NOW CONSISTENT WITH OLD RAD/LTG C VARIABLES. C OCTOBER 2015 CHARBA IMPROVED DOC IN DATA STATEMENTS C OCTOBER 2015 SAMPLATSKY REMOVED THE HALF GRIDLENGTH C OFFSET IN DO 327 LOOP. REMOVED C CALL TO GETRAD BELOW LABEL 320, AND C ADJUSTED SURROUNDING DOCUMENTATION. C APRIL 2016 SAMPLATSKY ADDED IDS FOR ALL 15-MIN TIME C PERIODS FOR MRMS AND LTG VARS, ALSO C ADDED 2 MORE LTG VARS. INCREASED C NVAL TO 85. C APRIL 2017 SAMPLATSKY MODIFIED IDS TO FINAL APPROVED C IDS. C SEPTEMBER 2018 SAMPLATSKY ADDED IDS FOR MRMS 1H PRECIP, C INCREASED NVAL TO 87. ALSO ADDED C 1H PRECIP IDS TO LOGIC FOR CALLING C GETRADLTG. C MARCH 2024 SAMPLATSKY THIS COPY OF U454 IS FOR 15 MIN C TIME PERIODS. CHANGED SUBROUTINE C NAME TO U45415M. CALLS AWND15M C INSTEAD OF AWND. ISCAL FOR PACKING C THE POS ARRAYS INCREASED FROM 1 TO 4. C MARCH 2024 SAMPLATSKY TO BE CONSISTENT WITH THE C HOURLY ADVECTION, RMISS FOR VIS C IS ADJUSTED TO 10 (WAS 50). C C PURPOSE C PROGRAM U454 IS THE CLAM MODEL, TAILORED FROM U452 AND C EARLIER VERSIONS OF LAMP. C C U454 WILL RUN IF ANY ONE OF THE ID(1, ) INDICATES C ONE OF THE VARIABLES IN ITABLE(1, ), PROVIDED THE C PROJECTION IS NOT ZERO. WHICH FORECASTS ARE ACTUALLY C MADE IS CONTROLLED FROM THE U454XXX.CN. C THOSE WRITTEN TO THE ARCHIVE FILE, UNIT KFILIO IN U150, C IS CONTROLLED BY THE VARIABLES IN ID( , ). C C DATA SET USE C KFILDI - UNIT NUMBER OF INPUT FILE. (INPUT) C KFILDO - UNIT NUMBER OF OUTPUT (PRINT) FILE. (OUTPUT) C KFIL10 - UNIT NUMBER FOR INTERNAL RANDOM ACCESS STORAGE. C (INPUT/OUTPUT) C KFILOG - UNIT NUMBER FOR DISPOSABLE TDLPACK GRIDPOINT C OUTPUT. (OUTPUT) C KFILRA(J)- UNIT NUMBERS FOR ACCESSING THE MOS-2000 C EXTERNAL RANDOM ACCESS FILES (J=1,6). (INPUT) C IP16 - UNIT NUMBER FOR INDICATING WHEN A RECORD IS C WRITTEN TO THE SEQUENTIAL FILE ON UNIT C NO. KFILOG. (OUTPUT) C IP22 - UNIT NUMBER FOR GRIDPRINTING. (OUTPUT) C C VARIABLES C KFILDI = UNIT NUMBER TO READ INPUT FILE 'U454XXX.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 FOR DISPOSABLE TDLPACK GRIDPOINT C OUTPUT. THIS IS FOR DIAGNOSTIC INFORMATION. C (INPUT) C KFILRA(J) = THE UNIT NUMBERS FOR ACCESSING THE MOS-2000 C EXTERNAL RANDOM ACCESS FILES (J=1,6). (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 IP16 = INDICATES WHETHER (>0) OR NOT (=0) C A STATEMENT WILL BE OUTPUT TO IP16 C WHEN A SEQUENTIAL FILE IS WRITTEN THROUGH C PAWOTG TO UNIT NO. KFILOG. (INPUT) C IP22 = UNIT NUMBER FOR GRIDPRINTING. (INPUT) C FD1(J) = WORK ARRAY (J=1,NX*NY). ONE USE IS OBTAINING C THE TERRAIN TERM FROM THE RANDOM ACCESS FILE. C (INTERNAL) C U(J), V(J) = THE MODEL ADVECTIVE U- AND V-WIND COMPONENTS C (J=1,NX*NY). THESE ARE ONLY USED FOR WORK C ARRAYS IN AWND AND FCST. (INTERNAL) C U51(J), V51(J) = WORK ARRAYS IN AWND. (INTERNAL) C XPOS(J) = X-POSITIONS OF BEGINNING POINTS OF C TRAJECTORIES FROM SUBROUTINE FORCST C (J=1,NX*NY). (INTERNAL) C YPOS(J) = Y-POSITIONS OF BEGINNING POINTS OF C TRAJECTORIES FROM SUBROUTINE FORCST C (J=1,NX*NY). (INTERNAL) C FD7(J) = WORK ARRAY (J=1,NX*NY). (INTERNAL) C FD9(J) = WORK ARRAY (J=1,NX*NY). (INTERNAL) C ND2X3 = THE DIMENSION OF SEVERAL ARRAYS = ND2*ND3 IN C DRIVER. (INPUT) C ID(J,N) = THE VARIABLE ID'S BEING DEALT WITH IN U150 C (J=1,4) (N=1,ND4). (INPUT) C IDPARS(J,N) = THE PARSED, INDIVIDUAL COMPONENTS OF THE C VARIABLE ID'S CORRESPONDING TO ID( ) C (J=1,15) (N=1,ND4). C J=1--CCC (CLASS OF VARIABLE), C J=2--FFF (SUBCLASS OF VARIABLE), C J=3--B (BINARY INDICATOR), C J=4--DD (DATA SOURCE, MODEL NUMBER), C J=5--V (VERTICAL APPLICATION), C J=6--LBLBLBLB (BOTTOM OF LAYER, 0 IF ONLY C 1 LAYER), C J=7--LTLTLTLT (TOP OF LAYER), C J=8--T (TRANSFORMATION), C J=9--RR (RUN TIME OFFSET, ALWAYS + AND BACK C IN TIME), C J=10--OT (TIME APPLICATION), C J=11--OH (TIME PERIOD IN HOURS), C J=12--TAU (PROJECTION IN HOURS), C J=13--I (INTERPOLATION TYPE), C J=14--S (SMOOTHING INDICATOR), AND C J=15--G (GRID INDICATOR). C (INPUT) C JD(J,N) = THE BASIC INTEGER PREDICTOR ID'S (J=1,4) C (N=1,ND4). THIS IS THE SAME AS ID(J), EXCEPT C THAT THE PORTIONS PERTAINING TO PROCESSING C 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) OR INTERMEDIATE TDLPACK C OUTPUT (J=2) (N=1,ND4). J = 3 IS NOT USED. C (INPUT) C ISCALD(N) = DECIMAL SCALING FOR THE VARIABLES (N=1,ND4). C (INPUT) 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 C HOLD THE DESCRIPTION BUT ONLY ONE 64-BIT WORD. C EQUIVALENCED TO PLAIN( ) IN DRU150. (INPUT) C PLAIN(N) = THE PLAIN LANGUAGE DESCRIPTION OF THE VARIABLES C IN ID( ) (N=1,ND4). EQUIVALENCED TO C IPLAIN( , ,N) IN DRU150. (CHARACTER*32) C (INPUT) C NPRED = THE NUMBER OF VARIABLES IDENTIFIED IN ID( ). C (INPUT) C ND4 = THE MAXIMUM NUMBER OF VARIABLES THAT CAN BE C IDENTIFIED IN ID( , ). (INPUT) C IPACK(J) = WORK ARRAY (J=1,ND5). (INTERNAL) C DATA(J) = WORK ARRAY (J=1,ND5). (INTERNAL) C IWORK(J) = WORK ARRAY (J=1,ND5). (INTERNAL) C ND5 = DIMENSION OF IPACK( ), IWORK( ), AND DATA( ). C (INPUT) C NCEPNO = EXPECTED NCEP INPUT MODEL NUMBER. (INPUT) C LAMPNO = LAMP OUTPUT MODEL NUMBER AND EXPECTED LAMP C INPUT MODEL NUMBER. (INPUT) C NDATE = THE DATE/TIME OF THE RUN. (INPUT) C ALATL = NORTH LATITUDE IN DEGREES OF LOWER LEFT CORNER C POINT OF A 1/4 B GRID OF THE SIZE ETC. C SPECIFIED BY NXL, NYL, NXPL, AND NYPL. (INPUT) C ALONL = WEST LONGITUDE IN DEGREES OF LOWER LEFT CORNER C POINT OF A 1/4 B GRID OF THE SIZE ETC. C SPECIFIED BY NXL, NYL, NXPL, AND NYPL. (INPUT) C NPROJ = NUMBER OF THE MAP PROJECTION TO WHICH THIS GRID C APPLIES. C 5 = POLAR STEREOGRAPHIC. 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 IN C THE X DIRECTION IN 1/4 BEDIENT UNITS. (INPUT) C NYL = THE SIZE OF THE PRIMARY GRID FOR THIS RUN IN C THE Y DIRECTION IN 1/4 BEDIENT UNITS. (INPUT) C NXPL = POLE POSITION OF THE PRIMARY GRID FOR THIS RUN C IN RELATION TO LOWER LEFT CORNER OF GRID AT C (1,1) IN THE X DIRECTION IN 1/4 BEDIENT UNITS. C (INPUT) C NYPL = POLE POSITION OF THE PRIMARY GRID FOR THIS RUN C IN RELATION TO LOWER LEFT CORNER OF GRID AT C (1,1) IN THE Y DIRECTION IN 1/4 BEDIENT UNITS. C (INPUT) C MESHB = THE NOMINAL MESH LENGTH OF 1/4 BEDIENT GRID. C 1/4 BEDIENT AT 60 N IS 95.25 KM WHICH IS ABOUT C 80 KM OVER THE U.S. MESH = 80 CORRESPONDS TO C 95.25 STORED WITH THE GRIDS. NXL, NYL, ETC. C ARE IN RELATION TO THIS. (INPUT) C MESHD = NOMINAL MESH LENGTH OF QUALITY CONTROL C (SUBSETTED) GRID FOR NON-CONTINUOUS VARIABLES. C (INPUT) C IOPTB(J) = SUBSETTING VALUES USED IN GRIDPRINTING (J=1,8) C IN RELATION TO THE QUARTER BEDIENT MESHB. 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 C VARIABLE. (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 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 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 ISTOP = ISTOP IS INCREMENTED BY 1 EACH TIME AN ERROR C OCCURS. (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 U150. (OUTPUT) C STATE = VARIABLE SET TO STATEMENT NUMBER TO INDICATE C WHERE AN ERROR OCCURRED. (CHARACTER*4) C (INTERNAL) C NVAL = NUMBER OF VALUES IN ITABLE( , ), DOTCH( ) C AND KOUNT( ). (INTERNAL) C ITABLE(I,J) = 4-WORD ID OF THE VARIABLES THAT ARE C ACCOMMODATED BY U454 (I=1,4) (J=1,NVAL) C J = 1--008000005 000000000; CEILING HEIGHT C (HUNDREDS OF FT) C J = 2--008100005 000000000; VISIBILITY (MI) C J = 3--008311005 000000000; TOTAL SKY COVER C (CODED 0-10) C J = 4--008320005 000000000; AMT LOWEST CLD LYR C J = 5--008321005 000000000; HGT LOWEST CLD LYR C J = 6--008322005 000000000; AMT 2ND LOW CLD LYR C J = 7--008323005 000000000; HGT 2ND LOW CLD LYR C J = 8--008324005 000000000; AMT 34D LOW CLD LYR C J = 9--008325005 000000000; HGT 3RD LOW CLD LYR C J = 10-008326005 000000000; AMT 4TH LOW CLD LYR C J = 11-008327005 000000000; HGT 4TH LOW CLD LYR C J = 12-008328005 000000000; AMT 5TH LOW CLD LYR C J = 13-008329005 000000000; HGT 5TH LOW CLD LYR C J = 14-008330005 000000000; AMT 6TH LOW CLD LYR C J = 15-008331005 000000000; HGT 6TH LOW CLD LYR C J = 16-008500005 000000000; WEATHER FIRST GROUP C J = 17-008501005 000000000; WEATHER SECOND GROUP C J = 18-008502005 000000000; WEATHER THIRD GROUP C J = 19-409020005 000000000; GRID ELEVATIONS C J = 20-002301005 000000002; TEMPERATURE C J = 21-003301005 000000002; DEW POINT C J = 22-007601005 000000000; RADAR REFLECT H+00 C J - 23-007616005 000000000; RADAR REFLECT H+15 C J - 24-007631005 000000000; RADAR REFLECT H+30 C J - 25-007646005 000000000; RADAR REFLECT H+45 C J = 26-007700005 000000000; RADAR COVRAGE H+00 C J - 27-007715005 000000000; RADAR COVRAGE H+15 C J - 28-007730005 000000000; RADAR COVRAGE H+30 C J - 29-007745005 000000000; RADAR COVRAGE H+45 C J = 30-008350005 000000001; CLOUD AMOUNT 0-1 C J = 31-008355005 000000001; CLOUD HEIGHT 0-1 C J = 32-008350005 000020004; CLOUD AMOUNT 2-4 C J = 33-008355005 000020004; CLOUD HEIGHT 2-4 C J = 34-008350005 000050009; CLOUD AMOUNT 5-9 C J = 35-008355005 000050009; CLOUD HEIGHT 5-9 C J = 36-008350005 000100019; CLOUD AMOUNT 10-19 C J = 37-008355005 000100019; CLOUD HEIGHT 10-19 C J = 38-008350005 000200030; CLOUD AMOUNT 20-30 C J = 39-008355005 000200030; CLOUD HEIGHT 20-30 C J = 40-008350005 000310045; CLOUD AMOUNT 31-45 C J = 41-008355005 000310045; CLOUD HEIGHT 31-45 C J = 42-008350005 000460065; CLOUD AMOUNT 46-65 C J = 43-008355005 000460065; CLOUD HEIGHT 46-65 C J = 44-008350005 000660120; CLOUD AMOUNT 66-120 C J = 45-008355005 000660120; CLOUD HEIGHT 66-120 C J = 46-008350005 001219999; CLOUD AMOUNT >120 C J = 47-008355005 001219999; CLOUD HEIGHT >120 C J = 48-008350005 000000000; OBSCURATION HEIGHT C J = 49-008355005 000000000; OBSCURATION AMOUNT C J = 50-008501005 000000000; PRECIP TYPE C J = 51-008504005 000000000; PRECIP OCCURRENCE C J = 52-008251005 000000000; OBSCURATION TO VISION C J = 53-007580005 000000000; LIGHTNING FLASHES C (INTERNAL) C RMISS(J) = THE SPECIFIC MISSING VALUE TO BE ASSIGNED IN NEARGR. C (J=1,NVAL) (INTERNAL) C IUSED(J) = INDICATES WHETHER (=1) OR NOT (=0) THE VALUE C IN ITABLE( ,J) HAS BEEN USED. (INTERNAL) C DOTCN(J) = THE SPECIFIC .CN FILES FOR U454 (J=1,NVAL). C (CHARACTER*14) (INTERNAL) C KOUNT(J) = KEEPS TRACK OF WHICH VARIABLES HAVE HAD C FORECASTS MADE (FOR ALL PROJECTIONS). C (INTERNAL) C NPROJH = THE NUMBER OF PROJECTIONS FOR THIS ROUTINE. C UP TO 25 ARE ACCOMMODATED. IT DETERMINES C THE NUMBER OF TIMES FORCST IS ENTERED AND C TRAJECTORY POSITIONS CALCULATED. (INTERNAL) C MESHW = THE NOMINAL MESH LENGTH TO USE IN COMPUTING C ADVECTING WINDS. (INTERNAL) C IBACKN = NUMBER OF 6-H CYCLES TO LOOK BACK FOR NCEP C FORECAST (IBACKN = 1 MEANS CURRENT (MOST C RECENT) CYCLE PLUS THE ONE 6 HOURS BEFORE). C NORMALLY, THIS IS 0 FOR DEVELOPMENT; MAY C BE OTHERWISE FOR OPERATIONS.(INPUT) C IBACKL = NUMBER OF 1-H CYCLES TO LOOK BACK FOR LAMP C FORECAST (IBACKL = 1 MEANS CURRENT CYCLE C PLUS THE ONE 1 HOUR BEFORE). NORMALLY, C THIS WOULD BE 0, ELSE AN IBACKL-HOUR OLD C ANALYSIS WILL BE USED FOR INITIALIZATION C WITH NO ADJUSTMENT FOR PROJECTIONS. C (INTERNAL) C R(J) = RADIUS OF INFLUENCE FOR EACH PROJECTION J C (J=1,NPROJH) IN TERMS OF MESH GRID UNITS C BEING USED ON THAT PROJECTION. R( ) MAY HAVE C NO USE. (INTERNAL) C ITRPLQ(L) = TYPE OF INTERPOLATION TO GO FROM ONE MESH C LENGTH TO ONE OF HALF THAT MESH LENGTH C (L=1,IVRBL). C 1 = BILINEAR C 2 = BIQUADRATIC C (INTERNAL) C B(J,L) = SMOOTHING PARAMETER FOR THE FORECAST FOR EACH C PROJECTION J (J=1,NPROJH) AND VARIABLE C (L=1,IVRBL). B( ) = 0 MEANS NO SMOOTHING. C (INTERNAL) C SMULT(J,L) = THE MULTIPLICATIVE FACTOR WHEN CONTOURING OR C GRIDPRINTING THE DATA (J=1,NPROJH) C AND VARIABLE (L=1,IVRBL). NOTE SMULT( , ), C 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 PROJECTION. (INTERNAL) C SADD(J,L) = THE ADDITIVE FACTOR WHEN CONTOURING OR C GRIDPRINTING THE DATA (J=1,NPROJH) AND C VARIABLE (L=1,IVRBL). (INTERNAL) C ORIGIN(J,L) = THE CONTOUR ORIGIN, APPLIES TO THE UNITS IN C UNITS(N) (J=1,NPROJH) AND VARIABLE (L=1,IVRBL). C (INTERNAL) C CINT(J,L) = THE CONTOUR INTERVAL, APPLIES TO THE UNITS IN C UNITS(N) (J=1,NPROJH) AND VARIABLE (L=1,IVRBL). C (INTERNAL) C MAKEF(J,L) = 1 FOR MAKING A FORECAST FOR PROJECTION J C (J=1,NPROJH) AND VARIABLE (L=1,IVRBL). C ZERO OTHERWISE. (INTERNAL) C NPRT(J,L) = 1 FOR GRID PRINTING OF ANALYSIS AFTER C PROJECTION J (J=1,NPROJH) AND VARIABLE C (L=1,IVRBL). ZERO FOR NO PRINTING. (INTERNAL) C NTDL(J,L) = 1 FOR TDLPACKING AND WRITING ANALYSIS AFTER C PROJECTION J (J=1,NPROJH) AND VARIABLE C (L=1,IVRBL). ZERO FOR NO PACKING. (INTERNAL) C IFIRST = COUNTS ENTRIES INTO U454. THIS ALLOWS (HARD C CODED) CONTROL OF OUTPUT. ALSO ALLOWS READING C OF .CN FILES ONLY ONCE; WITH THIS LATTER C CAPABILITY RECENTLY ADDED, CONTROL OF OUTPUT C IS NOT NEEDED EXCEPT AT 500. BUT IF MORE THAN C ONE SET OF PRINT IS DESIRED, IFIRST CAN STILL C BE USED AND THE CONTROL FILES WILL BE READ C MORE THAN ONCE. SET BY DATA STATEMENT TO ZERO. C (INTERNAL) C LIMIT = WHEN IFIRST GT LIMIT, PRINT OF CONTROL C INFORMATION WILL NOT OCCUR. SET BY DATA C STATEMENT. (INTERNAL) C JFIRST = COUNTS THE NUMBER OF TIMES FORMAT 500 HAS C PRINTED. IF THE FIRST CYCLE DOES NOT COMPLETE, C PRINT DOES NOT OCCUR ON THAT CYCLE. (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(L) = THE NOMINAL MESH LENGTH OF THE GRID BEING DEALT C WITH WHOSE DIMENSIONS ARE NX AND NY (L=1,IVRBL). C (INTERNAL) C IOPT(J) = SUBSETTING VALUES USED IN GRIDPRINTING (J=1,8) C IN RELATION TO THE SUBSETTED AREA MESH LENGTH C MESHD. (INTERNAL) C C00AF = THE FACTOR TO USE IN COMPUTING THE 1000-MB C ADVECTING WINDS. (INTERNAL) C C85AF = THE FACTOR TO USE IN COMPUTING THE 850-MB C ADVECTING WINDS. (INTERNAL) C C70AF = THE FACTOR TO USE IN COMPUTING THE 700-MB C ADVECTING WINDS. (INTERNAL) C C50AF = THE FACTOR TO USE IN COMPUTING THE 500-MB C ADVECTING WINDS. (INTERNAL) C N00SM = THE NUMBER OF TIMES THE 1/4-BEDIENT 1000-MB GRID C IS SMOOTHED FOR PURPOSES OF COMPUTING C ADVECTING WINDS. (INTERNAL) C N85SM = THE NUMBER OF TIMES THE 1/4-BEDIENT 850-MB GRID C IS SMOOTHED FOR PURPOSES OF COMPUTING C ADVECTING WINDS. (INTERNAL) C N70SM = THE NUMBER OF TIMES THE 1/4-BEDIENT 700-MB GRID C IS SMOOTHED FOR PURPOSES OF COMPUTING C ADVECTING WINDS. (INTERNAL) C N50SM = THE NUMBER OF TIMES THE 1/4-BEDIENT 500-MB GRID C IS SMOOTHED FOR PURPOSES OF COMPUTING C ADVECTING WINDS. (INTERNAL) C CFILT = THE FRACTION OF THE SPEED REDUCTION OF HIGH C WINDS TO APPLY. FOR FULL APPLICATION, C CFILT = 1. FOR NO REDUCTION, CFILT = 0. C (INTERNAL) C LAMTAU = THE NUMBER OF HOURS + 1 THE LAMP 1000-MB FIELD C WILL BE USED INSTEAD OF THE NCEP FIELD. C A LINEAR DECREASE FROM 100 PERCENT AT TAU = 0 C TO ZERO PERCENT AT LAMTAU IS USED. (INTERNAL) C I454DG(L) = 1 = DISPOSABLE GRIDS ARE TO BE WRITTEN TO UNIT C NOS. KFILOG AND IP22 FOR THE SUBSETTED AREA; C 0 OTHERWISE (L=1,IVRBL). WRITING IS ALSO C CONTINGENT ON KFILOG AND IP22 NOT BEING ZERO. C (INTERNAL) C MESHS = MESH AS READ IN. MESH MAY CHANGE; MESHS WILL C NOT. (INTERNAL) C PLAINT = 32-CHARACTER ARRAY FOR NAME TO USE IN PACKING. C (INTERNAL) C IPLANT(J) = EQUIVALENCED TO PLAINT (J=1,4). THIS IS FOR C A FOUR BYTE WORD MACHINE ONLY. (INTERNAL) C IMOD = MODEL NUMBER = 3 FOR CLAM. (INTERNAL) C ISCAL = SCALING PARAMETER FOR PACKING. (INTERNAL) C NSEQ = SEQUENCE NUMBER FOR PACKING. (INTERNAL) C ITAUH = HOUR FOR PACKING. (INTERNAL) C ITAUM = MINUTES FOR PACKING. (INTERNAL) C NCHAR = NUMBER OF CHARACTERS FOR PACKING. (INTERNAL) C XMISSP = PRIMARY MISSING INDICATOR FOR PACKING. C (INTERNAL) C XMISSS = SECONDARY MISSING INDICATOR FOR PACKING. C (INTERNAL) C ALATD = LL LATITUDE OF THE DISPOSABLE GRID. TRUNCATED C TO THOUSANDS TO AGREE WITH ARCHIVE WHEN THE C GRIDS ARE THE SAME. THIS IS NECESSARY FOR C U203 FOR GEMPAK. (INTERNAL) C ALOND = LL LONGITUDE OF THE DISPOSABLE GRID. SEE ALATD. C (INTERNAL) C CAFSM(J,L) = VALUES PERTAINING TO VARIABLE L (L=1,NVAL): C J = 1--WEIGHTING FOR NCEP 1000-MB HEIGHT C J = 2--WEIGHTING FOR NCEP 850-MB HEIGHT C J = 3--WEIGHTING FOR NCEP 700-MB HEIGHT C J = 4--WEIGHTING FOR NCEP 500-MB HEIGHT C J = 5--SMOOTHING FACTOR FOR NCEP 1000-MB HEIGHT C J = 6--SMOOTHING FACTOR FOR NCEP 850-MB HEIGHT C J = 7--SMOOTHING FACTOR FOR NCEP 700-MB HEIGHT C J = 8--SMOOTHING FACTOR FOR NCEP 500-MB HEIGHT C J = 9--MESH LENGTH FOR ADVECTING WINDS C J = 10--CFILTX = THE FRACTION OF THE SPEED C REDUCTION OF HIGH WINDS TO APPLY. C FOR FULL APPLICATION, CFILTX = 1. C FOR NO REDUCTION, CFILTX = 0. C (INTERNAL) C IDWND(J,L) = ID FOR THE ADVECTIVE U-WIND (J=1) AND V-WIND C (J=2) FOR VARIABLE L (L=1,NVAL). (INTERNAL) C IDCUR( ) = SET TO INDICATE WHETHER OR NOT (=0) THE XPOS( ) C AND YPOS( ) CAN BE REUSED. (INTERNAL) C MESHSV = SAVES MESH FROM LAST CALL TO FCST. (INTERNAL) C LINK(J) = FOR EACH VARIABLE (J=1,NPRED), LINK(J) HOLDS C THE CORRESPONDING VALUE IVRBL IN C ITABLE( ,IVRBL), (IVRBL=1,NVAL). C COMB(J,L) = THE COMBINATIONS OF CHARACTERISTICS FOR WHICH C WINDS ARE COMPUTED (J=1,10) (L=1,20). SEE C CAFSM(J) FOR DESCRIPTION OF THE 10 ELEMENTS. C 20 COMBINATIONS ARE PROVIDED FOR. (INTERNAL) C IWCOMB(J,L) = THE U (J=1) AND V (J=2) ADVECTIVE WIND IDS FOR C THE COMBINATIONS OF FACTORS IN COMB( ,L), C (L=1,20). (INTERNAL) C INCDD = INCREMENT TO ADD TO LAMPNO FOR WRITING FORECAST. C I0076 = SET TO 0 UPON ENTRY, AND SET TO 1 WHEN THE C INITIAL RADAR FIELD 0076XX IS GRIDPRINTED. C (INTERNAL) C I0077 = SET TO 0 UPON ENTRY, AND SET TO 1 WHEN THE C INITIAL RADAR FIELD 0077XX IS GRIDPRINTED. C (INTERNAL) C I0075 = SET TO 0 UPON ENTRY, AND SET TO 1 WHEN THE C INITIAL LIGHTNING FIELD 0075XX IS GRIDPRINTED. C (INTERNAL) C 1 2 3 4 5 6 7 X C C NONSYSTEM SUBROUTINES USED C SIZEGR, AWND15M, GETELE, DATPRS, FCST, GETFLD1, PAWOTG, C PAWING, SMOTH, IERX, TIMPR, MSHXMS, NEARGR, TRNSFR, C PRTGR, CUT, IJLLPS, GETRAD, INTRLN C PARAMETER (NVAL=87) C CHARACTER*4 STATE CHARACTER*14 DOTCN(NVAL) CHARACTER*32 PLAIN(ND4),PLAINT CHARACTER*40 TITLE/' '/ CHARACTER*60 RACESS(6) CHARACTER*61 TITLT/' '/ C DIMENSION FD1(ND2X3),U(ND2X3),V(ND2X3),U51(ND2X3),V51(ND2X3), 1 XPOS(ND2X3),YPOS(ND2X3),FD7(ND2X3),FD9(ND2X3) DIMENSION ID(4,ND4),IDPARS(15,ND4),JD(4,ND4),JP(3,ND4),ISCALD(ND4) DIMENSION LINK(ND4) C LINK( ) IS AN AUTOMATIC ARRAY. DIMENSION IPLAIN(L3264W,4,ND4) DIMENSION IPACK(ND5),DATA(ND5),IWORK(ND5) DIMENSION IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7) DIMENSION LSTORE(12,ND9) DIMENSION CORE(ND10) DIMENSION B(25,NVAL),R(25,NVAL) DIMENSION SMULT(25,NVAL),SADD(25,NVAL),ORIGIN(25,NVAL), 1 CINT(25,NVAL),MAKEF(25,NVAL), 2 NPRT(25,NVAL),NTDL(25,NVAL),KOUNT(NVAL) DIMENSION MESH(NVAL),ITRPLQ(NVAL),I454DG(NVAL) DIMENSION ITABLE(4,NVAL),IUSED(NVAL),RMISS(NVAL) DIMENSION CAFSM(10,NVAL),IDWND(2,NVAL),IDCUR(4) DIMENSION COMB(10,20),IWCOMB(2,20) DIMENSION IOPTB(8),IOPT(8),JDATE(4),LD(4),IPLANT(4),KFILRA(6) C EQUIVALENCE (PLAINT,IPLANT) C DATA ITABLE/008000005,0,0,0, 2 008100005,0,0,0, 3 008311005,0,0,0, 4 008320005,0,0,0, 5 008321005,0,0,0, 6 008322005,0,0,0, 7 008323005,0,0,0, 8 008324005,0,0,0, 9 008325005,0,0,0, X 008326005,0,0,0, 1 008327005,0,0,0, 2 008328005,0,0,0, 3 008329005,0,0,0, 4 008330005,0,0,0, 5 008331005,0,0,0, 6 008500005,0,0,0, 7 008510005,0,0,0, 8 008520005,0,0,0, 9 409020005,0,0,0, X 002301005,2,0,0, 1 003301005,2,0,0, 2 007545005,0,0,0, ! 60 min tl count 3 007545005,15,0,0, 4 007545005,30,0,0, 5 007545005,45,0,0, 6 007550005,0,0,0, ! 30 min tl count 7 007550005,15,0,0, 8 007550005,30,0,0, 9 007550005,45,0,0, X 007551005,0,0,0, ! 30 min ic ltg 1 007551005,15,0,0, 2 007551005,30,0,0, 3 007551005,45,0,0, 4 007552005,0,0,0, ! 30 min cg ltg 5 007552005,15,0,0, 6 007552005,30,0,0, 7 007552005,45,0,0, 8 007553005,0,0,0, ! 30 min time chg 9 007553005,15,0,0, X 007553005,30,0,0, 1 007553005,45,0,0, 2 007601005,0,0,0, 3 007616005,0,0,0, 4 007631005,0,0,0, 5 007646005,0,0,0, 6 007700005,0,0,0, 7 007715005,0,0,0, 8 007730005,0,0,0, 9 007745005,0,0,0, X 008350005,000000001,0,0, 1 008355005,000000001,0,0, 2 008350005,000020004,0,0, 3 008355005,000020004,0,0, 4 008350005,000050009,0,0, 5 008355005,000050009,0,0, 6 008350005,000100019,0,0, 7 008355005,000100019,0,0, 8 008350005,000200030,0,0, 9 008355005,000200030,0,0, X 008350005,000310045,0,0, 1 008355005,000310045,0,0, 2 008350005,000460065,0,0, 3 008355005,000460065,0,0, 4 008350005,000660120,0,0, 5 008355005,000660120,0,0, 6 008350005,001219999,0,0, 7 008355005,001219999,0,0, 8 008350005,000000000,0,0, 9 008355005,000000000,0,0, X 008501005,000000000,0,0, 1 008504005,000000000,0,0, 2 008251005,000000000,0,0, 3 007801005,0,0,0, ! mrms max cref 4 007801005,15,0,0, 5 007801005,30,0,0, 6 007801005,45,0,0, 7 007805005,0,0,0, ! mrms cref time chg 8 007805005,15,0,0, 9 007805005,30,0,0, X 007805005,45,0,0, 1 007580005,0,0,0, 2 007811005,0,0,0, ! mrms max vil 3 007811005,15,0,0, 4 007811005,30,0,0, 5 007811005,45,0,0, 6 003200005,0,0,0, ! mrms 1h precip cont. 7 003203005,0,0,0/ ! mrms 1h precip ac C DATA DOTCN/'lmp_cigfcst.cn', 2 'lmp_visfcst.cn', 3 'lmp_skyfcst.cn', 4 'lmp_ca1fcst.cn', 5 'lmp_ch1fcst.cn', 6 'lmp_ca2fcst.cn', 7 'lmp_ch2fcst.cn', 8 'lmp_ca3fcst.cn', 9 'lmp_ch3fcst.cn', X 'lmp_ca4fcst.cn', 1 'lmp_ch4fcst.cn', 2 'lmp_ca5fcst.cn', 3 'lmp_ch5fcst.cn', 4 'lmp_ca6fcst.cn', 5 'lmp_ch6fcst.cn', 6 'lmp_wx1fcst.cn', 7 'lmp_wx2fcst.cn', 8 'lmp_wx3fcst.cn', 9 'lmp_elefcst.cn', X 'lmp_tmpfcst.cn', 1 'lmp_dewfcst.cn', 2 'lmp_ltgfcst.cn', 3 'lmp_ltgfcst.cn', 4 'lmp_ltgfcst.cn', 5 'lmp_ltgfcst.cn', 6 'lmp_ltgfcst.cn', 7 'lmp_ltgfcst.cn', 8 'lmp_ltgfcst.cn', 9 'lmp_ltgfcst.cn', X 'lmp_ltgfcst.cn', 1 'lmp_ltgfcst.cn', 2 'lmp_ltgfcst.cn', 3 'lmp_ltgfcst.cn', 4 'lmp_ltgfcst.cn', 5 'lmp_ltgfcst.cn', 6 'lmp_ltgfcst.cn', 7 'lmp_ltgfcst.cn', 8 'lmp_ltgfcst.cn', 9 'lmp_ltgfcst.cn', X 'lmp_ltgfcst.cn', 1 'lmp_ltgfcst.cn', 2 'lmp_rflfcst.cn', 3 'lmp_rflfcst.cn', 4 'lmp_rflfcst.cn', 5 'lmp_rflfcst.cn', 6 'lmp_rrffcst.cn', 7 'lmp_rrffcst.cn', 8 'lmp_rrffcst.cn', 9 'lmp_rrffcst.cn', X 'lmp_a01fcst.cn', 1 'lmp_h01fcst.cn', 2 'lmp_a04fcst.cn', 3 'lmp_h04fcst.cn', 4 'lmp_a09fcst.cn', 5 'lmp_h09fcst.cn', 6 'lmp_a19fcst.cn', 7 'lmp_h19fcst.cn', 8 'lmp_a30fcst.cn', 9 'lmp_h30fcst.cn', X 'lmp_a45fcst.cn', 1 'lmp_h45fcst.cn', 2 'lmp_a64fcst.cn', 3 'lmp_h64fcst.cn', 4 'lmp_a1xfcst.cn', 5 'lmp_a2xfcst.cn', 6 'lmp_a99fcst.cn', 7 'lmp_h99fcst.cn', 8 'lmp_a00fcst.cn', 9 'lmp_h00fcst.cn', X 'lmp_ptpfcst.cn', 1 'lmp_pocfcst.cn', 2 'lmp_obvfcst.cn', 3 'lmp_rflfcst.cn', 4 'lmp_rflfcst.cn', 5 'lmp_rflfcst.cn', 6 'lmp_rflfcst.cn', 7 'lmp_rflfcst.cn', 8 'lmp_rflfcst.cn', 9 'lmp_rflfcst.cn', X 'lmp_rflfcst.cn', 1 'lmp_ltgfcst.cn', 2 'lmp_rflfcst.cn', 3 'lmp_rflfcst.cn', 4 'lmp_rflfcst.cn', 5 'lmp_rflfcst.cn', 4 'lmp_rflfcst.cn', 5 'lmp_rflfcst.cn'/ C DATA RMISS/450., 2 50., 3 -2., 4 -2., 5 -2., 6 -2., 7 -2., 8 -2., 9 -2., X -2., 1 -2., 2 -2., 3 -2., 4 -2., 5 -2., 6 -2., 7 -2., 8 -2., 9 9999., !ELEVATIONS X 9999., !TEMPERATURE 1 9999., !DEW POINT 2 0., 3 0., 4 0., 5 0., 6 0., 7 0., 8 0., 9 0., X 0., 1 0., 2 0., 3 0., 4 0., 5 0., 6 0., 7 0., 8 0., 9 0., X 0., 1 0., 2 9999., !RADAR 3 9999., 4 9999., 5 9999., 6 9999., 7 9999., 8 9999., 9 9999., X -2., 1 -2., 2 -2., 3 -2., 4 -2., 5 -2., 6 -2., 7 -2., 8 -2., 9 -2., X -2., 1 -2., 2 -2., 3 -2., 4 -2., 5 -2., 6 -2., 7 -2., 8 -2., 9 -2., X -2., 1 -2., 2 -2., 3 0., 4 0., 5 0., 6 0., 7 0., 8 0., 9 0., X 0., 1 0., 2 0., 3 0., 4 0., 5 0., 6 0., 7 0./ C DATA IFIRST/0/, 1 JFIRST/0/, 2 LIMIT/1/ DATA IMOD/3/ C SAVE NPROJH,MESHW,CAFSM,IBACKN,IBACKL,TITLE,MESH,ITRPLQ,B,R, 1 SMULT,SADD,ORIGIN,CINT,MAKEF,NPRT,NTDL,I454DG C D WRITE(KFILDO,100) D100 FORMAT(' ') D CALL TIMPR(KFILDO,KFILDO,'START U454 ') IER=0 IFIRST=IFIRST+1 I0076=0 I0077=0 I0075=0 C C PUT DATE/TIME INTO TITLT(46:61). FIRST PARSE IT INTO C JDATE( ). C TITLT(41:45)=' FOR ' CALL DATPRS(KFILDO,NDATE,JDATE) JMIN=0 WRITE(TITLT(46:61),101)(JDATE(J),J=1,4),JMIN 101 FORMAT(I4,1X,I2.2,1X,I2.2,1X,2I2.2,1X) WRITE(KFILDO,102)(JDATE(J),J=1,4) 102 FORMAT(/' STARTING ADVECTIVE CLAM MODEL FORECAST FOR DATE/TIME ', 1 I5,2I3,I3.2,'00.', 2 ' $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$') C THE ABOVE STATEMENT IS PUT UP HERE SO IT WON'T BE REPEATED C FOR EACH VARIABLE. XMISSP=0. XMISSS=0. ISCAL=0 C C ZERO LCOMBO AND COMB( , ). C LCOMBO=0 C DO 105 J=1,20 DO 104 M=1,10 COMB(M,J)=0 104 CONTINUE 105 CONTINUE C DO 107 J=1,ND4 LINK(J)=9999 107 CONTINUE C C IN INITIALIZING IDWND( , ) AND IDCUR( ), DO NOT SET C THEM TO THE SAME VALUE. C DO 108 M=1,NVAL DO 1079 J=1,2 IDWND(J,M)=9999. 1079 CONTINUE 108 CONTINUE C DO 109 J=1,4 IDCUR(J)=0 109 CONTINUE C C COMPUTE IOPT( ) FROM IOPTB( ) SO IOPT( ) REFERS TO C THE SUBSETTED AREA MESH LENGTH MESHD. C IF(IOPTB(1).EQ.0)THEN C DO 1091 J=1,8 IOPT(J)=0 1091 CONTINUE C ELSE IOPT(1)=IOPTB(1) C IF(MESHB.EQ.MESHD)THEN IOPT(2)=IOPTB(2) IOPT(3)=IOPTB(3) IOPT(4)=IOPTB(4) IOPT(5)=IOPTB(5) ELSE RATIO=FLOAT(MESHB)/MESHD 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) ENDIF C C SET PACKING PARAMETERS. C ITAUH=0 ITAUM=0 NSEQ=0 NCHAR=32 C 32 CHARACTERS OF PLAIN LANGUAGE ARE PACKED. C IF(IFIRST.GT.LIMIT)GO TO 280 C THIS STATEMENT LETS THE CONTROL FILES BE READ ONLY C ONCE. HOWEVER, IF PRINT IS REQUIRED MORE THAN ONCE C FOR CHECKOUT, INCREASE LIMIT. THIS WILL THEN READ THE C CONTROL FILES AGAIN, WITH NO HARM. C C ZERO IUSED( ). C DO 1096 J=1,NVAL IUSED(J)=0 1096 CONTINUE C C INITIALIZE CAFSM( , ). C DO 1098 J=1,NVAL DO 1097 M=1,10 CAFSM(M,J)=9999. 1097 CONTINUE 1098 CONTINUE C C READ ALL CONTROL INFORMATION FOR ALL VARIABLES TO BE C PROCESSED FOR THE FIRST CALL. C DO 270 N=1,NPRED C DO 110 IVRBL=1,NVAL C IF(ID(1,N).EQ.ITABLE(1,IVRBL).AND. 1 ID(2,N).EQ.ITABLE(2,IVRBL).AND. 3 IUSED(IVRBL).EQ.0)THEN C ANY TAU, EVEN 0, WILL TRIGGER READING OF CONTROL FILE. C TEST ON IUSED( ) KEEPS THE LOOP FROM EXECUTING FOR C EVERY PROJECTION OF THE SAME VARIABLE THAT MAY BE PRESENT. IUSED(IVRBL)=1 GO TO 120 C UPON TRANSFER, N IS THE NUMBER IN THE LIST OF C THE VARIABLE BEING TREATED. THIS IS COORDINATED C THROUGHOUT THE CALLED ROUTINES. ENDIF C 110 CONTINUE C GO TO 270 C C READ CONTROL INFORMATION. C 120 STATE='120 ' CLOSE(UNIT=KFILDI) C ABOVE CLOSE IS FOR SAFETY; FILE SHOULD ALREADY BE CLOSED. OPEN(UNIT=KFILDI,FILE=DOTCN(IVRBL),STATUS='OLD', 1 IOSTAT=IOS,ERR=900) C C READ AND WRITE FORECAST SPECIFIC CONTROL PARAMETERS. C THESE APPLY TO ALL VARIABLES, BUT EXIST IN EACH FILE. C THE VALUES READ LAST ARE USED. C STATE='122 ' C READ(KFILDI,122,IOSTAT=IOS,ERR=900)NPROJH,MESHW, 1 CAFSM(1,IVRBL),IBACKN,IBACKL,TITLE(1:16), 2 MESH(IVRBL),ITRPLQ(IVRBL),CAFSM(2,IVRBL),CAFSM(3,IVRBL), 3 CAFSM(4,IVRBL),CAFSM(5,IVRBL), 4 CAFSM(6,IVRBL),CAFSM(7,IVRBL), 5 CAFSM(8,IVRBL),CAFSM(10,IVRBL),I454DG(IVRBL) 122 FORMAT(2I4,8X,F4.0,4X,2I4,1X,A16,2I4,3F4.0,4X,5F4.0,I4) NPROJH=MIN(NPROJH,25) C NPROJH IS LIMITED TO 25 BY DIMENSION OF VARIABLES. C IF(MESH(IVRBL).GT.320.OR.MESH(IVRBL).LT.1)THEN WRITE(KFILDO,1225)MESH(IVRBL) 1225 FORMAT(/' ****MESH =',I6,' NOT IN RANGE 1 TO 320', 1 ' IN U454. FATAL ERROR.') GO TO 600 ENDIF C IF(MESHW.EQ.0)THEN WRITE(KFILDO,1226)MESH(IVRBL) 1226 FORMAT(/' ****MESH LENGTH FOR WINDS, MESHW, READ AS ZERO.', 1 ' IT IS USED AS MESH =',I4) ISTOP=ISTOP+1 MESHW=MESH(IVRBL) ELSEIF(MESHW.GT.320.OR.MESHW.LT.1)THEN WRITE(KFILDO,1227)MESHW 1227 FORMAT(/' ****MESHW =',I6,' NOT IN RANGE 1 TO 320', 1 ' IN U454. FATAL ERROR.') GO TO 600 ENDIF C IF(IFIRST.LE.LIMIT)WRITE(KFILDO,123)(ITABLE(J,IVRBL),J=1,4), 1 TITLE(1:16) 123 FORMAT(/' SPECIFIC FORECAST CONTROL PARAMETERS FOR ', 1 3I10.9,I10.3,3X,A16) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,124)NPROJH,MESHW, 1 CAFSM(1,IVRBL),IBACKN,IBACKL,TITLE(1:16), 2 MESH(IVRBL),ITRPLQ(IVRBL),CAFSM(2,IVRBL),CAFSM(3,IVRBL), 3 CAFSM(4,IVRBL),CAFSM(5,IVRBL),CAFSM(6,IVRBL), 5 CAFSM(7,IVRBL),CAFSM(8,IVRBL),CAFSM(10,IVRBL),I454DG(IVRBL) 124 FORMAT(/' NPROJH MW ', 1 ' C00AF IBACKN IBACKL TITLE ', 2 ' MESH ITRPLQ C85AF C70AF C50AF', 3 ' N00SM N85SM N70SM N50SM', 4 ' CFILT I454DG'/ 3 I8,I5,F6.2,I6,I7,5X,A16,I3,I6,1X,3F6.2,4F6.0,F6.2,I6) C C READ SMOOTHING PARAMETER TO USE FOR EACH PROJECTION. C STATE='160 ' READ(KFILDI,140,IOSTAT=IOS,ERR=900)(B(J,IVRBL),J=1,NPROJH) 140 FORMAT(25F4.0) C IF(IFIRST.LE.LIMIT)THEN WRITE(KFILDO,161)NPROJH,(B(J,IVRBL),J=1,NPROJH) 161 FORMAT(' B FOR ',I3,' PROJECTIONS'/5X,25F5.1) ENDIF C C READ RADIUS OF INFLUENCE TO USE FOR EACH PROJECTION. C STATE='170 ' READ(KFILDI,140,IOSTAT=IOS,ERR=900)(R(J,IVRBL),J=1,NPROJH) C IF(IFIRST.LE.LIMIT)THEN WRITE(KFILDO,171)NPROJH,(R(J,IVRBL),J=1,NPROJH) 171 FORMAT(' R FOR ',I3,' PROJECTIONS'/5X,25F5.1) ENDIF C C READ MULTIPLICATIVE FACTOR FOR GRIDPRINTING. C STATE='200 ' READ(KFILDI,140,IOSTAT=IOS,ERR=900)(SMULT(J,IVRBL),J=1,NPROJH) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,201)NPROJH,(SMULT(J,IVRBL), 1 J=1,NPROJH) 201 FORMAT(' SMULT FOR ',I3,' PROJECTIONS'/5X,25F5.1) C C READ ADDITIVE FACTOR FOR GRIDPRINTING. C STATE='210 ' READ(KFILDI,140,IOSTAT=IOS,ERR=900)(SADD(J,IVRBL),J=1,NPROJH) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,211)NPROJH,(SADD(J,IVRBL), 1 J=1,NPROJH) 211 FORMAT(' SADD FOR ',I3,' PROJECTIONS'/5X,25F5.1) C C READ ORIGIN FOR GRIDPRINTING. C STATE='220 ' READ(KFILDI,140,IOSTAT=IOS,ERR=900)(ORIGIN(J,IVRBL),J=1,NPROJH) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,221)NPROJH,(ORIGIN(J,IVRBL), 1 J=1,NPROJH) 221 FORMAT(' ORIGIN FOR ',I3,' PROJECTIONS'/5X,25F5.2) C C READ CONTOURING INTERVAL FOR GRIDPRINTING. C STATE='230 ' READ(KFILDI,140,IOSTAT=IOS,ERR=900)(CINT(J,IVRBL),J=1,NPROJH) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,231)NPROJH,(CINT(J,IVRBL), 1 J=1,NPROJH) 231 FORMAT(' CINT FOR ',I3,' PROJECTIONS'/5X,25F5.1) C C READ PROJECTIONS TO MAKE FORECASTS FOR. C STATE='235 ' READ(KFILDI,235,IOSTAT=IOS,ERR=900)(MAKEF(J,IVRBL),J=1,NPROJH) 235 FORMAT(25I4) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,236)NPROJH,(MAKEF(J,IVRBL), 1 J=1,NPROJH) 236 FORMAT(' MAKEF FOR ',I3,' PROJECTIONS'/5X,25I5) C C READ GRIDPRINTING OPTION FOR UNSMOOTHED GRID GRIDPRINTING. C STATE='240 ' READ(KFILDI,235,IOSTAT=IOS,ERR=900)(NPRT(J,IVRBL),J=1,NPROJH) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,241)NPROJH,(NPRT(J,IVRBL), 1 J=1,NPROJH) 241 FORMAT(' NPRT FOR ',I3,' PROJECTIONS'/5X,25I5) C C READ TDLPACKING OPTION FOR UNSMOOTHED PACKING. C STATE='260 ' READ(KFILDI,235,IOSTAT=IOS,ERR=900)(NTDL(J,IVRBL),J=1,NPROJH) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,261)NPROJH,(NTDL(J,IVRBL), 1 J=1,NPROJH) 261 FORMAT(' NTDL FOR ',I3,' PROJECTIONS'/5X,25I5) C CLOSE(UNIT=KFILDI) C C IF THE VALUE OF MESHD IS LT MESH( ), THEN THE DISPOSABLE C GRID WILL NOT BE WRITTEN, BECAUSE FIRST, IT DOESN'T MAKE C MUCH SENSE TO LOOK AT A GRID AT A FINER RESOLUTION THAN C COMPUTED, AND SECOND, THE INTERPOLATION ROUTINES WILL C NOT BEHAVE WITH DISCONTINUOUS VARIABLES. C IF(MESHD.LT.MESH(IVRBL).AND.I454DG(IVRBL).NE.0. 1 AND.KFILOG.GT.0)THEN IF(IFIRST.LE.LIMIT)WRITE(KFILDO,265)MESH(IVRBL),MESHD, 1 (ITABLE(J,IVRBL),J=1,2) 265 FORMAT(/' ****MESH(IVRBL) =',I5,' IS GREATER THAN MESHD =',I5, 1 '. DISPOSABLE GRIDS WILL NOT BE WRITTEN FOR', 2 ' VARIABLE',2(1X,I9.9)) ISTOP=ISTOP+1 ENDIF C 270 CONTINUE C C DETERMINE WHETHER ANY VARIABLES PROCESSED. C DO 275 J=1,NVAL IF(IUSED(J).NE.0)GO TO 278 275 CONTINUE C WRITE(KFILDO,276) 276 FORMAT(/' ****NO VARIABLE PROCESSED IN U454') GO TO 600 C C WRITE THE FINAL SET OF CONTROL VARIABLES THAT ARE NOT C VARIABLE SPECIFIC. NOTE THAT THE LAST SET READ FROM A C U454 .CN FILE IS USED. C 278 IF(IFIRST.LE.LIMIT)WRITE(KFILDO,279)NPROJH,MESHW,IBACKN,IBACKL 279 FORMAT(/' CONTROL PARAMETERS USED THAT ARE NOT ELEMENT SPECIFIC', 1 ' IN U454'/ 1 ' NPROJH =',I6,' MAXIMUM PROJECTION TO COMPUTE'/ 2 ' MESHW =',I6,' USED FOR COMPUTING WINDS FOR', X ' TRAJECTORIES'/ 3 ' IBACKN =',I6,' NO. OF CYCLES TO LOOK BACK FOR', X ' NCEP GRID'/ 4 ' IBACKL =',I6,' NO. OF CYCLES TO LOOK BACK FOR', X ' LAMP GRID') C C SET SAFSM(11) = MESHW WHICH IS HELD CONSTANT FOR THE RUN FOR C ALL VARIABLES. C DO 2795 IVRBL=1,NVAL CAFSM(9,IVRBL)=MESHW 2795 CONTINUE C C ZERO KOUNT( ) TO KEEP WINDS FROM BEING COMPUTED MORE C THAN ONCE FOR A PARTICULAR VARIABLE. THIS IS NECESSARY C BECAUSE THE LIST IN ID( ,NPRED) MUST CONTAIN ALL PROJECTIONS C TO WRITE TO THE ARCHIVE. C 280 DO 285 J=1,NVAL KOUNT(J)=0 285 CONTINUE C C COMPUTE VALUES FOR MESHW. NOTE THAT MESHW IS HELD FROM C CALL TO CALL, BUT RR, ETC. ARE NOT. C RR=FLOAT(MESHB)/FLOAT(MESHW) NXW=NINT((NXL-1)*RR)+1 NYW=NINT((NYL-1)*RR)+1 NXPW=NINT((NXPL-1)*RR)+1 NYPW=NINT((NYPL-1)*RR)+1 C LP0076=0 LP0077=0 LP0075=0 C LP0076 AND LP0077 ALLOW THE INITIAL RADAR DATA TO BE C GRIDPRINTED AND OR WRITTEN TO THE DISPOSABLE FILE, BUT ONLY C ONCE. SEE TEST BELOW 322. THE INITIAL DATA MAY NOT C BE AT ZERO HOUR, BUT FOR INSTANCE 45 MINUTES PAST THE C PREVIOUS HOUR. C DO 287 N=1,NPRED C DO 286 IVRBL=1,NVAL C*** WRITE(KFILDO,2850)N,IVRBL,ID(1,N),ID(2,N), C*** 1 ITABLE(1,IVRBL),ITABLE(2,IVRBL) C*** 2850 FORMAT(/' IN U454 AT 2850--N,IVRBL,ID(1,N),ID(2,N),', C*** 1 'ITABLE(1,IVRBL),ITABLE(2,IVRBL)'/6I12) C IF(N.GT.1)THEN IF(ID(1,N).EQ.ID(1,N-1).AND. 1 ID(2,N).EQ.ID(2,N-1))GO TO 287 C MOST VARIABLES WITH THE SAME ID WILL BE IN SEQUENCE C AND THIS SHORTENS THE SEARCH. THE FIRST ONE IN THE C LIST WILL BE FOUND FIRST. WORDS 1 AND 2 ARE THE C SAME FOR ALL PROJECTIONS. ENDIF C IF(ID(1,N).EQ.ITABLE(1,IVRBL).AND. 1 ID(2,N).EQ.ITABLE(2,IVRBL))THEN C NOTE THAT THE PROJECTIONS FOR WHICH FORECASTS ARE C MADE IS CONTROLLED BY THE .CN FILE. ANY PROJECTION C IN THE ID LIST, EVEN ZERO, WILL ALLOW FORECASTS C TO BE MADE. C IF(KOUNT(IVRBL).EQ.1)THEN GO TO 287 ELSE KOUNT(IVRBL)=1 LINK(N)=IVRBL C LINK( ) MAINTAINS THE LINK BETWEEN THE C VARIABLE N IN THE INPUT LIST AND THE VARIABLE C IVRBL IN THE LIST IN ITABLE( , ). C*** WRITE(KFILDO,2862)N,IVRBL,(CAFSM(L,IVRBL),L=1,10) C*** 2862 FORMAT(/' IN U454 AT 2862--N,IVRBL,(CAFSM(L,IVRBL),L=1,10)', C*** 1 2I4,10F6.2) GO TO 2865 C UPON TRANSFER, N IS THE NUMBER IN THE LIST OF C THE VARIABLE BEING TREATED. THIS IS COORDINATED C THROUGHOUT THE CALLED ROUTINES. IVRBL IS THE C NUMBER IN THE LIST OF VARIABLES THAT CAN BE C DEALT WITH IN U454. ENDIF C ENDIF C 286 CONTINUE C GO TO 287 C VARIABLE N NOT PROCESSED BY U454. C C COMPUTE ALL ADVECTIVE WINDS FOR VARIABLE IVRBL AND C STORE IN MOS-2000 INTERNAL RANDOM ACCESS FILE. ALL C GRIDS IN CALL ARE WORK ARRAYS. ANY C INTERPOLATION DONE IN AWND15M IS OK BECAUSE FIELDS ARE C CONTINUOUS AND DO NOT HAVE MISSING VALUES. C 2865 CALL AWND15M(KFILDO,KFIL10,KFILOG,IP16,IP22,I454DG(IVRBL), 1 NDATE,IBACKN,XPOS,YPOS,U51,V51,U,V,FD9,ND2X3, 2 NCEPNO,LAMPNO,NPROJ,ORIENT,XLAT, 3 NXL,NYL,NXPL,NYPL,ALATL,ALONL, 4 MESHB,MESHD,IOPT, 5 CAFSM(1,IVRBL),IDWND(1,IVRBL),COMB,IWCOMB,LCOMBO, 6 NXW,NYW,NXPW,NYPW,MESHW,ITRPLQ(IVRBL),NPROJH, 7 LSTORE,ND9,LITEMS, 8 IS0,IS1,IS2,IS4,ND7, 9 DATA,IPACK,IWORK,ND5,MINPK, A CORE,ND10,NBLOCK,NFETCH,MISTOT, B JTOTBY,JTOTRC, C L3264B,L3264W,ISTOP,IER) IF(IER.NE.0)GO TO 600 C 287 CONTINUE C C GET THE ELEVATIONS IN FD1( ). THE ID HAS DD = 00. ANY C INFORMATION ABOUT HOW THE GRID WAS PRODUCED OR THE C GRID LENGTH IS IN THE CCCFFF. 409020 WAS INTERPOLATED C WITH AN NCEP INTERPOLATION ROUTINE TO A 1/4 BEDIENT C GRID OVER THE TDL AVN ARCHIVE AREA FROM NCEP'S LAT/LON GRID. C WHEN I454DG( ) NE 0 AND KFILOG NE 0, THE ELEVATIONS WILL BE C WRITTEN TO UNIT KFILOG. WHEN I454DG( ) NE O AND IP22 NE 0, C THE ELEVATIONS WILL BE WRITTEN FOR GRIDPRINTING TO UNIT IP22. C THE ELEVATIONS ARE RETRIEVED HERE, ONLY IF NEEDED, AND C WRITTEN TO THE INTERNAL RANDOM ACCESS FILE SO THEY CAN C BE EASILY RETRIEVED WHEN MAKING FORECASTS. C DO 2870 N=1,NPRED IF(ID(1,N).EQ.409020005)GO TO 2871 2870 CONTINUE C GO TO 2875 C C ELEVATIONS ARE NEEDED. THE ELEVATIONS HAVE A DD = 0 C ON THE RANDOM ACCESS FILE, BUT ARE WRITTEN TO THE C ARCHIVE WITH DD = 5. C 2871 LD(1)=409020000 LD(2)=0 LD(3)=0 LD(4)=0 IVRBL=LINK(N) C C MESH(IVRBL) READ FROM EACH .CN CONTROL FILE. C NXL, NYL, NXPL, NYPL, CORRESPOND TO MESHB AND ARE INPUT C FROM THE CALL SEQUENCE. NOW COMPUTE NX, NY, NXP, AND NYP C CORRESPONDING TO MESH(IVRBL) FOR ELEVATIONS. C RR=FLOAT(MESHB)/FLOAT(MESH(IVRBL)) NX=NINT((NXL-1)*RR)+1 NY=NINT((NYL-1)*RR)+1 NXP=NINT((NXPL-1)*RR)+1 NYP=NINT((NYPL-1)*RR)+1 C CALL GETELE(KFILDO,KFILOG,KFILRA,RACESS,NUMRA,I454DG(IVRBL),LD, 1 IP16,IP22, 2 FD1,FD9,ND2X3, 3 IPACK,DATA,IWORK,ND5, 4 LAMPNO,NDATE, 5 ALATL,ALONL,NPROJ,ORIENT,XLAT, 6 NXL,NYL,NXPL,NYPL,MESHB,MESHD,IOPT,ITRPLQ(IVRBL), 7 NX,NY,NXP,NYP,MESH(IVRBL), 8 IS0,IS1,IS2,IS4,ND7, 9 JTOTBY,JTOTRC, A L3264B,L3264W,MINPK,ISTOP,IER) IF(IER.NE.0)GO TO 600 C GETELE PROVIDES ADEQUATE DIAGNOSTIC. IT MAY GRIDPRINT AND C WRITE TO THE DISPOSABLE FILE. IF IT NEEDS TO INTERPOLATE, C THAT IS OK BECAUSE IT IS A CONTINUOUS FIELD WITHOUT MISSINGS. C C AT THIS POINT THE ELEVATIONS IN METERS ARE IN FD1( ) C WITH RETURNED DIMENSIONS NX, NY AND MESH LENGTH MESH(IVRBL). C PACK AND WRITE THE ELEVATIONS TO THE INTERNAL STORAGE C SYSTEM SO THAT THEY CAN BE ACCESSED IN THE SAME WAY C AS THE OTHER VARIABLES. NOTE THAT THESE ARE UNSMOOTHED. C LD(1)=409020005 LD(2)=0 LD(3)=0 LD(4)=0 PLAINT=' TERRAIN ELEVATIONS ' XMISSP=0. XMISSS=0. ISCAL=0 C PACKING TO METERS. CALL PAWING(KFILDO,KFIL10,NDATE, 1 LD,ITAUH,ITAUM,LAMPNO,NSEQ,ISCAL, 2 NPROJ,ALATL,ALONL,ORIENT,MESHB,MESH(IVRBL),XLAT,NX,NY, 3 FD1,DATA,IWORK,IPACK,ND5,MINPK, 4 LSTORE,ND9,LITEMS,CORE,ND10,NBLOCK, 5 IS0,IS1,IS2,IS4,ND7, 6 IPLANT,IPLAINT,NCHAR, 7 XMISSP,XMISSS,LX,IOCTET, 8 L3264B,L3264W,IER) IF(IER.NE.0)THEN WRITE(KFILDO,2874) 2874 FORMAT(' ****FATAL ERROR IN U454. CANNOT WRITE ELEVATIONS', 1 ' TO RANDOM ACCESS FILE') GO TO 600 C ANY ERROR FROM PAWING SHOULD BE TREATED AS FATAL. ENDIF C C COMPUTE THE NPROJH X- AND Y-POSITIONS IN HOURLY STEPS C FOR EACH PROJECTION OUT TO NPROJ HOURS. DETERMINE C THE UPSTREAM VALUE OF THE VARIABLE AND WRITE. BY HAVING C THE N LOOP WITHIN THE LP LOOP ALLOWS THE REUSE OF C XPOS AND YPOS FROM FCST WHEN VARIABLES IN SEQUENCE C REQUIRE THE SAME ADVECTING WINDS. KEEP NPROJH SMALL AS C POSSIBLE. C 2875 DO 400 LP=1,NPROJH C DO 399 N=1,NPRED IVRBL=LINK(N) IF(IVRBL.EQ.9999)GO TO 399 C IVRBL IS THE LOCATION IN ITABLE OF VARIABLE N. IF IT C IS 9999, VARIABLE N IS NOT BEING CONSIDERED IN U454. C IF(MAKEF(LP,IVRBL).EQ.0)GO TO 399 C A FORECAST FOR THE VARIABLE UNDER CONSIDERATION IS C NOT MADE FOR PROJECTION LP. C IF(IDWND(1,IVRBL).EQ.9999)GO TO 399 C CONSIDERING THE TEST ON IVRBL ABOVE, THE ABOVE SHOULD C NOT BE TRUE. C D CALL TIMPR(KFILDO,KFILDO,'BEFORE TEST FOR WIND') C C MESH(IVRBL) READ FROM EACH .CN CONTROL FILE. C NXL, NYL, NXPL, NYPL, CORRESPOND TO MESHB AND ARE INPUT C FROM THE CALL SEQUENCE. NOW COMPUTE NX, NY, NXP, AND NYP C CORRESPONDING TO MESH(IVRBL). C RR=FLOAT(MESHB)/FLOAT(MESH(IVRBL)) NX=NINT((NXL-1)*RR)+1 NY=NINT((NYL-1)*RR)+1 NXP=NINT((NXPL-1)*RR)+1 NYP=NINT((NYPL-1)*RR)+1 C IF(IDCUR(1).EQ.IDWND(1,IVRBL).AND. 1 IDCUR(3).EQ.LP.AND. 2 MESH(IVRBL).EQ.MESHSV)GO TO 320 C C ABOVE TRANSFER MEANS THE NEEDED XPOS( ) AND YPOS( ) ARE C ALREADY THERE FROM A PREVIOUS CALL. IF SO, XPOS( ) AND C YPOS( ) HAVE BEEN PUT ONTO THE NX BY NY LAMP GRID. THIS C IS AN EFFICIENCY SHORTCUT. BECAUSE REUSED XPOS( ) AND C YPOS( ) MAY NOT HAVE GONE THROUGH THE PACKING AND C UNPACKING, THE RESULTS MAY DIFFER SLIGHTLY FROM THE C CASE WHERE THEY HAVE. THAT MEANS THE ORDER OF COMPUTATION C OF THE VARIABLES MAY MATTER. THIS COULD CAUSE CONFUSION, C BUT THE ACCURACY WILL NOT BE COMPROMISED MATERIALLY. C OTHERWISE, FCST RETURNS XPOS AND YPOS. C C***D CALL TIMPR(KFILDO,KFILDO,'BEFORE FCST ') CALL FCST(KFILDO,KFIL10,NDATE,LP,IDWND(1,IVRBL),IDCUR, 1 FD1,U,V,XPOS,YPOS,ND2X3, 2 NCEPNO,LAMPNO,NPROJ,ORIENT,XLAT, 3 NXL,NYL,NXPL,NYPL,ALATL,ALONL,MESHB, 4 NXW,NYW,MESHW,ITRPLQ(IVRBL), 5 LSTORE,ND9,LITEMS, 6 IS0,IS1,IS2,IS4,ND7, 7 IPACK,IWORK,ND5, 8 CORE,ND10,NBLOCK,NFETCH,MISTOT, 9 L3264B,ISAME,IER) C C***D CALL TIMPR(KFILDO,KFILDO,'END FCST ') MESHSV=MESH(IVRBL) C SAVES MESH OF THE VARIABLE FOR THE WINDS RETURNED. C THIS MUST BE THE SAME FOR THE VARIABLE BEING C PROCESSES AS FOR THE VARIABLE FOR WHICH THE C TRAJECTORY END POSITIONS ARE IN XPOS( ) AND YPOS( ). C IF(IER.NE.0)THEN WRITE(KFILDO,2877)LP 2877 FORMAT(' CANNOT COMPUTE TRAJECTORIES IN U454 FOR', 1 ' PROJECTION',I4,'.') C THIS DIAGNOSTIC FOLLOWS ONE IN FORCST. GO TO 600 ENDIF C IF(ISAME.EQ.1)GO TO 2887 C DO NOT WRITE XPOS( ) AND YPOS( ) BECAUSE THEY HAVE C BEEN WRITTEN PREVIOUSLY. D CALL TIMPR(KFILDO,KFILDO,'WRITING XPOS,YPOS ') C C WRITE XPOS( ) AND YPOS( ) TO INTERNAL STORAGE. NOTE C THAT THEY ARE STILL ON NXW BY NYW GRID, NOT NX BY NY C OR DISPOSABLE AREA. C LD(1)=IDWND(1,IVRBL) LD(2)=888 LD(3)=LP LD(4)=080 STATE='2880' PLAINT=' -H TRAJ XPOS ( ) ' WRITE(PLAINT(1:2),2880,IOSTAT=IOS,ERR=900)LP 2880 FORMAT(I2) STATE='2881' WRITE(PLAINT(17:25),2881,IOSTAT=IOS,ERR=900)LD(1) 2881 FORMAT(I9.9) XMISSP=9999. XMISSS=0. ISCAL=4 C PACKING TO TENTHS OF GRID UNITS. NOTE PACKING IN ONE C LARGE GROUP, NOT USING MINPK. CALL PAWING(KFILDO,KFIL10,NDATE, 1 LD,LP,ITAUM,LAMPNO,NSEQ,ISCAL, 2 NPROJ,ALATL,ALONL,ORIENT,MESHB,MESHW,XLAT,NXW,NYW, 3 XPOS,DATA,IWORK,IPACK,ND5,NXW*NYW-2, 4 LSTORE,ND9,LITEMS,CORE,ND10,NBLOCK, 5 IS0,IS1,IS2,IS4,ND7, 6 IPLANT,IPLAINT,NCHAR, 7 XMISSP,XMISSS,LX,IOCTET, 8 L3264B,L3264W,IER) IF(IER.NE.0)THEN WRITE(KFILDO,2885) 2885 FORMAT(' ****FATAL ERROR IN U454. CANNOT WRITE XPOS', 1 ' TO RANDOM ACCESS FILE') GO TO 600 C ANY ERROR FROM PAWING SHOULD BE TREATED AS FATAL. ENDIF C LD(1)=IDWND(2,IVRBL) LD(2)=888 LD(3)=LP LD(4)=080 STATE='2885' PLAINT=' -H TRAJ YPOS ( ) ' WRITE(PLAINT(1:2),340,IOSTAT=IOS,ERR=900)LP STATE='2880' WRITE(PLAINT(17:25),2881,IOSTAT=IOS,ERR=900)LD(2) XMISSP=9999. XMISSS=0. ISCAL=4 C PACKING TO TENTHS OF GRID UNITS. NOTE PACKING IN ONE C LARGE GROUP, NOT USING MINPK. CALL PAWING(KFILDO,KFIL10,NDATE, 1 LD,LP,ITAUM,LAMPNO,NSEQ,ISCAL, 2 NPROJ,ALATL,ALONL,ORIENT,MESHB,MESHW,XLAT,NXW,NYW, 3 YPOS,DATA,IWORK,IPACK,ND5,NXW*NYW-2, 4 LSTORE,ND9,LITEMS,CORE,ND10,NBLOCK, 5 IS0,IS1,IS2,IS4,ND7, 6 IPLANT,IPLAINT,NCHAR, 7 XMISSP,XMISSS,LX,IOCTET, 8 L3264B,L3264W,IER) IF(IER.NE.0)THEN WRITE(KFILDO,2886) 2886 FORMAT(' ****FATAL ERROR IN U454. CANNOT WRITE YPOS', 1 ' TO RANDOM ACCESS FILE') GO TO 600 C ANY ERROR FROM PAWING SHOULD BE TREATED AS FATAL. ENDIF C C MAKE SURE THE TRAJECTORY END POINTS ARE AT THE SAME C MESH LENGTH AS THE VARIABLE BEING FORECAST. MESHW HAS C REFERRED TO THE WIND GRID AND TRAJECTORIES. AFTER C SIZEGR, MESHW STILL REFERS TO THE WIND GRID, BUT NOW C THE TRAJECTORIES ARE AT THE SAME MESH AS MESH(IVRBL). C THE XPOS AND YPOS MUST BE CHANGED FROM THE MESHW TO THE C MESH GRID LENGTH. C 2887 IF(MESHW.NE.MESH(IVRBL))THEN MESHWS=MESHW NXS=NXW NYS=NYW NXPS=NXPW NYPS=NYPW CALL SIZEGR(KFILDO,XPOS,NXS,NYS,NXPS,NYPS, 1 MESHWS,MESH(IVRBL),ITRPLQ(IVRBL),ND2X3) MESHWS=MESHW NXS=NXW NYS=NYW NXPS=NXPW NYPS=NYPW CALL SIZEGR(KFILDO,YPOS,NXS,NYS,NXPS,NYPS, 1 MESHWS,MESH(IVRBL),ITRPLQ(IVRBL),ND2X3) C NXS, NYS, NXPS, NYPS ARE MODIFIED IN SIZEGR FROM C THE INPUT TO THE OUTPUT GRID; MESHW MUST REMAIN C INTACT. THE GRID IS NOW NX BY NY. C RR=FLOAT(MESHW)/FLOAT(MESH(IVRBL)) C SIZEGR MAKES THE GRID OF THE RIGHT SIZE, BUT XPOS C AND YPOS, WHICH ARE NEVER MISSING = 9999, MUST C REFER TO THAT GRID. C DO 2879 J=1,NX*NY XPOS(J)=(XPOS(J)-1)*RR+1 YPOS(J)=(YPOS(J)-1)*RR+1 2879 CONTINUE C ENDIF C C TDLPACK (WHEN KFILDO NE 0) AND GRIDPRINT (WHEN IP22 NE 0) C THE FINAL END POINTS OF THE TRAJECTORIES, PROVIDED C I454DG( ) NE 0. DO NOT DO THIS WHEN THE SAME XPOS( ) AND C YPOS( ) ARE USED AS USED PREVIOUSLY. C IF(I454DG(IVRBL).NE.0.AND.(KFILOG.GT.0.OR.IP22.GT.0). 1 AND.ISAME.EQ.0)THEN c C PUT XPOS( ) AND YPOS( ) INTO U( ) AND V( ) WITH C VALUES ADJUSTED TO THE DISPOSABLE GRID. C IF(MESH(IVRBL).NE.MESHD)THEN C RR=FLOAT(MESH(IVRBL))/FLOAT(MESHD) C DO 2888 J=1,NX*NY U(J)=(XPOS(J)-1.)*RR+1. V(J)=(YPOS(J)-1.)*RR+1. 2888 CONTINUE C ELSE C DO 2889 J=1,NX*NY U(J)=XPOS(J) V(J)=YPOS(J) 2889 CONTINUE C ENDIF C NXG=NX NYG=NY NXPG=NXP NYPG=NYP MESHG=MESH(IVRBL) C NXG, ETC. ARE NECESSARY BECAUSE SIZEGR CHANGE THEM, AND C NX, ETC. MUST BE RETAINED. CALL TRNSFR(U,FD9,NX*NY) CALL SIZEGR(KFILDO,FD9,NXG,NYG,NXPG,NYPG, 1 MESHG,MESHD,ITRPLQ(IVRBL),ND2X3) C THE SAME INTERPOLATION IS USED (IF NEEDED) AS FOR OTHER C USES IN U450. C IF(IP22.NE.0)THEN TITLT(1:40)=' -H TRAJECTORY XPOS ' STATE='290 ' WRITE(TITLT(1:2),290,IOSTAT=IOS,ERR=900)LP 290 FORMAT(I2) C IF(IDPARS(1,N).EQ.008.AND. 1 (IDPARS(2,N).EQ.350.OR.IDPARS(2,N).EQ.355))THEN C THIS IS A CLOUD LAYER. PUT IN CCCFFF AND HEIGHTS. STATE='2900' WRITE(TITLT(6:8),325,IOSTAT=IOS,ERR=900)IDPARS(1,N) STATE='2901' WRITE(TITLT(9:11),325,IOSTAT=IOS,ERR=900)IDPARS(2,N) STATE='2902' WRITE(TITLT(13:15),325,IOSTAT=IOS,ERR=900)IDPARS(6,N) STATE='2903' WRITE(TITLT(17:19),325,IOSTAT=IOS,ERR=900)IDPARS(7,N) TITLT(16:16)='-' ENDIF C XMULT=1. XADD=0. CALL PRTGR(IP22,FD9,NXG,NYG, 1 1.,0.,XMULT,XADD,IOPT,TITLT,IER) C CONTOUR AT 1 GRID UNIT INTERVALS AT 1 BEDIENT MESH. C IF(IER.NE.0)THEN ISTOP=ISTOP+1 WRITE(KFILDO,291)XMULT,XADD 291 FORMAT(/' ****SCALING CAUSED OVERFLOW. SMULT =',F10.2, 1 4X,'SADD =',F10.2/ 2 ' CONTOURING ABORTED AT 291.') ENDIF C ENDIF C IF(KFILOG.NE.0)THEN LD(1)=004540000+LAMPNO LD(2)=IDWND(1,IVRBL) LD(3)=LP LD(4)=0 ISCAL=4 C PACKING TO TENTHS OF GRID UNITS. PLAINT=' -H TRAJECTORY XPOS CLAM MODEL' WRITE(PLAINT(1:2),290,IOSTAT=IOS,ERR=900)LP C C THE GRID IN FD9( ) IS ALWAYS AT MESH LENGTH MESHD AS A C RESULT OF SIZEGR, WHICH IS WHAT IS WANTED FOR THE C DISPOSABLE GRID. NOW CUT THE GRID TO THE DISPOSABLE C AREA. SCALING IS ISCAL = 0 WHOLE GRID UNITS. C C SET PARAMETERS FOR THE DISPOSABLE GRID. THE ONLY C TIME THESE ARE NEEDED IS WHEN KFILOG NE 0. PRTGR DOES C NOT NEED THEM. NXPG, ETC., ARE IN RELATION TO THE C DISPOSABLE GRID MESH LENGTH MESHD WHICH AGREES WITH C IOPT( ). C NXD=IOPT(3)-IOPT(2)+1 NYD=IOPT(5)-IOPT(4)+1 C NXD AND NYD ARE THE CUT (DISPOSABLE) GRID DIMENSIONS. NXPD=NXPG-IOPT(2)+1 NYPD=NYPG-IOPT(4)+1 C NXPD AND NYPD ARE THE X AND Y POLE POSITIONS FOR THE C CUT (DISPOSABLE) GRID. C CALL CUT(KFILDO,FD9,NXG,NYG,NXPG,NYPG, 1 FD9,NXD,NYD,NXPD,NYPD) CALL MSHXMS(KFILDO,MESHD,XMESHN,XMESHD) C SUBROUTINE MSHXMS COMPUTES XMESHD FROM MESHD. CALL IJLLPS(1.,1.,XMESHD,ORIENT,XLAT, 1 FLOAT(NXPD),FLOAT(NYPD),ALATD,ALOND) C ALATD AND ALOND ARE THE LL LAT/LON GRID POSITION. C TRUNCATE TO THREE DECIMAL PLACES TO ASSURE C COMPATIBILITY WITH AVN ARCHIVE FOR U203 AND GENPAK. ALATD=NINT(ALATD*1000)/1000. ALOND=NINT(ALOND*1000)/1000. CALL PAWOTG(KFILDO,KFILOG,IP16,NDATE, 1 LD,LP,ITAUM,LAMPNO,NSEQ,ISCAL, 2 NPROJ,ALATD,ALOND,ORIENT,MESHD,XLAT,NXD,NYD, 3 FD9,FD1,IWORK,IPACK,ND5,MINPK, 4 IS0,IS1,IS2,IS4,ND7, 5 IPLANT,PLAINT,NCHAR, 6 XMISSP,XMISSS,LX,IOCTET, 7 JTOTBY,JTOTRC,L3264B,L3264W,IER) IF(IER.NE.0)ISTOP=ISTOP+1 C ERROR WRITING DISPOSABLE GRIDS NOT COUNTED AS FATAL. ENDIF C NXG=NX NYG=NY NXPG=NXP NYPG=NYP MESHG=MESH(IVRBL) C NXG, ETC. ARE NECESSARY BECAUSE SIZEGR CHANGE THEM, AND C NX, ETC. MUST BE RETAINED. C CALL TRNSFR(V,FD9,NX*NY) CALL SIZEGR(KFILDO,FD9,NXG,NYG,NXPG,NYPG, 1 MESHG,MESHD,ITRPLQ(IVRBL),ND2X3) C THE SAME INTERPOLATION IS USED (IF NEEDED) AS FOR OTHER C USES IN U450. C IF(IP22.NE.0)THEN TITLT(1:40)=' -H TRAJECTORY YPOS ' STATE='290 ' WRITE(TITLT(1:2),290,IOSTAT=IOS,ERR=900)LP C IF(IDPARS(1,N).EQ.008.AND. 1 (IDPARS(2,N).EQ.350.OR.IDPARS(2,N).EQ.355))THEN C THIS IS A CLOUD LAYER. PUT IN CCCFFF AND HEIGHTS. STATE='2900' WRITE(TITLT(6:8),325,IOSTAT=IOS,ERR=900)IDPARS(1,N) STATE='2901' WRITE(TITLT(9:11),325,IOSTAT=IOS,ERR=900)IDPARS(2,N) STATE='2902' WRITE(TITLT(13:15),325,IOSTAT=IOS,ERR=900)IDPARS(6,N) STATE='2903' WRITE(TITLT(17:19),325,IOSTAT=IOS,ERR=900)IDPARS(7,N) TITLT(16:16)='-' ENDIF C XMULT=1. XADD=0. CALL PRTGR(IP22,FD9,NXG,NYG, 1 1.,0.,XMULT,XADD,IOPT,TITLT,IER) C CONTOUR AT 1 GRID UNIT INTERVALS AT 1 BEDIENT MESH. C IF(IER.NE.0)THEN ISTOP=ISTOP+1 WRITE(KFILDO,292)XMULT,XADD 292 FORMAT(/' ****SCALING CAUSED OVERFLOW. SMULT =',F10.2, 1 4X,'SADD =',F10.2/ 2 ' CONTOURING ABORTED AT 292.') ENDIF C ENDIF C IF(KFILOG.NE.0)THEN LD(1)=004550000+LAMPNO LD(2)=IDWND(2,IVRBL) LD(3)=LP LD(4)=0 ISCAL=4 C PACKING TO TENTHS OF GRID UNITS. PLAINT=' -H TRAJECTORY YPOS CLAM MODEL' WRITE(PLAINT(1:2),340,IOSTAT=IOS,ERR=900)LP C C THE GRID IN YPOS( ) IS ALWAYS AT MESH LENGTH MESHD AS A C RESULT OF SIZEGR, WHICH IS WHAT IS WANTED FOR THE C DISPOSABLE GRID. NOW CUT THE GRID TO THE DISPOSABLE C AREA. SCALING IS ISCAL = 0 WHOLE GRID UNITS. C CALL CUT(KFILDO,FD9,NXG,NYG,NXPG,NYPG, 1 FD9,NXD,NYD,NXPD,NYPD) CALL PAWOTG(KFILDO,KFILOG,IP16,NDATE, 1 LD,LP,ITAUM,LAMPNO,NSEQ,ISCAL, 2 NPROJ,ALATD,ALOND,ORIENT,MESHD,XLAT,NXD,NYD, 3 FD9,FD1,IWORK,IPACK,ND5,MINPK, 4 IS0,IS1,IS2,IS4,ND7, 5 IPLANT,PLAINT,NCHAR, 6 XMISSP,XMISSS,LX,IOCTET, 7 JTOTBY,JTOTRC,L3264B,L3264W,IER) IF(IER.NE.0)ISTOP=ISTOP+1 C ERROR WRITING DISPOSABLE GRIDS NOT COUNTED AS FATAL. ENDIF C ENDIF C 320 KOUNT(IVRBL)=1 C KOUNT KEEPS A FORECAST FOR A PARTICULAR VARIABLE AND C PROJECTION FROM BEING MADE MORE THAN ONCE, BECAUSE C A VARIABLE MAY BE IN ID( , ) FOR SEVERAL PROJECTIONS. C ITABLE( , ) IS USED IN THE CALL TO GETFLD BECAUSE ID( , ) C MAY CONTAIN A PROJECTION. IF(MAKEF(LP,IVRBL).EQ.0)GO TO 399 C ONLY MAKE FORECASTS WHEN MAKEF( , ) NE 0. C GET THE FIELD TO ADVECT IN FD7( ) FROM INTERNAL STORAGE. C IF(IDPARS(1,N).EQ.007.OR.IDPARS(1,N).EQ.003)THEN C C GETRADLTG GETS RADAR OR LIGHTNING DATA, AND PUTS IT ON THE C LAMP GRID WITH MESH LENGTH MESH(IVRBL). C IFFF=IDPARS(2,N)/100 IF(IFFF.EQ.2.OR.IFFF.EQ.5.OR.IFFF.EQ.8)THEN C C AS OF OCT 2015: C 0075XX = LIGHTNING VARIABLES C 0078XX = MRMS RADAR VARIABLES C CALL GETRADLTG(KFILDO,KFIL10,ITABLE(1,IVRBL), 1 ITABLE(2,IVRBL),NDATE,FD7,FD9,ND2X3, 2 NPROJ,ORIENT,XLAT,RMISS(IVRBL), 3 NXL,NYL,NXPL,NYPL,ALATL,ALONL,MESHB, 4 NX,NY,MESH(IVRBL),ITRPLQ(IVRBL), 5 LSTORE,LITEMS,ND9, 6 IS0,IS1,IS2,IS4,ND7, 7 IPACK,IWORK,ND5, 8 CORE,ND10,NBLOCK,NFETCH,MISTOT,NSLAB, 9 L3264B,ISTOP,IER) C C ALTHOUGH IT IS AN ERROR IF THE RADAR OR LIGHTNING DOES C NOT EXIST IT IS NOT A FATAL ERROR AND SHOULD NOT KILL C THE REST OF THE LAMP PROCESS. SET ERROR TO 0 AND C CONTINUE. C IF(IER.NE.0)THEN WRITE(KFILDO,322)(ITABLE(J,IVRBL),J=1,4) IER=0 GO TO 399 ENDIF C C WRITE GRID TO INTERNAL STORAGE WITH CCC = 007 C AND DD = 5 SO THAT IT WILL BE AVAILABLE FOR ARCHIVAL C ON THE LAMP GRID; THE INPUT GRID WILL LIKELY C NOT BE THE LAMP GRID. DO THIS ONLY ONCE FOR 007580. C ENDIF C IF(IFFF.EQ.5.AND.I0075.EQ.0.OR. 1 IFFF.EQ.6.AND.I0076.EQ.0.OR. 2 IFFF.EQ.7.AND.I0077.EQ.0)THEN C IF(IFFF.EQ.5)I0075=1 IF(IFFF.EQ.6)I0076=1 IF(IFFF.EQ.7)I0077=1 C LD(1)=ID(1,N) LD(2)=0 LD(3)=0 LD(4)=0 XMISSP=9999. XMISSS=0. STATE=' 321' CALL PAWING(KFILDO,KFIL10,NDATE, 1 LD,ITAUH,ITAUM,LAMPNO,NSEQ,ISCALD(N), 2 NPROJ,ALATL,ALONL,ORIENT,MESHB,MESH(IVRBL),XLAT,NX,NY, 3 FD7,DATA,IWORK,IPACK,ND5,MINPK, 4 LSTORE,ND9,LITEMS,CORE,ND10,NBLOCK, 5 IS0,IS1,IS2,IS4,ND7, 6 IPLAIN(1,1,N),PLAIN(N),NCHAR, 7 XMISSP,XMISSS,LX,IOCTET, 8 L3264B,L3264W,IER) C IF(IER.NE.0)THEN WRITE(KFILDO,321) 321 FORMAT(' ****ERROR IN U454. CANNOT WRITE RADAR', 1 ' GRID TO RANDOM ACCESS FILE') IER=0 GO TO 399 C ANY ERROR FROM PAWING MAY BE FATAL. NOT FATAL C FOR RADAR OR LIGHTNING. ENDIF C ENDIF C ELSE C GETFLD GETS FIELD AND PUTS IT ON THE LAMP GRID WITH C MESH LENGTH MESH(IVRBL). FOR DISCONTINUOUS VARIABLES, C MESH(IVRBL) SHOULD NOT BE LESS THAN THE AVAILABLE GRID C BECAUSE INTERPOLATION WILL NOT BEHAVE PROPERLY. CALL GETFLD(KFILDO,KFIL10,ITABLE(1,IVRBL),NDATE, 1 FD7,FD9,ND2X3, 2 NCEPNO,LAMPNO,NPROJ,ORIENT,XLAT, 3 NXL,NYL,NXPL,NYPL,ALATL,ALONL,MESHB, 4 NX,NY,MESH(IVRBL),ITRPLQ(IVRBL), 5 LSTORE,LITEMS,ND9, 6 IS0,IS1,IS2,IS4,ND7, 7 IPACK,IWORK,ND5, 8 CORE,ND10,NBLOCK,NFETCH,MISTOT,NSLAB, 9 L3264B,IER) C IF(IER.NE.0)THEN WRITE(KFILDO,322)(ITABLE(J,IVRBL),J=1,4) 322 FORMAT(/' ****COULD NOT GET THE FIELD TO ADVECT =', 1 3(1X,I9.9),1X,I10.3,' IN U454.') IER=0 GO TO 399 ENDIF C ENDIF C C GRIDPRINT (WHEN IP22 NE 0) THE INITIAL FIELD, PROVIDED C I454DG( ) NE 0. OUTPUT IS ALSO CONTROLLED BY JP( ,N). C DO IT ONLY ONCE. HOWEVER, THE GRID SHOULD NOT BE THICKENED C BECAUSE THE ROUTINES WON'T WORK WELL. THEREFORE, MESHD C SHOULD BE GE MESH(IVRBL). C IF((I454DG(IVRBL).NE.0).AND. 1 ((IP22. GT.0.AND.JP(1,N).GT.0).OR. 2 (KFILOG.GT.0.AND.JP(2,N).GT.0)).AND. 3 (MESH(IVRBL).LE.MESHD).AND. 4 ((LP0076.EQ.0.AND.IDPARS(1,N).EQ.007.AND. 5 IDPARS(2,N)/100.EQ.6).OR. 6 (LP0077.EQ.0.AND.IDPARS(1,N).EQ.007.AND. 7 IDPARS(2,N)/100.EQ.7)))THEN C THIS CHECK ON IDPARS(2,N) ALLOWS FOR ANY ONE OF THE C 4 POSSIBLE RADAR GRIDS TO BE THE PRIMARY ONE. NXG=NX NYG=NY NXPG=NXP NYPG=NYP MESHG=MESH(IVRBL) C NXG, ETC. ARE NECESSARY BECAUSE SIZEGR CHANGE THEM, AND C NX, ETC. MUST BE RETAINED. CALL TRNSFR(FD7,FD9,NX*NY) CALL SIZEGR(KFILDO,FD9,NXG,NYG,NXPG,NYPG, 1 MESHG,MESHD,ITRPLQ(IVRBL),ND2X3) C THE SAME INTERPOLATION IS USED (IF NEEDED) AS FOR OTHER C USES IN U454. IF(IP22.NE.0.AND.JP(1,N).GT.0.AND. 1 (IDPARS(1,N).EQ.007.AND.IDPARS(2,N)/100.EQ.6.AND.LP0076.EQ.0) 2 .OR. 3 (IDPARS(1,N).EQ.007.AND.IDPARS(2,N)/100.EQ.7.AND.LP0077.EQ.0)) 4 THEN C THIS CHECK ON IDPARS(2,N) ALLOWS FOR ANY ONE OF THE C 4 POSSIBLE RADAR GRIDS TO BE THE PRIMARY ONE. TITLT(1:40)=' 0-H ' TITLT(20:37)=PLAIN(N)(3:20) C IF(IDPARS(1,N).EQ.008.AND. 1 (IDPARS(2,N).EQ.350.OR.IDPARS(2,N).EQ.355))THEN C THIS IS A CLOUD LAYER. PUT IN HEIGHTS. STATE='3240' WRITE(TITLT(6:8),325,IOSTAT=IOS,ERR=900)IDPARS(1,N) STATE='3241' WRITE(TITLT(9:11),325,IOSTAT=IOS,ERR=900)IDPARS(2,N) STATE='3242' WRITE(TITLT(13:15),325,IOSTAT=IOS,ERR=900)IDPARS(6,N) STATE='3243' WRITE(TITLT(17:19),325,IOSTAT=IOS,ERR=900)IDPARS(7,N) TITLT(16:16)='-' 325 FORMAT(I3.3) ENDIF C IF(IP22.NE.0)THEN STATE='325 ' CALL PRTGR(IP22,FD9,NXG,NYG, 1 CINT(1,IVRBL),ORIGIN(1,IVRBL), 2 SMULT(1,IVRBL),SADD(1,IVRBL), 3 IOPT,TITLT,IER) C THE SAME PRINT PARAMETERS ARE USED AS FOR C PROJECTION 1. C IF(IER.NE.0)THEN ISTOP=ISTOP+1 C ERROR GRIDPRINTING NOT COUNTED AS FATAL. WRITE(KFILDO,326)SMULT(1,IVRBL),SADD(1,IVRBL) 326 FORMAT(/' ****SCALING CAUSED OVERFLOW. SMULT =', 1 F10.2,4X,'SADD =',F10.2/ 2 ' CONTOURING ABORTED AT 326.') ENDIF C ENDIF C ENDIF C IF(KFILOG.NE.0.AND.JP(2,N).GT.0.AND. 1 (IDPARS(1,N).EQ.007.AND.IDPARS(2,N)/100.EQ.6.AND.LP0076.EQ.0) 2 .OR. 3 (IDPARS(1,N).EQ.007.AND.IDPARS(2,N)/100.EQ.7.AND.LP0077.EQ.0)) 4 THEN C THIS CHECK ON IDPARS(2,N) ALLOWS FOR ANY ONE OF THE C 4 POSSIBLE RADAR GRIDS TO BE THE PRIMARY ONE. LD(1)=(ID(1,N)/100)*100+LAMPNO C MAKE SURE THE DD = LAMPNO; RADAR WON'T BE UP TO THIS C POINT. LD(2)=ID(2,N) LD(3)=0 C THIS IS THE INITIAL (0-H) FIELD. LD(4)=0 C C THE GRID IN FD9( ) IS ALWAYS AT MESH LENGTH MESHD AS A C RESULT OF SIZEGR, WHICH IS WHAT IS WANTED FOR THE C DISPOSABLE GRID. NOW CUT THE GRID TO THE DISPOSABLE C AREA. C C SET PARAMETERS FOR THE DISPOSABLE GRID. THE ONLY C TIME THESE ARE NEEDED IS WHEN KFILOG NE 0. PRTGR DOES C NOT NEED THEM. NXPG, ETC., ARE IN RELATION TO THE C DISPOSABLE GRID MESH LENGTH MESHD WHICH AGREES WITH C IOPT( ). C NXD=IOPT(3)-IOPT(2)+1 NYD=IOPT(5)-IOPT(4)+1 C NXD AND NYD ARE THE CUT (DISPOSABLE) GRID DIMENSIONS. NXPD=NXPG-IOPT(2)+1 NYPD=NYPG-IOPT(4)+1 C NXPD AND NYPD ARE THE X AND Y POLE POSITIONS FOR THE C CUT (DISPOSABLE) GRID. C CALL CUT(KFILDO,FD9,NXG,NYG,NXPG,NYPG, 1 FD9,NXD,NYD,NXPD,NYPD) CALL MSHXMS(KFILDO,MESHD,XMESHN,XMESHD) C SUBROUTINE MSHXMS COMPUTES XMESHD FROM MESHD. CALL IJLLPS(1.,1.,XMESHD,ORIENT,XLAT, 1 FLOAT(NXPD),FLOAT(NYPD),ALATD,ALOND) C ALATD AND ALOND ARE THE LL LAT/LON GRID POSITION. C TRUNCATE TO THREE DECIMAL PLACES TO ASSURE C COMPATIBILITY WITH AVN ARCHIVE FOR U203 AND GENPAK. ALATD=NINT(ALATD*1000)/1000. ALOND=NINT(ALOND*1000)/1000. CALL PAWOTG(KFILDO,KFILOG,IP16,NDATE, 1 LD,0,0,LAMPNO,NSEQ,ISCALD(N), 2 NPROJ,ALATD,ALOND,ORIENT,MESHD,XLAT,NXD,NYD, 3 FD9,FD1,IWORK,IPACK,ND5,MINPK, 4 IS0,IS1,IS2,IS4,ND7, 5 IPLAIN(1,1,N),PLAIN(N),NCHAR, 6 XMISSP,XMISSS,LX,IOCTET, 7 JTOTBY,JTOTRC,L3264B,L3264W,IER) IF(IER.NE.0)ISTOP=ISTOP+1 C ERROR WRITING DISPOSABLE GRIDS NOT COUNTED AS FATAL. ENDIF C IF(IDPARS(2,N)/100.EQ.5)LP0075=1 IF(IDPARS(2,N)/100.EQ.6)LP0076=1 IF(IDPARS(2,N)/100.EQ.7)LP0077=1 C THIS CHECK ON IDPARS(2,N) ALLOWS FOR ANY ONE OF THE C 4 POSSIBLE RADAR GRIDS TO BE THE PRIMARY ONE. C LP0076 OR LP0077 IS SET TO 1 INDICATING THIS PRINT WILL C NOT BE DONE AGAIN FOR THIS VARIABLE. ONLY THE C RADAR DATA ARE DEALT WITH. OTHER INITIAL FIELDS CAN C BE PRINTED AND WRITTEN IN THE ANALYSIS PROGRAMS. C RADAR DATA ARE INPUT DIRECTLY. C (IF ANOTHER TYPE OF DATA, SUCH AS LIGHTNING, ARE INPUT C DIRECTLY, A MODIFICATION WILL BE NEEDED HERE.) C ENDIF C C PUT UPSTREAM VARIABLE IN FD1( , ). IF THE VARIABLE IS C RADAR, THE VALUE AT THE GRIDPONT REPRESENTS THE BOX C TO THE UPPER RIGHT, NOT THE VALUE OF A BOX CENTERED C AT THE GRIDPOINT. TO COUNTERACT THIS, WHEN THE C ENDOINT OF THE TRAJECTORY IS COMPUTED, THE END POINT C IS DISPLACED ONE HALF GRIDLENGTH IN EACH DIRECTION C DOWN AND TO THE LEFT. C IF(IDPARS(1,N).EQ.007.AND. 1 (IDPARS(2,N)/100.EQ.6.OR.IDPARS(2,N)/100.EQ.7))THEN C C REMOVED THE HALF-GRID OFFSET 10/2015 DO 327 J=1,NX*NY C U(J)=XPOS(J)-.5 U(J)=XPOS(J) IF(U(J).LT.0.)U(J)=0. C SUBROUTNE NEARGR EXPECTS POSITIVE VALUES. C V(J)=YPOS(J)-.5 V(J)=YPOS(J) IF(V(J).LT.0.)V(J)=0. C SUBROUTNE NEARGR EXPECTS POSITIVE VALUES. 327 CONTINUE C D CALL TIMPR(KFILDO,KFILDO,'START NEARGR ') CALL NEARGR(KFILDO,FD7,U,V,FD1,NX,NY,R(LP,IVRBL), 1 RMISS(IVRBL)) D CALL TIMPR(KFILDO,KFILDO,'END NEARGR ') ELSE C IF(ID(1,N).EQ.409020005.OR. 1 ID(1,N).EQ.002301005.OR. 2 ID(1,N).EQ.003301005)THEN C THE THREE FIELDS TERRAIN, TEMPERATURE, AND DEW C POINT ARE LINEARLY INTERPLATED. FOR THE OTHERS C THE NEAREST NEIGHBOR APPROACH IS USED. CALL INTRLN(KFILDO,FD7,XPOS,YPOS,FD1,NX,NY) ELSE D CALL TIMPR(KFILDO,KFILDO,'START NEARGR ') CALL NEARGR(KFILDO,FD7,XPOS,YPOS,FD1,NX,NY,R(LP,IVRBL), 1 RMISS(IVRBL)) D CALL TIMPR(KFILDO,KFILDO,'END NEARGR ') ENDIF C ENDIF C C SMOOTH FORECAST IF DESIRED. WHILE THIS OPTION IS C FURNISHED, IT IS EXPECTED IT WILL NOT BE USED, BECAUSE C SMOTH DOES NOT DEAL WITH MISSING VALUES. A SMOOTH C FIELD WITH NON MISSING VALUES, SUCH AS TEMPERATURE, C COULD BE SMOOTHED, BUT ANY MISSING VALUES NEAR THE C BORDERS WILL GIVE ERRONEOUS VALUES. C IF(B(LP,IVRBL).NE.0.)THEN WRITE(KFILDO,328) 328 FORMAT(/' ****DANGER. A FIELD IS BEING SMOOTHED.', 1 ' SMOOTHING ROUTINE DOES NOT ACCOMMODATE', 2 ' MISSING VALUES.') ISTOP=ISTOP+1 CALL SMOTH(FD1,FD9,NX,NY,B(LP,IVRBL)) ENDIF C C PACK AND WRITE THE FORECASTS TO THE INTERNAL STORAGE C SYSTEM. THEY ARE WRITTEN AT THE MESH LENGTH = MESH. C U150 WILL THEN WRITE THEM TO THE ARCHIVE FILE. C C LD(1)=(ID(1,N)/100)*100+LAMPNO C THE RADAR IDS HAVE DD = 4 AND MUST BE CHANGED TO LAMPNO. C COMMENTED OUT THIS IS NO LONGER TRUE. -JRW MARCH 2004 C LD(1)=ID(1,N) LD(2)=ID(2,N) C THIS IS 2 FOR TEMPERATURE AND DEW POINT AND DEFINES C CLOUD LAYERS. LD(3)=LP LD(4)=0 C NOTE THAT THESE FINAL FORECASTS ARE WRITTEN WITH SMOOTHING C PARAMETER S = 0, EVEN THOUGH THEY MAY HAVE BEEN SMOOTHED. XMISSP=9999. XMISSS=0. C THESE ARE FORECASTS AND MISSING VALUES CAN BE PRESENT, C BECAUSE OF MISSING VALUES IN THE GRID. SET C XMISSP=9999. ALSO SOME FIELDS (E.G., HGT AND AMT C OF CLOUDS ABOVE THE LOWEST LEVEL) CAN HAVE LEGITIMATE C "SECONDARY" MISSING VALUES OF 8888. HOWEVER, SECOND ORDER C DIFFERENCES CANNOT BE USED WHEN XMISSS NE 0, AND TESTING C SHOWS THAT SETTING XMISSS = 0 GIVES BETTER RESULTS FOR C THE FULL RANGE OF FIELDS ANALYZED BY U400D THAN XMISSS = 8888 C ON A 10-KM GRID. AT 10-KM, THERE IS MUCH REDUNDANCY AND C SECOND ORDER DIFFERENCES ARE EVIDENTLY ADVANTAGEOUS; AT 80-KM, C IT DOESN'T SEEM TO MATTER MUCH WHETHER 0 OR 8888 IS USED. CALL PAWING(KFILDO,KFIL10,NDATE, 1 LD,LP,ITAUM,LAMPNO,NSEQ,ISCALD(N), 2 NPROJ,ALATL,ALONL,ORIENT,MESHB,MESH(IVRBL),XLAT,NX,NY, 3 FD1,DATA,IWORK,IPACK,ND5,MINPK, 4 LSTORE,ND9,LITEMS,CORE,ND10,NBLOCK, 5 IS0,IS1,IS2,IS4,ND7, 6 IPLAIN(1,1,N),PLAIN(N),NCHAR, 7 XMISSP,XMISSS,LX,IOCTET, 8 L3264B,L3264W,IER) C THIS IS SCALED TO ISCALD(N) = 1 (PROBABLY) FOR TENTHS OF C METERS. C IF(IER.NE.0)THEN WRITE(KFILDO,330)LP 330 FORMAT(' ****FATAL ERROR IN U454. CANNOT WRITE FORECAST', 1 ' TO RANDOM ACCESS FILE FOR PROJECTION',I3,'.') GO TO 600 C ANY ERROR FROM PAWING SHOULD BE TREATED AS FATAL. ENDIF C C TDLPACK (WHEN KFILDO NE 0) AND GRIDPRINT (WHEN IP22 NE 0) C THE FORECAST, PROVIDED I454DG(IVRBL) NE 0. OUTPUT IS ALSO C CONTROLLED BY JP( ,N). HOWEVER, THE GRID SHOULD NOT BE C THICKENED BECAUSE THE ROUTINES WON'T WORK WELL. THEREFORE, C MESHD SHOULD BE GE MESH(IVRBL). C IF((I454DG(IVRBL).NE.0).AND. 1 ((IP22. GT.0.AND.JP(1,N).GT.0).OR. 2 (KFILOG.GT.0.AND.JP(2,N).GT.0)).AND. 3 (MESH(IVRBL).LE.MESHD))THEN C NXG=NX NYG=NY NXPG=NXP NYPG=NYP MESHG=MESH(IVRBL) C NXG, ETC. ARE NECESSARY BECAUSE SIZEGR CHANGE THEM, AND C NX, ETC. MUST BE RETAINED. CALL TRNSFR(FD1,FD9,NX*NY) CALL SIZEGR(KFILDO,FD9,NXG,NYG,NXPG,NYPG, 1 MESHG,MESHD,ITRPLQ(IVRBL),ND2X3) C THE SAME INTERPOLATION IS USED (IF NEEDED) AS FOR OTHER C USES IN U454. C IF(IP22.NE.0.AND.JP(1,N).NE.0)THEN C JP(1,N) CONTROLS GRIDPRINTING FOR VARIABLE N. TITLT(1:40)=' -H ' TITLT(20:37)=PLAIN(N)(3:20) C IF(IDPARS(1,N).EQ.008.AND. 1 (IDPARS(2,N).EQ.350.OR.IDPARS(2,N).EQ.355))THEN C THIS IS A CLOUD LAYER. PUT IN HEIGHTS. STATE='3400' WRITE(TITLT(6:8),325,IOSTAT=IOS,ERR=900)IDPARS(1,N) STATE='3401' WRITE(TITLT(9:11),325,IOSTAT=IOS,ERR=900)IDPARS(2,N) STATE='3402' WRITE(TITLT(13:15),325,IOSTAT=IOS,ERR=900)IDPARS(6,N) STATE='3403' WRITE(TITLT(17:19),325,IOSTAT=IOS,ERR=900)IDPARS(7,N) TITLT(16:16)='-' ENDIF C STATE='340 ' WRITE(TITLT(1:2),340,IOSTAT=IOS,ERR=900)LP 340 FORMAT(I2) CALL PRTGR(IP22,FD9,NXG,NYG, 1 CINT(LP,IVRBL),ORIGIN(LP,IVRBL), 2 SMULT(LP,IVRBL),SADD(LP,IVRBL), 3 IOPT,TITLT,IER) C IF(IER.NE.0)THEN ISTOP=ISTOP+1 C ERROR GRIDPRINTING NOT COUNTED AS FATAL. WRITE(KFILDO,341)SMULT(LP,IVRBL),SADD(LP,IVRBL) 341 FORMAT(/' ****SCALING CAUSED OVERFLOW. SMULT =',F10.2, 1 4X,'SADD =',F10.2/ 2 ' CONTOURING ABORTED AT 341.') ENDIF C ENDIF C IF(KFILOG.NE.0.AND.JP(2,N).NE.0)THEN C JP(2,N) CONTROLS TDLPACKING FOR VARIABLE N. LD(1)=(ID(1,N)/100)*100+LAMPNO C DATA WRITTEN SHOULD HAVE A MODEL NUMBER = LAMPNO. LD(2)=ID(2,N) C THIS IS 2 FOR TEMPERATURE AND DEW POINT AND DEFINES C CLOUD LAYERS. LD(3)=LP LD(4)=0 C NOTE THAT THESE FINAL FORECASTS ARE WRITTEN WITH C SMOOTHING PARAMETER S = 0, EVEN THOUGH THEY MAY HAVE C BEEN SMOOTHED. C C THE GRID IN FD9( ) IS ALWAYS AT MESH LENGTH MESHD AS A C RESULT OF SIZEGR, WHICH IS WHAT IS WANTED FOR THE C DISPOSABLE GRID. NOW CUT THE GRID TO THE DISPOSABLE C AREA. THIS IS SCALED TO ISCALD(N) = 1 (PROBABLY) C FOR TENTHS OF METERS. C C SET PARAMETERS FOR THE DISPOSABLE GRID. THE ONLY C TIME THESE ARE NEEDED IS WHEN KFILOG NE 0. PRTGR DOES C NOT NEED THEM. NXPG, ETC., ARE IN RELATION TO THE C DISPOSABLE GRID MESH LENGTH MESHD WHICH AGREES WITH C IOPT( ). C NXD=IOPT(3)-IOPT(2)+1 NYD=IOPT(5)-IOPT(4)+1 C NXD AND NYD ARE THE CUT (DISPOSABLE) GRID DIMENSIONS. NXPD=NXPG-IOPT(2)+1 NYPD=NYPG-IOPT(4)+1 C NXPD AND NYPD ARE THE X AND Y POLE POSITIONS FOR THE C CUT (DISPOSABLE) GRID. C CALL CUT(KFILDO,FD9,NXG,NYG,NXPG,NYPG, 1 FD9,NXD,NYD,NXPD,NYPD) CALL MSHXMS(KFILDO,MESHD,XMESHN,XMESHD) C SUBROUTINE MSHXMS COMPUTES XMESHD FROM MESHD. CALL IJLLPS(1.,1.,XMESHD,ORIENT,XLAT, 1 FLOAT(NXPD),FLOAT(NYPD),ALATD,ALOND) C ALATD AND ALOND ARE THE LL LAT/LON GRID POSITION. C TRUNCATE TO THREE DECIMAL PLACES TO ASSURE C COMPATIBILITY WITH AVN ARCHIVE FOR U203 AND GENPAK. ALATD=NINT(ALATD*1000)/1000. ALOND=NINT(ALOND*1000)/1000. LD(1)=LD(1)+INCDD C INCDD ALLOWS FOR WRITING DISPOSABLE FORECASTS WITH C DD OTHER THAN LAMPNO. CALL PAWOTG(KFILDO,KFILOG,IP16,NDATE, 1 LD,LP,ITAUM,LAMPNO,NSEQ,ISCALD(N), 2 NPROJ,ALATD,ALOND,ORIENT,MESHD,XLAT,NXD,NYD, 3 FD9,DATA,IWORK,IPACK,ND5,MINPK, 4 IS0,IS1,IS2,IS4,ND7, 5 IPLAIN(1,1,N),PLAIN(N),NCHAR, 6 XMISSP,XMISSS,LX,IOCTET, 7 JTOTBY,JTOTRC,L3264B,L3264W,IER) IF(IER.NE.0)ISTOP=ISTOP+1 C ERROR WRITING DISPOSABLE GRIDS NOT COUNTED AS FATAL. ENDIF C ENDIF C 399 CONTINUE C 400 CONTINUE C C WRITE THE COMBINATIONS OF HEIGHTS USED. C IF(JFIRST.LT.LIMIT)THEN WRITE(KFILDO,500)LCOMBO,(J,(COMB(M,J),M=1,10), 1 (IWCOMB(M,J),M=1,2),J=1,LCOMBO) 500 FORMAT(/' ',I4,' COMBINATIONS OF HEIGHTS USED FOR WINDS'// 1 ' NO WEIGHTINGS FOR WINDS ', 2 ' SMOOTHINGS ', 3 ' MESHW FILT ADVECTIVE WINDS'/ 4 ' _______________________________', 5 ' ______________________________', 6 ' _______________'// 7 ' C00AF C85AF C70AF C50AF', 8 ' N00SM N85SM N70SM N50SM', 9 ' U V'// X (I4,8F8.2,2X,F8.2,F7.2,2X,2I10)) JFIRST=JFIRST+1 C JFIRST SET SO THE THE ABOVE PRINT WILL NOT REOCCUR. ENDIF C WRITE(KFILDO,502)(JDATE(J),J=1,4) 502 FORMAT(/' U454 HAS SUCCESSFULLY COMPLETED FOR DATE/TIME ', 1 I5,2I3,I3.2,'00.') C GO TO 700 C C FOR THIS DEVELOPMENTAL PROGRAM, IF U454 CANNOT COMPLETE C IT IS INDICATED BY IER = 777. 600 IER=777 ISTOP=ISTOP+1 700 RETURN C C ERROR STOP BELOW IS FOR ERRORS OF CONTROL INFORMATION INPUT. 900 CALL IERX(KFILDO,KFILDO,IOS,'U454 ',STATE) IER=9999 GOTO 700 END