SUBROUTINE U400A(KFILDI,KFILDO,KFIL10,KFILOG,KFILOV,KFILQC,KFILRA, 1 RACESS,NUMRA,IP16,IP17,IP18,IP19,IP20,IP21,IP22, 2 CCALL,XP,YP,XPL,YPL,DP,WX,PW,EL,THICK,TOSS,QUEST, 3 WDIR,WSPD,LTAG,NSTA,ND1, 4 P,FD2,FD3,FD4,FD5,FD6,U,V,FDSINS,ND2X3, 5 ID,IDPARS,JD,JP,NGRIDC,ND11,ISCALD, 6 IPLAIN,PLAIN,NPRED,ND4, 7 IPACK,DATA,IWORK,ND5, 8 NCEPNO,LAMPNO,NDATE, 9 ALATL,ALONL,NPROJ,ORIENT,XLAT, A NXL,NYL,NXPL,NYPL,MESHB,BMESH,MESHL,IOPTB, B IS0,IS1,IS2,IS4,ND7, C LSTORE,LITEMS,MSTORE,MITEMS,ND9, D CORE,ND10,NBLOCK, E JTOTBY,JTOTRC,MTOTBY,MTOTRC,ITOTBY,ITOTRC, F L3264B,L3264W,MISTOT,MINPK,ISTOP,IER) C C JULY 2000 GLAHN TDL LAMP-2000 C NOVEMBER 2000 GLAHN ADDED DIMENSION TO ITABLE( , , ) C DECEMBER 2000 GLAHN CHANGED IOPT( ) TO IOPTB( ) IN CALL; C ADDED TRANSFORMATION TO IOPT( ) C DECEMBER 2000 GLAHN MODIFIED ID FOR SLP, TEMP, AND DP C IN ITABLE( ,1,1) C FEBRUARY 2001 GLAHN ADDED DIAGNOSTIC FORMAT 277 IN C 3 PLACES C FEBRUARY 2001 GLAHN MODIFIED TO WRITE VECTOR RECORD WITH C TOSSED OBS AS MISSING; ADDED KFILOV, C PLAIN, TOSS( ), AND QUEST( ) C FEBRUARY 2001 GLAHN MODIFIED COMMENTS FOR USE OF TOSS( ) C AND QUEST( ) C FEBRUARY 2001 GLAHN ADDED KFILQC C MARCH 2001 GLAHN REMOVED CALL TO SETMST; MODS FOR USING C WIND IN ANALYSIS BY READING WNDTHR, C WNDTRN, WNDGRD, WNDWT( ); ADDED CALLS C TO DIRTUV, PSMAPF, PRTGR AND INTRPL; C ADDED BMESH, U, V, FDSINS TO CALL; C ADDED ROUTINE INTRPL C MARCH 2001 GLAHN ZEROED IOPT( ) WHEN IOPTB(1)=0 C MARCH 2001 GLAHN ADDED NSMTYP C MARCH 2001 GLAHN ADDED WNDTHR AND WNDTRN TO CALL TO BCD C MARCH 2001 GLAHN ADDED PLAIN TO CALL TO FSTGS C JUNE 2001 GLAHN RESCALING FOR SD CHANGED, -.04 TO -.06 C JUNE 2001 GLAHN MODIFIED USE OF WX( ) VARIABLE C JUNE 2001 GLAHN MODIFIED USE OF ITABLE( , , ) C JUNE 2001 GLAHN ADDED WRITING SATURATION THICKNESS, C ELEVATION, 1000-500 MB THICKNESS, AND C PRECIPITABLE WATER TO KFILVO C JUNE 2001 GLAHN WROTE SD TO KFILOV; MODIFIED SOME IDS; C ENHANCED EXPLANATION OF ITABLE( , , ) C JUNE 2001 GLAHN CHANGED ID 703400 TO 703410 AND C 703401 TO 703411 C AUGUST 2001 GLAHN ADDED CHECK FOR NO STATIONS TO ANALYZE C SEPTEMBER 2001 GLAHN ADDED DATE TO FORMAT 1220 C OCTOBER 2001 GLAHN ADDED TO COMMENT AFTER 350 C OCTOBER 2001 GLAHN ADDED KFIRST, KSECND TO CALL TO RADARS; C ADDED GRIDPRINT AND WRITING TO KFILOG C OF FINAL SD ANALYSIS; REMOVED TITLE C FROM CALL TO RADARS C DECEMBER 2001 GLAHN DELETED COMMENT REGARDING MESHD C FEBRUARY 2002 GLAHN TREATED WX CODE 10 AS NO PRECIP; C COMMENT CONCERNING LTAG( ) = -3 TEST C IN ESP; ADDED $$$$ TO START OF SD ANAL C APRIL 2002 GLAHN CORRECTED TO ALWAYS WRITE SD ANALYSIS C TO INTERNAL STORAGE C APRIL 2002 GLAHN CHANGED CALL TO INTRPL TO CALL TO ITRP C MAY 2002 GLAHN ADDED I400ADG C JUNE 2002 GLAHN ADJUSTED WIND CORRECTION FOR CURRENT C MESH; SPELL CHECKED C JUNE 2002 GLAHN CHANGED NX,NY TO NXL,NYL IN CALL TO C ITRP AT 342 C AUGUST 2002 GLAHN MADE FORMAT 501 **** C DECEMBER 2002 GLAHN ADDED ISTOP(2) 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 OTHER ROUTINES; SPELL CHECKED C MARCH 2003 GLAHN/GHIRARDELLI CORRECTED ERROR IN RESCALING C OF SD AND COMMENT IN DO 350 LOOP 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 AGREE WITH AUGIDS. C MAY 2007 SCALLION MODIFIED TO CORRECT THE READING/PRINTING C OF I400ADG VARIABLE. IMPACT IS ONLY C COSMETIC. C NOVEMBER 2012 GHIRARDELLI MODIFIED TO PASS PLAIN TO PAWING C WHICH WAS MODIFIED FOR INTEL CHANGES C C PURPOSE C PROGRAM U400A IS THE ANALYSIS PROGRAM FOR CONTINUOUS C VARIABLES. ENTRY INTO U400A WILL PRODUCE AN ANALYSIS C OF ONE OR MORE OF THE VARIABLES IN ITABLE( ,J,1), C SEA LEVEL PRESSURE (J=1), SURFACE TEMPERATURE (J=2), C SURFACE DEW POINT (J=3), AND SATURATION DEFICIT (J=4) C ACCORDING TO THE VALUES IN ID( , ). C C FATAL ERRORS, IER: C 777 FROM FSTGS--CANNOT OBTAIN A FIRST GUESS. C C ISTOP(1) INCREMENTED: C FROM FSTGS--FIRST GUESS IS NOT FIRST CHOICE. 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 OF TDLPACK DISPOSABLE OUTPUT FILE. C (OUTPUT) C KFILOV - UNIT NUMBER OF OUTPUT VECTOR FILE CONTAINING C TOSSED OR QUESTIONABLE OBS AS MISSING. (OUTPUT) C KFILQC - UNIT NUMBER OF OUTPUT VECTOR FILE CONTAINING C QUALITY CONTROLLED OBS AFTER THE FINAL ANALYSIS C PASS. (OUTPUT) C KFILRA(J)- HOLDS THE 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. (OUTPUT) C IP17 - UNIT NUMBER FOR LISTING OF STATIONS, THEIR C X/Y POSITIONS,THEIR DATA VALUES, AND LTAGS. C (OUTPUT) C IP18 - UNIT NUMBER FOR LISTING OF STATIONS, C THEIR X/Y POSITIONS, DATA VALUES, LTAGS, C ANALYSIS (INTERPOLATED) VALUES, AND C DIFFERENCES BETWEEN THE DATA AND THE ANALYSIS C VALUES. (OUTPUT) C IP19 - SAME AS IP18 EXCEPT IT APPLIES TO THE C SMOOTHED ANALYSIS. (OUTPUT) C IP20 - UNIT NUMBER FOR LISTING OF STATIONS, THEIR C X/Y POSITIONS, DATA VALUES, LTAGS, ANALYSIS C (INTERPOLATED) VALUES, AND DIFFERENCES C BETWEEN THE DATA AND THE ANALYSIS VALUES C FOR ONLY THE SUBSETTED AREA FOR GRIDPRINTING. C IF IOPT( ) IS NOT USED, IP(20) IS NOT C ACTIVATED. (OUTPUT) C IP21 - UNIT NUMBER FOR LISTING THE AVERAGE DEGREE C OF FIT BETWEEN THE UNSMOOTHED AND SMOOTHED, C IF SMOOTHED, ANALYSIS AND THE DATA. (OUTPUT) C IP22 - UNIT NUMBER FOR GRIDPRINTING. (OUTPUT) C C VARIABLES C KFILDI = UNIT NUMBER TO READ INPUT FILE 'U450A.CN'. C (INPUT) C KFILDO = UNIT NUMBER OF OUTPUT (PRINT) FILE. (INPUT) C KFIL10 = UNIT NUMBER FOR INTERNAL RANDOM ACCESS STORAGE. C (INPUT) C KFILOG = UNIT NUMBER OF TDLPACK DISPOSABLE OUTPUT FILE. C THIS IS FOR WRITING THE RESULTS OF THE VARIOUS C PASSES IN THE ANALYSES AND THEIR SMOOTHINGS. C (INPUT) C KFILOV = UNIT NUMBER OF OUTPUT VECTOR FILE CONTAINING C TOSSED OR QUESTIONABLE OBS AS MISSING. (INPUT) C KFILQC = UNIT NUMBER OF OUTPUT VECTOR FILE CONTAINING C QUALITY CONTROLLED OBS AFTER THE FINAL ANALYSIS C PASS. (OUTPUT) C KFILRA(J) = HOLDS THE UNIT NUMBERS FOR ACCESSING THE MOS-2000 C EXTERNAL RANDOM ACCESS FILES (J=1,6). C THE ACCESS ROUTINES ALLOW 6 RANDOM ACCESS C FILES. HOWEVER, IT UNLIKELY U150 WILL NEED C MORE THAN 1 OR 2. (INPUT) C RACESS(J) = THE FILE NAMES CORRESPONDING TO KFILRA(J) C (J=1,6). (CHARACTER*60) (INPUT) C NUMRA = THE NUMBER OF UNIT NUMBERS IN KFILRA( ) AND C NAMES IN RACESS( ). (INPUT) C 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. (INPUT) C IP17 = UNIT NUMBER FOR LISTING OF STATIONS, THEIR C X/Y POSITIONS,THEIR DATA VALUES, AND LTAGS. C (INPUT) C IP18 = UNIT NUMBER FOR LISTING OF STATIONS, THEIR C X/Y POSITIONS, DATA VALUES, LTAGS, C ANALYSIS (INTERPOLATED) VALUES, AND C DIFFERENCES BETWEEN THE DATA AND THE ANALYSIS C VALUES. (INPUT) C IP19 = SAME AS IP18 EXCEPT IT APPLIES TO THE C SMOOTHED ANALYSIS. (INPUT) C IP20 = UNIT NUMBER FOR LISTING OF STATIONS, THEIR C X/Y POSITIONS, DATA VALUES, LTAGS, ANALYSIS C (INTERPOLATED) VALUES, AND DIFFERENCES C BETWEEN THE DATA AND THE ANALYSIS VALUES C FOR ONLY THE SUBSETTED AREA FOR GRIDPRINTING. C IF IOPT( ) IS NOT USED, IP(20) IS NOT C ACTIVATED. (INPUT) C IP21 = UNIT NUMBER FOR LISTING THE AVERAGE DEGREE C OF FIT BETWEEN THE UNSMOOTHED AND SMOOTHED, C IF SMOOTHED, ANALYSIS AND THE DATA. (INPUT) C IP22 = UNIT NUMBER FOR GRIDPRINTING OF FIRST GUESS C AND ANALYSES. (INPUT) C CCALL(K,J) = 8-CHARACTER STATION CALL LETTERS (J=1) AND C 5 POSSIBLE OTHER STATION CALL LETTERS (J=2,6) C THAT CAN BE USED INSTEAD IF THE PRIMARY (J=1) C STATION CANNOT BE FOUND IN AN INPUT DIRECTORY C (K=1,NSTA). ALL STATION DATA ARE KEYED TO C THIS LIST. (INPUT) C XP(K) = THE X POSITION FOR STATION K (K=1,NSTA) ON C THE LAMP GRID AREA AT THE CURRENT GRID MESH C LENGTH XMESH. (INTERNAL) C YP(K) = THE Y POSITION FOR STATION K (K=1,NSTA) ON C THE LAMP GRID AREA AT THE CURRENT GRID MESH C LENGTH XMESH. (INTERNAL) C XPL(K) = THE X POSITION FOR STATION K (K=1,NSTA) ON C THE LAMP GRID AREA AT THE QUARTER BEDIENT C MESH LENGTH MESHB. C YPL(K) = THE Y POSITION FOR STATION K (K=1,NSTA) ON C THE LAMP GRID AREA AT THE QUARTER BEDIENT C MESH LENGTH MESHB. C DP(K) = DEW POINT OBSERVATION (K=1,NSTA). (INTERNAL) C WX(K) = WEATHER OBSERVATION (K=1,NSTA). (INTERNAL) C PW(K) = PRECIPITABLE WATER AT THE NEEDED PROJECTION C INTERPOLATED TO STATIONS FROM NCEP GRID C (K=1,NSTA). (INTERNAL) C EL(K) = STATION ELEVATION INTERPOLATED TO STATIONS C (K=1,NSTA). (INTERNAL) C THICK(K) = 1000-500 MB THICKNESS AT THE NEEDED PROJECTION C CALCULATED AND INTERPOLATED TO STATIONS FROM C NCEP GRIDS (K=1,NSTA). (INTERNAL) C TOSS(K) = CONTAINS TOSSED OBS (K=1,NSTA). ALL OTHER C VALUES ARE 9999. (INTERNAL) C QUEST(K) = CONTAINS QUESTIONABLE OBS (K=1,NSTA). ALL C OTHER VALUES ARE 9999. QUESTIONABLE IS DEFINED C AS MEETING THE ERROR CRITERION, BUT NOT C MEETING X PERCENT OF IT, WHERE X IS HARDWIRED C BY PASS. (INTERNAL) C LTAG(K) = DENOTES USE OF DATA IN DATA(K) FOR STATION K C (K=1,NSTA). C 0 = USE DATA. C 1 = STATION OUTSIDE RADIUS OF INFLUENCE FOR C AREA BEING ANALYZED OR MISSING DATUM. C 2 = STATION LOCATION UNKNOWN. C (INTERNAL) C WDIR(K) = OBSERVED WIND DIRECTION (K=1,NSTA). THE TOSSED C REPORTS HAVE BEEN SET TO 9999. ON INPUT. THE C DIRECTION IS THEN TURNED WNDTRN DEGREES CLOCKWISE. C (INPUT) C WSPD(K) = OBSERVED WIND SPEED (K=1,NSTA). THE TOSSED C REPORTS HAVE BEEN SET TO 9999. ON INPUT. (INPUT) C NSTA = NUMBER OF STATIONS OR LOCATIONS BEING DEALT WITH. C (INPUT) C ND1 = MAXIMUM NUMBER OF STATIONS THAT CAN BE DEALT C WITH. NOTE THAT THIS DOES NOT NECESSARILY C INCLUDE THE NUMBER OF STATIONS IN A C DIRECTORY. (INPUT) C P(I,J) = THE FIRST GUESS FROM FSTGS AND THE ANALYSIS C FROM BCD (I=1,NXL) (J=1,NYL). (INTERNAL) C FD2(J), FD2(J), ETC = WORK ARRAYS (J=1,ND2X3). THESE CAN BE USED IN C ROUTINES AS 2-DIMENSIONAL ARRAYS, THE ONLY SIZE C RESTRICTION BEING THE TOTAL, NOT THE INDIVIDUAL C GRID DIMENSIONS. (INTERNAL) C U(K) = U-WIND AT STATIONS (K=1,NSTA). OBS TOSSED BY C U400B HAVE BEEN SET TO 9999. WHEN SPEED IS C LT WNDTHR, U(K) IS SET = 9999. LATER, THE C CHANGE IN PRESSURE IN MB PER GRID UNIT IN THE C X DIRECTION FOR GEOSTROPHIC COMPUTATIONS WHEN C SLP IS BEING ANALYZED. THIS IS FD7( ) IN THE C CALLING PROGRAM. (INTERNAL) C V(K) = V-WIND AT STATIONS (K=1,NSTA). WHEN SPEED IS C LT WNDTHR, U(K) IS SET = 9999. OBS TOSSED BY C U400B HAVE BEEN SET TO 9999. LATER, THE C CHANGE IN PRESSURE IN MB PER GRID UNIT IN THE C Y DIRECTION FOR GEOSTROPHIC COMPUTATIONS WHEN C SLP IS BEING ANALYZED. THIS IS FD8( ) IN THE C CALLING PROGRAM. (INTERNAL) C FDSINS(J) = WORK ARRAY FOR SIN OF THE LATITUDE (J=1,ND2X3). C THIS IS FD9( ) IN THE CALLING PROGRAM. C (INTERNAL) C ND2X3 = THE DIMENSION OF SEVERAL ARRAYS = C MAX(ND1,ND2*ND3) IN DRIVER. (INPUT) C ID(J,N) = THE VARIABLE ID'S BEING DEALT WITH(J=1,4) C (N=1,ND4). (INPUT) C IDPARS(J,N) = THE PARSED, INDIVIDUAL COMPONENTS OF THE C VARIABLE ID'S CORRESPONDING TO ID( ,N) 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). C THIS IS THE SAME AS ID(J,N), EXCEPT THAT THE C PORTIONS PERTAINING TO PROCESSING ARE OMITTED: C B = IDPARS(3, ), C T = IDPARS(8,), C I = IDPARS(13, ), C S = IDPARS(14, ), C G = IDPARS(15, ), AND C THRESH( ). C JD( , ) IS USED TO IDENTIFY THE BASIC MODEL C FIELDS AS READ FROM THE ARCHIVE. (INPUT) C JP(J,N) = INDICATES WHETHER A PARTICULAR VARIABLE N MAY C HAVE GRIDPRINTS (J=1), INTERMEDIATE TDLPACK C OUTPUT (J=2), OR PRINT OF VECTOR RECORDS IN C PACKV (J=3) (N=1,ND4). PACKV IS FOR THE C DATA SHOWING T0SSED DATA AS MISSING AND C QUESTIONABLE DATA AS MISSING. THIS IS C AN OVERRIDE FEATURE FOR THE PARAMETERS FOR C GRIDPRINTING AND TDLPACKING IN EACH VARIABLE'S C CONTROL FILE. (INPUT) C NGRIDC(L,M) = HOLDS THE GRID CHARACTERISTICS (L=1,6) FOR EACH GRID C COMBINATION (M=1,NGRID). C L=1--MAP PROJECTION NUMBER (3=LAMBERT, 5=POLAR C STEREOGRAPHIC). C L=2--GRID LENGTH IN METERS, C L=3--LATITUDE AT WHICH GRID LENGTH IS CORRECT, C L=4--GRID ORIENTATION IN DEGREES, AND C L=5--LATITUDE OF LL CORNER IN DEGREES, C L=6--LONGITUDE OF LL CORNER IN DEGREES C (INPUT) C ND11 = MAXIMUM NUMBER OF GRID COMBINATIONS THAT CAN BE C DEALT WITH ON THIS RUN. LAST DIMENSION OF C NGRIDC( , ). (INPUT) C 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 HOLD C 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) (N=1,ND4). EQUIVALENCED TO C IPLAIN( , ,N) IN DRU150. (CHARACTER*32) C NPRED = THE NUMBER OF VARIABLES IDENTIFIED IN ID( , ), C ETC. (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 FOR OBSERVED DATA (J=1,ND5). C (INTERNAL) C IWORK(J) = WORK ARRAY (J=1,ND5). (INTERNAL) C ND5 = DIMENSION OF IPACK( ), IWORK( ), AND DATA( ). C (INPUT) C 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 OF 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 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 BMESH = ACTUAL MESH LENGTH CORRESPONDING TO MESHB. C (INPUT) C MESHL = NOMINAL MESH LENGTH OF QUALITY CONTROL C (SUBSETTED) GRID FOR CONTINUOUS VARIABLES. C (INPUT) C IOPTB(J) = SUBSETTING VALUES USED IN GRIDPRINTING (J=1,8) C IN RELATION TO 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 VARIABLE. C (INPUT) C LITEMS = THE NUMBER OF ITEMS IN LSTORE( , ). (INPUT) C MSTORE(L,J) = THE ARRAY HOLDING THE VARIABLES NEEDED AS C INPUT, AFTER DAY 1, AND ASSOCIATED INFORMATION C (L=1,7) (J=1,MITEMS). C J=1,4 --THE 4 ID'S OF THE DATA. C J=5 --THE VALUE TAKEN FROM LSTORE(11, ) WHICH C INDICATES WHETHER OR NOT TO STORE THE C VARIABLE AND THE FIRST PREDICTOR TO USE C IT FOR. C J=6 --THE CYCLE TIME FOR WHICH THIS VARIABLE C IS NEEDED FOR THE DATE BEING PROCESSED. C A VARIABLE NEEDED FOR MORE THAN ONE C CYCLE TIME WILL HAVE ONE (AND ONLY ONE) C ENTRY FOR EACH CYCLE. C J=7 --THE MAXIMUM TIME OFFSET RR (SEE C IDPARS(9, ) CORRESPONDING TO MSTORE(6, ) C (INPUT/OUTPUT) C MITEMS = THE NUMBER OF ITEMS IN MSTORE( , ). (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 MTOTBY = THE TOTAL NUMBER OF BYTES ON THE FILE ASSOCIATED C WITH UNIT NO. KFILOV. (INPUT/OUTPUT) C MTOTRC = THE TOTAL NUMBER OF RECORDS IN THE FILE ON UNIT C NUMBER KFILOV. (INPUT/OUTPUT) C ITOTBY = THE TOTAL NUMBER OF BYTES ON THE FILE ASSOCIATED C WITH UNIT NO. KFILQC. (INPUT/OUTPUT) C ITOTRC = THE TOTAL NUMBER OF RECORDS IN THE FILE ON UNIT C NUMBER KFILQC. (INPUT/OUTPUT) C 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(J) = ISTOP(1) IS INCREMENTED BY 1 EACH TIME AN ERROR C OCCURS. ISTOP(2) IS INCREMENTED WHEN LESS THAN C 200 STATIONS ARE AVAILABLE FOR AN ANALYSIS. C (INPUT/OUTPUT) C IER = STATUS RETURN. C 0 = GOOD RETURN. C 777 = FATAL ERROR C SEE CALLED ROUTINES FOR OTHER VALUES. C ANY NON ZERO VALUE WILL CLOSE OUT THIS C DATE/TIME IN U150. (OUTPUT) C STATE = VARIABLE SET TO STATEMENT NUMBER TO INDICATE C WHERE AN ERROR OCCURRED. (CHARACTER*4) C (INTERNAL) C ITABLE(I,L,J) = 4-WORD ID OF THE VARIABLES THAT ARE C ACCOMMODATED BY U400A (I=1,4) (J=1,NVAL) C FOR L = 1: C J = 1--001201005 000000000; SLP (MB) C J = 2--002301005 000000002; TEMPERATURE (DEG F) C J = 3--003301005 000000002; DEW POINT (DEG F) C J = 4--003410005 000000000; SAT DEF (M) C FOR L = 2: C THE IDS OF VARIABLES NEEDED TO ANALYZE THE C FIELD J. THESE VARIABLES CAN BE WRITTEN IN C BCD. IN THE CASE OF SD, THIS IS NOT AN C OBSERVATION PER SE, BUT IS WHAT IS BEING C ANALYZED. C FOR L = 3: C EXCEPT FOR J = 4, THIS IS THE FIELD NEEDED C FOR THE FIRST GUESS, AND IS USED IN FSTGS. C FOR L = 4: C FOR J = 4, SATURATION DEFICIT, L = 3 AND 4 C ARE THE OBSERVATIONS NEEDED TO COMPUTE C THE VARIABLE TO BE ANALYZED. FOR J = 1-3, C THIS IS A DUMMY AND IS NOT USED. C (INTERNAL) C DOTCN(J) = THE SPECIFIC .CN FILE FOR THE VARIABLE BEING C ANALYZED, CORRESPONDING TO ITABLE ( ,1,J) C (J=1,3). IT IS ASSUMED THE CONTROL FILES WILL C BE IN THE DIRECTORY WHERE THE RUN IS MADE. C (CHARACTER*14) (INTERNAL) C NPASS = THE NUMBER OF PASSES FOR THIS ANALYSIS. C UP TO 6 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). (INTERNAL) C MSHPAS(J,L) = THE NOMINAL MESH LENGTH FOR EACH PASS (J=1,NPASS) C FOR EACH FIRST GUESS OPTION (L=1,4). C (INTERNAL) C ER1(J,L,M) = ERROR CRITERIA FOR EACH PASS (J=1,NPASS), C FOR EACH FIRST GUESS OPTION (L=1,4), C AND FOR EACH MONTH (M=1,12). C IF AN OBSERVATION IS DIFFERENT FROM THE CURRENT C ANALYSIS BY MORE THAN ER1( , , ), IT IS C PROBABLY NOT USED ON THIS PASS. HOWEVER, C BEFORE A DATUM IS DISCARDED, A BUDDY CHECK C IS MADE. ALSO IF ER1(J,L,M) = 0, IT MEANS THE C CHECK IS NOT PERFORMED ON THIS PASS. (INTERNAL) C NTYPE(J,L) = TYPE OF CORRECTION FOR EACH PASS J (J=1,NPASS) C FOR EACH FIRST GUESS OPTION (L=1,4). C 0 MEANS SKIP THIS PASS C 1 MEANS W = 1 C 2 MEANS W = (R**2 - D**2)/(R**2 + D**2) C 3 MEANS SAME AS 2 EXCEPT SUM OF WEIGHTS IN C DENOMINATOR. C (INTERNAL) C R(J,L) = RADIUS OF INFLUENCE FOR EACH PASS J (J=1,NPASS) C FOR EACH FIRST GUESS OPTION (L=1,4) IN TERMS C OF MESH GRID UNITS BEING USED ON THAT PASS. C (INTERNAL) C ITRPLQ(J,L) = TYPE OF INTERPOLATION TO GO FROM ONE MESH C LENGTH TO ONE OF HALF THAT FOR EACH PASS J C (J=1,NPASS), FOR EACH FIRST GUESS OPTION C (L=1,4). C 1 = BILINEAR C 2 = BIQUADRATIC C (INTERNAL) C B(J,L) = SMOOTHING PARAMETER FOR EACH PASS J (J=1,NPASS) C FOR EACH FIRST GUESS OPTION (L=1,4). C B( ) = 0 MEANS NO SMOOTHING. (INTERNAL) C RSTAR(J) = MULTIPLICATIVE FACTOR (J=1,NPASS) TO USE WITH C R(J) IN DETERMINING HOW FAR OUTSIDE GRID TO USE C DATA. FOR PASS J, PROGRAM WILL USE DATA C R(J)*RSTAR(J) GRID UNITS OUTSIDE GRID. C (INTERNAL) C SMULT(J) = THE MULTIPLICATIVE FACTOR WHEN CONTOURING OR C GRIDPRINTING THE DATA (J=1,NPASS). C NOTE SMULT( ), SADD( ), ORIGIN( ), CINT( ), C AND UNITS( ), ALTHOUGH NAMED THE SAME AND C PLAYING THE SAME ROLE IN GRIDPRINTING, ARE C NOT THE SAME VARIABLES AS IN THE CALLING C PROGRAM; THEY ARE FILLED HERE AND PERTAIN C TO EACH PASS. (INTERNAL) C SADD(J) = THE ADDITIVE FACTOR WHEN CONTOURING OR C GRIDPRINTING THE DATA (J=1,NPASS). (INTERNAL) C ORIGIN(J) = THE CONTOUR ORIGIN, APPLIES TO THE UNITS IN C UNITS(N) (J=1,NPASS). (INTERNAL) C CINT(J) = THE CONTOUR INTERVAL, APPLIES TO THE UNITS IN C UNITS(N) (J=1,NPASS). (INTERNAL) C NPRT(J) = 1 FOR GRID PRINTING OF ANALYSIS AFTER PASS J C (J=1,NPASS). ZERO FOR NO PRINTING. (INTERNAL) C JPRT(J) = SAME AS ABOVE EXCEPT FOR SMOOTHED ANALYSIS. C (INTERNAL) C NTDL(J) = 1 FOR TDLPACKING AND WRITING ANALYSIS AFTER PASS J C (J=1,NPASS). ZERO FOR NO PACKING. (INTERNAL) C JTDL(J) = SAME AS ABOVE EXCEPT FOR SMOOTHED ANALYSIS. C (INTERNAL) C WNDWT(J,L) = WEIGHT TO APPLY TO WIND OBS CORRECTIONS C RELATIVE TO PRESSURE CORRECTIONS FOR EACH PASS C (J=1,6) FOR EACH FIRST GUESS OPTION (L=1,4). C (INTERNAL) C NSMTYP = TYPE OF SMOOTHING: C 1 = NORMAL, 5-PT C 2 = SAME EXCEPT NO CHANGE IS MADE UNLESS ONE C OF THE POINTS TO CONTRIBUTE TO THE NEW C VALUE HAS BEEN CHANGED. C 3 = 9-POINT SMOOTHING USED ON LAST PASS ONLY, C ANY OTHER PASS DEFAULTS TO NSMTYP = 2. C 4 = FOR PASSES GE 4, SAME AS 2 EXCEPT C A POINT IS NOT CHANGED IF IT IS LOWER THAN C BOTH POINTS ABOVE AND BELOW OR IF IT IS C LOWER THAN BOTH SIDE POINTS. DIAGONALS C ARE ALSO CONSIDERED. FOR THE OTHER C PASSES, DEFAULTS TO 2. C (INPUT) C WNDTHR = THRESHOLD TO USE FOR WIND SPEED FOR WIND TO BE C USED IN ANALYSIS. (INTERNAL) C WNDTRN = DEGREES TO TURN SURFACE WIND BEFORE APPLYING C GEOSTROPHIC CORRECTION. (INTERNAL) C WNDGRD = PARAMETER FOR CONVERTING WIND SPEED TO SLP C GRADIENTS. (INTERNAL) C I400ADG = 1 = DIAGNOSTIC PRINT TO KFILDO; C 0 OTHERWISE. (INTERNAL) C IFIRST = COUNTS ENTRIES INTO U400A. 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 IGUESS(J) = TYPE OF FIRST GUESS TO USE IN PRIORITY ORDER C (J=1,4) C 1 = CONSTANT. C 2 = NMC MODEL (OR LAMP FIELD FOR THE SAME TIME). C 3 = PREVIOUS ANALYSIS. (NOT CURRENTLY USED) C 4 = AVERAGE OF OBSERVATIONS. C (INTERNAL) C GUESS = THE VALUE TO USE AS CONSTANT WHEN IGUESS(1) IS C ACTIVATED. (INTERNAL) C IFSTGS = CONTROLS GRIDPRINTING AND TDLPACKING AND C WRITING OF FIRST GUESS C 0 = FIRST GUESS IS NEITHER GRIDPRINTED OR C TDLPACKED AND WRITTEN. C 1 = FIRST GUESS IS TO BE GRIDPRINTED. C 2 = FIRST GUESS IS TO BE TDLPACKED AND WRITTEN. C 3 = FIRST GUESS IS TO BE BOTH GRIDPRINTED AND C TDLPACKED AND WRITTEN. C (INTERNAL) C MGUESS = THE TYPE OF FIRST GUESS ACTUALLY USED (SEE C (IGUESS( )). SET IN FSTGS. C IVRBL = 1 = VARIABLE IS SLP. C 2 = VARIABLE IS TEMPERATURE. C 3 = VARIABLE IS DEW POINT. C 4 = SATURATION DEFICIT. C (INTERNAL) C JDATE(J) = NDATE PARSED INTO ITS 4 COMPONENTS: C J=1 IS YYYY C J=2 IS MM C J=3 IS DD C J=4 IS HH C (INTERNAL) C MESH = THE NOMINAL MESH LENGTH OF THE GRID BEING DEALT C WITH WHOSE DIMENSIONS ARE NX AND NY, AND C THE STATION LOCATIONS IN XP( ) AND YP( ) ARE C IN REFERENCE TO. (INTERNAL) C NVAL = NUMBER OF VARIABLES HANDLED IN U400A. THIRD C DIMENSION OF ITABLE( , , ). C JVAL = MAXIMUM NUMBER OF VARIABLES NEEDED FROM INTERNAL C STORAGE TO ANALYZE INDIVIDUAL VARIABLES. SECOND C DIMENSION OF ITABLE( , , ). C IOPT(J) = SUBSETTING VALUES USED IN GRIDPRINTING (J=1,8) C IN RELATION TO THE SUBSETTED AREA MESH LENGTH C MESHL. (INTERNAL) C SAVDAT(J) = DATE FROM JDATE( ) SAVED FOR USE IN NEXT ENTRY C (J=1,4). (INTERNAL) C IOPTL(J) = IOPT( ) FOR THE FULL AREA. ONLY USED FOR C CHECKOUT. (INTERNAL) C RACK = FOR HOLDING PLAIN LANGUAGE FOR TURNED WINDS. C (CHARACTER*32) (INTERNAL) C JPP(J) = ONLY FOR USE IN PACKV. (INTERNAL) C CORMSH = FLOAT(MESH)/FLOAT(MESHB). ADJUSTS GEOSTROPHIC C WIND CORRECTION FOR MESH. (INTERNAL) C C 1 2 3 4 5 6 7 X C NONSYSTEM SUBROUTINES USED C FSTGS, BCD, FLTAG, GFETCH, IERX, NEWXY, SIZEGR C PARAMETER (NVAL=4, 1 JVAL=4) C CHARACTER*4 STATE CHARACTER*8 CCALL(ND1,6) CHARACTER*14 DOTCN(NVAL) CHARACTER*32 PLAIN(ND4),RACK CHARACTER*40 TITLE/' '/, 1 TITLEX, 2 SIN/'SIN OF LATITUDE '/ CHARACTER*60 RACESS(6) C DIMENSION XP(ND1),YP(ND1),XPL(ND1),YPL(ND1), 1 LTAG(ND1),PW(ND1),THICK(ND1),EL(ND1), 2 DP(ND1),WX(ND1),ISCALD(ND1),WDIR(ND1),WSPD(ND1), 3 TOSS(ND1),QUEST(ND1) DIMENSION P(ND2X3) DIMENSION FD2(ND2X3),FD3(ND2X3),FD4(ND2X3),FD5(ND2X3),FD6(ND2X3), 1 U(ND2X3),V(ND2X3),FDSINS(ND2X3) DIMENSION ID(4,ND4),IDPARS(15,ND4),JD(4,ND4),JP(3,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),MSTORE(7,ND9) DIMENSION CORE(ND10) DIMENSION NGRIDC(6,ND11) DIMENSION MSHPAS(6,4),ER1(6,4,12),NTYPE(6,4),B(6,4),R(6,4), 1 ITRPLQ(6,4),RSTAR(6,4),WNDWT(6,4) DIMENSION SMULT(6),SADD(6),ORIGIN(6),CINT(6), 1 NPRT(6),JPRT(6),NTDL(6),JTDL(6) DIMENSION IRACK(8) DIMENSION ITABLE(4,JVAL,NVAL),IGUESS(4),LD(4),KFILRA(6),ISTOP(2) DIMENSION IOPTB(8),IOPT(8),JDATE(4),SAVDAT(4),IOPTL(8),JPP(3) C EQUIVALENCE (RACK,IRACK) C DATA ITABLE/001201005,0,0,0, 1 701200000,0,0,0, 2 001200008,0,0,0, 3 000000000,0,0,0, C 4 002301005,2,0,0, 5 702000000,0,0,0, 6 002001008,0,0,0, 7 000000000,0,0,0, C 8 003301005,2,0,0, 9 703100000,0,0,0, A 003101008,0,0,0, B 000000000,0,0,0, C C 003410005,0,0,0, D 703410000,0,0,0, E 703100000,0,0,0, E 708500000,0,0,0/ C ITABLE(I,1,J) = 4-WORD ID OF THE VARIABLES THAT ARE C ACCOMMODATED BY U400A (I=1,4) (J=1,NVAL) C SOME OF THESE ARE USED IN FSTGS, NOT U400A. C J = 1--001201005 000000000; SLP (MB) C 701200000 000000000; SLP OBS C 001200008 000000000; SLP (PASCALS) C 000000000 000000000; NOT USED C J = 2--002301005 000000002; TEMPERATURE (DEG F) C 702000000 000000000; TEMP. OBS (DEG F) C 002001008 000000002; TEMPERATURE (DEG K) C 000000000 000000000; NOT USED C J = 3--003301005 000000002; DEW POINT (DEG F) C 703100000 000000000; DEW POINT OBS (DEG F) C 003101008 000000000; DEW POINT (DEG K) (NOT USED) C 000000000 000000000; NOT USED C J = 4--003410005 000000000; SAT DEF (M) (NOT SCALED) C 703410000 000000000; SAT DEF OBS (SCALED, CALCULATED) (M) C 703100000 000000000; DEW POINT OBS (DEG F) C 708500000 000000000; WX TYPE OBS (CATEGORICAL) C DATA DOTCN/'lmp_slpanly.cn', 1 'lmp_tmpanly.cn', 2 'lmp_dewanly.cn', 3 'lmp_sadanly.cn'/ DATA A000/.5562/, 1 A100/.01121/, 2 A200/.6293/ DATA A012/.5782/, 1 A112/.01388/, 2 A212/.5920/ DATA B0/4681./, 1 B1/267.1/, 2 B2/.1056/ DATA IFIRST/0/, 1 LIMIT/1/ DATA IOPTL/8*0/ DATA JPP/3*0/ C SAVE SAVDAT C D WRITE(KFILDO,100) D100 FORMAT(' ') D CALL TIMPR(KFILDO,KFILDO,'START U400A ') C IER=0 IFIRST=IFIRST+1 IFIND=0 C C PARSE THE DATE INTO ITS FOUR COMPONENTS. C CALL DATPRS(KFILDO,NDATE,JDATE) C IF(IFIRST.EQ.1)THEN C NORMALLY THIS SAVING IS DONE AT THE END, BUT MUST BE DONE C ON FIRST ENTRY TO KEEP FROM PRINTING TWICE. SAVDAT(1)=JDATE(1) SAVDAT(2)=JDATE(2) SAVDAT(3)=JDATE(3) SAVDAT(4)=JDATE(4) ENDIF 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 DETERMINE WHICH VARIABLE TO ANALYZE ON A PARTICULAR PASS C THROUGH THE DATA. UP TO NPRED COULD BE ANALYZED, BUT C ONLY NVAL ARE ACCOMMODATED ACCORDING TO ITABLE( , , ). C SINCE ID( , ) CONTAINS ALL VARIABLES FOR THIS RUN, ANY C PARTICULAR ONE MAY OR MAY NOT BE IN ITABLE( , , ). C DO 500 N=1,NPRED C DO 110 IVRBL=1,NVAL C IF(ID(1,N).EQ.ITABLE(1,1,IVRBL).AND. 1 ID(2,N).EQ.ITABLE(2,1,IVRBL).AND. 2 ID(3,N).EQ.ITABLE(3,1,IVRBL).AND. 3 ID(4,N).EQ.ITABLE(4,1,IVRBL))THEN IFIND=1 GO TO 120 C UPON TRANSFER, IVRBL IS THE NUMBER IN THE LIST OF C THE VARIABLE BEING TREATED. THIS IS COORDINATED C THROUGHOUT THE CALLED ROUTINES. ENDIF C 110 CONTINUE GO TO 500 C C READ CONTROL INFORMATION ACCORDING TO THE VARIABLE TO BE C ANALYZED, DESIGNATED BY IVRBL = 1, 2, 3 OR 4 FOR THE C FIRST ENTRY INTO U400A. C 120 STATE='120 ' OPEN(UNIT=KFILDI,FILE=DOTCN(IVRBL),STATUS='OLD', 1 IOSTAT=IOS,ERR=900) C C READ AND WRITE ANALYSIS SPECIFIC CONTROL PARAMETERS. THE C CONTENT OF THE FIRST RECORD IS DIFFERENT FOR SLP (IVRBL=1) C THAN FOR OTHER VARIABLES. C STATE='122 ' C IF(IVRBL.EQ.1)THEN READ(KFILDI,122,IOSTAT=IOS,ERR=900)NPASS,IFSTGS, 1 (IGUESS(J),J=1,4),IBACKN,IBACKL,GUESS,TITLE(1:16), 2 NSMTYP,WNDTHR,WNDTRN,WNDGRD,I400ADG 122 FORMAT(8I4,F8.0,1X,A16,I4,2F4.0,F6.0,I4) NPASS=MIN(NPASS,6) C NPASS IS LIMITED TO 6 BY DIMENSION OF VARIABLES. WRITE(KFILDO,1220)TITLE(1:16),(JDATE(J),J=1,4) 1220 FORMAT(/' STARTING ANALYSIS FOR ',A16,' FOR DATE/TIME ', 1 I5,2I3,I3.2,'00.', 2 ' $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$') C IF(IFIRST.LE.LIMIT)WRITE(KFILDO,123)(ID(J,N),J=1,4),TITLE(1:16) 123 FORMAT(/' ANALYSIS SPECIFIC CONTROL PARAMETERS FOR ', 1 3I10.9,I10.3,3X,A16) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,124)NPASS,IFSTGS, 1 (IGUESS(J),J=1,4),IBACKN,IBACKL,GUESS,TITLE(1:16), 2 NSMTYP,WNDTHR,WNDTRN,WNDGRD,I400ADG 124 FORMAT(/' NPASS, IFSTGS, IGUESS(1-4), IBACKN, IBACKL,', 1 ' GUESS, TITLE NSMTYP WNDTHR', 2 ' WNDTRN WNDGRD I400ADG'/ 3 I7,I8,I7,3I2,I8,I10,F11.2,4X,A16,I9,2F9.1,F9.4,I10) ELSE READ(KFILDI,126,IOSTAT=IOS,ERR=900)NPASS,IFSTGS, 1 (IGUESS(J),J=1,4),IBACKN,IBACKL,GUESS,TITLE(1:16), 2 NSMTYP,I400ADG 126 FORMAT(8I4,F8.0,1X,A16,2I4) NPASS=MIN(NPASS,6) C NPASS IS LIMITED TO 6 BY DIMENSION OF VARIABLES. WRITE(KFILDO,1220)TITLE(1:16),(JDATE(J),J=1,4) C IF(IFIRST.LE.LIMIT)WRITE(KFILDO,123)(ID(J,N),J=1,4),TITLE(1:16) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,125)NPASS,IFSTGS, 1 (IGUESS(J),J=1,4),IBACKN,IBACKL,GUESS,TITLE(1:16), 2 NSMTYP,I400ADG 125 FORMAT(/' NPASS, IFSTGS, IGUESS(1-4), IBACKN, IBACKL,', 1 ' GUESS, TITLE NSMTYP I400ADG'/ 3 I7,I8,I7,3I2,I8,I10,F11.2,4X,A16,I9,I10) ENDIF C C READ NOMINAL MESH LENGTH TO USE FOR EACH PASS FOR EACH C POSSIBILITY OF FIRST GUESS. C STATE='130 ' C DO 135 L=1,4 READ(KFILDI,130,IOSTAT=IOS,ERR=900)(MSHPAS(J,L),J=1,NPASS) 130 FORMAT(6I8) C IF(IFIRST.LE.LIMIT)THEN IF(L.EQ.1)WRITE(KFILDO,131)NPASS 131 FORMAT(' MSHPAS FOR ',I3,' PASSES') WRITE(KFILDO,132)L,(MSHPAS(J,L),J=1,NPASS) 132 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6I8) ENDIF C 135 CONTINUE C C READ ERROR CRITERIA TO USE FOR EACH PASS FOR EACH POSSIBILITY C OF FIRST GUESS. C STATE='140 ' C DO 146 M=1,12 DO 145 L=1,4 READ(KFILDI,140,IOSTAT=IOS,ERR=900)(ER1(J,L,M),J=1,NPASS) 140 FORMAT(6F8.0) C IF(IFIRST.LE.LIMIT)THEN IF(L.EQ.1.AND.M.EQ.JDATE(2))WRITE(KFILDO,141)NPASS,M 141 FORMAT(' ER1 FOR ',I3,' PASSES FOR MONTH',I3) C C PRINT THE CRITERIA ONLY FOR THE ANALYSIS MONTH. C IF(M.EQ.JDATE(2))THEN WRITE(KFILDO,142)L,(ER1(J,L,M),J=1,NPASS) 142 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6F8.2) ENDIF C ENDIF C 145 CONTINUE 146 CONTINUE C C ASSURE THAT THE ERROR CRITERIA GET WRITTEN FOR THE ANALYSIS C MONTH. C IF(JDATE(2).NE.SAVDAT(2))THEN C DO 148 L=1,4 C IF(L.EQ.1)THEN WRITE(KFILDO,147)NPASS,JDATE(2) 147 FORMAT(/' ER1 FOR ',I3,' PASSES FOR MONTH',I3) ENDIF C IF(IGUESS(1).EQ.L.OR. 1 IGUESS(2).EQ.L.OR. 2 IGUESS(3).EQ.L.OR. 3 IGUESS(4).EQ.L)THEN C THIS WILL WRITE FOR ONLY THE OPTIONS POSSIBLE. WRITE(KFILDO,142)L,(ER1(J,L,JDATE(2)),J=1,NPASS) ENDIF C 148 CONTINUE C ENDIF C READ TYPE OF CORRECTION TO USE FOR EACH PASS FOR EACH C POSSIBILITY OF FIRST GUESS. C STATE='150 ' C DO 155 L=1,4 READ(KFILDI,130,IOSTAT=IOS,ERR=900)(NTYPE(J,L),J=1,NPASS) C IF(IFIRST.LE.LIMIT)THEN IF(L.EQ.1)WRITE(KFILDO,151)NPASS 151 FORMAT(' NTYPE FOR ',I3,' PASSES') WRITE(KFILDO,152)L,(NTYPE(J,L),J=1,NPASS) 152 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6I8) ENDIF C 155 CONTINUE C C READ SMOOTHING PARAMETER TO USE FOR EACH PASS FOR EACH C POSSIBILITY OF FIRST GUESS. C STATE='160 ' C DO 165 L=1,4 READ(KFILDI,140,IOSTAT=IOS,ERR=900)(B(J,L),J=1,NPASS) C IF(IFIRST.LE.LIMIT)THEN IF(L.EQ.1)WRITE(KFILDO,161)NPASS 161 FORMAT(' B FOR ',I3,' PASSES') WRITE(KFILDO,162)L,(B(J,L),J=1,NPASS) 162 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6F8.2) ENDIF C 165 CONTINUE C C READ RADIUS OF INFLUENCE TO USE FOR EACH PASS FOR EACH C POSSIBILITY OF FIRST GUESS. C STATE='170 ' C DO 175 L=1,4 READ(KFILDI,140,IOSTAT=IOS,ERR=900)(R(J,L),J=1,NPASS) C IF(IFIRST.LE.LIMIT)THEN IF(L.EQ.1)WRITE(KFILDO,171)NPASS 171 FORMAT(' R FOR ',I3,' PASSES') WRITE(KFILDO,172)L,(R(J,L),J=1,NPASS) 172 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6F8.2) ENDIF C 175 CONTINUE C C READ TYPE OF INTERPOLATION TO USE IN COMPUTING C THE NEXT GRID FOR EACH PASS FOR EACH POSSIBILITY C OF FIRST GUESS. ITRPLQ = 1 FOR BILINEAR AND C ITRPLQ = 2 FOR BIQUADRATIC INTERPOLATION. THIS C WILL HAVE MEANING ONLY IF THE GRID NEEDS TO BE C INTERPOLATED FROM A PREVIOUS GRID. C FOR INSTANCE, ITRPLQ(2,1) = 1 MEANS BILINEAR WILL C BE USED IN ARRIVING AT THE FIRST GUESS C (THAT IS, THE FIELD FOR THE FIRST PASS), IF C INTERPOLATION IS NEEDED, FOR FIRST GUESS TYPE 2. C ITRPLQ(2,2) = 2 MEANS THAT BIQUADRATIC WILL BE C USED IN ARRIVING AT THE GRID TO USE FOR PASS 2, C FOR FIRST GUESS TYPE 2. C STATE='180 ' C DO 185 L=1,4 READ(KFILDI,130,IOSTAT=IOS,ERR=900)(ITRPLQ(J,L),J=1,NPASS) C IF(IFIRST.LE.LIMIT)THEN IF(L.EQ.1)WRITE(KFILDO,181)NPASS 181 FORMAT(' ITRPLQ FOR ',I3,' PASSES') WRITE(KFILDO,182)L,(ITRPLQ(J,L),J=1,NPASS) 182 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6I8) ENDIF C 185 CONTINUE C C READ RDSTAR, THE FRACTION OF THE RADIUS OF INFLUENCE C TO USE DATA OUTSIDE THE ANALYSIS AREA FOR EACH PASS C FOR EACH POSSIBILITY OF FIRST GUESS. C STATE='190 ' C DO 195 L=1,4 READ(KFILDI,140,IOSTAT=IOS,ERR=900)(RSTAR(J,L),J=1,NPASS) C IF(IFIRST.LE.LIMIT)THEN IF(L.EQ.1)WRITE(KFILDO,191)NPASS 191 FORMAT(' RSTAR FOR ',I3,' PASSES') WRITE(KFILDO,192)L,(RSTAR(J,L),J=1,NPASS) 192 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6F8.2) ENDIF C 195 CONTINUE C C READ MULTIPLICATIVE FACTOR FOR GRIDPRINTING. C STATE='200 ' READ(KFILDI,140,IOSTAT=IOS,ERR=900)(SMULT(J),J=1,NPASS) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,201)NPASS,(SMULT(J),J=1,NPASS) 201 FORMAT(' SMULT FOR ',I3,' PASSES',10X,6F8.2) C C READ ADDITIVE FACTOR FOR GRIDPRINTING. C STATE='210' READ(KFILDI,140,IOSTAT=IOS,ERR=900)(SADD(J),J=1,NPASS) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,211)NPASS,(SADD(J),J=1,NPASS) 211 FORMAT(' SADD FOR ',I3,' PASSES',10X,6F8.2) C C READ ORIGIN FOR GRIDPRINTING. C STATE='220 ' READ(KFILDI,140,IOSTAT=IOS,ERR=900)(ORIGIN(J),J=1,NPASS) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,221)NPASS,(ORIGIN(J),J=1,NPASS) 221 FORMAT(' ORIGIN FOR ',I3,' PASSES',10X,6F8.2) C C READ CONTOURING INTERVAL FOR GRIDPRINTING. C STATE='230 ' READ(KFILDI,140,IOSTAT=IOS,ERR=900)(CINT(J),J=1,NPASS) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,231)NPASS,(CINT(J),J=1,NPASS) 231 FORMAT(' CINT FOR ',I3,' PASSES',10X,6F8.2) C C READ GRIDPRINTING OPTION FOR UNSMOOTHED GRID GRIDPRINTING. C STATE='240 ' READ(KFILDI,130,IOSTAT=IOS,ERR=900)(NPRT(J),J=1,NPASS) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,241)NPASS,(NPRT(J),J=1,NPASS) 241 FORMAT(' NPRT FOR ',I3,' PASSES',10X,6I8) C C READ GRIDPRINTING OPTION FOR SMOOTHED GRID GRIDPRINTING. C STATE='250 ' READ(KFILDI,130,IOSTAT=IOS,ERR=900)(JPRT(J),J=1,NPASS) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,251)NPASS,(JPRT(J),J=1,NPASS) 251 FORMAT(' JPRT FOR ',I3,' PASSES',10X,6I8) C C READ TDLPACKING OPTION FOR UNSMOOTHED PACKING. C STATE='260 ' READ(KFILDI,130,IOSTAT=IOS,ERR=900)(NTDL(J),J=1,NPASS) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,261)NPASS,(NTDL(J),J=1,NPASS) 261 FORMAT(' NTDL FOR ',I3,' PASSES',10X,6I8) C C READ TDLPACKING OPTION FOR SMOOTHED PACKING. C STATE='270 ' READ(KFILDI,130,IOSTAT=IOS,ERR=900)(JTDL(J),J=1,NPASS) IF(IFIRST.LE.LIMIT)WRITE(KFILDO,271)NPASS,(JTDL(J),J=1,NPASS) 271 FORMAT(' JTDL FOR ',I3,' PASSES',10X,6I8) C C READ WEIGHTS OF WIND OBS TO APPLY RELATIVE TO HEIGHT OBS C FOR SLP ONLY. C IF(IVRBL.EQ.1)THEN STATE='280 ' C DO 285 L=1,4 READ(KFILDI,140,IOSTAT=IOS,ERR=900)(WNDWT(J,L),J=1,NPASS) C IF(IFIRST.LE.LIMIT)THEN IF(L.EQ.1)WRITE(KFILDO,281)NPASS 281 FORMAT(' WNDWT FOR ',I3,' PASSES') WRITE(KFILDO,282)L,(WNDWT(J,L),J=1,NPASS) 282 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6F8.2) ENDIF C 285 CONTINUE C ELSE C C INITIALIZE WNDWT( , ) FOR OTHER THAN SLP ANALYSIS. C DO 2855 J=1,NPASS DO 2854 L=1,4 WNDWT(J,L)=0. 2854 CONTINUE 2855 CONTINUE ENDIF C CLOSE(UNIT=KFILDI) C C GET THE DATA TO ANALYZE IN DATA( ), EXCEPT FOR SATURATION C DEFICIT. C IF(IVRBL.EQ.1.OR. 1 IVRBL.EQ.2.OR. 2 IVRBL.EQ.3)THEN C THIS IS SLP, TEMPERATURE OR DEWPOINT. GET THE OBS. LD(1)=ITABLE(1,2,IVRBL) LD(2)=ITABLE(2,2,IVRBL) LD(3)=ITABLE(3,2,IVRBL) LD(4)=ITABLE(4,2,IVRBL) ENDIF C IF(IVRBL.NE.4)THEN CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,DATA,ND1, 2 NWORDS,NPACK,NDATE,NTIMES,CORE,ND10, 3 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B,1,IER) C IF(IER.NE.0)THEN C IER NE 0 MEANS DATA TO ANALYZE WERE NOT OBTAINED. C IF(IER.EQ.47)THEN WRITE(KFILDO,288)(LD(J),J=1,4),NDATE ENDIF C ISTOP(1)=ISTOP(1)+1 GO TO 500 ENDIF C IF(NWORDS.NE.NSTA)THEN WRITE(KFILDO,287)NWORDS,NSTA,IVRBL 287 FORMAT(/' ****THE NUMBER OF DATA VALUES READ',I6, 1 ' DOES NOT MATCH THE NUMBER OF STATIONS READ',I5, 2 ' IN THE DIRECTORY RECORD FOR VARIABLE IVRBL',I3,/ 3 ' FATAL ERROR IN U400A FOR THIS DATE.') GO TO 600 ENDIF C C GET DEW POINT AND WEATHER OBS FOR SATURATION DEFICIT C COMPUTATION. C ELSE C THIS IS SATURATION DEFICIT. GET THE DEW POINT OBS C IN DP( ). THIS IS ID 703100000 0 0 0. LD(1)=ITABLE(1,3,IVRBL) LD(2)=ITABLE(2,3,IVRBL) LD(3)=ITABLE(3,3,IVRBL) LD(4)=ITABLE(4,3,IVRBL) C CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,DP,ND1, 2 NWORDS,NPACK,NDATE,NTIMES,CORE,ND10, 3 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B,1,IER) C C IF(IER.NE.0)THEN C IER NE 0 MEANS DATA TO ANALYZE WERE NOT OBTAINED. C IF(IER.EQ.47)THEN WRITE(KFILDO,288)(LD(J),J=1,4),NDATE ENDIF C ISTOP(1)=ISTOP(1)+1 GO TO 500 ENDIF C IF(NWORDS.NE.NSTA)THEN WRITE(KFILDO,287)NWORDS,NSTA,IVRBL GO TO 600 ENDIF C C THIS IS SATURATION DEFICIT. GET THE WEATHER TYPE OBS C IN WX( ). THIS IS ID 708500000 0 0 0. LD(1)=ITABLE(1,4,IVRBL) LD(2)=ITABLE(2,4,IVRBL) LD(3)=ITABLE(3,4,IVRBL) LD(4)=ITABLE(4,4,IVRBL) C CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,WX,ND1, 2 NWORDS,NPACK,NDATE,NTIMES,CORE,ND10, 3 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B,1,IER) C IF(IER.NE.0)THEN C IER NE 0 MEANS DATA TO ANALYZE WERE NOT OBTAINED. C IF(IER.EQ.47)THEN WRITE(KFILDO,288)(LD(J),J=1,4),NDATE 288 FORMAT(/' ****DATA FOR ANALYSIS =',3(1X,I9.9),1X,I10.3, 1 ' COULD NOT BE OBTAINED IN U400A FOR DATE',I12/ 2 ' INPUT VARIABLE LIKELY DOES NOT EXIST', 3 ' ON INPUT FILE.') ENDIF C ISTOP(1)=ISTOP(1)+1 GO TO 500 ENDIF C IF(NWORDS.NE.NSTA)THEN WRITE(KFILDO,287)NWORDS,NSTA,IVRBL GO TO 600 C ENDIF C ENDIF C C GET THE FIRST GUESS. ALL INFORMATION IS AVAILABLE C FOR INGESTING NEEDED GRIDS. THIS FIRST GUESS C WILL BE USED FOR THE FIRST PASS. EACH PASS C OF THE ANALYSIS WILL USE THE GRID FROM THE PREVIOUS C PASS. ONLY THE FIRST VALUE IN CINT( ), ORIGIN( ), C SMULT( ), AND SADD( ) WILL BE USED IN FSTGS. C THAT IS, THE VALUES READ FOR THE FIRST PASS C ANALYSIS WILL ALSO BE USED FOR THE FIRST GUESS. C CALL FSTGS(KFILDO,KFIL10,KFILOG,KFILRA,RACESS,NUMRA,IP16,IP22, 1 NDATE,ID(1,N),IDPARS(1,N),JD(1,N),JP(1,N),ISCALD(N), 2 IVRBL,NGRIDC,ND11,DATA,XP,YP,XPL,YPL, 3 PW,EL,THICK,ND1,NSTA, 4 P,FD2,FD3,FD4,FD5,FD6,ND2X3, 5 NCEPNO,LAMPNO,NPROJ,ORIENT,XLAT, 6 NXL,NYL,NXPL,NYPL,ALATL,ALONL,MESHB,MESHL, 7 NX,NY,NXP,NYP,MESH,MSHPAS,ITRPLQ, 8 IBACKN,IBACKL,IGUESS,MGUESS,GUESS,IFSTGS, 9 LSTORE,ND9,LITEMS, A IS0,IS1,IS2,IS4,ND7, B IPLAIN(1,1,N),PLAIN(N), C IPACK,IWORK,ND5,MINPK, D CORE,ND10,NBLOCK,NFETCH,MISTOT,NSLAB, E CINT,ORIGIN,SMULT,SADD,TITLE,IOPT, F JTOTBY,JTOTRC,L3264B,L3264W,ISTOP,IER) IF(IER.NE.0)GO TO 500 C NOTE THAT FSTGS HAS FILLED TITLE( ,25:40) WITH DATE. C A FATAL ERROR OF IER = 777 IS RETURNED WHEN A FIRST C GUESS COULD NOT BE OBTAINED OR WHEN A PROBLEM C WITH WRITING TO KFILOG OCCURRED. OTHERWISE, IER = 0. C C MAKE SURE XP( ) AND YP( ) CONFORM THE THE CURRENT FIRST C GUESS GRID. MESH WAS DEFINED IN FSTGS; THIS IS JUST C A SAFETY CHECK. C IF(MESH.NE.MSHPAS(1,MGUESS))THEN CALL NEWXY(KFILDO,MESH,XP,YP,MSHPAS(1,MGUESS),XP,YP,NSTA) C MSHPAS(1,MGUESS) IS FOR THE FIRST PASS AND GUESS C OPTION MGUESS. WRITE(KFILDO,289)MESH,MSHPAS(1,MGUESS) 289 FORMAT(/' ****UNEXPECTED CALL TO NEWXY IN U400A AT 289.', 1 ' MESH =',I8,' MSHPAS(1,MGUESS) =',I8) ISTOP(1)=ISTOP(1)+1 ENDIF C C SET LTAG( ). WHEN LTAG( ) = 1 or 2, THAT STATION'S C VALUE WILL NEVER BE USED. THEREFORE, THE MAXIMUM VALUE OF C R( )*RSTAR( ) FOR THE FIRST GUESS OPTION USED MUST BE C USED IN FLTAG. THIS JUST HAS THE EFFECT OF PERMANENTLY C DISCARDING THE STATIONS FAR OUTSIDE THE GRID. THIS C DISCARDING IS IN RELATION TO THE FIRST GUESS GRIDLENGTH C MESH. THE FIRST GUESS GRIDLENGTH IS NORMALLY AT C LEAST AS LARGE AS ANY OTHER GRIDLENGTH, SO STATIONS C NEEDED ARE NOT DISCARDED; IN ANY CASE THIS JUST C AFFECTS DATA OUTSIDE THE ANALYSIS GRID. RMAX=0. C DO 290 J=1,NPASS IF(NTYPE(J,MGUESS).NE.0)THEN RMAX=MAX(RMAX,R(J,MGUESS)*RSTAR(J,MGUESS)) ENDIF C 290 CONTINUE C C SET LTAG( ). FOR SATURATION DEFICIT, USE DEW POINT IN C DP( ); FOR OTHER VARIABLES, DATA( ) HOLDS THE DATA. C FOR FLTAG, XP, YP, NX, AND NY REFER TO THE CURRENT C FIRST GUESS GRID. AT THIS POINT, LTAG( ) HAS ONLY C VALUES 0, 1, OR 2. C IF(IVRBL.NE.4)THEN CALL FLTAG(KFILDO,DATA,XP,YP,LTAG,NSTA, 1 NX,NY,RMAX) ELSE CALL FLTAG(KFILDO,DP,XP,YP,LTAG,NSTA, 1 NX,NY,RMAX) ENDIF C JSTA=0 C DO 300 K=1,NSTA IF(LTAG(K).EQ.0)JSTA=JSTA+1 300 CONTINUE C IF(JSTA.EQ.0)THEN WRITE(KFILDO,310) 310 FORMAT(/' ****NO STATIONS WITH DATA AVAILABLE', 1 ' FOR ANALYSIS.') ISTOP(1)=ISTOP(1)+1 IER=777 GO TO 5015 ELSEIF(JSTA.LT.200)THEN WRITE(KFILDO,311)JSTA 311 FORMAT(/' ****WARNING, ONLY ',I4,' STATIONS WITH DATA', 1 ' FOR ANALYSIS. PROCEEDING.') ISTOP(2)=ISTOP(2)+1 ELSE WRITE(KFILDO,320)JSTA 320 FORMAT(/' ',I4,' STATIONS WITH DATA THAT MAY BE USED', 1 ' ON ONE OR MORE PASSES') ENDIF C IF(IVRBL.NE.4)GO TO 340 C C THE SECTION BELOW IS FOR SATURATION DEFICIT. C COMPUTE THE CYCLE TIME, ICYCLE. C IF(JDATE(4).GE.06.AND.JDATE(4).LE.17)THEN ICYCLE=0 ELSE ICYCLE=12 ENDIF C C CALCULATE SATURATION DEFICIT, WHEN IT IS THE VARIABLE C BEING DEALT WITH. IT IS SCALED, READY FOR ANALYSIS C IN BCD. C DO 330 K=1,NSTA IF(LTAG(K).EQ.2)THEN DATA(K)=9999. ELSEIF(DP(K).EQ.9999.)THEN C C DEW POINT OB NOT AVAILABLE. CAN STILL USE PRECIP OB C IF AVAILABLE. C IF(WX(K).EQ.9999..OR. 1 WX(K).LE.11..OR. 2 (WX(K).GE.18..AND.WX(K).LE.45.).OR. 3 WX(K).EQ.76..OR. 4 WX(K).GE.204.)THEN DATA(K)=9999. ELSE DATA(K)=-15 IF(LTAG(K).EQ.0)LTAG(K)=-3 C IF LTAG(K) NE 0, THE DATUM CAN'T BE USED. THIS CAN C HAPPEN IF THE DATUM IS OUTSIDE THE ANALYSIS AREA. C LTAG(K) SET = -3 MEANS TO BCD TO NOT TOSS THIS DATUM. ENDIF C ELSE C C DEW POINT OB AVAILABLE. C IF(LTAG(K).EQ.1)THEN DATA(K)=9999. ELSE IF(PW(K).LE..01)PW(K)=.01 C IF(ICYCLE.EQ.0)THEN ELNW=A000+A100*DP(K)+A200*LOG(PW(K)) ELSE ELNW=A012+A112*DP(K)+A212*LOG(PW(K)) ENDIF C TOSS(K)=B0+B1*ELNW+B2*EL(K) C TOSS( ) IS THE ESTIMATE OF (OBSERVED) SATURATION THICKNESS. DATA1=THICK(K)-TOSS(K) C DATA1 IS THE ESTIMATE OF (OBSERVED) SATURATION DEFICIT. C CHECK THREE POSSIBLE CONDITIONS OF WEATHER IN WX( )-- C 9999 (MISSING), 0 (NO WEATHER), OR (WEATHER). C IF(WX(K).EQ.9999.)THEN C IF(DATA1.GT.0.)THEN DATA(K)=DATA1/6.+5. ELSE DATA(K)=5.01 ENDIF C ELSEIF(WX(K).LE.11..OR. 1 (WX(K).GE.18..AND.WX(K).LE.45.).OR. 2 WX(K).EQ.76..OR. 3 WX(K).GE.204.)THEN C IF(DATA1.GT.0.)THEN DATA(K)=DATA1/6.+5. ELSE DATA(K)=10 ENDIF C ELSE DATA(K)=-15 C PRECIP AT STATION, SO OVERRIDE SD ESTIMATE. IF(LTAG(K).EQ.0)LTAG(K)=-3 C IF LTAG(K) NE 0, THE DATUM CAN'T BE USED. THIS CAN C HAPPEN IF THE DATUM IS OUTSIDE THE ANALYSIS AREA. C LTAG(K) SET = -3 MEANS TO BCD TO NOT TOSS THIS DATUM. C NOTE: A SPECIAL TEST WAS PUT INTO ESP FOR THIS 2/18/02. ENDIF C ENDIF C ENDIF C 330 CONTINUE C IF(KFILOV.EQ.0)GO TO 340 C DON'T WRITE WHEN KFILOV = 0 C C WRITE THE PRECIPITABLE WATER AT STATIONS TO KFILOV. C XMISSP=9999.0 XMISSS=0. C LD(1)=003350*1000+NCEPNO LD(2)=0 LD(3)=0 LD(4)=0 CALL PRSID1(KFILDO,LD,LDPARS) C PRSID1 FILLS LDPARS( ) ACCORDING TO LD( ). RACK='PRECIPITABLE WATER ' CALL PACKV(KFILDO,KFILOV,LD,LDPARS, 1 JPP,0,0, 2 IRACK,RACK,NDATE,JDATE(1),JDATE(2),JDATE(3),JDATE(4), 3 CCALL,QUEST,PW,NSTA,NSTA,IPACK,ND5,MINPK, 4 IS0,IS1,IS2,IS4,ND7,XMISSP,XMISSS, 5 IP18,NWORDS,MTOTBY,MTOTRC, 6 L3264B,L3264W,ISTOP,IER) C QUEST( ) IS WORK ARRAY FOR PACKV. IP18 IS USED TO LIST VALUES. C ISCALD IS USED AS 0 FOR PRECIP WATER IN MM. THE VALUES WILL NOT C BE PRINTED IN PACKV. C IF(IP16.NE.0)THEN WRITE(IP16,335)(LD(J),J=1,4),RACK,NDATE 335 FORMAT(/' WRITING DATA TO UNIT KFILOV',3I10.9,I10.3,3X, 1 A32,' FOR DATE',I12) ENDIF C C WRITE THE ELEVATION AT STATIONS TO KFILOV. C LD(1)=409020000 LD(2)=0 LD(3)=0 LD(4)=0 CALL PRSID1(KFILDO,LD,LDPARS) C PRSID1 FILLS LDPARS( ) ACCORDING TO LD( ). RACK='ELEVATION OF GROUND ' CALL PACKV(KFILDO,KFILOV,LD,LDPARS, 1 JPP,0,0, 2 IRACK,RACK,NDATE,JDATE(1),JDATE(2),JDATE(3),JDATE(4), 3 CCALL,QUEST,EL,NSTA,NSTA,IPACK,ND5,MINPK, 4 IS0,IS1,IS2,IS4,ND7,XMISSP,XMISSS, 5 IP18,NWORDS,MTOTBY,MTOTRC, 6 L3264B,L3264W,ISTOP,IER) C QUEST( ) IS WORK ARRAY FOR PACKV. IP18 IS USED TO LIST VALUES. C ISCALD IS USED AS 0 FOR ELEVATIONS IN M. THE VALUES WILL NOT C BE PRINTED IN PACKV. C IF(IP16.NE.0)THEN WRITE(IP16,335)(LD(J),J=1,4),RACK,NDATE ENDIF C C WRITE THE 1000-500 MB THICKNESS AT STATIONS TO KFILOV. C LD(1)=001000000+NCEPNO LD(2)=110000500 LD(3)=0 LD(4)=0 CALL PRSID1(KFILDO,LD,LDPARS) C PRSID1 FILLS LDPARS( ) ACCORDING TO LD( ). RACK='1000-500 MB THICKNESS ' CALL PACKV(KFILDO,KFILOV,LD,LDPARS, 1 JPP,0,0, 2 IRACK,RACK,NDATE,JDATE(1),JDATE(2),JDATE(3),JDATE(4), 3 CCALL,QUEST,THICK,NSTA,NSTA,IPACK,ND5,MINPK, 4 IS0,IS1,IS2,IS4,ND7,XMISSP,XMISSS, 5 IP18,NWORDS,MTOTBY,MTOTRC, 6 L3264B,L3264W,ISTOP,IER) C QUEST( ) IS WORK ARRAY FOR PACKV. IP18 IS USED TO LIST VALUES. C ISCALD IS USED AS 0 FOR THICKNESS IN M. THE VALUES WILL NOT C BE PRINTED IN PACKV. C IF(IP16.NE.0)THEN WRITE(IP16,335)(LD(J),J=1,4),RACK,NDATE ENDIF C C WRITE THE SATURATION THICKNESS AT STATIONS TO KFILOV. C LD(1)=703411000 LD(2)=0 LD(3)=0 LD(4)=0 CALL PRSID1(KFILDO,LD,LDPARS) C PRSID1 FILLS LDPARS( ) ACCORDING TO LD( ). RACK='SATURATION THICKNESS ' CALL PACKV(KFILDO,KFILOV,LD,LDPARS, 1 JPP,1,0, 2 IRACK,RACK,NDATE,JDATE(1),JDATE(2),JDATE(3),JDATE(4), 3 CCALL,QUEST,TOSS,NSTA,NSTA,IPACK,ND5,MINPK, 4 IS0,IS1,IS2,IS4,ND7,XMISSP,XMISSS, 5 IP18,NWORDS,MTOTBY,MTOTRC, 6 L3264B,L3264W,ISTOP,IER) C QUEST( ) IS WORK ARRAY FOR PACKV. IP18 IS USED TO LIST VALUES. C ISCALD IS USED AS 1 FOR SATURATION THICKNESS. THE VALUES WILL NOT C BE PRINTED IN PACKV. C IF(IP16.NE.0)THEN WRITE(IP16,335)(LD(J),J=1,4),RACK,NDATE ENDIF C C WRITE THE SCALED SATURATION DEFICIT AT STATIONS TO KFILOV. C LD(1)=ITABLE(1,2,4) LD(2)=0 LD(3)=0 LD(4)=0 CALL PRSID1(KFILDO,LD,LDPARS) C PRSID1 FILLS LDPARS( ) ACCORDING TO LD( ). RACK='SCALED SATURATION DEFICIT ' CALL PACKV(KFILDO,KFILOV,LD,LDPARS, 1 JPP,1,0, 2 IRACK,RACK,NDATE,JDATE(1),JDATE(2),JDATE(3),JDATE(4), 3 CCALL,QUEST,DATA,NSTA,NSTA,IPACK,ND5,MINPK, 4 IS0,IS1,IS2,IS4,ND7,XMISSP,XMISSS, 5 IP18,NWORDS,MTOTBY,MTOTRC, 6 L3264B,L3264W,ISTOP,IER) C QUEST( ) IS WORK ARRAY FOR PACKV. IP18 IS USED TO LIST VALUES. C ISCALD IS USED AS 1 FOR SATURATION DEFICIT. THE VALUES WILL NOT C BE PRINTED IN PACKV. C IF(IP16.NE.0)THEN WRITE(IP16,335)(LD(J),J=1,4),RACK,NDATE ENDIF C C TURN THE SURFACE WINDS CLOCKWISE BY WNDTRN DEGREES. C 340 IF(IVRBL.NE.1)GO TO 345 C C THE SECTION BELOW IS FOR SEA LEVEL PRESSURE TO PREPARE C FOR USING WINDS IN THE ANALYSIS. C IF(WNDGRD.EQ.0.)GO TO 345 C WHEN WNDGRD = 0, WIND WILL NOT BE USED. C C TURN WIND DIRECTION WNDTRN DEGREES CLOCKWISE. C CALL TRNWND(KFILDO,WDIR,WNDTRN,NSTA) C C*********************************** C THIS SECTION FOR WRITING TURNED WIND FOR VIEWING. C C*** LD(1)=794200000 C*** LD(2)=88*10000 C*** LD(3)=0 C*** LD(4)=0 C*** CALL PRSID1(KFILDO,LD,LDPARS) C***C PRSID1 FILLS LDPARS( ) ACCORDING TO LD( ). C*** RACK='OBSERVED WINDS TURNED WNDTRN DEG' C*** CALL PACKV(KFILDO,KFILOV,LD,LDPARS, C*** 1 JPP,0,0, C*** 2 IRACK,RACK,NDATE,JDATE(1),JDATE(2),JDATE(3),JDATE(4), C*** 3 CCALL,FD6,WDIR,NSTA,NSTA,IPACK,ND5,MINPK, C*** 4 IS0,IS1,IS2,IS4,ND7,9999.,0., C*** 5 IP18,NWORDS,MTOTBY,MTOTRC, C*** 6 L3264B,L3264W,ISTOP,IER) C***C FD6( ) IS WORK ARRAY FOR PACKV. IP18 IS USED TO LIST VALUES. C***C ISCALD IS USED AS ZERO FOR WIND DIRECTION. C***C C*** IF(IP16.NE.0)THEN C*** WRITE(IP16,341)(LD(J),J=1,4),RACK,NDATE C*** 341 FORMAT(/' WRITING DATA TO UNIT KFILOV',3I10.9,I10.3,3X, C*** 1 A32,' FOR DATE',I12) C*** ENDIF C***C C***C THIS SECTION FOR WRITING TURNED WIND FOR VIEWING. C***C C*** LD(1)=794210000 C*** LD(2)=88*10000 C*** LD(3)=0 C*** LD(4)=0 C*** CALL PRSID1(KFILDO,LD,LDPARS) C***C PRSID1 FILLS LDPARS( ) ACCORDING TO LD( ). C*** RACK='OBSERVED WIND SPEED ' C*** CALL PACKV(KFILDO,KFILOV,LD,LDPARS, C*** 1 JPP,0,0, C*** 2 IRACK,RACK,NDATE,JDATE(1),JDATE(2),JDATE(3),JDATE(4), C*** 3 CCALL,FD6,WSPD,NSTA,NSTA,IPACK,ND5,MINPK, C*** 4 IS0,IS1,IS2,IS4,ND7,9999.,0., C*** 5 IP18,NWORDS,MTOTBY,MTOTRC, C*** 6 L3264B,L3264W,ISTOP,IER) C***C FD6( ) IS WORK ARRAY FOR PACKV. IP18 IS USED TO LIST VALUES. C***C ISCALD IS USED AS ZERO FOR WIND DIRECTION. C***C C*** IF(IP16.NE.0)THEN C*** WRITE(IP16,342)(LD(J),J=1,4),RACK,NDATE C*** 342 FORMAT(/' WRITING DATA TO UNIT KFILOV',3I10.9,I10.3,3X, C*** 1 A32,' FOR DATE',I12) C*** ENDIF C*********************************** C C CONVERT SPEED AND DIRECTION INTO GRID ORIENTED U C AND V-COMPONENTS IN U( ) AND V( ), RESPECTIVELY. C ALL ARE IN KT. C CALL DIRTUV(KFILDO,WDIR,WSPD,XPL,YPL,U,V,NSTA, 1 FLOAT(NXPL),FLOAT(NYPL)) C C COMPUTE THE SINE OF THE LATITUDE IN FDSINS( ). C CALL PSMAPF(KFILDO,BMESH*1000.,ORIENT,XLAT,ALATL,ALONL, 1 FDSINS,FD2,NXL,NYL,IER) C MESH LENGTH FOR PSMAPF HAS TO BE IN M, NOT KM. C C PRINT SINE OF THE LATITUDE FOR CHECKOUT. C C***D CALL PRTGR(KFILDO,FDSINS,NXL,NYL, C***D 1 CINT,ORIGIN,100.,0.,IOPTL,SIN,IER) C C CALCULATE THE CHANGE IN PRESSURE IN MB PER GRID UNIT IN THE C X AND Y DIRECTIONS; U( ) AND V( ) ARE USED FOR THS PURPOSE. C WNDGRD IS THE EMPIRICAL FACTOR TO ACCOUNT FOR NON-GEOSTROPHIC C SPEED EFFECTS; THE DIRECTION HAS ALREADY BEEN ACCOUNTED FOR C BY TURNING THE SURFACE WIND CLOCKWISE WNDTRN DEGREES. C IF THE SPEED IS LT WNDTHR, SET U( ) AND V( ) TO MISSING. C CORMSH=FLOAT(MESH)/FLOAT(MESHB) C THE CORRECTION IN MB PER GRID UNIT DEPENDS ON THE GRID C MESH. THE SMALLER THE MESH, THE SMALLER THE CORRECTION C PER UNIT MESH. CORMSH IS USED BELOW TO ADJUST FROM THE C CONSTANTS CALCULATED ON THE BASIS OF 1/4 BEDIENT = MESHB. DO 343 K=1,NSTA C IF(WSPD(K).EQ.9999..OR.WSPD(K).LT.WNDTHR)THEN U(K)=9999. V(K)=9999. ELSE CALL ITRP(FDSINS,NXL,NYL,XPL(K),YPL(K),SINLAT) C SINLAT IS THE SINE OF THE LATITUDE AT STATION K C INTERPOLATED FROM FDSINS( , ). FAC=SINLAT*(1.+SINLAT)*CORMSH C FAC IS (SINPHI)(1+SINPHI) OF THE STATION. U(K)=-.16*WNDGRD*FAC*U(K) V(K)= .16*WNDGRD*FAC*V(K) C*** WRITE(KFILDO,342)K,MESH,MESHB,SINLAT,FAC,CORMSH,WNDGRD, C*** 1 U(K),V(K) C*** 342 FORMAT(' IN U400A--K,MESH,MESHB,SINLAT,FAC,CORMSH,WNDGRD,', C*** 1 'U(K),V(K)',3I4,6F10.3) C WITH SPEED IN KT, THE GEOSTROPHIC MB CHANGE PER NOMINAL 80 KM C GRID UNIT IS 1.47 M/GRID UNIT * 1 MB/9M = .16 MB/GRID UNIT ENDIF C 343 CONTINUE C C AT THIS POINT, P( ) CONTAINS THE FIRST GUESS, SCALED IF IT IS C SATURATION DEFICIT, AND DATA( ) CONTAINS THE DATA TO ANALYZE, C SCALED IF SATURATION DEFICIT. NOTE THAT THE TYPE OF FIRST C GUESS IS USED TO REDUCE THE DIMENSIONALITY OF SEVERAL VARIABLES, C AND THE MONTH, JDATE(2), IS FURTHER USED TO REDUCE THE C DIMENSIONALITY OF ER1( , , ). C 345 CALL BCD(KFILDO,KFILOG,KFILOV,KFILQC, 1 IP16,IP17,IP18,IP19,IP20,IP21,IP22,I400ADG, 2 ID(1,N),IDPARS(1,N),JP(1,N),IVRBL,LAMPNO,ISCALD(N),NDATE, 3 JDATE,DATA,CCALL,XP,YP,XPL,YPL,TOSS,QUEST,LTAG,NSTA, 4 P,FD2,FD3,FD4,FD5,ND2X3,NX,NY,NXP,NYP, 5 IPACK,IWORK,ND5,MINPK, 6 IS0,IS1,IS2,IS4,ND7, 7 ITABLE(1,2,IVRBL),IPLAIN(1,1,N),PLAIN(N), 8 NPROJ,ORIENT,MESH,MESHB,MESHL,XLAT, 9 MSHPAS(1,MGUESS),ER1(1,MGUESS,JDATE(2)),NTYPE(1,MGUESS), A B(1,MGUESS),R(1,MGUESS),RSTAR(1,MGUESS),ITRPLQ(1,MGUESS), B NSMTYP,U,V,WNDWT(1,MGUESS),WNDGRD,WNDTHR,WNDTRN, C NPRT,JPRT,NTDL,JTDL,NPASS, D CINT,ORIGIN,SMULT,SADD,TITLE,IOPT, E JTOTBY,JTOTRC,MTOTBY,MTOTRC,ITOTBY,ITOTRC, F L3264B,L3264W,ISTOP,IER) C IER ALWAYS EQUALS 0 ON RETURN FROM BCD. C C RESCALE WHEN THE ANALYSIS IS SATURATION DEFICIT. NEGATIVES C ARE SET TO -.06 RATHER THAN -.04 AS IN OLD VERSION BECAUSE C PACKING IS ONLY TO TENTHS, AND THE -.04 COMES OUT ZERO AND C ON A GRIDPRINT, FOR INSTANCE, THERE IS NO ZERO LINE. THE C -.06 ROUNDS TO -.1 AND IS KEPT. NOTE THAT VALUES BETWEEN C 0 AND 6 INCLUSIVE ARE LEFT INTACT. C IF(IVRBL.EQ.4)THEN C DO 350 IXY=1,NX*NY C IF(P(IXY).GT.6.)THEN P(IXY)=P(IXY)*6.-30. ELSEIF(P(IXY).LT.0.)THEN P(IXY)=-.06 ENDIF C 350 CONTINUE C C READ RADAR DATA. NOTE THAT RADARS AND SDOVER DO C NOT HAVE AN ERROR RETURN. KFIRST AND KSECND INDICATE C AVAILABILITY OF RADAR DATA TO SDOVER. UNAVAILABILITY C OF RADAR DATA DOES NOT STOP RUN. C CALL RADARS(KFILDO,KFIL10,KFILOG,IP16,IP22,NDATE, 1 FD2,FD3,FD4,FD5,FD6,U,ND2X3, 2 NPROJ,ORIENT,XLAT, 3 NXL,NYL,NXPL,NYPL,ALATL,ALONL,MESHB,MESHL, 4 NX,NY,NXP,NYP,MESH, 5 LSTORE,LITEMS,ND9, 6 IS0,IS1,IS2,IS4,ND7, 7 IPACK,IWORK,ND5, 8 CORE,ND10,NBLOCK,NFETCH,NSLAB,IOPT, 9 JTOTBY,JTOTRC,LAMPNO,MINPK, A KFIRST,KSECND, B L3264B,L3264W,ISTOP) C C OVERRIDE AS NECESSARY WHERE PRECIP IS INDICATED. C CALL SDOVER(KFILDO, 1 P,FD2,FD3,FD4,FD5,ND2X3, 2 KFIRST,KSECND,NX,NY) C IF(KFILOG.EQ.0.AND.IP22.EQ.0)GO TO 450 C C PREPARE FOR GRIDPRINTING AND/OR TDLPACKING. C TITLEX(1:40)=TITLE(1:40) TITLEX(1:24)='SATURATION DEFICIT ANAL' C THE ABOVE KEEPS TITLE INTACT AND PUTS DATE/TIME INTO C TITLEX. 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,DATA,NX*NY) CALL SIZEGR(KFILDO,DATA,NXG,NYG,NXPG,NYPG, 1 MESHG,MESHL,ITRPLQ(1,MGUESS),ND2X3) C THE SAME INTERPOLATION IS USED (IF NEEDED) AS IS SPECIFIED C FOR DEFINING THE FIRST PASS. C C GRIDPRINT SATURATION DEFICIT ANALYSIS IF DESIRED. C IF(IP22.NE.0.AND.JP(1,N).NE.0)THEN CALL PRTGR(IP22,DATA,NXG,NYG, 1 CINT(NPASS)*6,ORIGIN(NPASS),SMULT(NPASS), 2 SADD(NPASS),IOPT,TITLEX,IER) C THE PRINT PARAMETERS FOR THE LAST PASS ARE USED. C CINT( ) AS READ PERTAINS TO THE SCALED VALUES. MULTIPLY C BY 6 TO GET A REASONABLE VALUE FOR THE UNSCALED VALUES C GRIDPRINTED HERE. C THE ONLY NON ZERO IER FROM PRTGR IS SCALING OVERFLOW. C DO NOT TREAT AS FATAL ERROR. ENDIF C C TDLPACK AND WRITE SATURATION DEFICIT ANALYSIS IF DESIRED. C IF(KFILOG.NE.0.AND.JP(2,N).NE.0)THEN ITAUH=0 ITAUM=0 NSEQ=0 NCHAR=32 C 32 CHARACTERS OF PLAIN LANGUAGE ARE PACKED. XMISSP=0 XMISSS=0 C THIS IS AN ANALYSIS AND NO MISSING VALUES ARE C PROVIDED FOR. IF THERE EVER ARE, JUST SET XMISSP=9999, C OR WHATEVER THE MISSING VALUE IS. C C THE GRID IN DATA( ) 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,DATA,NXG,NYG,NXPG,NYPG, 1 DATA,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 GENPAK. ALATD=NINT(ALATD*1000)/1000. ALOND=NINT(ALOND*1000)/1000. CALL PAWOTG(KFILDO,KFILOG,IP16,NDATE, 1 ID(1,N),ITAUH,ITAUM,LAMPNO,NSEQ,ISCALD(N), 2 NPROJ,ALATD,ALOND,ORIENT,MESHL,XLAT,NXD,NYD, 3 DATA,FD3,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) C IF(IER.NE.0)THEN ISTOP(1)=ISTOP(1)+1 C ERROR IN PAWOTG NOT TREATED AS FATAL. ENDIF C ENDIF C ENDIF C C PACK AND WRITE THE ANALYSIS TO THE INTERNAL STORAGE SYSTEM. C IT IS WRITTEN AT THE MESH LENGTH = MESH, WHICH WILL C BE MSHPAS( , ) FOR THE LAST PASS. C 450 ITAUM=0 NSEQ=0 NCHAR=32 C 32 CHARACTERS OF PLAIN LANGUAGE ARE PACKED. XMISSP=0. XMISSS=0. C THESE ARE ANALYSES AND NO MISSING VALUES ARE PROVIDED FOR. C IF THERE EVER ARE, JUST SET XMISSP=9999, OR WHATEVER THE C MISSING VALUE IS. NOTE THAT THE ID IN ID( , ) IS USED, C WHICH WOULD NORMALLY HAVE THE SMOOTHING VARIABLE S = 0, C NO MATTER WHETHER THE ANALYSIS HAS BEEN SMOOTHED OR NOT. CALL PAWING(KFILDO,KFIL10,NDATE, 1 ID(1,N),IDPARS(12,N),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)GO TO 600 C ANY ERROR FROM PAWING SHOULD BE TREATED AS FATAL. 500 CONTINUE C IF(IFIND.EQ.0)THEN WRITE(KFILDO,501) 501 FORMAT(/' ****NO VARIABLE IN U400A RECOGNIZED') IER=777 ENDIF C 5015 IF(IER.EQ.0)THEN WRITE(KFILDO,502)(JDATE(J),J=1,4) 502 FORMAT(/' U400A HAS SUCCESSFULLY COMPLETED FOR DATE/TIME ', 1 I5,3I3.2,'00.') ELSE WRITE(KFILDO,503)(JDATE(J),J=1,4) 503 FORMAT(/' U400A HAS COMPLETED WITH AN ERROR FOR DATE/TIME ', 1 I5,3I3.2,'00.') ISTOP(1)=ISTOP(1)+1 ENDIF C GO TO 700 C C FOR THIS DEVELOPMENTAL PROGRAM, IF ALL VARIABLES CAN'T BE C ANALYZED, THE PROGRAM WILL NOT COMPLETE. THIS IS INDICATED C BY IER = 777. 600 IER=777 ISTOP(1)=ISTOP(1)+1 C C SAVE JDATE( ) IN SAVDAT( ) FOR USE ON NEXT ENTRY. C 700 SAVDAT(1)=JDATE(1) SAVDAT(2)=JDATE(2) SAVDAT(3)=JDATE(3) SAVDAT(4)=JDATE(4) 800 RETURN C C ERROR STOP BELOW IS FOR ERRORS OF CONTROL INFORMATION INPUT. 900 CALL IERX(KFILDO,KFILDO,IOS,'U400A ',STATE) IER=9999 GOTO 800 END