SUBROUTINE U450(KFILDI,KFILDO,KFIL10,KFILOG,KFILRA,RACESS,NUMRA, 1 IP16,IP22, 2 P,U,V,TERRM,Z10,Z51,G,SINPHI,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,MESHL,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 MARCH 2001 GLAHN TDL LAMP-2000 C MAY 2001 GLAHN MODIFIED TO INCLUDE 1000 MB HEIGHTS C IN COMPUTING ADVECTING WINDS; C INCLUDED PREVIOUS CYCLES; OMITTED C IOPTL( ); CHANGED CALL TO SIZEGR C ABOVE DO 360 LOOP C MAY 2001 GLAHN ADDED REDUCTION OF HIGH 500-MB HEIGHTS C MAY 2001 GLAHN ADDED KFILOG WRITING AND GRIDPRINTING C MAY 2001 GLAHN IMPLEMENTED SMOOTHING OF FORECASTS C MAY 2001 GLAHN ADDED NXPS AND NYPS C JUNE 2001 GLAHN MODIFIED TO ACCOMMODATE GENERIC ADVWND C AND FORCST; CHANGED GRIDPRINT INTERVAL C FROM 100 TO 10 FOR TERRAIN TERM; C REMOVED Z51( ) FROM CALL TO FORCST C JUNE 2001 GLAHN CHANGED G TO FD9 IN CALL TO PRTGR C JUNE 2001 GLAHN CHANGED LOCATION OF PRTGR TO RIGHT C AFTER SIZEGR C JUNE 2001 GLAHN CHANGED ORDER OF HEIGHT REDUCTION; C SET SMALL SMOOTHED TERRAIN VALUES C TO ZERO; SMOOTHED TERRAIN ON A C 1/4 BEDIENT GRID RATHER THAN 1-BEDIENT C JUNE 2001 GLAHN CHANGED TERRM( ) FORMULATION C JULY 2000 GLAHN ADDED GRIDPOINT AND TDLPAK CAPABILITY C FOR XPOS AND YPOS OF TRAJECTORIES; C CHANGED LD(2) FOR 1000-MB HEIGHT; C REMOVED ISCALD( ) IN CALL TO FORCST C JULY 2001 GLAHN TRUNCATED ALATD, ALOND TO 3 PLACES C JULY 2001 GLAHN CHANGED CALL TO FORCST AND INSERTED C OUTPUT SECTION FROM FORCST C AUGUST 2001 GLAHN COMMENTS FOR SCALING WITH PAWOTG; C SCALING FOR X- AND Y-POS NOW 1 C AUGUST 2001 GLAHN CORRECTED PROJECTION FOR 500-MB C HEIGHTS FOR LAMP PROJECTION LP C AUGUST 2001 GLAHN MODIFIED SOME VALUES OF ISCAL AND C CONTOUR INTERVALS FOR GRIDPRINT C AUGUST 2001 GLAHN INTRQ IS NOW QUADRATIC, NOT LINEAR C AUGUST 2001 GLAHN PUT DATE/TIME INTO TITLT; C ALLOWED FOR MISSING VALUES IN UPSTREAM C CONSERVATIVE QUANTITY C SEPTEMBER 2001 GLAHN MODIFIED TO SMOOTH TERRAIN 3 TIMES, C AND SLP FORECAST SELECTIVELY 0-3 TIMES C DEPENDING ON PROJECTION C SEPTEMBER 2001 GLAHN ADDED CHECK FOR TAU NE 0 TO EXECUTE C SEPTEMBER 2001 GLAHN MADE IT MANDATORY FOR TAU TO BE 0; C CHANGED ID(J,N) TO ITABLE(J) FOR C FORMAT 123, CHANGED ITAUH AND C IDPARS(12,N) TO LP IN APPROPRIATE C CALLS TO PAWOTG AND PAWING C SEPTEMBER 2001 GLAHN ADDED DEFINITION OF ALATD, ALOND C SEPTEMBER 2001 GLAHN ADDED CHECK FOR MESH AT 278; CHANGED C MESHD TO MESHL IN CALL TO GETELE C OCTOBER 2001 GLAHN LOCATION OF XMISSP = 0 CHANGED TO INTO C DO 400 LOOP C OCTOBER 2001 GLAHN CHANGED NX,NY TO NXG,NYG IS SEVERAL C CALLS TO PRTGR; ADJUSTED CONTOUR C INTERVAL IN PRTGR FOR TRAJECTORY END C POINTS FOR MESH LENGTH C DECEMBER 2001 GLAHN OMITTED COMMENT ABOUT RDSTAR, ITRPLQ C JANUARY 2002 GLAHN ADDED I450DG TO LIMIT PRINT OF C UPSTREAM CONSERVATIVE QUANTITY C JANUARY 2002 GLAHN ADDED ISTOP TO CALL TO ADVWND C APRIL 2002 GLAHN ADDED CHECK ON IER AFTER GETELE C APRIL 2002 GLAHN ADDED COMMENTS C MAY 2002 GLAHN ADDED RR FOR ADJUSTING XPOS AND YPOS C FOR DISPLAY WITH MESHD C JUNE 2002 GLAHN ADDED INCDD TO CALL AND PAWOTG LD(1) C AUGUST 2002 GLAHN REMOVED VESTIGES OF POSSIBILITY OF C FORECASTS IN Z10( ) BEING MISSING C AUGUST 2002 GLAHN COMMENT BEFORE CALL TO ADVWND C DECEMBER 2002 RUDACK MODIFIED FORMAT STATEMENTS TO ADHERE C TO THE F90 COMPILER STANDARDS FOUND ON C THE IBM SYSTEM C FEBRUARY 2003 GLAHN MADE IBACKN COMMENT THE SAME AS IN C FIRST GUESS ROUTINES C MARCH 2004 WIEDENFELD MODIFIED TO PACK THE 1000 MB AND 500 MB C HEIGHTS TO THE INTERNAL STORAGE SYSTEM. C APRIL 2004 WIEDENFELD CORRECTED THE PLAIN LANGUAGE FOR THE 1000 C AND 500 MB HEIGHTS. C AUGUST 2005 WIEDENFELD MODIFIED FOR OPERATIONS. TOOK OUT C STOP 9999 REPLACED WITH IER=9999 C U150 WILL GIVE ERROR STATEMENT. MODIFIED C DOTCN TO BE lmp_slpfcst.cn C NOVEMBER 2012 GHIRARDELLI MODIFIED TO PASS PLAIN TO PAWING C WHICH WAS MODIFIED FOR INTEL CHANGES C C PURPOSE C PROGRAM U450 IS THE SEA LEVEL PRESSURE MODEL, BASED C ON THE REED MODEL, TAILORED FROM EARLIER VERSIONS OF C LAMP. NOTE THAT SMOOTHED 500-MB HEIGHTS (IF DESIRED) C ARE USED IN ADVECTING WIND, BUT UNSMOOTHED 500-MB HEIGHTS C ARE USED IN THE DEVELOPMENT TERM. THE TERRAIN IS C SMOOTHED 3 TIMES WITH THE SQUARE 25-PT SMOOTHER ON C A 1/4-BEDIENT GRID, ONLY 1/2 THE SMOOTHED TERRAIN TERM C IS USED IN THE ADVECTION (IN UWIND AND VWIND), AND THE C SLP FORECAST IS SMOOTHED WITH THE SELECTIVE SMOOTHER, C THE NUMBER TIMES DEPENDING ON THE PROJECTION. C C U450 WILL RUN IF ANY ONE OF THE ID(1, ) INDICATES C SLP, EVEN THOUGH THE TAU IS ZERO. WHICH C FORECASTS ARE ACTUALLY MADE IS CONTROLLED FROM U450.CN. C THOSE WRITTEN TO THE ARCHIVE FILE, UNIT KFILIO IN U150, C IS CONTROLLED BY THE VARIABLES IN ID( , ). C C BECAUSE OF THE U450.CN CONTROL, NOT ALL THE SLP VARIABLES C IN THE ID( , ) LIST ARE FOUND. RATHER, THE ONE WITH C TAU = 0 IS USED. THIS IS CONSISTENT WITH U400A BECAUSE C U400A WON'T PRODUCE A SLP ANALYSIS UNLESS TAU = 0. C THE ISCALD( ), PLAIN( ), AND JP( , ) ARE USED FOR THIS C REQUIRED VARIABLE WITH TAU = 0. C C THE TRAJECTORY END POINTS ARE RESTRAINED TO ONE C GRIDLENGTH OUTSIDE THE GRID, AND THE FORECAST WILL NOT C CONTAIN MISSING VALUES. C C THE FOLLOWING OUTPUTS ARE POSSIBLE FOR GRIDPRINTING C OR TO UNIT NUMBER KFILOG USED FOR DISPOSABLE GRIDS: C 409020005 0 0 0 TERRAIN HEIGHT IN M C 409020005 0 0 060 SMOOTHED TERRAIN HEIGHT IN M C 409021005 0 0 0 (SMOOTHED) TERRAIN AFTER C ADJUSTMENT C 409022005 0 0 0 TERRAIN TERM FOR INSERTION INTO C CONSERVATIVE QUANTITY (AFTER C APPLICATION OF D405F) C 409120005 0 0 0 LATITUDE TERM FOR INSERTION INTO C CONSERVATIVE QUANTITY (AFTER C APPLICATION OF CLAT) C 409220005 0 0 0 FULL CONSERVATIVE QUANTITY C 001000005 1000 0 0 1000-MB HEIGHT DERIVED FROM C SLP ANALYSIS 001201005 0 0 0 C 004500005 0 LP 0 XPOS OF TRAJECTORIES AT THE C END OF LP HOURS. C 004510005 0 LP 0 YPOS OF TRAJECTORIES AT THE C END OF LP HOURS. C 001201005 0 LP 0 SLP FORECASTS SMOOTHED AS C INDICATED IN 3983 LOOP 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 '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 FOR DISPOSABLE TDLPACK GRIDPOINT C OUTPUT. THIS IS FOR DIAGNOSTIC INFORMATION. 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 P(J) = THE SLP FORECAST (J=1,NX*NY). WORK ARRAY C IN ADVWND. (INTERNAL) C U(J), V(J) = THE MODEL ADVECTIVE U- AND V-WIND COMPONENTS C (J=1,NX*NY). (INTERNAL) C TERRM(J) = THE TERRAIN TERM (J=1,NX*NY). IT IS COMPUTED C BY FIRST SMOOTHING THE TERRAIN HEIGHTS IN M C WITH A SQUARE 25-POINT SMOOTHER THREE TIMES C ON A 1/4-BEDIENT GRID. THEN, THE HEIGHTS ARE PUT C BACK ONTO THE GRID WITH A MESH LENGTH OF MESH C WITH BILINEAR INTERPOLATION. TERRM( ) IS C FIRST CONVERTED TO AVERAGE PRESSURE AT THE C GROUND, THEN, MULTIPLIED BY .405 (M/MB) TO C CONVERT TO METERS. THE "HEIGHT" OF THIS TERM C IS NOT IMPORTANT, ONLY THE SPATIAL DIFFERENCES. C TO BE COMPATIBLE WITH THE PREVIOUS MODEL, THE C AVERAGE SLP OF 1013.25 IS SUBTRACTED TO MAKE C THE VALUES ZERO OVEF THE OCEAN. THIS FORMULATION C IS FOR THE COMPUTATION OF WINDS. LATER, C TERRM( ) IS MODIFIED ACCORDING TO C405F. C THE .405 COMES FROM THE MODEL. THEN A TUNING C FACTOR C405F IS PROVIDED TO MULTIPLY THIS VALUE C BY, WHICH NORMALLY WOULD BE 1 BUT UNGER C IMPLEMENTED AS .5. (INTERNAL) C Z10(J) = 1000-MB HEIGHT (J=1,NX*NY). WORK ARRAY C IN ADVWND. (INTERNAL) C Z51(J) = INITIAL 500-MB HEIGHTS (J=1,NX*NY). WORK ARRAY C IN ADVWND. (INTERNAL) C G(J) = HOLDS LATITUDE TERM (J=1,NX*NY). PART OF C THE "CONSERVATIVE QUANTITY." IT IS C 163*SIN OF THE LATITUDE SQUARED. (INTERNAL) C SINPHI(J) = SINPHI (J=1,NX*NY). WORK ARRAY IN FORCST. C (INTERNAL) C FD9(J) = WORK ARRAY AND THEN CONSERVATIVE QUANTITY C (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. 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 NPRED = THE NUMBER OF VARIABLES IDENTIFIED IN ID( ) C =1. (INPUT) C ND4 = THE MAXIMUM NUMBER OF VARIABLES FOR WHICH C TDLPACK OUTPUT DATA CAN BE PROVIDED. (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 C IN THE X DIRECTION IN 1/B BEDIENT UNITS. C NYL = THE SIZE OF THE PRIMARY GRID FOR THIS RUN C IN THE Y DIRECTION IN 1/B BEDIENT UNITS. 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/B BEDIENT UNITS. 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/B BEDIENT UNITS. 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. 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 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 ITABLE(J) = 4-WORD ID OF THE VARIABLE SEA LEVEL PRESSURE C (J=1,4). (INTERNAL) C DOTCN = THE SPECIFIC .CN FILE FOR U450. (CHARACTER*14) C (INTERNAL) C NPROJH = THE NUMBER OF PROJECTIONS FOR THIS ROUTINE. C UP TO 25 ARE ACCOMMODATED. (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. (INTERNAL) 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 = TYPE OF INTERPOLATION TO GO FROM ONE MESH C LENGTH TO ONE OF HALF THAT MESH LENGTH. 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). B( ) = 0 MEANS C NO SMOOTHING. (INTERNAL) C SMULT(J) = THE MULTIPLICATIVE FACTOR WHEN CONTOURING OR C GRIDPRINTING THE DATA (J=1,NPROJH). 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 PROJECTION. (INTERNAL) C SADD(J) = THE ADDITIVE FACTOR WHEN CONTOURING OR C GRIDPRINTING THE DATA (J=1,NPROJH). (INTERNAL) C ORIGIN(J) = THE CONTOUR ORIGIN, APPLIES TO THE UNITS IN C UNITS(N) (J=1,NPROJH). (INTERNAL) C CINT(J) = THE CONTOUR INTERVAL, APPLIES TO THE UNITS IN C UNITS(N) (J=1,NPROJH). (INTERNAL) C MAKEF(J) = 1 FOR MAKING A FORECAST FOR PROJECTION J C (J=1,NPROJH). ZERO OTHERWISE. (INTERNAL) C NPRT(J) = 1 FOR GRID PRINTING OF ANALYSIS AFTER C PROJECTION J (J=1,NPROJH). ZERO FOR NO C PRINTING. (INTERNAL) C NTDL(J) = 1 FOR TDLPACKING AND WRITING ANALYSIS AFTER C PROJECTION J (J=1,NPROJH). ZERO FOR NO PACKING. C (INTERNAL) C IFIRST = COUNTS ENTRIES INTO U450. THIS ALLOWS (HARD C CODED) CONTROL OF OUTPUT. SET BY DATA C STATEMENT TO ZERO. (INTERNAL) C LIMIT = WHEN IFIRST GT LIMIT, PRINT OF CONTROL C INFORMATION WILL NOT OCCUR. SET BY DATA C STATEMENT. (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. (INTERNAL) C IOPT(J) = SUBSETTING VALUES USED IN GRIDPRINTING (J=1,8) C IN RELATION TO THE SUBSETTED AREA MESH LENGTH C MESHL. (INTERNAL) C N50SM = THE NUMBER OF TIMES THE 1-BEDIENT 500-MB GRID C IS SMOOTHED FOR PURPOSES OF COMPUTING C ADVECTING WINDS. (INTERNAL) C N00SM = THE NUMBER OF TIMES THE 1-BEDIENT 1000-MB GRID C IS SMOOTHED FOR PURPOSES OF COMPUTING C ADVECTING WINDS. (INTERNAL) C C405F = THE FACTOR TO MULTIPLY BY .405 IN COMPUTING C THE TERRM( ) ARRAY FOR PURPOSES OF THE C CONSERVATIVE QUANTITY. THIS IS 1 FOR THE BASIC C MODEL, BUT WAS IMPLEMENTED AS .5. THIS C IS FOR POSSIBLE TUNING. NOTE THAT THIS C DOES NOT APPLY TO THE USE OF TERRM( ) IN C COMPUTING WINDS, WERE THE FULL .405 IS USED. C (INTERNAL) C C55HCF = THE FACTOR TO MULTIPLY BY .55 IN COMPUTING C THE 500-MG HEIGHT CHANGE Z5( ). NORMALLY = 1. C THIS IS FOR POSSIBLE TUNING. (INTERNAL) C C55AF = THE FACTOR TO USE IN COMPUTING THE 500-MB C ADVECTING WINDS. NORMALLY = .55. C THIS IS FOR POSSIBLE TUNING. (INTERNAL) C C00AF = THE FACTOR TO USE IN COMPUTING THE 1000-MB C ADVECTING WINDS. NORMALLY = .00. C THIS IS FOR POSSIBLE TUNING. (INTERNAL) C C163GF = THE FACTOR TO MULTIPLY BY 163. IN COMPUTING C THE LATITUDE TERM G( ). NORMALLY = 1. THIS C IS FOR POSSIBLE TUNING. (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 I450DG = 1 = DISPOSABLE GRIDS ARE TO BE WRITTEN TO UNIT C NOS. KFILOG AND IP22 FOR THE SUBSETTED AREA; C 0 OTHERWISE. WRITING IS ALSO CONTINGENT ON C KFILOG AND IP22 NOT BEING ZERO. (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 IPLANT(J) = EQUIVALENCED TO PLAINT (J=1,4). THIS IS FOR C A FOUR BYTE WORD MACHINE ONLY. (INTERNAL) C IMOD = MODEL NUMBER = 1 FOR SLP. (INTERNAL) C KDATE = DATE/TIME OF DATA NEEDED. (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 NHGT1 = THE LOCATION OF 1000 MB HEIGHT ID IN U150.CN C NHGT5 = THE LOCATION OF 500 MB HEIGHT ID IN U150.CN C RR = FLOAT(MESH)/FLOAT(MESHL) FOR ADJUSTING XPOS( ) C AND YPOS( ) TO DISPLAY GRID. (INTERNAL) C INCDD = INCREMENT TO ADD TO LAMPNO FOR WRITING FORECAST. C 1 2 3 4 5 6 7 X C C NONSYSTEM SUBROUTINES USED C SIZEGR, ADVWND, DATPRS, FORCST, GETFLD, MSHXMS, PAWING, c POSGRD, XMSMSH, GETELE, PAWOTG, SMOTHCM, SMTH25, TRNSFR, c UPDAT, TIMPR C CHARACTER*4 STATE CHARACTER*14 DOTCN CHARACTER*32 PLAIN(ND4),PLAINT CHARACTER*40 TITLE/' '/ CHARACTER*60 RACESS(6) CHARACTER*61 TITLT/' '/ C DIMENSION P(ND2X3),U(ND2X3),V(ND2X3),TERRM(ND2X3), 1 Z10(ND2X3),Z51(ND2X3),G(ND2X3),SINPHI(ND2X3), 2 FD9(ND2X3) DIMENSION ID(4,ND4),IDPARS(15,ND4),JD(4,ND4),JP(3,ND4),ISCALD(ND4) 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),R(25) DIMENSION SMULT(25),SADD(25),ORIGIN(25),CINT(25),MAKEF(25), 1 NPRT(25),NTDL(25) DIMENSION ITABLE(4),KFILRA(6),JTABLE(4,2) DIMENSION IOPTB(8),IOPT(8),JDATE(4),LD(4),LDPARS(15),IPLANT(4) C EQUIVALENCE (PLAINT,IPLANT) C DATA ITABLE/001201005,0,0,0/ DATA JTABLE/001000005,1000,0,0, 1 001000005,500,0,0/ C DATA DOTCN/'lmp_slpfcst.cn'/ DATA IFIRST/0/, 1 LIMIT/1/ DATA CLAT/163./ DATA IMOD/1/ C D WRITE(KFILDO,100) D100 FORMAT(' ') D CALL TIMPR(KFILDO,KFILDO,'START U450 ') C IER=0 IFIRST=IFIRST+1 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) C C COMPUTE IOPT( ) FROM IOPTB( ) SO IOPT( ) REFERS TO C THE SUBSETTED AREA MESH LENGTH MESHL. C IF(IOPTB(1).EQ.0)THEN C DO 105 J=1,8 IOPT(J)=0 105 CONTINUE C ELSE IOPT(1)=IOPTB(1) C IF(MESHB.EQ.MESHL)THEN IOPT(2)=IOPTB(2) IOPT(3)=IOPTB(3) IOPT(4)=IOPTB(4) IOPT(5)=IOPTB(5) ELSE RATIO=FLOAT(MESHB)/MESHL 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. XMISSP=0. XMISSS=0. C NHGT1=0 NHGT5=0 C DO 113 MN=1,NPRED IF(ID(1,MN).EQ.JTABLE(1,1).AND.ID(2,MN).EQ.JTABLE(2,1).AND. 1 ID(3,MN).EQ.0)NHGT1=MN IF(ID(1,MN).EQ.JTABLE(1,2).AND.ID(2,MN).EQ.JTABLE(2,2).AND. 1 ID(3,MN).EQ.0)NHGT5=MN 113 CONTINUE C DO 115 N=1,NPRED C IF(ID(1,N).EQ.ITABLE(1).AND.ID(3,N).EQ.0)THEN C U450 WILL NOT EXECUTE UNLESS SLP ID( , ) WITH TAU = 0 C IS IN THE LIST. THIS IS CONSISTENT WITH U400A, SINCE C U400A WON'T EXECUTE UNLESS THIS IS TRUE AND A SLP C ANALYSIS WOULD NOT HAVE BEEN DONE AND FORECASTS COULD C NOT BE MADE. IF NO TAU IS GT 0, NO FORECAST WILL C BE WRITTEN TO KFILIO BY U150, BUT DISPOSABLE GRIDS C CAN BE WRITTEN. 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 115 CONTINUE C WRITE(KFILDO,116) 116 FORMAT(/' ****SEA LEVEL PRESSURE ID NOT IN VARIABLE LIST.', 1 ' U450 WILL NOT BE EXECUTED.') GO TO 600 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,STATUS='OLD', 1 IOSTAT=IOS,ERR=900) C C READ AND WRITE FORECAST SPECIFIC CONTROL PARAMETERS. C STATE='122 ' C READ(KFILDI,122,IOSTAT=IOS,ERR=900)NPROJH,C405F, 1 C55HCF,C55AF,C00AF,C163GF,IBACKN,IBACKL,TITLE(1:16), 2 MESH,ITRPLQ,N50SM,N00SM,CFILT,I450DG 122 FORMAT(I4,5F4.0,2I4,1X,A16,4I4,F4.0,I4) WRITE(KFILDO,1220)TITLE(1:16),(JDATE(J),J=1,4) 1220 FORMAT(/' STARTING FORECAST FOR ',A16,' FOR DATE/TIME ', 1 I5,2I3,I3.2,'00.', 2 ' $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$') NPROJH=MIN(NPROJH,25) C NPROJH IS LIMITED TO 25 BY DIMENSION OF VARIABLES. C IF(IFIRST.LE.LIMIT)WRITE(KFILDO,123)(ITABLE(J),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,C405F,C55HCF, 1 C55AF,C00AF,C163GF,IBACKN,IBACKL,TITLE(1:16), 2 MESH,ITRPLQ,N50SM,N00SM,CFILT,I450DG 124 FORMAT(/' NPROJH C405F C55HCF C55AF', 1 ' C00AF C163GF IBACKN IBACKL TITLE ', 2 ' MESH ITRPLQ N50SM N00SM CFILT I450DG'/ 3 I8,F9.3,F7.3,2F7.3,F8.3,I7,I9,5X,A16,I3,3I7,F9.3,I6) C C READ SMOOTHING PARAMETER TO USE FOR EACH PROJECTION. C STATE='160 ' C READ(KFILDI,140,IOSTAT=IOS,ERR=900)(B(J),J=1,NPROJH) 140 FORMAT(25F4.0) C IF(IFIRST.LE.LIMIT)THEN WRITE(KFILDO,161)NPROJH,(B(J),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 ' C READ(KFILDI,140,IOSTAT=IOS,ERR=900)(R(J),J=1,NPROJH) C IF(IFIRST.LE.LIMIT)THEN WRITE(KFILDO,171)NPROJH,(R(J),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),J=1,NPROJH) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,201)NPROJH,(SMULT(J),J=1,NPROJH) 201 FORMAT(' SMULT FOR ',I3,' PROJECTIONS'/5X,25F5.0) C C READ ADDITIVE FACTOR FOR GRIDPRINTING. C STATE='210' READ(KFILDI,140,IOSTAT=IOS,ERR=900)(SADD(J),J=1,NPROJH) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,211)NPROJH,(SADD(J),J=1,NPROJH) 211 FORMAT(' SADD FOR ',I3,' PROJECTIONS'/5X,25F5.0) C C READ ORIGIN FOR GRIDPRINTING. C STATE='220 ' READ(KFILDI,140,IOSTAT=IOS,ERR=900)(ORIGIN(J),J=1,NPROJH) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,221)NPROJH,(ORIGIN(J),J=1,NPROJH) 221 FORMAT(' ORIGIN FOR ',I3,' PROJECTIONS'/5X,25F5.0) C C READ CONTOURING INTERVAL FOR GRIDPRINTING. C STATE='230 ' READ(KFILDI,140,IOSTAT=IOS,ERR=900)(CINT(J),J=1,NPROJH) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,231)NPROJH,(CINT(J),J=1,NPROJH) 231 FORMAT(' CINT FOR ',I3,' PROJECTIONS'/5X,25F5.0) C C READ PROJECTIONS TO MAKE FORECASTS FOR. C STATE='235 ' READ(KFILDI,235,IOSTAT=IOS,ERR=900)(MAKEF(J),J=1,NPROJH) 235 FORMAT(25I4) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,236)NPROJH,(MAKEF(J),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),J=1,NPROJH) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,241)NPROJH,(NPRT(J),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),J=1,NPROJH) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,261)NPROJH,(NTDL(J),J=1,NPROJH) 261 FORMAT(' NTDL FOR ',I3,' PROJECTIONS'/5X,25I5) C CLOSE(UNIT=KFILDI) C C VERIFY THAT MESH IS A LEGITIMATE VALUE IN RANGE 1 TO 320. C 278 IF(MESH.GT.320.OR.MESH.LT.1)THEN WRITE(KFILDO,279)MESH 279 FORMAT(/' ****MESH =',I6,' NOT IN RANGE 1 TO 320.', 1 ' STOP IN U450 AT 279.') STOP 279 ENDIF C MESHS=MESH C C GET THE ELEVATIONS IN TERRM( ). 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 I450DG NE 0 AND KFILOG NE 0, THE ELEVATIONS WILL BE C WRITTEN TO UNIT KFILOG. WHEN I450DG NE O AND IP22 NE 0, C THE ELEVATIONS WILL BE WRITTEN FOR GRIDPRINTING TO UNIT IP22. C LD(1)=409020000 LD(2)=0 LD(3)=0 LD(4)=0 C CALL GETELE(KFILDO,KFILOG,KFILRA,RACESS,NUMRA,I450DG,LD, 1 IP16,IP22, 2 TERRM,FD9,ND2X3, 3 IPACK,DATA,IWORK,ND5, 4 LAMPNO,NDATE, 5 ALATL,ALONL,NPROJ,ORIENT,XLAT, 6 NXL,NYL,NXPL,NYPL,MESHB,MESHL,IOPT,ITRPLQ, 7 NX,NY,NXP,NYP,MESH, 8 IS0,IS1,IS2,IS4,ND7, 9 JTOTBY,JTOTRC, A L3264B,L3264W,MINPK,ISTOP,IER) IF(IER.NE.0)GO TO 600 C C AT THIS POINT THE ELEVATIONS IN METERS ARE IN TERRM( ) C WITH RETURNED DIMENSIONS NX, NY AND MESH LENGTH MESH. C SMOOTH OVER 25 POINTS ON A 1/4-BEDIENT GRID THREE TIMES. C NOTE THAT THESE ARE NOT WRITTEN TO INTERNAL STORAGE. C CALL SIZEGR(KFILDO,TERRM,NX,NY,NXP,NYP, 1 MESH,MESHB,1,ND2X3) C MESH IS NOW THE SAME AS MESHB. C SMOOTH TERRAIN OVER 25 POINTS. THE RESULT IS IN TERRM( , ); C FD9( , ) IS USED AS A WORK ARRAY. C CALL SMTH25(KFILDO,TERRM,FD9,NX,NY) CALL SMTH25(KFILDO,TERRM,FD9,NX,NY) CALL SMTH25(KFILDO,TERRM,FD9,NX,NY) C NOTE SECOND AND THIRD SMOOTHING OF THE TERRAIN. THE C ORIGINAL MODEL SMOOTHED ONLY ONCE. C C INTERPOLATE BIQUADRATICALLY TO LAMP GRID OF MESH LENGTH C MESH IF NECESSARY. THE NX, NY, NXP, AND NYP ARE C ADJUSTED ACCORDINGLY. C CALL SIZEGR(KFILDO,TERRM,NX,NY,NXP,NYP, 1 MESH,MESHS,2,ND2X3) C MESHS IS THE GRID MESH BEING USED ON THIS RUN. C C ELIMINATE VERY SMALL VALUES OVER THE OCEAN CREATED BY C THE INTERPOLATION USED TO GET HEIGHTS FROM NCEP. C DO 355 J=1,NX*NY IF(TERRM(J).LT.5.)TERRM(J)=-.001 355 CONTINUE C C TDLPACK (WHEN KFILDO NE 0) AND GRIDPRINT (WHEN IP22 NE 0) C THE SMOOTHED TERRAIN HEIGHT, PROVIDED I450DG NE 0. C IF(I450DG.NE.0.AND.(KFILOG.GT.0.OR.IP22.GT.0))THEN C NXG=NX NYG=NY NXPG=NXP NYPG=NYP MESHG=MESH C NXG, ETC. ARE NECESSARY BECAUSE SIZEGR CHANGE THEM, AND C NX, ETC. MUST BE RETAINED. CALL TRNSFR(TERRM,FD9,NX*NY) CALL SIZEGR(KFILDO,FD9,NXG,NYG,NXPG,NYPG, 1 MESHG,MESHL,ITRPLQ,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)='TERRAIN HEIGHT SMOOTHED IN M FOR SLP ' CALL PRTGR(IP22,FD9,NXG,NYG, 1 100.,0.,1.,0.,IOPT,TITLT,IER) C CONTOUR AT 100 M INTERVALS. C IF(IER.NE.0)THEN ISTOP=ISTOP+1 WRITE(KFILDO,356) 356 FORMAT(' ****ERROR IN GRDPRT') C ERROR GRIDPRINTING NOT COUNTED AS FATAL. ENDIF C ENDIF C IF(KFILOG.NE.0)THEN LD(1)=409020000+LAMPNO LD(2)=0 LD(3)=0 LD(4)=060 C THE SMOOTHING VALUE OF 6 IS USED TO INDICATE SMOOTHING C OVER 25 POINTS. NOTE THAT THIS IS SMOOTHED 3 TIMES. ISCAL=0 C PACKING TO METERS. PLAINT='TERRAIN HEIGHT SMOOTHED FOR SLP ' C C THE GRID IN FD9( ) IS ALWAYS AT MESH LENGTH MESHL 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 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. CALL CUT(KFILDO,FD9,NXG,NYG,NXPG,NYPG, 1 FD9,NXD,NYD,NXPD,NYPD) CALL MSHXMS(KFILDO,MESHL,XMESHN,XMESHL) C SUBROUTINE MSHXMS COMPUTES XMESHL FROM MESHL. CALL IJLLPS(1.,1.,XMESHL,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 GEMPAK. ALATD=NINT(ALATD*1000)/1000. ALOND=NINT(ALOND*1000)/1000. CALL PAWOTG(KFILDO,KFILOG,IP16,NDATE, 1 LD,ITAUH,ITAUM,LAMPNO,NSEQ,ISCAL, 2 NPROJ,ALATD,ALOND,ORIENT,MESHL,XLAT,NXD,NYD, 3 FD9,DATA,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 C NOW REDUCE THE HIGH HEIGHTS WITH THE LOGARITHMIC C FUNCTION DESCRIBED IN NOAA TECH MEMO NWS TDL 70. THIS C IS MAINLY FOR THE DEVELOPMENT TERM IN THE CONSERVATIVE C QUANTITY. IT WON'T HAVE MUCH AFFECT ON THE WINDS, C BECAUSE THEY ARE IN TERMS OF DIFFERENCES ACROSS ONLY TWO C GRIDPOINTS. C C*** DO 3561 JY=1,10 C*** WRITE(KFILDO,3560)(TERRM(IX),IX=(JY-1)*NX+1,(JY-1)*NX+10) C*** 3560 FORMAT(/' TERRM IN U450 AT 3560'10F10.4) C*** 3561 CONTINUE C DO 360 J=1,NX*NY IF(TERRM(J).LT.1250.)GO TO 360 TERRM(J)=500.*LOG(.02*TERRM(J)-4.91)-250. 360 CONTINUE C C TDLPACK (WHEN KFILDO NE 0) AND GRIDPRINT (WHEN IP22 NE 0) C THE TERRAIN AFTER HIGH HEIGHT REDUCTION, C PROVIDED I450DG NE 0. C IF(I450DG.NE.0.AND.(KFILOG.GT.0.OR.IP22.GT.0))THEN C NXG=NX NYG=NY NXPG=NXP NYPG=NYP MESHG=MESH C NXG, ETC. ARE NECESSARY BECAUSE SIZEGR CHANGE THEM, AND C NX, ETC. MUST BE RETAINED. CALL TRNSFR(TERRM,FD9,NX*NY) CALL SIZEGR(KFILDO,FD9,NXG,NYG,NXPG,NYPG, 1 MESHG,MESHL,ITRPLQ,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)='TERRAIN TERM AFTER HGT REDUCTION FOR SLP' CALL PRTGR(IP22,FD9,NXG,NYG, 1 100.,0.,1.,0.,IOPT,TITLT,IER) C CONTOUR AT 100 M INTERVALS. C IF(IER.NE.0)THEN ISTOP=ISTOP+1 WRITE(KFILDO,356) C ERROR GRIDPRINTING NOT COUNTED AS FATAL. ENDIF C ENDIF C IF(KFILOG.NE.0)THEN LD(1)=409021000+LAMPNO LD(2)=0 LD(3)=0 LD(4)=0 ISCAL=0 C PACKING TO METERS. PLAINT='TERRAIN AFTER HGT REDUCTION, SLP' C C THE GRID IN FD9( ) IS ALWAYS AT MESH LENGTH MESHL 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 CALL CUT(KFILDO,FD9,NXG,NYG,NXPG,NYPG, 1 FD9,NXD,NYD,NXPD,NYPD) CALL MSHXMS(KFILDO,MESHL,XMESHN,XMESHL) C SUBROUTINE MSHXMS COMPUTES XMESHL FROM MESHL. CALL IJLLPS(1.,1.,XMESHL,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 GEMPAK. ALATD=NINT(ALATD*1000)/1000. ALOND=NINT(ALOND*1000)/1000. CALL PAWOTG(KFILDO,KFILOG,IP16,NDATE, 1 LD,ITAUH,ITAUM,LAMPNO,NSEQ,ISCAL, 2 NPROJ,ALATD,ALOND,ORIENT,MESHL,XLAT,NXD,NYD, 3 FD9,DATA,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 C COMPUTE THE TERRAIN TERM TERRM( ) FOR INSERTION INTO C THE CONSERVATIVE QUANTITY, AFTER MODIFICATION BY C405F. C DO 365 J=1,NX*NY C C THE BELOW EQUATION CONVERTS TERRAIN HT. IN M. TO SURFACE C PRESSURE IN MB. C C PP=1013.25-TERRM(J)*.12015 C C THE BELOW EQUATION APPLIES THE .405 TERM AND SUBTRACTS C 1013.25 TO MAKE VALUES OVER THE OCEANS ZERO. NOTE THAT C THE "LEVEL" OF THE TERRM( ) TERM DOES NOT MATTER; ALL C POINTS CAN CHANGED BY A CONSTANT AMOUNT BECAUSE IT IS C ONLY SPATIAL DIFFERENCES THAT ARE IMPORTANT IN BOTH THE C "DEVELOPMENT" TERM AND THE WIND COMPUTATIONS. C C TERRM(J)=.405*(PP-1013.25) C C SINCE 1013.25 APPEARS IN BOTH EQUATIONS, IT IS OMITTED C IN THE COMPUTATIONS BELOW. NOTE THAT THE MORE EXACT C EQUATION FOR COMPUTING SURFACE PRESSURE USED IN THE C SLYH MODEL: C C PP=AP*(AT/(AT-ALR*TERRM(J)))**POW C C IS NOT USED TO BE COMPATIBLE WITH PRIOR FORMULATION C OF THIS REED SLP MODEL. C PP=-TERRM(J)*.12015 TERRM(J)=.405*PP 365 CONTINUE C C COMPUTE ALL ADVECTIVE WINDS AND STORE IN MOS-2000 INTERNAL C RANDOM ACCESS FILE. TERRM( ) AT THIS POINT IS APPROPRIATE C FOR COMPUTING WINDS. WIND FIELDS WILL NOT CONTAIN C MISSING VALUES. C CALL ADVWND(KFILDO,KFIL10,KFILOG,IP16,IP22,IMOD,I450DG, 1 NDATE,IBACKN,Z10,Z51,U,V,TERRM,SINPHI,FD9,ND2X3, 2 NCEPNO,LAMPNO,NPROJ,ORIENT,XLAT,C55AF,C00AF, 3 NXL,NYL,NXPL,NYPL,ALATL,ALONL, 4 MESHB,MESHL,CFILT,IOPT, 5 NX,NY,NXP,NYP,MESH,ITRPLQ,NPROJH,N50SM,N00SM, 6 LSTORE,ND9,LITEMS, 7 IS0,IS1,IS2,IS4,ND7, 8 DATA,IPACK,IWORK,ND5,MINPK, 9 CORE,ND10,NBLOCK,NFETCH,MISTOT, A JTOTBY,JTOTRC, B L3264B,L3264W,ISTOP,IER) IF(IER.NE.0)GO TO 600 C C ADJUST TERRM( ) FOR USE IN THE CONSERVATIVE QUANTITY, C BY MULTIPLING BY C405F. NOTE THAT C405F DOES NOT APPLY C TO THE COMPUTATION OF WINDS IN ADVWND. C DO 366 J=1,NX*NY TERRM(J)=C405F*TERRM(J) 366 CONTINUE C C TDLPACK (WHEN KFILDO NE 0) AND GRIDPRINT (WHEN IP22 NE 0) C THE TERRAIN TERM AS IT GOES INTO THE CONSERVATIVE QUANTITY, C PROVIDED I450DG NE 0. C IF(I450DG.NE.0.AND.(KFILOG.GT.0.OR.IP22.GT.0))THEN C NXG=NX NYG=NY NXPG=NXP NYPG=NYP MESHG=MESH C NXG, ETC. ARE NECESSARY BECAUSE SIZEGR CHANGE THEM, AND C NX, ETC. MUST BE RETAINED. CALL TRNSFR(TERRM,FD9,NX*NY) CALL SIZEGR(KFILDO,FD9,NXG,NYG,NXPG,NYPG, 1 MESHG,MESHL,ITRPLQ,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)='TERRAIN TERM FOR CONSERVATIVE QUANT IN M ' CALL PRTGR(IP22,FD9,NXG,NYG, 1 10.,0.,1.,0.,IOPT,TITLT,IER) C CONTOUR AT 10 M INTERVALS. C IF(IER.NE.0)THEN ISTOP=ISTOP+1 WRITE(KFILDO,356) C ERROR GRIDPRINTING NOT COUNTED AS FATAL. ENDIF C ENDIF C IF(KFILOG.NE.0)THEN LD(1)=409022000+LAMPNO LD(2)=0 LD(3)=0 LD(4)=0 ISCAL=1 C PACKING TO TENTHS OF METERS. PLAINT='TERRAIN IN CONSERVATIVE QUANTITY' C C THE GRID IN FD9( ) IS ALWAYS AT MESH LENGTH MESHL 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 CALL CUT(KFILDO,FD9,NXG,NYG,NXPG,NYPG, 1 FD9,NXD,NYD,NXPD,NYPD) CALL MSHXMS(KFILDO,MESHL,XMESHN,XMESHL) C SUBROUTINE MSHXMS COMPUTES XMESHL FROM MESHL. CALL IJLLPS(1.,1.,XMESHL,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 GEMPAK. ALATD=NINT(ALATD*1000)/1000. ALOND=NINT(ALOND*1000)/1000. CALL PAWOTG(KFILDO,KFILOG,IP16,NDATE, 1 LD,ITAUH,ITAUM,LAMPNO,NSEQ,ISCAL, 2 NPROJ,ALATD,ALOND,ORIENT,MESHL,XLAT,NXD,NYD, 3 FD9,DATA,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 C USE 500-MB HEIGHTS IN Z51( ), SLP ANALYSIS IN Z(10) FOR C PROJECTION 0, TERRM( ), AND G( ) TO COMPUTE C CONSERVATIVE QUANTITY IN FD9( , ). C C GET LAMP SEA LEVEL PRESSURE ANALYSIS IN Z10( ) TO USE IN C COMPUTING 1000 MB HEIGHT. NOTE THAT A PREVIOUS DATE C MAY BE USED, ALWAYS AT PROJECTION 0. C DO 367 KCYCLE=0,IBACKL C IBACKL = 1 MEANS IT WILL LOOK BACK ONE CYCLE. NORMALLY, C THIS WOULD BE 0, ELSE AN IBACKL-HOUR OLD ANALYSIS WILL C BE USED FOR INITIALIZATION WITH NO ADJUSTMENT FOR C PROJECTIONS. CALL UPDAT(NDATE,-KCYCLE,KDATE) LD(1)=001201000+LAMPNO LD(2)=0 LD(3)=0 LD(4)=0 CALL PRSID1(KFILDO,LD,LDPARS) CALL GETFLD(KFILDO,KFIL10,LD,KDATE, 1 Z10,FD9,ND2X3, 2 NCEPNO,LAMPNO,NPROJ,ORIENT,XLAT, 3 NXL,NYL,NXPL,NYPL,ALATL,ALONL,MESHB, 4 NX,NY,MESH,ITRPLQ, 5 LSTORE,LITEMS,ND9, 6 IS0,IS1,IS2,IS4,ND7, 7 IPACK,IWORK,ND5, 8 CORE,ND10,NBLOCK,NFETCH,MISTOT,NSLAB, 9 L3264B,IER) IF(IER.EQ.0)GO TO 369 367 CONTINUE C C DROP THROUGH MEANS THE SEA LEVEL PRESSURE ANALYSIS COULD NOT C BE FOUND. C WRITE(KFILDO,368) 368 FORMAT(' ****FATAL ERROR IN U450. CANNOT OBTAIN SLP', 1 ' ANALYSIS.') GO TO 600 C 369 F=1./.12015 C F IS THE CONVERSION FACTOR FOR MB TO M. C C CONVERT SLP IN Z10( , ) IN MB TO 1000-MB HEIGHT IN C Z10( , ) IN M AT .12015 MB/M. C DO 370 J=1,NX*NY Z10(J)=(Z10(J)-1000.)*F 370 CONTINUE C IF(NHGT1.NE.0)THEN C C SETTING THE LD() ARRAY FOR PACKING OF 1000 MB HEIGHTS. C LD(1)=ID(1,NHGT1) LD(2)=ID(2,NHGT1) LD(3)=0 LD(4)=0 C C PACKING THE INTIAL 1000 MB HEIGHTS TO INTERNAL STORAGE. C WHEN NHGT1 EQUALS 0 THERE IS NO ID FOR 1000 MB HEIGHTS C IN THE U150.CN FILE C CALL PAWING(KFILDO,KFIL10,NDATE, 1 LD,LP,ITAUM,LAMPNO,NSEQ,ISCALD(NHGT1), 2 NPROJ,ALATL,ALONL,ORIENT,MESHB,MESH,XLAT,NX,NY, 3 Z10,DATA,IWORK,IPACK,ND5,MINPK, 4 LSTORE,ND9,LITEMS,CORE,ND10,NBLOCK, 5 IS0,IS1,IS2,IS4,ND7, 6 IPLAIN(1,1,NHGT1),PLAIN(NHGT1),NCHAR, 7 XMISSP,XMISSS,LX,IOCTET, 8 L3264B,L3264W,IER) IF(IER.NE.0)GO TO 600 ELSE WRITE(KFILDO,371) 371 FORMAT(/' ****THE 1000 MB HEIGHT ID IS NOT IN THE', 1 ' VARIABLE LIST AND USUALLY IS WHEN RUNNING U450.'/ 2 ' U450 WILL NOT BE EXECUTED FOR THIS VARIABLE,', 3 ' BUT WILL CONTINUE FOR SLP FORECAST.') C ENDIF C C TDLPACK (WHEN KFILDO NE 0) AND GRIDPRINT (WHEN IP22 NE 0) C THE INITIAL 1000 MB HEIGHT, PROVIDED I450DG NE 0. C IF(I450DG.NE.0.AND.(KFILOG.GT.0.OR.IP22.GT.0))THEN C NXG=NX NYG=NY NXPG=NXP NYPG=NYP MESHG=MESH C NXG, ETC. ARE NECESSARY BECAUSE SIZEGR CHANGE THEM, AND C NX, ETC. MUST BE RETAINED. CALL TRNSFR(Z10,FD9,NX*NY) CALL SIZEGR(KFILDO,FD9,NXG,NYG,NXPG,NYPG, 1 MESHG,MESHL,ITRPLQ,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)='INITIAL 1000-MB HEIGHT ' CALL PRTGR(IP22,FD9,NXG,NYG, 1 30.,0.,1.,0.,IOPT,TITLT,IER) C CONTOUR AT 30 M INTERVALS. C IF(IER.NE.0)THEN ISTOP=ISTOP+1 WRITE(KFILDO,356) C ERROR GRIDPRINTING NOT COUNTED AS FATAL. ENDIF C ENDIF IF(KFILOG.NE.0)THEN LD(1)=001000000+LAMPNO LD(2)=1000 LD(3)=0 LD(4)=0 ISCAL=1 C PACKING TO TENTHS OF METERS. PLAINT='INITIAL 1000-MB HEIGHT IN M ' C C THE GRID IN FD9( ) IS ALWAYS AT MESH LENGTH MESHL 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 FOR METERS; AT .12 MB PER M, C THIS IS CONSISTENT WITH SCALING OF SLP TO TENTHS OF MB. C CALL CUT(KFILDO,FD9,NXG,NYG,NXPG,NYPG, 1 FD9,NXD,NYD,NXPD,NYPD) CALL MSHXMS(KFILDO,MESHL,XMESHN,XMESHL) C SUBROUTINE MSHXMS COMPUTES XMESHL FROM MESHL. CALL IJLLPS(1.,1.,XMESHL,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 GEMPAK. ALATD=NINT(ALATD*1000)/1000. ALOND=NINT(ALOND*1000)/1000. CALL PAWOTG(KFILDO,KFILOG,IP16,NDATE, 1 LD,ITAUH,ITAUM,LAMPNO,NSEQ,ISCAL, 2 NPROJ,ALATD,ALOND,ORIENT,MESHL,XLAT,NXD,NYD, 3 FD9,DATA,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 CALL MSHXMS(KFILDO,MESH,XMESHN,XMESH) C XMESH IS THE TRUE MESH LENGTH FOR THE NOMINAL MESH LENGTH MESH. PTOEQS=(11887.2/XMESH)**2 C PTOEQS IS THE POLE TO EQUATOR DISTANCE ON A POLAR C STEREOGRAPHIC MAP PROJECTION IN GRID UNITS SQUARED. C C CALCULATE SINPHI. C CALL SINP(KFILDO,SINPHI,NX,NY,FLOAT(NXP),FLOAT(NYP),PTOEQS) C C CALCULATE THE LATITUDE TERM G( ), INCLUDING CLAT. C DO 380 J=1,NX*NY G(J)=C163GF*CLAT*SINPHI(J)**2 380 CONTINUE C C TDLPACK (WHEN KFILDO NE 0) AND GRIDPRINT (WHEN IP22 NE 0) C THE TERM G, PROVIDED I450DG NE 0. C IF(I450DG.NE.0.AND.(KFILOG.GT.0.OR.IP22.GT.0))THEN C NXG=NX NYG=NY NXPG=NXP NYPG=NYP MESHG=MESH C NXG, ETC. ARE NECESSARY BECAUSE SIZEGR CHANGE THEM, AND C NX, ETC. MUST BE RETAINED. CALL TRNSFR(G,FD9,NX*NY) CALL SIZEGR(KFILDO,FD9,NXG,NYG,NXPG,NYPG, 1 MESHG,MESHL,ITRPLQ,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)='CONSTANT TERM G IN M ' CALL PRTGR(IP22,FD9,NXG,NYG, 1 10.,0.,1.,0.,IOPT,TITLT,IER) C CONTOUR AT 10 M INTERVALS. C IF(IER.NE.0)THEN ISTOP=ISTOP+1 WRITE(KFILDO,356) C ERROR GRIDPRINTING NOT COUNTED AS FATAL. ENDIF C ENDIF C IF(KFILOG.NE.0)THEN LD(1)=409120000+LAMPNO LD(2)=0 LD(3)=0 LD(4)=0 ISCAL=1 C PACKING TO TENTHS OF METERS. PLAINT='CONSTANT TERM G ' C C THE GRID IN FD9( ) IS ALWAYS AT MESH LENGTH MESHL 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 = 1 FOR TENTHS OF METERS. C CALL CUT(KFILDO,FD9,NXG,NYG,NXPG,NYPG, 1 FD9,NXD,NYD,NXPD,NYPD) CALL MSHXMS(KFILDO,MESHL,XMESHN,XMESHL) C SUBROUTINE MSHXMS COMPUTES XMESHL FROM MESHL. CALL IJLLPS(1.,1.,XMESHL,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 GEMPAK. ALATD=NINT(ALATD*1000)/1000. ALOND=NINT(ALOND*1000)/1000. CALL PAWOTG(KFILDO,KFILOG,IP16,NDATE, 1 LD,ITAUH,ITAUM,LAMPNO,NSEQ,ISCAL, 2 NPROJ,ALATD,ALOND,ORIENT,MESHL,XLAT,NXD,NYD, 3 FD9,DATA,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 C GET INITIAL 500-MB HEIGHT IN Z51( ) TO USE IN COMPUTING C CONSERVATIVE QUANTITY. C KDATE=NDATE C DO 387 KCYCLE=0,IBACKN C IBACKN = 1 MEANS IT WILL LOOK BACK ONE CYCLE. CALL UPDAT(NDATE,-KCYCLE*6,KDATE) C THIS ASSUMES AN NCEP RUN EACH 6 HOURS. NHR=KDATE-(KDATE/100)*100 MDATE=KDATE-MOD(NHR,6) LD(1)=001000000+NCEPNO LD(2)=500 LD(3)=MOD(NHR,6)+KCYCLE*6 LD(4)=0 CALL PRSID1(KFILDO,LD,LDPARS) CALL GETFLD(KFILDO,KFIL10,LD,MDATE, 1 Z51,FD9,ND2X3, 2 NCEPNO,LAMPNO,NPROJ,ORIENT,XLAT, 3 NXL,NYL,NXPL,NYPL,ALATL,ALONL,MESHB, 4 NX,NY,MESH,ITRPLQ, 5 LSTORE,LITEMS,ND9, 6 IS0,IS1,IS2,IS4,ND7, 7 IPACK,IWORK,ND5, 8 CORE,ND10,NBLOCK,NFETCH,MISTOT,NSLAB, 9 L3264B,IER) IF(IER.EQ.0)GO TO 389 387 CONTINUE C C DROP THROUGH MEANS THE 500-MB HEIGHTS COULD NOT BE FOUND. C WRITE(KFILDO,388)MDATE,LD(3) 388 FORMAT(' ****FATAL ERROR IN U452. CANNOT OBTAIN 500-MB', 1 ' HEIGHT FOR DATE/TIME',I10,' PROJECTION',I3,'.') GO TO 600 C C COMPUTE CONSERVATIVE QUANTITY IN FD9( ). FD9( ) MUST REMAIN C INTACT IN THE DO 390 LOOP BELOW. C 389 DO 390 J=1,NX*NY FD9(J)=Z10(J) -Z51(J)*.55*C55HCF +TERRM(J) -G(J) 390 CONTINUE C IF(NHGT5.NE.0)THEN C C SETTING THE LD() ARRAY FOR PACKING OF 500 MB HEIGHTS. C LD(1)=ID(1,NHGT5) LD(2)=ID(2,NHGT5) LD(3)=0 LD(4)=0 C C PACKING THE INTIAL 500 MB HEIGHTS TO INTERNAL STORAGE. C THE UNSMOOTHED 500 MB HEIGHTS ARE PUT INTO Z51 VIA LOOP 387 C WHEN NHGT5 EQUALS 0 THERE IS NO ID IN THE U150.CN FILE C CALL PAWING(KFILDO,KFIL10,NDATE, 1 LD,LP,ITAUM,LAMPNO,NSEQ,ISCALD(NHGT5), 2 NPROJ,ALATL,ALONL,ORIENT,MESHB,MESH,XLAT,NX,NY, 3 Z51,DATA,IWORK,IPACK,ND5,MINPK, 4 LSTORE,ND9,LITEMS,CORE,ND10,NBLOCK, 5 IS0,IS1,IS2,IS4,ND7, 6 IPLAIN(1,1,NHGT5),PLAIN(NHGT5),NCHAR, 7 XMISSP,XMISSS,LX,IOCTET, 8 L3264B,L3264W,IER) IF(IER.NE.0)GO TO 600 ELSE WRITE(KFILDO,391) 391 FORMAT(/' ****THE 500 MB HEIGHT ID IS NOT IN THE', 1 ' VARIABLE LIST AND USUALLY IS WHEN RUNNING U450.'/ 2 ' U450 WILL NOT BE EXECUTED FOR THIS VARIABLE,', 3 ' BUT WILL CONTINUE FOR SLP FORECAST.') C C ENDIF C C C TDLPACK (WHEN KFILDO NE 0) AND GRIDPRINT (WHEN IP22 NE 0) C THE FULL CONSERVATIVE QUANTITY IN FD9( ), PROVIDED C I450DG NE 0. C IF(I450DG.NE.0.AND.(KFILOG.GT.0.OR.IP22.GT.0))THEN C NXG=NX NYG=NY NXPG=NXP NYPG=NYP MESHG=MESH C NXG, ETC. ARE NECESSARY BECAUSE SIZEGR CHANGE THEM, AND C NX, ETC. MUST BE RETAINED. CALL TRNSFR(FD9,P,NX*NY) C ARRAY P( ) AVAILABLE FOR USE HERE AS A WORK ARRAY. CALL SIZEGR(KFILDO,P,NXG,NYG,NXPG,NYPG, 1 MESHG,MESHL,ITRPLQ,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)='FULL CONSERVATIVE QUANTITY IN M ' CALL PRTGR(IP22,P,NXG,NYG, 1 25.,0.,1.,0.,IOPT,TITLT,IER) C CONTOUR AT 25 M INTERVALS. C IF(IER.NE.0)THEN ISTOP=ISTOP+1 WRITE(KFILDO,356) C ERROR GRIDPRINTING NOT COUNTED AS FATAL. ENDIF C ENDIF C IF(KFILOG.NE.0)THEN LD(1)=409220000+LAMPNO LD(2)=0 LD(3)=0 LD(4)=0 ISCAL=1 C PACKING TO TENTHS OF METERS. PLAINT='FULL CONSERVATIVE QUANTITY IN M' C C THE GRID IN P( ) IS ALWAYS AT MESH LENGTH MESHL 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 = 1 FOR TENTHS OF METERS. C CALL CUT(KFILDO,P,NXG,NYG,NXPG,NYPG, 1 P,NXD,NYD,NXPD,NYPD) CALL MSHXMS(KFILDO,MESHL,XMESHN,XMESHL) C SUBROUTINE MSHXMS COMPUTES XMESHL FROM MESHL. CALL IJLLPS(1.,1.,XMESHL,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 GEMPAK. ALATD=NINT(ALATD*1000)/1000. ALOND=NINT(ALOND*1000)/1000. CALL PAWOTG(KFILDO,KFILOG,IP16,NDATE, 1 LD,ITAUH,ITAUM,LAMPNO,NSEQ,ISCAL, 2 NPROJ,ALATD,ALOND,ORIENT,MESHL,XLAT,NXD,NYD, 3 P,DATA,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 C COMPUTE THE NPROJH FORECASTS IN HOURLY STEPS. THE TRAJECTORY C ALWAYS GOES BACK TO THE BEGINNING, SO THE CONSERVATIVE C QUANTITY CAN BE COMPUTED ONCE PRIOR TO THE LOOP. TERRM( ) C AND SINPHI( ) ARE NO LONGER NEEDED AND ARE USED AS WORK C ARRAYS IN FORCST. C DO 400 LP=1,NPROJH IF(MAKEF(LP).EQ.0)GO TO 400 C ONLY MAKE FORECASTS WHEN MAKEF( ) NE 0. CALL FORCST(KFILDO,KFIL10,NDATE,LP,IMOD, 1 P,U,V,DATA,SINPHI,ND2X3, 2 NCEPNO,LAMPNO,NPROJ,ORIENT,XLAT, 3 NXL,NYL,NXPL,NYPL,ALATL,ALONL,MESHB, 4 NX,NY,MESH,ITRPLQ, 5 LSTORE,ND9,LITEMS, 6 IS0,IS1,IS2,IS4,ND7, 7 IPACK,IWORK,ND5, 8 CORE,ND10,NBLOCK,NFETCH,MISTOT, 9 L3264B,IER) C XPOS AND YPOS ARE RETURNED IN DATA AND SINPHI, RESPECTIVELY. C THEY CAN BE OUTSIDE THE GRID BY AT MOST ONE GRIDLENGTH, AND C WILL NOT BE MISSING (=9999.). IF(IER.NE.0)THEN WRITE(KFILDO,395)LP 395 FORMAT(' CANNOT COMPUTE TRAJECTORIES IN U450 FOR', 1 ' PROJECTION',I4,'.') C THIS DIAGNOSTIC FOLLOWS ONE IN FORCST. GO TO 600 ENDIF C C TDLPACK (WHEN KFILDO NE 0) AND GRIDPRINT (WHEN IP22 NE 0) C THE THE FINAL END POINTS OF THE TRAJECTORIES, PROVIDED C I450DG NE 0. C IF(I450DG.NE.0.AND.(KFILOG.GT.0.OR.IP22.GT.0))THEN C NXG=NX NYG=NY NXPG=NXP NYPG=NYP MESHG=MESH C NXG, ETC. ARE NECESSARY BECAUSE SIZEGR CHANGE THEM, AND C NX, ETC. MUST BE RETAINED. CALL TRNSFR(DATA,P,NX*NY) C DATA( ) FROM FORCST CONTAINS THE XPOS. C ARRAY P( ) AVAILABLE FOR USE HERE AS A WORK ARRAY. C C THE VALUES OF TRAJECTORY END POINTS ARE IN RELATION TO C MESH. THEY MUST BE PUT IN TERMS OF MESHL FOR OUTPUT. C ALSO, THE CONTOUR INTERVAL IN PRTGR MUST BE ADJUSTED. C RR=FLOAT(MESH)/FLOAT(MESHL) C DO 3955 J=1,NX*NY P(J)=(P(J)-1.)*RR+1. 3955 CONTINUE C CALL SIZEGR(KFILDO,P,NXG,NYG,NXPG,NYPG, 1 MESHG,MESHL,ITRPLQ,ND2X3) C THE SAME INTERPOLATION IS USED (IF NEEDED) AS FOR OTHER C USES IN U450. THE TRAJECTORIES CAN BE OUTSIDE THE GRID C BY AT MOST ONE GRIDLENGTH, AND WILL NOT BE MISSING C (=9999.). THEREFORE, SIZEGR, WHICH DOES NOT CONSIDER C MISSING VALUES, WORK OK. C IF(IP22.NE.0)THEN TITLT(1:40)=' -H TRAJECTORY XPOS SLP MODEL ' STATE='396 ' WRITE(TITLT(1:2),396,IOSTAT=IOS,ERR=900)LP 396 FORMAT(I2) CALL PRTGR(IP22,P,NXG,NYG, 1 1.,0.,1.,0.,IOPT,TITLT,IER) C CONTOUR AT 1 GRID UNIT INTERVALS AT 1/B BEDIENT MESH. C IF(IER.NE.0)THEN ISTOP=ISTOP+1 WRITE(KFILDO,356) C ERROR GRIDPRINTING NOT COUNTED AS FATAL. ENDIF C ENDIF C IF(KFILOG.NE.0)THEN LD(1)=004500000+LAMPNO LD(2)=0 LD(3)=LP LD(4)=0 ISCAL=1 C PACKING TO TENTHS OF GRID UNITS. PLAINT=' -H TRAJECTORY XPOS SLP MODEL ' WRITE(PLAINT(1:2),396,IOSTAT=IOS,ERR=900)LP C C THE GRID IN P( ) IS ALWAYS AT MESH LENGTH MESHL 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 = 1 FOR TENTHS OF GRID UNITS. C CALL CUT(KFILDO,P,NXG,NYG,NXPG,NYPG, 1 P,NXD,NYD,NXPD,NYPD) CALL MSHXMS(KFILDO,MESHL,XMESHN,XMESHL) C SUBROUTINE MSHXMS COMPUTES XMESHL FROM MESHL. CALL IJLLPS(1.,1.,XMESHL,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 GEMPAK. 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,MESHL,XLAT,NXD,NYD, 3 P,Z51,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) C Z51( ) IS AVAILABLE FOR WORK ARRAY HERE. 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 C NXG, ETC. ARE NECESSARY BECAUSE SIZEGR CHANGE THEM, AND C NX, ETC. MUST BE RETAINED. C CALL TRNSFR(SINPHI,P,NX*NY) C SINPHI( ) FROM FORCST CONTAINS THE YPOS. C ARRAY P( ) AVAILABLE FOR USE HERE AS A WORK ARRAY. C C THE VALUES OF TRAJECTORY END POINTS ARE IN RELATION TO C MESH. THEY MUST BE PUT IN TERMS OF MESHL FOR OUTPUT. C ALSO, THE CONTOUR INTERVAL IN PRTGR MUST BE ADJUSTED. C DO 3965 J=1,NX*NY P(J)=(P(J)-1.)*RR+1. 3965 CONTINUE C CALL SIZEGR(KFILDO,P,NXG,NYG,NXPG,NYPG, 1 MESHG,MESHL,ITRPLQ,ND2X3) C THE SAME INTERPOLATION IS USED (IF NEEDED) AS FOR OTHER C USES IN U450. THE TRAJECTORIES CAN BE OUTSIDE THE GRID C BY AT MOST ONE GRIDLENGTH, AND WILL NOT BE MISSING C (=9999.). THEREFORE, SIZEGR, WHICH DOES NOT CONSIDER C MISSING VALUES, WORK OK. C IF(IP22.NE.0)THEN C TITLT(1:40)=' -H TRAJECTORY YPOS SLP MODEL ' STATE='3963' WRITE(TITLT(1:2),396,IOSTAT=IOS,ERR=900)LP CALL PRTGR(IP22,P,NXG,NYG, 1 1.,0.,1.,0.,IOPT,TITLT,IER) C CONTOUR AT 1 GRID UNIT INTERVALS AT 1.4 BEDIENT MESH. C IF(IER.NE.0)THEN ISTOP=ISTOP+1 WRITE(KFILDO,356) C ERROR GRIDPRINTING NOT COUNTED AS FATAL. ENDIF C ENDIF C IF(KFILOG.NE.0)THEN LD(1)=004510000+LAMPNO LD(2)=0 LD(3)=LP LD(4)=0 ISCAL=1 C PACKING TO TENTHS OF GRID UNITS. PLAINT=' -H TRAJECTORY YPOS SLP MODEL ' WRITE(PLAINT(1:2),396,IOSTAT=IOS,ERR=900)LP C C THE GRID IN XPOS( ) IS ALWAYS AT MESH LENGTH MESHL 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 = 1 FOR TENTHS OF GRID UNITS. C CALL CUT(KFILDO,P,NXG,NYG,NXPG,NYPG, 1 P,NXD,NYD,NXPD,NYPD) CALL PAWOTG(KFILDO,KFILOG,IP16,NDATE, 1 LD,LP,ITAUM,LAMPNO,NSEQ,ISCAL, 2 NPROJ,ALATD,ALOND,ORIENT,MESHL,XLAT,NXD,NYD, 3 P,Z51,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) C Z51( ) IS AVAILABLE FOR WORK ARRAY HERE. IF(IER.NE.0)ISTOP=ISTOP+1 C ERROR WRITING DISPOSABLE GRIDS NOT COUNTED AS FATAL. ENDIF C ENDIF C C PUT UPSTREAM CONSERVATIVE QUANTITY IN Z10( , ). C INTRQ IS BIQUADRATIC INTERPOLATION. C CALL INTRQ(FD9,Z10,DATA,SINPHI,NX,NY) C INTRQ CAN PRODUCE MISSING VALUES (=9999.); HOWEVER, HERE C THE XPOS( ) AND YPOS( ), WHICH ARE IN DATA( ) AND SINPHI( ), C RESPECTIVELY, ARE AT MOST ONE GRIDLENGTH OUTSIDE THE GRID, C WHICH INTRQ HANDLES AS NON MISSING. C IF(I450DG.NE.0.AND.IP22.NE.0)THEN NXG=NX NYG=NY NXPG=NXP NYPG=NYP MESHG=MESH C NXG, ETC. ARE NECESSARY BECAUSE SIZEGR CHANGE THEM, AND C NX, ETC. MUST BE RETAINED. C CALL TRNSFR(Z10,P,NX*NY) C Z10( ) FROM INTRQ CONTAINS THE CONSERVATIVE QUANTITY. C ARRAY P( ) AVAILABLE FOR USE HERE AS A WORK ARRAY. CALL SIZEGR(KFILDO,P,NXG,NYG,NXPG,NYPG, 1 MESHG,MESHL,ITRPLQ,ND2X3) C THE SAME INTERPOLATION IS USED (IF NEEDED) AS FOR OTHER C USES IN U450. TITLT(1:40)=' -H UPSTREAM CONSERVATIVE QUANTITY IN M' STATE='3965' WRITE(TITLT(1:2),396,IOSTAT=IOS,ERR=900)LP CALL PRTGR(IP22,P,NXG,NYG, 1 25.,0.,1.,0.,IOPT,TITLT,IER) C CONTOUR AT 25 M INTERVALS. C IF(IER.NE.0)THEN ISTOP=ISTOP+1 WRITE(KFILDO,356) C ERROR GRIDPRINTING NOT COUNTED AS FATAL. ENDIF C ENDIF C C GET INITIAL 500-MB HEIGHT IN Z51( ) FOR PROJECTION LP C TO USE IN COMPUTING DOWNSTREAM CONSERVATIVE QUANTITY C AND FINAL FORECAST. NOTE THAT KCYCLE IS STILL DEFINED C FROM ABOVE. C LD(1)=001000000+NCEPNO LD(2)=500 LD(3)=MOD(NHR,6)+KCYCLE*6+LP LD(4)=0 CALL PRSID1(KFILDO,LD,LDPARS) CALL GETFLD(KFILDO,KFIL10,LD,MDATE, 1 Z51,P,ND2X3, 2 NCEPNO,LAMPNO,NPROJ,ORIENT,XLAT, 3 NXL,NYL,NXPL,NYPL,ALATL,ALONL,MESHB, 4 NX,NY,MESH,ITRPLQ, 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,397)LP 397 FORMAT(' ****FATAL ERROR IN U450. CANNOT OBTAIN', 1 ' 500-MB HEIGHT FOR PROJECTION,',I3,'.') GO TO 600 ENDIF C IF(NHGT5.NE.0)THEN C C SETTING THE LD() ARRAY FOR PACKING THE FORECASTED 500 MB HEIGHTS C LD(1)=ID(1,NHGT5) LD(2)=ID(2,NHGT5) LD(3)=LP LD(4)=0 C C PACKING THE 500 FORECASTED 500 MB HEIGHTS TO INTERNAL STORAGE. THIS C WILL PACK ALL FORECASTS LISTED IN THE U450.CN FILE. U150 WILL WRITE C ONLY THE FORECASTS PUT IN THE U150.CN FILE TO THE ARCHIVE GRID. C WHEN NHGT5 EQUALS 0 THERE IS NO ID IN THE U150.CN FILE C CALL PAWING(KFILDO,KFIL10,NDATE, 1 LD,LP,ITAUM,LAMPNO,NSEQ,ISCALD(NHGT5), 2 NPROJ,ALATL,ALONL,ORIENT,MESHB,MESH,XLAT,NX,NY, 3 Z51,DATA,IWORK,IPACK,ND5,MINPK, 4 LSTORE,ND9,LITEMS,CORE,ND10,NBLOCK, 5 IS0,IS1,IS2,IS4,ND7, 6 IPLAIN(1,1,NHGT5),PLAIN(NHGT5),NCHAR, 7 XMISSP,XMISSS,LX,IOCTET, 8 L3264B,L3264W,IER) C IF(IER.NE.0)GOTO 600 C ENDIF C C THE SEA LEVEL PRESSURE FORECAST FOR LP HOURS IS COMPUTED C IN P( , ), WHICH IS A CONVERSION FROM THE 1000-MB HEIGHTS C COMPUTED FROM THE UPSTREAM CONSERVATIVE QUANTITY (INCLUDING C THE INITIAL 1000-MB HEIGHTS) IN Z10( ) AND THE DOWNSTREAM C COMPONENTS IN Z51( ), TERRM( ) AND G( ). TRAJECTORY C ENDPOINTS ARE AT MOST 1 GRIDLENGTH OFF THE GRID, AND C INTRPQ PROVIDES NON MISSING VALUES IN Z10( ). C DO 398 J=1,NX*NY P(J)=(Z10(J)-(-Z51(J)*.55*C55HCF +TERRM(J) 1 -G(J)))*.12015+1000. 398 CONTINUE C C SMOOTH FORECAST IF DESIRED. C IF(B(LP).NE.0.)THEN C DO 3983 LL=1,MIN(LP-1,3) C THIS SMOOTHS A C 1-H FORECAST 0 TIMES, C 2-H FORECAST 1 TIME, C 3-H FORECAST 2 TIMES, AND C OTHERS 3 TIMES. C IPACK( ) MUST NOT BE ZERO FOR A SMOOTHING CORRECTION C TO BE MADE. C DO 3982 J=1,ND5 IPACK(J)=1 3982 CONTINUE C CALL SMOTHCM(KFILDO,P,DATA,U,NX,NY,B(LP),IPACK,MESH) C U( ) IS AVAILABLE AS SCRATCH, AS WELL AS DATA( ) AND C IPACK( ). 3983 CONTINUE C ENDIF C C WRITE(KFILDO,3984)(P(J),J=1,NX*NY) C 3984 FORMAT(/' P '10F8.0/' '10F8.0/ C 1 ' '10F8.0/ C 1 ' '10F8.0/ C 1 ' '10F8.0/ C 1 ' '10F8.0/ C 1 ' '10F8.0/ C 1 ' '10F8.0/ C 1 ' '10F8.0/ C 1 ' '10F8.0/ C 1 ' '10F8.0/ C 1 ' '10F8.0/ C 1 ' '10F8.0/' ',7F8.0) C C PACK AND WRITE THE SLP FORECASTS TO THE INTERNAL STORAGE C SYSTEM. THEY ARE WRITTEN AT THE MESH LENGTH = MESH. C LD(1)=ID(1,N) LD(2)=0 LD(3)=LP LD(4)=0 C C NOTE THAT THESE FINAL FORECASTS ARE WRITTEN WITH SMOOTHING C PARAMETER S = 0, EVEN THOUGH THEY MAY HAVE BEEN SMOOTHED. C SCALING = ISCALD(N) = 1 (PROBABLY) FOR TENTHS OF MB. C NOTE THAT N CORRESPONDS TO TAU = 0, AND NOT FOR SPECIFIC C PROJECTIONS. C CALL PAWING(KFILDO,KFIL10,NDATE, 1 LD,LP,ITAUM,LAMPNO,NSEQ,ISCALD(N), 2 NPROJ,ALATL,ALONL,ORIENT,MESHB,MESH,XLAT,NX,NY, 3 P,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) IF(IER.NE.0)THEN WRITE(KFILDO,3985)LP 3985 FORMAT(' ****FATAL ERROR IN U450. CANNOT WRITE FORECAST', 1 ' TO RANDOM ACCESS FILE FOR PROJECTION',I3,'.') GO TO 600 ENDIF C C ANY ERROR FROM PAWING SHOULD BE TREATED AS FATAL. C C CHANGING SEA LEVEL PRESSURE FORECASTS TO 1000 MB HEIGHT FORECASTS C DO 3986 J=1,NX*NY Z10(J)=(P(J)-1000.)*1./.12015 3986 CONTINUE C IF(NHGT1.NE.0)THEN C C SETTING LD() ARRAY TO 1000 MB HEIGHTS FOR PACKING PURPOSES. C LD(1)=ID(1,NHGT1) LD(2)=ID(2,NHGT1) LD(3)=LP LD(4)=0 C C PACK AND WRITE THE 1000 MB HEIGHT FORECASTS TO THE INTERNAL STORAGE C SYSTEM. THEY ARE WRITTEN AT THE MESH LENGTH = MESH. C WHEN NHGT1 EQUALS 0 THERE IS NO ID IN THE U150.CN FILE C CALL PAWING(KFILDO,KFIL10,NDATE, 1 LD,LP,ITAUM,LAMPNO,NSEQ,ISCALD(NHGT1), 2 NPROJ,ALATL,ALONL,ORIENT,MESHB,MESH,XLAT,NX,NY, 3 Z10,DATA,IWORK,IPACK,ND5,MINPK, 4 LSTORE,ND9,LITEMS,CORE,ND10,NBLOCK, 5 IS0,IS1,IS2,IS4,ND7, 6 IPLAIN(1,1,NHGT1),PLAIN(NHGT1),NCHAR, 7 XMISSP,XMISSS,LX,IOCTET, 8 L3264B,L3264W,IER) IF(IER.NE.0)GOTO 600 C ENDIF C C TDLPACK AND WRITE SEA LEVEL PRESSURE FORECAST C WHEN I450DG NE 0. ALSO GRIDPRINT WHEN IP22 NE 0. C OUTPUT IS ALSO CONTROLLED BY JP( ,N). C IF(I450DG.NE.0.AND.(KFILOG.GT.0.OR.IP22.GT.0).AND. 1 (JP(1,N).GT.0.OR.JP(2,N).GT.0))THEN C NXG=NX NYG=NY NXPG=NXP NYPG=NYP MESHG=MESH C NXG, ETC. ARE NECESSARY BECAUSE SIZEGR CHANGE THEM, AND C NX, ETC. MUST BE RETAINED. CALL TRNSFR(P,Z10,NX*NY) C ARRAY Z10( ) AVAILABLE FOR USE HERE AS A WORK ARRAY. CALL SIZEGR(KFILDO,Z10,NXG,NYG,NXPG,NYPG, 1 MESHG,MESHL,ITRPLQ,ND2X3) C THE SAME INTERPOLATION IS USED (IF NEEDED) AS FOR OTHER C USES IN U450. 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 FORECAST SEA LEVEL PRESSURE ' STATE='399 ' WRITE(TITLT(1:2),396,IOSTAT=IOS,ERR=900)LP CALL PRTGR(IP22,Z10,NXG,NYG, 1 CINT(LP),ORIGIN(LP),SMULT(LP),SADD(LP),IOPT,TITLT,IER) C IF(IER.NE.0)THEN ISTOP=ISTOP+1 WRITE(KFILDO,356) C ERROR GRIDPRINTING NOT COUNTED AS FATAL. 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) LD(2)=0 LD(3)=LP LD(4)=10 C NOTE THAT SMOOTHING IS INDICATED, PRIMARILY TO C DISTINGUISH THE ID FROM THAT ON UNIT KFILIO, C THE ARCHIVE FILE. PLAINT='SEA LEVEL PRESSURE FORECAST ' C C THE GRID IN Z10( ) IS ALWAYS AT MESH LENGTH MESHL 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. THE SCALING IS ISCALD(N) = 1 (PROBABLY) FOR C TENTHS OF MB. C CALL CUT(KFILDO,Z10,NXG,NYG,NXPG,NYPG, 1 Z10,NXD,NYD,NXPD,NYPD) CALL MSHXMS(KFILDO,MESHL,XMESHN,XMESHL) C SUBROUTINE MSHXMS COMPUTES XMESHL FROM MESHL. CALL IJLLPS(1.,1.,XMESHL,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 GEMPAK. 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,MESHL,XLAT,NXD,NYD, 3 Z10,DATA,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 400 CONTINUE C WRITE(KFILDO,502)(JDATE(J),J=1,4) 502 FORMAT(/' U450 HAS SUCCESSFULLY COMPLETED FOR DATE/TIME ', 1 I5,2I3,I3.2,'00.') C GO TO 700 C C FOR THIS DEVELOPMENTAL PROGRAM, IF U450 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,'U450 ',STATE) IER=9999 GOTO 700 END