SUBROUTINE U400B(KFILDI,KFILDO,KFIL10,KFILOG,KFILOV,KFILQC, 1 IP16,IP17,IP18,IP19,IP20,IP21,IP22, 2 CCALL,STALAT,STALON,XP,YP,XPL,YPL,ITOSS,IQUEST, 3 LTAG,WDIR,WSPD,NSTA,ND1, 4 P,P1,P2,FD4,FD5,FD6,FD7,FD8,FD9,ND2X3, 5 ID,IDPARS,JD,JP,ISCALD,w 6 IPLAIN,PLAIN,NPRED,ND4, 7 IPACK,DATA,SDATA,IWORK,ND5, 8 NCEPNO,LAMPNO,NDATE, 9 ALATL,ALONL,NPROJ,ORIENT,XLAT, A NXL,NYL,NXPL,NYPL,MESHB,MESHL,IOPTB, B IS0,IS1,IS2,IS4,ND7, C LSTORE,LITEMS,ND9, D CORE,ND10,NBLOCK, E JTOTBY,JTOTRC,MTOTBY,MTOTRC,ITOTBY,ITOTRC, F L3264B,L3264W,MISTOT,MINPK,ISTOP,IER) C C SEPTEMBER 2000 GLAHN TDL LAMP-2000 C DECEMBER 2000 GLAHN CHANGED IOPT( ) TO IOPTB( ) IN CALL; C ADDED TRANSFORMATION TO IOPT( ) C FEBRUARY 2001 GLAHN ADDED DIAGNOSTIC FORMAT 272 IN C 2 PLACES C FEBRUARY 2001 GLAHN MODIFIED TO WRITE VECTOR RECORD WITH C TOSSED OBS AS MISSING; ADDED KFILOV, C ITOSS( ), AND IQUEST( ); CHANGED C IDPARS(12,N) TO JPROJ( ) IN CALLS C TO PAWING; CHANGED DO 280 J=1,6 TO C J=1,NPASS C FEBRUARY 2001 GLAHN ADDED KFILQC C FEBRUARY 2001 GLAHN CHANGED JPROJ(4)=JPROJ(2) TO C JPROJ(4) = JPROJ(3) BELOW 111 C FEBRUARY 2001 GLAHN DEFINED D = WDIR(K)/DEGRAD ABOVE 275; C FEBRUARY 2001 GLAHN SUBSTITUTED XPL( ) AND YPL( ) FOR C XP( ) AND YP( ) IN CALCULATION OF C GRID ORIENTED WINDS. C MARCH 2001 GLAHN MODIFIED CALL TO BCDW C MARCH 2001 GLAHN INSERTED CALL TO DIRTUV C MARCH 2001 GLAHN ZEROED IOPT( ) WHEN IOPTB(1)=0 C MARCH 2001 GLAHN ADDED NSMTYP; MESHB TO CALL TO BCDW C MARCH 2001 GLAHN CHANGED ITABLE FOR KT NOT M/S AND C ELIMINATED 10 FROM ID(2) C MARCH 2001 GLAHN ADDED PLAIN TO CALL TO FSTGSW C MARCH 2001 GLAHN ELIMINATED ONE ICOUNT IN CALL TO BCDW C MARCH 2001 GLAHN CHANGED IDS IN ITABLE TO GRID-ORIENTED C MARCH 2001 GLAHN ADDED WRITING ANALYZED VECTOR AND C GRID DIRECTION; ADDED JTABLE( , ) AND C KEYED DIR AND SPEED INPUT TO IT C AUGUST 2001 GLAHN ADDED CHECK FOR NO STATIONS TO ANALYZE C SEPTEMBER 2001 GLAHN ADDED IVRBL(4) TO TEST ABOVE 112 C SEPTEMBER 2001 GLAHN ADDED DATE TO FORMAT 1220 C OCTOBER 2001 GLAHN ADDED CALL TO TIMER AT START C MAY 2002 GLAHN ADDED I400BDG C AUGUST 2002 GLAHN MADE FORMAT 112 **** C DECEMBER 2002 RUDACK MODIFIED FORMAT STATEMENTS TO ADHERE C TO THE F90 COMPILER STANDARDS FOUND ON C THE IBM SYSTEM C DECEMBER 2002 GLAHN ADDED ISTOP(2) C FEBRUARY 2003 GLAHN MADE IBACKN COMMENT THE SAME AS IN C OTHER ROUTINES; SPELL CHECKED C MARCH 2005 WIEDENFELD ADDED QC CHECK ON WIND OBSERVATIONS C NEAR LOOP 275. SEE IN LINE DOCUMENTATION 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_wndanly.cn. C NOVEMBER 2012 GHIRARDELLI MODIFIED TO PASS PLAIN TO PAWING C WHICH WAS MODIFIED FOR INTEL CHANGES C C PURPOSE C PROGRAM U400B IS THE ANALYSIS PROGRAM FOR WIND SPEED AND C DIRECTION. ENTRY INTO U400B WILL PRODUCE AN ANALYSIS C OF ALL OF THE VARIABLES IN ITABLE( ,J), U-WIND (J=1), C V-WIND (J=2), AND WIND SPEED (J=3), PROVIDED AT LEAST C ONE IS IN ID( , ). C C C FATAL ERRORS, IER: C 777 FROM FSTGSW--CANNOT OBTAIN A FIRST GUESS. C C ISTOP INCREMENTS: C FROM FSTGSW--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 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 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. (OUTPUT) 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 STALAT(K) = LATITUDE OF STATIONS (K=1,NSTA). THIS IS C ONLY USED FOR POSSIBLE PRINTING AT STATEMENT C 276. (INPUT) C STALON(K) = LONGITUDE OF STATIONS (K=1,NSTA). THIS IS C ONLY USED FOR POSSIBLE PRINTING AT STATEMENT C 276. (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. (INPUT) 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. (INPUT) C ITOSS(K) = FOR USE IN BCDW. NELEV( ) IN CALLING PROGRAM C U400B (K=1,NSTA). (INTERNAL) C IQUEST(K) = FOR USE IN BCDW. IWBAN( ) IN CALLING PROGRAM C U400B (K=1,NSTA). (INTERNAL) C LTAG(K) = DENOTES USE OF DATA IN DATA(K) AND SDATA(K) C FOR STATION K (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). (INTERNAL) C WSPD(K) = OBSERVED WIND SPEED (K=1,NSTA). (INTERNAL) C NSTA = NUMBER OF STATIONS OR LOCATIONS BEING DEALT C WITH. (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 AND ANALYSIS (I=1,NXL) (J=1,NYL) C OF THE WIND U-WIND COMPONENT. (OUTPUT) C P1(I,J) = THE FIRST GUESS AND ANALYSIS (I=1,NXL) (J=1,NYL) C OF THE WIND V-WIND COMPONENT. (OUTPUT) C P2(I,J) = THE FIRST GUESS AND ANALYSIS (I=1,NXL) (J=1,NYL) C OF THE WIND SPEED. (OUTPUT) C FD4(J), FD5(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 ND2X3 = THE DIMENSION OF SEVERAL ARRAYS = ND2*ND3 IN C 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 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(K) = OBSERVED U-WIND, FIRST EARTH ORIENTED THEN C GRID ORIENTED (K=1,NSTA). (INTERNAL) C SDATA(K) = OBSERVED V-WIND, FIRST EARTH ORIENTED THEN C GRID ORIENTED (K=1,NSTA). (INTERNAL) C IWORK(J) = WORK ARRAY (J=1,ND5). (INTERNAL) C ND5 = DIMENSION OF IPACK( ), IWORK( ), DATA( ) C AND SDATA( ). (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 OF LOWER LEFT CORNER POINT C OF A 1/4 B GRID OF THE SIZE ETC. SPECIFIED C BY NXL, NYL, NXPL, AND NYPL. (INPUT) C ALONL = WEST LONGITUDE OF LOWER LEFT CORNER POINT C OF A 1/4 B GRID OF THE SIZE ETC. SPECIFIED C 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 (INPUT) C NXL = THE SIZE OF THE DESIRED (FINAL) GRID FOR THIS C RUN IN THE X DIRECTION. (INPUT) C NYL = THE SIZE OF THE DESIRED (FINAL) GRID FOR THIS C RUN IN THE Y DIRECTION. (INPUT) C NXPL = POLE POSITION OF THE DESIRED (FINAL) GRID FOR C THIS RUN IN RELATION TO LOWER LEFT CORNER OF C GRID AT (1,1) IN THE X DIRECTION. (INPUT) C NYPL = POLE POSITION OF THE DESIRED (FINAL)GRID FOR C THIS RUN IN RELATION TO LOWER LEFT CORNER OF C GRID AT (1,1) IN THE Y DIRECTION. (INPUT) C MESHB = THE NOMINAL MESH LENGTH OF 1/4 BEDIENT GRID. C 1/4 BEDIENT AT 60 N IS 95.25 KM WHICH IS ABOUT C 80 KM OVER THE U.S. MESH = 80 CORRESPONDS TO C 95.25 STORED WITH THE GRIDS. NXL, NYL, ETC. C ARE IN RELATION TO THIS. C MESHL = NOMINAL MESH LENGTH OF QUALITY CONTROL C (SUBSETTED) GRID FOR CONTINUOUS VARIABLES. 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 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. C JTOTRC = THE TOTAL NUMBER OF RECORDS IN THE FILE ON UNIT C NUMBER KFILOG. 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. C ITOTRC = THE TOTAL NUMBER OF RECORDS IN THE FILE ON UNIT C NUMBER KFILQC. 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,J) = 4-WORD ID OF THE VARIABLES THAT ARE C ACCOMMODATED BY U400B (I=1,4) (J=1,NVAL) C THESE ARE THE IDS THAT WOULD APPEAR IN THE C U150.CN FILE. C J = 1--004051005 000000010; U-WIND (KT) C J = 2--004151005 000000010; V-WIND (KT) C J = 3--004221005 000000010; WIND SPEED (KT) C J = 4--004201005 000000010; WIND DIRECTION (DEG) C U, V, AND DIRECTION ARE GRID-ORIENTED ON A C CONSTANT HEIGHT SURFACE. (INTERNAL) C JTABLE(I,J) = 4-WORD ID OF THE VARIABLES THAT ARE C ACCOMMODATED BY U400B (I=1,4) (J=1,NVAL) C THESE ARE VARIABLES ASSOCIATED ONE TO ONE C WITH THOSE IN ITABLE( , ) THAT ARE NEEDED C FOR INPUT OR OUTPUT IDS. C J = 1--704061000 000000000; U-WIND (KT) C J = 2--704161000 000000000; V-WIND (KT) C J = 3--704210000 000000000; WIND SPEED (KT) C J = 4--704200005 000000000; WIND DIRECTION (DEG) C U, V, AND DIRECTION ARE EARTH-ORIENTED ON A C CONSTANT HEIGHT SURFACE. (INTERNAL) C DOTCN = THE SPECIFIC .CN FILE FOR THE VARIABLE BEING C ANALYZED, CORRESPONDING TO ITABLE ( ,1). C IT IS ASSUMED THE CONTROL FILE WILL BE IN C 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 I400BDG = 1 = DIAGNOSTIC PRINT TO KFILDO; C 0 OTHERWISE. (INTERNAL) C MSHPAS(J,L) = THE NOMINAL MESH LENGTH FOR EACH PASS C (J=1,NPASS) FOR EACH FIRST GUESS OPTION C (L=1,4). (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 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 CHECK C THE 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 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. (INTERNAL) C IFIRST = COUNTS ENTRIES INTO U400B. 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 WHID SPEED WHEN C IGUESS(1) IS ACTIVATED. THE CONSTANT FIRST C GUESS FOR THE WIND COMPONENTS IS ZERO. C (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 FSTGSW. C DEGRAD = DEGREES PER RADIAN. SET BY PARAMETER. 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 IVRBL(J) = THE NUMBER OF THE VARIABLE IN THE ID( ) LIST C OF THE THREE WIND VARIABLES, U, V, AND SPEED C FOR J = 1, 2, AND 3, RESPECTIVELY. IVRBL(J) C = 99 MEANS THE CORRESPONDING VARIABLE FOR J C IS NOT IN THE LIST AND WILL NOT BE WRITTEN TO C THE DISPOSABLE FILE. (INTERNAL) C ISCD(J) = THE SCALING FACTOR FOR EACH OF THE THREE C WIND VARIABLES, U, V, AND SPEED FOR J = 1, 2, C AND 3, RESPECTIVELY. C JPROJ(J) = THE PROJECTION FOR EACH OF THE WIND VARIABLES, C U, V, SPEED, AND DIRECTION FOR J = 1, 2, 3, C AND 4, RESPECTIVELY. (INTERNAL) C JPP(J,N) = INDICATES WHETHER THE U WIND (N=1), V WIND C (N=2), SPEED (N=3), OR DIRECTION (N=4) MAY C HAVE GRIDPRINTS (J=1), OR INTERMEDIATE TDLPACK C OUTPUT (J=2), OR PRINT OF VECTOR RECORDS IN C PACKV (J=3) (N=1,ND4). (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 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 TITLE(J) = TITLES FOR FOUR WIND VARIABLES, U, V, S, AND C DIR (J=1,4). (CHARACTER*40) (INTERNAL) C C 1 2 3 4 5 6 7 X C NONSYSTEM SUBROUTINES USED C FSTGSW, BCDW, FLTAG, GFETCH, IERX, NEWXY C PARAMETER(DEGRAD=180./3.1416) PARAMETER (NVAL=4) C CHARACTER*4 STATE CHARACTER*8 CCALL(ND1,6) CHARACTER*14 DOTCN CHARACTER*32 PLAIN(ND4) CHARACTER*40 TITLE(NVAL) C DIMENSION XP(ND1),YP(ND1),XPL(ND1),YPL(ND1), 1 LTAG(ND1),STALAT(ND1),STALON(ND1), 2 SDATA(ND1),WDIR(ND1),WSPD(ND1),ITOSS(ND1),IQUEST(ND1) DIMENSION P(ND2X3),P1(ND2X3),P2(ND2X3) DIMENSION FD4(ND2X3),FD5(ND2X3),FD6(ND2X3),FD7(ND2X3), 1 FD8(ND2X3),FD9(ND2X3) DIMENSION ISCALD(ND4) 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) DIMENSION CORE(ND10) DIMENSION MSHPAS(6,4),ER1(6,4,12),ERD(6,4),FLSL(6,4),NTYPE(6,4), 1 B(6,4),R(6,4),ITRPLQ(6,4),RSTAR(6,4) DIMENSION SMULT(6),SADD(6),ORIGIN(6),CINT(6), 1 NPRT(6),JPRT(6),NTDL(6),JTDL(6) DIMENSION ITABLE(4,NVAL),JTABLE(4,NVAL),IGUESS(4),LD(4),ISTOP(2) DIMENSION IOPTB(8),IOPT(8),JDATE(4),IVRBL(NVAL),ISCD(NVAL), 1 JPROJ(NVAL),JPP(3,NVAL),SAVDAT(4) C DATA ITABLE/004051005,10,0,0, 1 004151005,10,0,0, 2 004221005,10,0,0, 3 004201005,10,0,0/ DATA JTABLE/704061000,0,0,0, 1 704161000,0,0,0, 2 704210000,0,0,0, 3 704200000,0,0,0/ DATA DOTCN/'lmp_wndanly.cn'/ DATA TITLE/'SFC U-WIND ', 1 'SFC V-WIND ', 2 'SFC WIND SPEED ', 3 'SFC WIND DIR '/ DATA IFIRST/0/, 1 LIMIT/1/ C SAVE SAVDAT C D WRITE(KFILDO,100) D100 FORMAT(' ') D CALL TIMPR(KFILDO,KFILDO,'START U400B ') C IER=0 IFIRST=IFIRST+1 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 VERIFY THAT EITHER A WIND COMPONENT OR WIND C SPEED IS INDICATED IN ID( , ). C DO 111 J=1,NVAL IVRBL(J)=99 ISCD(J)=0 JPROJ(J)=0 JPP(1,J)=0 JPP(2,J)=0 JPP(3,J)=0 C C PLACE THE U, V, SPEED, AND DIRECTION PARAMETERS C ORDERED THAT WAY IN IVRBL( ), ETC. NOTE THAT WIND DIRECTION C MAY NOT BE IN THE VARIABLE LIST, SO ASSUMPTIONS ARE MADE. C THE PROJECTION FOR J = 4 IS TAKEN FROM THE SPEED COMPONENT; C OTHER VALUES ARE LEFT AT ZERO, WHICH PACKS DIRECTION TO THE C NEAREST DEGREE. C DO 110 N=1,NPRED C IF(ID(1,N).EQ.ITABLE(1,J))THEN IVRBL(J)=N ISCD(J)=ISCALD(N) JPROJ(J)=IDPARS(12,N) JPP(1,J)=JP(1,N) JPP(2,J)=JP(2,N) JPP(3,J)=JP(3,N) GO TO 111 ENDIF C 110 CONTINUE C 111 CONTINUE C IF(IVRBL(4).EQ.99)THEN JPROJ(4)=JPROJ(3) ENDIF C IF(IVRBL(1).NE.99.OR.IVRBL(2).NE.99.OR. 1 IVRBL(3).NE.99.OR.IVRBL(4).NE.99)GO TO 120 WRITE(KFILDO,112) 112 FORMAT(/' ****NO VARIABLE IN U400B RECOGNIZED') IER=777 GO TO 500 C C READ CONTROL INFORMATION. C 120 STATE='120 ' OPEN(UNIT=KFILDI,FILE=DOTCN,STATUS='OLD', 1 IOSTAT=IOS,ERR=900) C C READ AND WRITE ANALYSIS SPECIFIC CONTROL PARAMETERS. C STATE='122 ' READ(KFILDI,122,IOSTAT=IOS,ERR=900)NPASS,IFSTGS, 1 (IGUESS(J),J=1,4),IBACKN,IBACKL,GUESS,NSMTYP,I400BDG 122 FORMAT(8I4,F8.0,17X,2I4) NPASS=MIN(NPASS,6) C NPASS IS LIMITED TO 6 BY DIMENSION OF VARIABLES. WRITE(KFILDO,1220)(JDATE(J),J=1,4) 1220 FORMAT(/' STARTING ANALYSIS FOR WIND U, V, AND S', 1 ' FOR DATE/TIME ',I5,2I3,I3.2,'00.', 2 ' $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$') C IF(IFIRST.LE.LIMIT)WRITE(KFILDO,123) 1 ((ITABLE(J,M),J=1,4),TITLE(M)(1:16),M=1,3) 123 FORMAT(/' ANALYSIS SPECIFIC CONTROL PARAMETERS FOR ', 1 3I10.9,I10.3,3X,A16/(43X,3I10.9,I10.3,3X,A16)) C IF(IFIRST.LE.LIMIT)WRITE(KFILDO,124)NPASS,IFSTGS, 1 (IGUESS(J),J=1,4),IBACKN,IBACKL,GUESS,NSMTYP,I400BDG, 2 (TITLE(J)(1:16),J=1,3) 124 FORMAT(/' NPASS, IFSTGS, IGUESS(1-4), IBACKN, IBACKL,', 1 ' GUESS, NSMTYP, I400BDG, TITLE'/ 2 I7,I8,I7,3I2,I8,I10,F11.2,I8,I11,3X,3(2X,A16)) C C READ MESH LENGTH TO USE FOR EACH PASS FOR EACH POSSIBILITY C 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 FOR WIND SPEED TO USE FOR EACH C PASS FOR EACH POSSIBILITY OF FIRST GUESS. C STATE='140 ' C DO 143 M=1,12 DO 142 L=1,4 READ(KFILDI,139,IOSTAT=IOS,ERR=900)(ER1(J,L,M),J=1,NPASS) 139 FORMAT(6F8.0) C IF(IFIRST.LE.LIMIT)THEN IF(L.EQ.1.AND.M.EQ.JDATE(2))WRITE(KFILDO,140)NPASS,M 140 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,141)L,(ER1(J,L,M),J=1,NPASS) 141 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6F8.2) ENDIF C ENDIF C 142 CONTINUE 143 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 1435 L=1,4 C IF(L.EQ.1)THEN WRITE(KFILDO,1430)NPASS,JDATE(2) 1430 FORMAT(/' ER1 FOR ',I3,' PASSES FOR MONTH',I3) ENDIF C WRITE(KFILDO,141)L,(ER1(J,L,JDATE(2)),J=1,NPASS) 1435 CONTINUE C ENDIF C C READ ERROR CRITERIA FOR WIND DIRECTION TO USE FOR EACH C PASS FOR EACH POSSIBILITY OF FIRST GUESS. C STATE='144 ' C DO 146 L=1,4 READ(KFILDI,139,IOSTAT=IOS,ERR=900)(ERD(J,L),J=1,NPASS) C IF(IFIRST.LE.LIMIT)THEN IF(L.EQ.1)WRITE(KFILDO,144)NPASS 144 FORMAT(' ERD FOR ',I3,' PASSES') WRITE(KFILDO,145)L,(ERD(J,L),J=1,NPASS) 145 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6F8.2) ENDIF C 146 CONTINUE C C READ MINIMUM WIND SPEED FOR WHICH WIND DIRECTION C ERROR CRITERION ERD(J) IS USED FOR EACH C PASS FOR EACH POSSIBILITY OF FIRST GUESS. C STATE='147 ' C DO 149 L=1,4 READ(KFILDI,139,IOSTAT=IOS,ERR=900)(FLSL(J,L),J=1,NPASS) C IF(IFIRST.LE.LIMIT)THEN IF(L.EQ.1)WRITE(KFILDO,147)NPASS 147 FORMAT(' FLSL FOR ',I3,' PASSES') WRITE(KFILDO,148)L,(FLSL(J,L),J=1,NPASS) 148 FORMAT(' FOR FIRST GUESS OPTION',I2,4X,6F8.2) ENDIF C 149 CONTINUE C 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,139,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,139,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. STATE='190 ' C DO 195 L=1,4 READ(KFILDI,139,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,139,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,139,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,139,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,139,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) CLOSE(UNIT=KFILDI) C C GET THE WIND DIRECTION AND WIND SPEED IN WDIR( ) AND C WSPD( ), RESPECTIVELY. C LD(1)=JTABLE(1,4) C JTABLE(1,4) IS 704200000. LD(2)=0 LD(3)=0 LD(4)=0 CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,WDIR,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,272)(LD(J),J=1,4),NDATE 272 FORMAT(/' ****DATA FOR ANALYSIS =',3(1X,I9.9),1X,I10.3, 1 ' COULD NOT BE OBTAINED IN U400B 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,273)NWORDS,NSTA 273 FORMAT(/' ****THE NUMBER OF DATA VALUES READ',I6, 1 ' DOES NOT MATCH THE NUMBER OF STATIONS READ',I5, 2 ' IN THE DIRECTORY RECORD.'/ 3 ' FATAL ERROR IN U400B FOR THIS DATE.') GO TO 600 C ENDIF C LD(1)=JTABLE(1,3) C JTABLE(1,3) IS 704210000 LD(2)=0 LD(3)=0 LD(4)=0 CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,WSPD,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,272)(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,273)NWORDS,NSTA GO TO 600 ENDIF C C PERFORM A QUICK QC ON WIND OBSERVATIONS. IT IS POSSIBLE C TO HAVE A WIND DIRECTION = 990.0 (LIGHT AND VARIABLE) C IN THIS CASE SET BOTH WDIR AND WSPD TO 9999. IF WDIR OR C WSPD ARE MISSING SET BOTH TO MISSING. C DO 275 K=1,NSTA IF(WDIR(K).GT.360..OR.WDIR(K).LT.0..OR. 1 WSPD(K).EQ.9999..OR.WSPD(K).LT.0.)THEN WDIR(K)=9999. WSPD(K)=9999. ENDIF 275 CONTINUE C C CONVERT SPEED AND DIRECTION INTO GRID ORIENTED U C AND V-COMPONENTS IN DATA( ) AND SDATA( ), RESPECTIVELY. C CALL DIRTUV(KFILDO,WDIR,WSPD,XPL,YPL,DATA,SDATA,NSTA, 1 FLOAT(NXPL),FLOAT(NYPL)) 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 FSTGSW. C THAT IS, THE VALUES READ FOR THE FIRST PASS C ANALYSIS WILL ALSO BE USED FOR THE FIRST GUESS. C NOTE THAT THE SAME VALUE OF CINT( ) ETC. WILL BE C USED FOR U AND V COMPONENTS AND SPEED IN P( ), C P1( ), AND P2( ). C CALL FSTGSW(KFILDO,KFIL10,KFILOG,IP16,IP22,NDATE, 1 ITABLE,JPP,ISCD,IVRBL, 2 DATA,SDATA,XP,YP,XPL,YPL,ND1,NSTA, 3 P,P1,P2,FD4,FD5,FD6,ND2X3, 4 NCEPNO,LAMPNO,NPROJ,ORIENT,XLAT, 5 NXL,NYL,NXPL,NYPL,ALATL,ALONL,MESHB,MESHL, 6 NX,NY,NXP,NYP,MESH,MSHPAS,ITRPLQ, 7 IBACKN,IBACKL,IGUESS,MGUESS,GUESS,IFSTGS, 8 LSTORE,LITEMS,ND9, 9 IS0,IS1,IS2,IS4,ND7, A IPLAIN,PLAIN,ND4, B IPACK,IWORK,ND5,MINPK, C CORE,ND10,NBLOCK,NFETCH,MISTOT,NSLAB, D CINT,ORIGIN,SMULT,SADD,TITLE,IOPT, E JTOTBY,JTOTRC,L3264B,L3264W,ISTOP,IER) C NOTE THAT FSTGSW 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. IF(IER.NE.0)GO TO 500 C C MAKE SURE XP( ) AND YP( ) CONFORM THE THE CURRENT FIRST C GUESS GRID. 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,279)MESH,MSHPAS(1,MGUESS) 279 FORMAT(/' ****UNEXPECTED CALL TO NEWXY IN U400B AT 279.', 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 280 J=1,NPASS IF(NTYPE(J,MGUESS).NE.0)THEN RMAX=MAX(RMAX,R(J,MGUESS)*RSTAR(J,MGUESS)) ENDIF C 280 CONTINUE C CALL FLTAG(KFILDO,DATA,XP,YP,LTAG,NSTA, 1 NX,NY,RMAX) 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. DATA( ) AND SDATA( ) CONTAIN THE C WIND COMPONENTS; IF ONE IS OK, THE OTHER IS ALSO, SO C ONLY ONE NEEDS BE CHECKED. 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 C AT THIS POINT, P( ), P1( ), AND P2( ) CONTAIN THE C FIRST GUESS, AND DATA( ) CONTAINS THE U WIND, SDATA( ) C THE V WIND, WDIR( ) THE WIND DIRECTION AND WSPD( ) THE C WIND SPEED. NOTE THAT THE TYPE OF FIRST GUESS IS USED C TO REDUCE THE DIMENSIONALITY OF SEVERAL VARIABLES, C AND THE MONTH, JDATE(2), IS FURTHER USED TO REDUCE THE C DIMENSIONALITY OF ER1( , , ). C CALL BCDW(KFILDO,KFILOG,KFILOV,KFILQC, 1 IP16,IP17,IP18,IP19,IP20,IP21,IP22,I400BDG, 2 ITABLE,JTABLE,NVAL,JPP,LAMPNO,ISCD,IVRBL, 3 NDATE,JDATE,DATA,SDATA,WDIR,WSPD,CCALL, 4 XP,YP,XPL,YPL,ITOSS,IQUEST,LTAG,NSTA, 5 P,P1,P2,FD4,FD5,FD6,FD7,FD8,FD9,ND2X3, 6 NX,NY,NXP,NYP, 7 IPACK,IWORK,ND5,MINPK, 8 IS0,IS1,IS2,IS4,ND7, 9 IPLAIN,PLAIN,ND4, A NPROJ,ORIENT,MESH,MESHB,MESHL,XLAT, B MSHPAS(1,MGUESS),ER1(1,MGUESS,JDATE(2)),ERD(1,MGUESS), C FLSL(1,MGUESS),NTYPE(1,MGUESS), D B(1,MGUESS),R(1,MGUESS),RSTAR(1,MGUESS), E ITRPLQ(1,MGUESS),NSMTYP, F NPRT,JPRT,NTDL,JTDL,NPASS, G CINT,ORIGIN,SMULT,SADD,TITLE,IOPT, H JTOTBY,JTOTRC,MTOTBY,MTOTRC,ITOTBY,ITOTRC, I L3264B,L3264W,ISTOP,IER) C IER ALWAYS EQUALS 0 ON RETURN FROM BCD. C C PACK AND WRITE THE FINAL ANALYSES TO THE INTERNAL STORAGE C SYSTEM. THEY ARE WRITTEN AT THE MESH LENGTH = MESH, WHICH WILL C BE MSHPAS( , ) FOR THE LAST PASS. C ITAUH=0 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. CALL PAWING(KFILDO,KFIL10,NDATE, 1 ITABLE(1,1),JPROJ(1),ITAUM,LAMPNO,NSEQ,ISCD(1), 3 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,IVRBL(1)),PLAIN(IVRBL(1)),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. CALL PAWING(KFILDO,KFIL10,NDATE, 1 ITABLE(1,2),JPROJ(2),ITAUM,LAMPNO,NSEQ,ISCD(2), 2 NPROJ,ALATL,ALONL,ORIENT,MESHB,MESH,XLAT,NX,NY, 3 P1,DATA,IWORK,IPACK,ND5,MINPK, 4 LSTORE,ND9,LITEMS,CORE,ND10,NBLOCK, 5 IS0,IS1,IS2,IS4,ND7, 6 IPLAIN(1,1,IVRBL(2)),PLAIN(IVRBL(1)),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. CALL PAWING(KFILDO,KFIL10,NDATE, 1 ITABLE(1,3),JPROJ(3),ITAUM,LAMPNO,NSEQ,ISCD(3), 2 NPROJ,ALATL,ALONL,ORIENT,MESHB,MESH,XLAT,NX,NY, 3 P2,DATA,IWORK,IPACK,ND5,MINPK, 4 LSTORE,ND9,LITEMS,CORE,ND10,NBLOCK, 5 IS0,IS1,IS2,IS4,ND7, 6 IPLAIN(1,1,IVRBL(3)),PLAIN(IVRBL(1)),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 C 5015 IF(IER.EQ.0)THEN WRITE(KFILDO,502)(JDATE(J),J=1,4) 502 FORMAT(/' U400B HAS SUCCESSFULLY COMPLETED FOR DATE/TIME ', 1 I5,3I3.2,'00.') ELSE WRITE(KFILDO,503)(JDATE(J),J=1,4) 503 FORMAT(/' U400B 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,'U400B ',STATE) IER=9999 GOTO 800 END