C$$$ MAIN PROGRAM DOCUMENTATION BLOCK C . . . . C MAIN PROGRAM: PREPACQC QC'S, TRACK CHK'S & SUPEROBS AIRCFT RPTS C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 2008-12-16 C C ABSTRACT: C READS IN BUFR/PREPDA FILE CONTAINING ALL PREPROCESSED DATA TYPES. C SORTS BY STATION ID, DOES TRACK CHECKING, AND AGGRAGATES OBS BY POSI C (CALLED A 'STACK'). DOES QUALITY CONTROL BY MAKING TRACK CHECKS C ON FLIGHTS, REMOVING DUPLICATES, COMPARING COLOCATED OBSERVATIONS, C AND, IF REQUESTED, FORMING SUPEROBS OF THOSE WINDS PASSING THE C QUALITY CHECKS. A SERIES OF BUFR/PREPDA QUALITY MARKS C ARE ATTACHED TO EACH OBSERVATION (SEE REMARKS). FINALLY: C WRITES STACKED EVENTS (CONSISTING OF THE C UPDATED BUFR/PREPDA QUALITY MARKS) ONTO THE EXISTING BUFR/PREPDA C DATA. THE NEW FILE CONTAINS ALL OF THE ORIGINAL C OBSERVATIONAL DATA (P-ALT, TEMP, WIND) MINUS THE DUPLICATES AND C THOSE OUTSIDE THE DESIRED TIME WINDOW. IF APPLICABLE, ADDITIONAL C SUPEROBS WILL BE ADDED. OBSERVATIONS THAT ARE USED TO GENERATE C A SUPEROB ARE FLAGGED IN THE WIND AND TEMPERATURE QUALITY MARKERS C TO ENSURE THAT THEY ARE OMITTED FROM THE ANALYSIS SCHEME. AIREP/ C PIREP AND SUPEROB REPORTS OVER CONTINENTAL U.S. AND SURROUNDING C ENVIRONS MAY ALSO BE FLAGGED AND EXCLUDED FROM ANALYSIS SCHEME C IF REQUESTED (APPLICABLE ONLY FOR BUFR/PREPDA INPUT/OUTPUT). C C PROGRAM HISTORY LOG: C 89-04-01 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR C 90-03-29 P. JULIAN -- MODIFIED TO HONOR SDM/QCAIRCFT PURGE FOR C STACKED OBSERVATIONS (OBS. INCRMENT CHECK) C 90-04-16 P. JULIAN -- MODIFIED TO PACK SUPEROBS ONE AT A C TIME ON SINGLE LEVELS ONLY C 90-06-14 D. A. KEYSER -- INCLUDED PROCESSING OF TEMP; CORRECTED C ERROR LEADING TO LOSS OF SOME OBS. IN REPACKING; COR- C RECTED TO HONOR ALL SDM/QCAIRCFT PURGES FOR STACKED C OBS. AND ALL SDM KEEPS FOR ISOLATED OBS.; CORRECTED C SLIGHT ERROR IN LAT/LON IN OUTPUT FILE FOR SOME OBS. C 90-07-03 D. A. KEYSER -- SOME OMIT Q.M. INCORRECTLY CHGED, FIXED; C ALT. CORRESP. TO PRESS. OF 300 & 200 MB FOR REGRESS. C CALC. OF SUPEROBS OFF SLIGHTLY, FIXED; ADDED 1 TO C OUTPUT TIME FOR MULT. SUPEROBS IN SAME STACK W/ SAME C ORIG. TIME (SO OI WON'T TOSS AS DUPLICATES) C 90-09-18 D. A. KEYSER -- MINOR ERROR IN LOGIC CORRECTED, SOME ORIG. C REPORTS WERE BEING GIVEN 'O' Q. MARK BY MISTAKE C 90-11-08 D. A. KEYSER -- INCREASED ARRAY SIZES FROM 2000 TO 8000 C TO ALLOW FOR ACARS REPORTS WHICH CAN HAVE .GT. 2000 C REPORTS IN THE 'AIRCAR' FILE ***OVER-RIDDEN** C 91-02-26 G. J. DIMEGO -- ADDED FT05 INPUT FOR VARIABLE WINDOW C AND A VARIABLE TIME-INCREMENT FOR MULTI-LEVEL SUPROBS C AND ADDED CALL TO QSORT TO ENSURE ASCENDING LATITUDE C 91-12-04 D. A. KEYSER -- ALL ASDAR REPORTS NOW CONSIDERED ISO- C LATED OBS. AND CANNOT BE USED TO FORM A SUPEROB, C PRIOR TO CHANGE ASDAR REPORTS COULD BE SUPEROBED C 92-09-02 D. A. KEYSER -- THE SDM/QCAIRCFT PURGE FLAG IS NOW C OBTAINED IN THE FIRST POSITION OF THE Q. M. WORD RATHER C THAN THE FOURTH POSITION C 93-01-05 P. JULIAN-- THIS VERSION CONSIDERABLY REVISED OVER THAT C ABOVE. NEW SUBPROGRAMS ADDED TO DO TRACK CHECK. TEMPS C ARE NOW QC'D WITH NEW SUBPROGRAM. ENTIRE NEW SET OF C ON29(REVISED) Q MARKS USED. SEE OFFICE NOTE XXX FOR C DETAILS-ALSO DOCBLOCKS IN SUBPROGRAMS C 93-06-05 P. JULIAN-- THIS VERSION REVISED TO PRODUCE CODE FOR C EITHER HDS OR CRAY. SORT ROUTINES ARE LOCAL. C 94-01-01 P. JULIAN-- THIS VERSION REVISED TO PRODUCE CODE FOR C OPERATIONAL USE. QUAL MARKS REVISED ONCE AGAIN C 94-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT; ADDED C REPACKING OF ORIGINAL RESERVE CHARACTER INFO PLUS OTHER C META-DATA IN ON29 CATEGORY 8 FOR NON-SUPEROBED REPORTS; C ADDED ABILITY TO I/O A BUFR/PREPDA FILE AND ADD STACKED C EVENTS CONSISTING OF UPDATED WIND AND TEMPERATURE C QUALITY MARKERS; SEVERAL ERRORS DETECTED AND CORRECTED C 95-02-10 D. A. KEYSER -- MINOR CHANGE TO ALLOW WAYPOINT CORRECTED C LAT/LON TO BE CARRIED BACK TO CALLING SUBROUTINE FOR C WAYPOINT CALL REASON 3 (WASN'T BEING DONE BEFORE); C WAYPOINT CALL IN MAIN FOR ISOLATED REPORTS ALSO WAS NOT C RESETTING LAT/LON AND TAGS WHEN WAYPOINT CORR. MADE; C ADDED COND. CODE 24 IF NO. RPTS. IN A TRACK EXCEEDS C PARAMETER "ITMX", THIS IS BUMPED UP FROM 40 TO 500; C PARAMETER "ISMX" IS BUMPED UP FROM 64 TO 128 C 95-03-27 D. A. KEYSER -- ASDAR/AMDAR TMP/WND RPTS NOT FLAGGED BY C OTHER CHKS NOW GET "GOOD" Q.M. (& FOR INIDST=2, NEW RSN. C CODE 28) REGARDLESS OF SCALED VECTOR INCR. (BEFORE Q.M. C BASED ON S.V. INCR.); ALL ASDAR/AMDAR RPTS IN A TRACK W/ C AVG. INCR. > 70 KTS AMONGST > 14 RPTS. GET FLAGGED WIND C (& LATER TEMP) (& FOR INIDST=2, NEW RSN. CODE 27); ADDED C NEW SUBR. CMDDFF (WIND U/V TO SPD/DIR); FOR INIDST=2, C STORES FORECAST(GUESS) P-ALT, WIND DIR, WIND SPEED & TEMP C FOR EACH DECODED RPT (DIR/SPEED OBTAINED FROM FCST U/V); C FOR INIDST=2 & DOSPOB=T: SUPEROBS NOW CONTAIN S-OBED FCST C P-ALT, WIND DIR, WIND SPEED & TEMP (IF AVAIL. FROM INDIV. C RPTS MAKING UP SUPEROBS), FCST INFO. THEN ENCODED IN BUFR C ALONG W/ REST OF S-OB DATA (FCST DIR/SPEED CONV. TO U/V); C N-LIST SWITCHES "JAMASS" & "JAWIND" NOW 6-WORD ARRAYS, C REPORTS CAN NOW BE EXCLUDED FROM OUTPUT ACCORDING TO C LAT. BAND; N-LIST SWITCH "FLAGUS"(LOGICAL) REPLACED BY C "IFLGUS"(INTEGER), WHERE IFLGUS=0(1) EQUATES TO C FLAGUS=F(T) AND NEW CHOICE IFLGUS=2 MEANS EXCLUDE RPTS C OVER U.S. FROM OUTPUT RATHER THAN JUST FLAGGING C 95-04-26 D. A. KEYSER -- CORRECTED PROBLEM IN SUPEROBING GUESS C (OCCASIONALLY OCCURRED); ALL ASDAR/AMDAR RPTS IN A TRACK C W/ > 14 RPTS GET FLAGGED WIND (& LATER TEMP) IF > 9 RPTS C HAVE WIND INCR. > 50 KNOTS (CHANGE FROM PREVIOUS TEST, C SEE PREVIOUS HISTORY LOG); ADDED 300 TO REASON CODES C TO PREPARE FOR NEW BUFR USER TABLE, ORIGINAL REASON C CODE VALUES ARE STILL ENCODED INTO BUFR DUE TO 8-BIT C LIMIT IN CURRENT USER TABLE; PROGRAM CODE STILL ENCODED C INTO BUFR BUT ITS VALUE HARDWIRED TO 7 (IN PREP. FOR C NEW BUFR USER TABLE WHICH WILL NO LONGER HAVE PGM CODE) C 95-05-30 D. A. KEYSER -- ADDED PARAMETER NAME "LSIZE" FOR MAX. C NO. OF LAT/LON CORRECTIONS IN WAYPOINT FILE, ADDED C COND. CODE 25 IF PARAMETER NAME "LSIZE" IS EXCEEDED; C IN SUBR. INDEXF/INDEXC, TESTS FOR < 2 ELEMENTS IN SORT C LIST, IF SO RETURNS W/O SORTING (BUT FILLS INDX ARRAY); C THE INPUT TIME WINDOW IS NOW SET TO THE LARGER OF 3-HRS C 15-MIN OR INPUT NAMELIST SWITCH "WINDOW" PLUS 15-MIN, C ALLOWING THE TRACK CHECKING TO DE DONE PROPERLY C (PREVIOUSLY THIS WAS SET TO "WINDOW" PLUS 15-MIN., BUT C THIS COULD ADVERSELY AFFECT THE TRACK CHECK FOR SMALL C OUTPUT TIME WINDOWS); RECEIPT TIME TEST CHANGED TO CHECK C FOR DATA WITH RECEIPT TIME OUTSIDE THE RANGE OF REPORT C TIME MINUS 1-HOUR TO REPORT TIME PLUS 11.99 HOURS (SUCH C REPORTS ARE SKIPPED), BEFORE ONLY TESTED FOR RECEIPT C TIME OUTSIDE RANGE OF REPORT TIME MINUS 1-HOUR; ADDED C NAMELIST SWITCH "RCPTST", IF FALSE THEN THE RECEIPT TIME C TEST IS NOT PERFORMED C 95-07-06 D. A. KEYSER -- ADDED CHECK FOR ALL REPORTS WITH C ALTITUDE BETWEEN 2000 & 5000 FT., IF TEMPERATURE DIFFERS C FROM GUESS BY > 25 DEG. C THE WIND AND TEMPERATURE ARE C FLAGGED AS BAD (AND ARE ASSIGNED THE NEW REASON CODE C "302" FOR OUTPUT TO BUFR/PREPDA FILE) {REPORT IS FLAGGED C HERE BECAUSE A "0" DIGIT HAS PROBABLY BEEN DROPPED FROM C THE TRUE ALTITUDE BETWEEN 20,000 & 50,000 FT.}; FIXED C TIME WINDOW CHECK TO HANDLE REPORTS IN FILES THAT HAVE C A TIME OF 0100 TO 0500 UTC (SIMILAR TO WHAT OCCURS FOR C 0000 UTC FILE TIME); REPORTS IN A STACK OF TWO NOW GET C TEMPERATURE AND WIND FLAGGED AS BAD (AND ARE ASSIGNED C THE NEW REASON CODE "329" FOR OUTPUT TO BUFR/PREPDA C FILE) IF THE SCALED VECTOR WIND INCREMENT IS LARGE C (IN THE RANGE 'V' TO 'Z'), A SUPEROB IS NEVER STORED; C IN SUBR. IDSORT, NO LONGER SETS CHAR. ' ' TO '0' IN C WORKING STNID ARRAY PRIOR TO IDSORT (WAS BREAKING-UP C SOME TRACKS AND WAS NEVER NEEDED FOR ANY OTHER REASON) C 97-02-25 M. KANAMITSU -- MODIFICATION TO RUN ON ANY WORKSTATIONS C ON29 PART REMOVED C 2008-12-16 D. A. KEYSER -- IN RESPONSE TO CHANGE FROM SINGLE LEVEL C TO DELAYED REPLICATION FOR "AIRCFT" REPORT LEVEL DATA NOW C IN PREPBUFR FILE {IN PREPARATION FOR NRL AIRCRAFT QC C PROGRAM WHICH WILL REPLACE THE REAL-TIME PRODUCTION C VERSION OF THIS PROGRAM (PREPOBS_PREPACQC) IN THE RUC, C NAM, NDAS, GFS, GDAS AND CDAS NETWORKS AND CAN GENERATE C AIRCRAFT "PROFILES"}, RECEIPT TIME (RCT) (WHICH IS NOW C PART OF LEVEL DATA) IS NO LONGER RETRIEVED IN SAME CALL C TO UFBINT AS REMAINING SINGLE-LEVEL HEADER DATA (TO AVOID C BUFRLIB ERROR) (ALL LEVEL DATA HERE STILL HAS JUST ONE C REPLICATION AT THIS POINT) C C USAGE: C INPUT FILES: C UNIT 05 - NAMELIST INPUT C UNIT 14 - BUFR/PREPDA FILE CONTAINING ALL DATA C UNIT 15 - SEQUENTIAL FILE HOLDING FIXED FIELDS: N.H. 1 DEG. C LAT/LON GRID LAND/SEA INDICATOR; S.H. 2.5 DEG. C LAT/LON GRID LAND/SEA INDICATOR; N.H. U.S.-MAINLAND/ C GULF-OF-MEX/S.-ONTARIO 1 DEG LAT/LON YES/NO INDICATOR C NMC.PROD.SFIX.GRIDS C UNIT 23 - TEXT FILE CONTAINING WAYPOINT CORRECTIONS C NMC.PROD.AIRCFT.WAYPTS C (READ IN WHEN NAMELIST SWITCH WAYPIN=.TRUE.) C C OUTPUT FILES: C JOBLOG - (JCL DDNAME/NAS MACH. ONLY) NMC PRODUCTION JOBLOG FILE C UNIT 06 - PRINTOUT C UNIT 52 - TEXT FILE FOR SDM PERUSAL (LIST OF ISOLATED REPORTS C - THAT ARE FLAGGED FOR NON-USE BY THIS PROGRAM) C UNIT 53 - TEXT FILE FOR SDM PERUSAL (LIST OF STACKED REPORTS C - WITH AVERAGE VECTOR WIND INCREMENT .GT. NAMELIST C - VARIABLE 'STCLIM', ALSO LIST OF STACKED REPORTS WITH C - AT LEAST ONE REPORT IN STACK CONTAINING SDM KEEP FLAG) C UNIT 61 - BUFR/PREPDA FILE CONTAINING ALL DATA (NOW WITH ACFT QC) C C SUBPROGRAMS CALLED: C UNIQUE: - SUPROB SHEAR AVEROB RPACKR STATS INDEXF LAPSE C - INDEXC TRKCHK WAYPT ACOUNT PRELIM IDSORT FORSDM C - NOEQ2 CHOOSE AVEDIR DBUFR IBUFR OBUFR SUBFR C - CMDDFF C LIBRARY: C COMMON C (NAS): - XMOVEX XSTORE C W3LIB C (NAS): - W3FI04 W3AI39 W3FS21 C W3LIB C (CRAY): - W3FI04 XSTORE XMOVEX W3AI39 W3FS21 C BUFR.O C (CRAY): - OPENBF READMG READSB UFBINT CLOSBF OPENMB UFBCPY C WRITSB UFBCNT COPYMG CLOSMG C C REMARKS: SEE COMMENT CARDS FOLLOWING DOCBLOCK. C COMPLETE WRITE-UP CAN BE FOUND IN OFFICE NOTE 358. NOTE THAT C ALL WIND SPEEDS HERE ARE IN KNOTS. THE FOLLOWING DESCRIBE C THE COMMON BLOCKS IN THIS PROGRAM: C /ALLDAT/ -- CONTAINS ARRAYS FOR ALL AIRCRAFT OBSERVATIONS C /SUMDAT/ -- CONTAINS ARRAYS FOR ONLY GROUP OF STACKED OBS. C ARRAY ISTCPT: C -- KEEPS SERIAL COUNT OF OBS. IN STACK, WITH THE C -- INTEGER COUNT REPLACED BY 0 FOR A REJECTED C -- REPORT AND -1 FOR A REPORT NOT TREATED BECAUSE C -- OF ALTITUDE OR OTHER REASONS. ARRAY IFLEPT DOES C -- THE SAME THING HOWEVER THE INDEXING IS WITH C -- RESPECT TO THE NUMBER IN THE STACK FOR ISTCPT C C THE NEW (UPDATED) QUALITY MARKERS ARE DEFINED AS FOLLOWS: C (WHERE: 'T' IS TEMPERATURE, 'W' IS WIND; N/A IS NOT APPLICABLE) C C ON29 BUFR/PREPDA C ORIGINAL SDM KEEP FLAG MAINTAINED (T/W) ......... 'H' 0 C CHECKED BY THIS PROGRAM AND GOOD (T/W) .......... 'A' 1 C ORIGINAL DATA NOT CHECKED BY THIS PROGRAM (T/W) . ' ' 2 C ORIGINAL DATA MISSING (T/W) ..................... ' ' 15 C CHECKED BY THIS PROGRAM AND SUSPECT (T/W) ....... 'Q' 3 C CHECKED BY THIS PROGRAM AND BAD/FAILED (T/W) .... 'F' 13 C OMIT FLAG -- USED TO GENERATE SUPEROB (T/W) ..... 'O' 10 C ORIGINAL SDM/QCAIRCFT PURGE FLAG MAINTAINED (T/W) 'P' 14 C NEW SUPEROBED REPORT (STNID IS 'SUPROB') (T/W) .. 'S' 1 C FLAGGED REPORT OVER CONTINENTAL U.S. (T/W) ...... N/A 15 C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS, SGI, SUN, HP, DEC C C ***** VARIABLES IN NAMELIST INPUT READ IN MAIN PROGRAM ***** C C INIDST - TYPE OF INPUT FILE C INIDST=2 ---> BUFR PREPDA FILE IN UNIT 14 C DOSPOB - SWITCH TO FORM SUPEROBS C DOSPOB=.TRUE. ---> FORM SUPEROBS (DEFAULT) C DOSPOB=.FALSE. --> DO NOT FORM SUPEROBS C DOACRS - RUN WITH ACARS AIRCRAFT FILE C DOACRS=.TRUE. ---> RUN WITH ACARS FILE C DOACRS=.FALSE. --> DO NOT RUN WITH ACARS FILE (DEFAULT) C (NOTE: THIS SWITCH NOT INVOKED -- CAN NOT RUN W/ ACARS FILE) C WINDOW - TIME WINDOW FOR REPORTS TO BE OUTPUT BY THIS PROGRAM (IF C WINDOW=X, TIME WINDOW IS +/- X HOURS OF CYCLE TIME) C (DEFAULT=3.00, 6-HOUR TOTAL WINDOW) C C {NOTE: THE MAXIMUM VALUE FOR WINDOW IS 5.75 (5-HOURS, C 45-MINUTES; ANYTHING LARGER WILL RESULT IN ERROR!} C C (NOTE: FOR INPUT, THE TIME WINDOW IS SET TO THE LARGER OF C 3-HOURS 15-MINUTES OR "WINDOW" PLUS 15-MINUTES. C THIS ALLOWS THE TRACK CHECKING TO BE DONE PROPERLY. C ON OUTPUT, THE VALUE OF "WINDOW" IS USED - ALL C REPORTS OUTSIDE WINDOW ARE OMITTED FROM OUTPUT) C TIMINC - TIME INCREMENT (IN HOURS/100) ADDED TO EACH OCCURRENCE C OF A MULTI-LEVEL SUPEROB (STARTING WITH ORIGINAL TIME) C TO PREVENT RGL/OI FROM TOSSING AS DUPLICATES C (NOTE: IF TIMINC=10., PREVENTS UNIFIED FERR CODE FROM RE- C CONSTRUCTING A PROFILE) C (DEFAULT=1.00, ADD ONE-HUNDREDTH OF AN HOUR TO EACH) C RCPTST - SWITCH TO PERFORM THE RECEIPT-TIME TEST C RCPTST=.TRUE. ---> PERFORM THE TEST (DEFAULT) C RCPTST=.FALSE. --> DO NOT PERFORM THE TEST C (NOTE: THE RECEIPT TIME TEST CHECKS FOR REPORTS WITH A C STRANGE RECEIPT TIME COMPARED TO THE REPORT TIME - C MAY BE YESTERDAY'S REPORT PROCESSED TODAY -- C IF THE RECEIPT TIME IS OUTSIDE THE RANGE OF REPORT C TIME MINUS 1-HOUR TO REPORT TIME PLUS 11.99 HOURS, THE C REPORT IS SKIPPED SINCE ITS VALIDITY IS IN QUESTION) C STCLIM - LIMIT FOR THE AVERAGE VECTOR WIND INCREMENT IN STACK FOR C WHICH SDM PRINT TO UNIT 53 OCCURS (KNOTS) (DEFAULT=41.9) C WAYPIN - SWITCH FOR INPUT WAYPOINT CORRECTION INFORMATION C WAYPIN=.TRUE. ---> FROM EXTERNAL FILE (UNIT 23) C WAYPIN=.FALSE. --> FROM INTERNAL DATA STATEMNTS (DEFAULT) C C N O T E -- THE FOLLOWING 6-WORD ARRAYS REFER TO SIX LATITUDE C BANDS: -90 TO -70, -70 TO -20, -20 TO 0, 0 TO 20, C 20 TO 70, AND 70 TO 90 DEGREES (N +) C C JAMASS - PROCESS AIRCRAFT MASS REPORTS ON OUTPUT? C JAMASS=0 ---> YES, PROCESS MASS REPORTS C JAMASS=9999 ---> NO, DO NOT PROCESS MASS REPORTS C (DEFAULT=JAMASS(6)/6*0/) C JAWIND - PROCESS AIRCRAFT WIND REPORTS ON OUTPUT? C JAWIND=0 ---> YES, PROCESS WIND REPORTS C JAWIND=9999 ---> NO, DO NOT PROCESS WIND REPORTS C (DEFAULT=JAWIND(6)/6*0/) C IFLGUS - WHEN IFLGUS=1 OR 2 ---> WILL DO THE FOLLOWING TO C CONVENTIONAL AIREP/PIREP AIRCRAFT REPORTS OVER U.S. C MAINLAND/GULF OF AMERICA/SOUTHERN ONTARIO: C IF THERE ARE AT LEAST TWO TABLE A ENTRY 'AIRCAR' BUFR C MESSAGES READ IN PRIOR TO READING IN THE FIRST "AIRCFT" C BUFR MESSAGE: C 1) WILL EXCLUDE SUCH RPTS FROM SDM LISTING IN UNIT 52 C 2) WILL FLAG SUCH RPTS FOR NON-USE BY ANALYSIS BY C SETTING TEMPERATURE AND WIND QUALITY MARKERS TO 15 C IF IFLGUS=1; WILL EXCLUDE SUCH RPTS FROM BEING C OUTPUT IF IFLGUS=2 C - WHEN IFLGUS=0 ---> REPORTS ARE NOT CHECKED FOR C GEOGRAPHICAL LOCATION C (DEFAULT: IFLGUS=1) C FWRITE - SWITCH TO GET STANDARD OUTPUT PRINTOUT OF FINAL LISTING C OF ORIGINAL REPORTS IN AIRCFT FILE WITH NEW Q. MARKS C FWRITE=.TRUE. ---> PRODUCE PRINTOUT C FWRITE=.FALSE. --> NO PRINTOUT (DEFAULT) C SWRITE - SWITCH TO GET STANDARD OUTPUT PRINTOUT FOR STATISTICS C SWRITE=.TRUE. ---> PRODUCE PRINTOUT C SWRITE=.FALSE. --> NO PRINTOUT (DEFAULT) C IWRITE - SWITCH TO GET STANDARD OUTPUT PRINTOUT OF INPUT LISTING C OF ORIGINAL REPORTS IN AIRCFT FILE BEFORE IDSORT, AFTER C IDSORT, AND AFTER TRACK CHECK C IWRITE=.TRUE. ---> PRODUCE PRINTOUT C IWRITE=.FALSE. --> NO PRINTOUT (DEFAULT) C C PARAMETER NAME "IRMX" THROUGHOUT THIS PROGRAM SETS THE MAXIMUM C NUMBER OF ACFT RPTS THAN CAN BE UNPACKED FROM THE INPUT FILE CHOSEN C PARAMETER NAME "ISMX" THROUGHOUT THIS PROGRAM SETS THE MAXIMUM C NUMBER OF ACFT RPTS THAT CAN BE TREATED IN A STACK c changed 10/8/2001 PARAMETER (IRMX= 5000, ISMX= 500) c PARAMETER (IRMX=10000, ISMX= 500) c changed 11/25/2000 PARAMETER (IRMX=100000, ISMX= 500) C PARAMETER NAME "ISUP" THROUGHOUT THIS PROGRAM SETS THE MAXIMUM C NUMBER OF SUPEROBED REPORTS THAT CAN BE PROCESSED PARAMETER (ISUP= 250) C PARAMETER NAME "ISIZE" THROUGHOUT THIS PROGRAM SETS THE NUMBER OF C VARIABLES THAT ARE AFFECTED BY THE SORTS ID IDSORT AND TRKCHK C (EXCLUDING STATION ID AND THE TAGS WHICH ARE IN SEPARATE ARRAYS) C C*********************************************************************** C FOR INPUT/OUTPUT BUFR/PREPDA C*********************************************************************** C C INPUT AIRCFT TABLE A ENTRY MESSAGE QUALITY MARKER SITUATION - C (P-ALTITUDE, TEMPERATURE. MOISTURE AND WIND) C C WILL CONTAIN VALUE OF 14 IF EITHER QCAIRCFT OR SDM HAS PURGED C ELSE WILL CONTAIN VALUE OF 0 IF SDM KEEPS C ELSE WILL CONTAIN DEFAULT VALUE OF 2 C ELSE WILL CONTAIN A VALUE OF 15 IF DATA ARE MISSING C C OTHER INPUT REPORT INFORMATION AS INDICATED: C C +++ CONTAINS PROPER AIRCRAFT FLIGHT NUMBER (UP TO EIGHT CHARACTERS) C +++ CONTAINS SCALED VECTOR WIND INCREMENT (IF INIDST=0,1: FROM PGM C "QCAIRCFT" USING 6-HR GDAS FCST; IF INIDST=2: USES ASSIMILATING C FORECAST DIRECTLY, ASSUMING FCST U AND V ARE IN BUFR DATA C +++ CONTAINS CARSWELL-TINKER INDICATOR (AS REPORT SUBTYPE) C +++ CONTAINS RECEIPT TIME (HOURS) C +++ CONTAINS INSTRUMENT TYPE C C C OUTPUT QUALITY MARKER SITUATION - SEE DOCBLOCK REMARKS C (P-ALTITUDE, TEMPERATURE. MOISTURE AND WIND) C C C EVENTS WRITTEN BY THIS PROGRAM INTO OUTPUT BUFR/PREPDA FILE: C NOTE: AN EVENT CAN ONLY CHANGE A VARIABLE'S QUALITY MARKER, C THE OBSERVED VARIABLE ITSELF IS NEVER CHANGED. C IF THE OBSERVED VARIABLE IS MISSING, THE EVENT IS C NOT ACTIVE. C VARIABLE C EVENT SUBR. MEANING QUAL. MARK C ----- ------ -------------------------------------------- ---------- C 301 MAIN CARSWELL/TINKER CONVERTED PIREP REPORT TEMP=13 C (ID=XX999). TEMPERATURE AND/OR WIND WIND=13 C CONSIDERED BAD. C 302 MAIN REPORT WITH ALTITUDE BETWEEN 2000 & 5000 FT. TEMP=13 C WITH TEMPERATURE THAT DIFFERS FROM GUESS WIND=13 C BY > 25 DEG. C {PROBABLY DUE TO "0" DIGIT C DROPPED FROM REPORTED ALTITUDE (TRUE C ALTITUDE BETWEEN 20,000 & 50,000 FT.)} C TEMPERATURE AND/OR WIND CONSIDERED BAD. C 303 MAIN REPORT WITH NON-MISSING TEMPERATURE GREATER TEMP=13 C THAN 12 DEG. C. TEMPERATURE CONSIDERED BAD. C 304 MAIN REPORT WITH CALM WIND NOT FROM A DIRECTION WIND=13 C OF 360 DEG. WIND CONSIDERED BAD. C 305 MAIN PIREP REPORT (ID=P...P) WITH VECTOR WIND TEMP=13 C INCREMENT GREATER THAN 20 KNOTS, OR WITH WIND=13 C UNKNOWN VECTOR WIND INCREMENT. TEMPERATURE C AND/OR WIND CONSIDERED BAD. C 306 MAIN REPORT WITH A CALM WIND IN A STACK OF LESS WIND=13 C THAN 7 CO-LOCATED REPORTS WITH LESS THAN 4 C REPORTS HAVING A CALM WIND. WIND CONSIDERED C BAD. C 307 TRKCHK MID- OR HIGH-LEVEL ASDAR/AMDAR REPORT IN A WIND=13 C TRACK WITH AN UNREASONABLE GROUND SPEED AND C VECTOR WIND INCREMENT GREATER THAN 70 KNOTS. C WIND CONSIDERED BAD. C 308 TRKCHK THIS ONE OF A PAIR OF AIREP/PIREP REPORTS WIND=13 C IN A TRACK IS DETERMINED TO BE A TYPE 2A C DUPLICATE. WIND CONSIDERED BAD. C 309 TRKCHK THIS ONE OF A PAIR OF AIREP/PIREP REPORTS WIND=13 C IN A TRACK IS DETERMINED TO HAVE A TYPE 3 C ERROR. WIND CONSIDERED BAD. C 310 TRKCHK THIS ONE OF SEVERAL (> 2) AIREP/PIREP WIND=13 C REPORTS IN A TRACK IS DETERMINED TO HAVE A C TYPE 3 ERROR. WIND CONSIDERED BAD. C 311 TRKCHK THIS ONE OF SEVERAL (> 2) AIREP/PIREP WIND=13 C REPORTS IN A TRACK IS DETERMINED TO BE A C TYPE 2B DUPLICATE. WIND CONSIDERED BAD. C 312 TRKCHK THIS ONE OF SEVERAL (> 2) AIREP/PIREP WIND=13 C REPORTS IN A TRACK IS DETERMINED TO BE A C TYPE 2A DUPLICATE. WIND CONSIDERED BAD. C 313 TRKCHK THIS LAST OF SEVERAL (> 2) AIREP/PIREP WIND=13 C REPORTS IN A TRACK IS DETERMINED TO IN C ERROR. WIND CONSIDERED BAD. C 314 TRKCHK THIS ONE OF SEVERAL (> 2) AIREP/PIREP WIND=13 C REPORTS IN A TRACK IS DETERMINED TO BE A C TYPE 3 DUPLICATE. WIND CONSIDERED BAD. C 315 AVEROB, REPORT IS USED TO GENERATE A SUPEROB TEMP=10 C SUPROB, REPORT. TEMPERATURE AND/OR WIND ARE FLAGGED WIND=10 C NOEQ2 FOR NON-USE BY ANALYSIS. C 316 RPACKR ISOLATED AIREP/PIREP REPORT WITH VECTOR WIND TEMP=13 C INCREMENT GREATER THAN 50 KNOTS. TEMPERATURE WIND=13 C AND/OR WIND CONSIDERED BAD. C 317 RPACKR ISOLATED AIREP/PIREP REPORT WITH VECTOR WIND TEMP= 1 C INCREMENT LESS THAN 21 KNOTS. TEMPERATURE WIND= 1 C AND/OR WIND CONSIDERED GOOD. C 318 RPACKR ISOLATED AIREP/PIREP REPORT WITH VECTOR WIND TEMP= 3 C INCREMENT GREATER THAN 20 KNOTS BUT LESS WIND= 3 C THAN 51 KNOTS. TEMPERATURE AND/OR WIND C CONSIDERED SUSPECT. C 319 RPACKR, REPORT (ISOLATED OR STACKED) WITH A WIND TEMP=13 C PRELIM THAT HAS FAILED ONE OR MORE CHECKS AND IS C CONSIDERED BAD. TEMPERATURE CONSIDERED BAD. C 320 RPACKR REPORT IN A STACK OF CO-LOCATED REPORTS WITH TEMP= 1 C A TEMPERATURE AND/OR WIND THAT HAS PASSED WIND= 1 C ALL CHECKS. TEMPERATURE AND/OR WIND C CONSIDERED GOOD. C 321 PRELIM REPORT IN A STACK OF CO-LOCATED REPORTS WITH WIND=13 C A WIND THAT HAS FAILED THE WIND SHEAR CHECK. C WIND CONSIDERED BAD. C 322 PRELIM REPORT IN A STACK OF CO-LOCATED REPORTS WITH TEMP=13 C A TEMPERATURE THAT HAS FAILED THE LAPSE C CHECK. TEMPERATURE CONSIDERED BAD. C 323 SUPROB REPORT IN A STACK OF CO-LOCATED REPORTS THAT TEMP=13 C IS AVAILABLE TO BE USED TO GENERATE A WIND=13 C SUPEROB REPORT. HOWEVER, IT'S WIND HAS C FAILED ONE OR MORE CHECKS AND IT IS NOT USED C TO GENERATE A SUPEROB. TEMPERATURE AND/OR C WIND CONSIDERED BAD. C 324 NOEQ2 THIS ONE OF A PAIR OF CO-LOCATED REPORTS HAS TEMP=13 C A VECTOR WIND INCREMENT GREATER THAN 50 WIND=13 C KNOTS AND CONTAINS A SUSPECTED TRACK CHECK C ERROR. TEMPERATURE AND/OR WIND CONSIDERED C BAD. C 325 OBUFR, AIREP/PIREP OR SUPEROB REPORT OVER THE TEMP=15 C SBUFR CONTINENTAL U.S. OR SURROUNDING ENVIRONS WIND=15 C WHEN NAMELIST SWITCH IFLGUS=1 AND THERE C ARE AT LEAST TWO "AIRCAR" TABLE A BUFR C MESSAGES READ IN PREVIOUSLY. TEMPERATURE C AND/OR WIND ARE FLAGGED FOR NON-USE BY C ANALYSIS. C 326 SBUFR SUPEROB REPORT THAT HAS BEEN GENERATED BY TEMP= 1 C THIS PROGRAM. TEMPERATURE AND/OR WIND WIND= 1 C CONSIDERED GOOD. C 327 TRKCHK IN A TRACK CONTAINING AT LEAST 15 ASDAR/ WIND=13 C AMDAR REPORTS, THERE ARE AT LEAST 10 C REPORTS WITH A VECTOR WIND INCREMENT C GREATER THAN 50 KNOTS. WIND CONSIDERED BAD. C 328 RPACKR ISOLATED ASDAR/AMDAR REPORT WITH A TEMP= 1 C TEMPERATURE AND/OR WIND THAT HAS PASSED WIND= 1 C ALL CHECKS. TEMPERATURE AND/OR WIND C CONSIDERED GOOD. C 329 RPACKR AIREP/PIREP REPORT IN A STACK OF ONLY TWO TEMP=13 C CO-LOCATED REPORTS WITH VECTOR WIND WIND=13 C INCREMENT GREATER THAN 50 KNOTS. C TEMPERATURE AND/OR WIND CONSIDERED BAD. C C C*********************************************************************** C C EACH REPORT CARRIES WITH IT IN THIS PROGRAM THE FOLLOWING 'TAG' INFO: C C BYTE 1 : WILL CONTAIN 'P' IF EITHER QCAIRCFT OR SDM HAS PURGED C : ELSE WILL CONTAIN 'H' IF SDM KEEPS C : ELSE WILL CONTAIN THE ON29 FORM OF SCALED OBSERVED C VECTOR INCREMENT ('Q' - 'Z') IF INCREMENT COULD BE C PRODUCED C : ELSE WILL CONTAIN 'C' (OLD ON29 MARKER FOR C 'INSTANTANEOUS SPOT WIND USED') C : ELSE WILL CONTAIN ' ' IF WAYPOINT CORRECTION IS MADE C : ELSE WILL CONTAIN 'D' IF THIS REPORT IS A DUPLICATE C BYTE 2 : +++ FINAL TEMPERATURE QUALITY MARKER (ON29 FORM) C BYTE 3 : +++ TRACK CHECK INDICATOR C : WILL CONTAIN 'E' IF SUSPECTED TRACK CHECK ERROR C : ELSE WILL BE BLANK C --> ON29 O-PUT: IF 'E' PACKED INTO CAT. 8, CODE FIGURE 301 C BYTE 4 : +++ FINAL WIND QUALITY MARKER (ON29 FORM) C BYTE 5 : +++ ON29 FORM OF ORIGINAL SCALED VECTOR INCREMENT VALUE C : WILL CONTAIN 'Q' - 'Z' IF INCREMENT COULD BE PRODUCED C : ELSE WILL CONTAIN 'N' IF NOT CALUCLATED C --> ON29 O-PUT: IF 'Q'-'Z' PACKED INTO CAT. 8, CODE FIGURE 300 C BYTE 6 : +++ ASDAR/AMDAR TEMPERATURE PRECISION C : WILL CONTAIN '0' IF LOW PRECISION C : WILL CONTAIN '1' IF HIGH PRECISION C : ELSE WILL BE BLANK IF ASDAR/AMDAR T. PRECISION NOT C REPORTED, OR IF NOT AN ASDAR/AMDAR REPORT C --> ON29 O-PUT: PACKED INTO RESERVE CHARACTER 26 C BYTE 7 : +++ ASDAR/AMDAR/CARSWELL-TINKER INDICATOR C : WILL CONTAIN 'Z' IF ASDAR/AMDAR REPORT C : ELSE WILL CONTAIN 'C' IF CARSWELL-TINKER REPORT C : ELSE WILL BE BLANK IF NONE OF THE ABOVE C --> ON29 O-PUT: PACKED INTO RESERVE CHARACTER 27 C BYTE 8 : +++ ASDAR/AMDAR TURBULENCE INDICATOR C : WILL CONTAIN '0' IF NO TURBULENCE C : WILL CONTAIN '1' IF LIGHT TURBULENCE C : WILL CONTAIN '2' IF MODERATE TURBULENCE C : WILL CONTAIN '3' IF SEVERE TURBULENCE C : ELSE WILL BE BLANK IF NONE OF ABOVE OR AIREP/PIREP REPORT C --> ON29 O-PUT: IF '0'-'3' PACKED INTO CAT. 8, CODE FIGURE 302 C BYTE 9 : +++ CORRECTED WAYPOINT LOCATION INDICATOR C : WILL CONTAIN 'C' IF LAT/LON CHANGED (CORRECTED) C : ELSE WILL BE BLANK C --> ON29 O-PUT: IF 'C' PACKED INTO CAT. 8, CODE FIGURE 303 C BYTE 10 : +++ ASDAR/AMDAR PHASE OF FLIGHT INDICATOR C : WILL CONTAIN '0' - '2' IF RESERVED C : WILL CONTAIN '3' IF LEVEL FLIGHT, ROUTINE OBSERVATION C : WILL CONTAIN '4' IF LEVEL FLIGHT, HIGHEST WND ENCOUNTERED C : WILL CONTAIN '5' IF ASCENDING C : WILL CONTAIN '6' IF DESCENDING C : WILL CONTAIN '7' IF MISSING C : ELSE WILL CONTAIN '9' IF AIREP/PIREP REPORT C --> ON29 O-PUT: PACKED INTO RESERVE CHARACTER 25 C BYTE 11 : +++ ORIGINAL SOURCE OF PURGE INDICATOR C : WILL CONTAIN 'S' IF PURGED BY THE SDM C : WILL CONTAIN 'Q' IF PURGED BY QCAIRCFT C : ELSE WILL BE BLANK IF NOT PURGED C --> ON29 O-PUT: IF 'S' OR 'Q' PACKED INTO CAT. 8, CODE FIGURE 304 C BYTE 12 : +++ ISOLATED REPORT INDICATOR C : WILL CONTAIN 'I' IF AN ISOLATED REPORT C : ELSE WILL BE BLANK C --> ON29 O-PUT: IF 'I' PACKED INTO CAT. 8, CODE FIGURE 306 C BYTE 13 : +++ NUMERICAL VALUE FOR TEMPERATURE QUALITY MARKER C : LOWER NUMBER ALWAYS SUPERCEDES HIGHER NUMBER (SEE && ) C BYTE 14 : +++ NUMERICAL VALUE FOR WIND QUALITY MARKER C : LOWER NUMBER ALWAYS SUPERCEDES HIGHER NUMBER (SEE && ) C C && - '0' -- DUPLICATE ('D') ('D' IS ONLY STORED IN POS. 1 OF TAG) C '1' -- PURGE ('P') -- OR -- C KEEP ('H') C '2' -- DATA ARE MISSING C '3' -- BAD ('F') C '4' -- OMIT ('O') C '5' -- SUSPECT ('Q') C '6' -- GOOD ('A') C '7' -- CANNOT BE CHECKED/UNTREATABLE OR NOT CHECKED (' ') C '8' -- INITIAL VALUE C C C OTHER OUTPUT REPORT INFORMATION NOT IN TAG BUT REPACKED INTO ON29 C AS INDICATED: C C +++ RECEIPT TIME (HOURS X 100) C --> ON29 O-PUT: PACKED INTO RESERVE CHARACTERS 21-24 C +++ CHARACTERS IN POSITIONS 7 AND 8 OF STATION IDENTIFICATION C --> ON29 O-PUT: IF NOT ' ' PACKED INTO CAT. 8, CODE FIGURE 305 C PARAMETER (ISIZE= 16) C C-CRA LOGICAL FWRITE,SWRITE,IWRITE,DOSPOB,DOACRS,WAYPIN,RCPTST LOGICAL FWRITE CHARACTER*1 CF,QCACMK(15),CBUF CHARACTER*4 CECTME,CBUF4,SPEC5,SPEC6,QMARKI,SSMARK CHARACTER*8 COB,ACID,SAID,IDENT,AAID(IRMX) CHARACTER*14 TAG,CTAG(IRMX),STAG(IRMX) CHARACTER*32 CLABEL C-CRA INTEGER IDATA(1608),NNQM(15),IDSTR(400,2) INTEGER NNQM(15),IDSTR(400,2) REAL DATA(1608) C COMMON/BUFF/CBUF(6432) COMMON/OUTPUT/KNTOUT(5) C-CRA COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), C-CRA$ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), C-CRA$ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), $ KBAD(ISMX),SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) COMMON/SUMDATI/NUMORG COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), $ ADIRF(IRMX) COMMON/CMPNTS/U(ISMX),V(ISMX),UF(ISMX),VF(ISMX) COMMON/ACCONT/KQM2F(15),KISO(15),KNQM(15),KSDM(2),KT,KTYPS(9) C-CRA COMMON/INPT/DOSPOB,DOACRS,TMAXO,TMINO,TIMINC,WAYPIN,INIDST,IFLGUS, C-CRA$ JAMASS(6),JAWIND(6),RCPTST COMMON/INPT/TMAXO,TMINO,TIMINC COMMON/INPTI/INIDST,IFLGUS,JAMASS(6),JAWIND(6) LOGICAL DOSPOB,DOACRS,WAYPIN,RCPTST COMMON/INPTL/DOSPOB,DOACRS,WAYPIN,RCPTST COMMON/TSTACAR/KTACAR C-CRA COMMON/WRITE/SWRITE,IWRITE LOGICAL SWRITE,IWRITE COMMON/COMWRITE/SWRITE,IWRITE COMMON/WORD/LW,ICHTP COMMON/MASK/GDNH(362,91),GDSH(145,37),GDUS(362,91) COMMON/XXXXX/AAID,JARRAY(IRMX,ISIZE),CTAG,KARRAY(IRMX,ISIZE),STAG C-CRA COMMON/CBUFR/IRCTME,DATA,IDENT,QMARKI,CF COMMON/CBUFR/DATA,QMARKI,CF COMMON/CBUFRI/IDENT,IRCTME COMMON/SUPOBS/SSLAT(ISUP),SSLON(ISUP),SSTIM(ISUP),SSHGT(ISUP), $ SSTMP(ISUP),SSDIR(ISUP),SSSPD(ISUP),SSHGTF(ISUP),SSTMPF(ISUP), $ SSDIRF(ISUP),SSSPDF(ISUP),SSMARK(ISUP) COMMON/XDATE/IDATE(5) C LOGICAL EWRITE C NAMELIST/INPUT/DOSPOB,DOACRS,WINDOW,TIMINC,STCLIM,WAYPIN,INIDST, $ FWRITE,SWRITE,IWRITE,EWRITE,IFLGUS,JAMASS,JAWIND,RCPTST C INTEGER*8 IDATA(1608),IOB EQUIVALENCE (DATA,IDATA),(IOB,COB) C DATA XMSG/99999./,ITOL/55/,QCACMK/'Q','R','S','T','U','V','W', $ 'X','Y','Z','C','P','H',' ','D'/,IMSG/99999/ C PRINT *,'***** WELCOME TO THE AIRCRAFT QUALITY CONTROL ', $ 'PROGRAM PREPACQC -- VERSION CREATED 16 DEC 2008 *****' C C CALL W3FI04 TO DETERMINE MACHINE WORD LGTH(BYTES) (LW=4/NAS; =8/CRAY) C AND TO TEST FOR ASCII(ICHTP=0) OR EBCDIC(ICHTP=1) CHARACTERS C CALL W3FI04(IENDN,ICHTP,LW) C C IF CHARACTERS ON THIS MACHINE ARE NEITHER ASCII OR EBCDIC, ABORT. C IF(ICHTP.GT.1) THEN PRINT 217 217 FORMAT(/' CHARACTERS ON THIS MACHINE ARE NEITHER ASCII NOR', $ ' EBCDIC -- ABORT'/) CALL ABORT END IF C RAD=3.14159/180. C C INITIALIZE CONSTANTS FOR ACCOUNTING C KT =0 KSDM(1)=0 KSDM(2)=0 ICNT1 =0 ICNT2 =0 ICNT3 =0 ICNT45 =0 ICNT69 =0 ICNTX =0 KDUP =0 KTACAR =0 C C-CRA CALL XSTORE(KQM2F,0,15) C-CRA CALL XSTORE(KISO ,0,15) C-CRA CALL XSTORE(KNQM ,0,15) C-CRA CALL XSTORE(NNQM ,0,15) C-CRA CALL XSTORE(KTYPS,0,9) DO I=1,15 KQM2F(I)=0 KISO(I)=0 KNQM(I)=0 NNQM(I)=0 ENDDO DO I=1,9 KTYPS(I)=0 ENDDO C C READ IN NAMELIST, FIRST SET-UP ANY DEFAULTS C WINDOW=3.00 TIMINC=1.00 RCPTST=.TRUE. STCLIM=41.9 DOSPOB=.TRUE. DOACRS=.FALSE. WAYPIN=.FALSE. IFLGUS=1 INIDST=2 FWRITE=.FALSE. SWRITE=.FALSE. IWRITE=.FALSE. C-CRA CALL XSTORE(JAMASS,0,6) C-CRA CALL XSTORE(JAWIND,0,6) DO I=1,6 JAMASS(I)=0 JAWIND(I)=0 ENDDO C READ(5,INPUT,END=9222) IF(INIDST.LE.1) IFLGUS=1 9222 CONTINUE C IF(DOSPOB) THEN PRINT *,'SUPEROBS WILL BE GENERATED' ELSE PRINT *,'SUPEROBS WILL NOT BE GENERATED' ENDIF C C INITIALIZE OUTPUT FILE C IF(INIDST.LT.2) THEN PRINT *,'ON29 DATA INPUT REQUESTED -- ABORT' CALL ABORT ELSE CALL DBUFR(IDATE8) IDATE(1)=IDATE8/1000000 IDATE(2)=MOD((IDATE8/10000),100) IDATE(3)=MOD((IDATE8/100),100) IDATE(4)=MOD(IDATE8,100) LATEST=9999 END IF C IDATE(5)=0 C C IDT IS NO. OF MIN. FROM 00Z 1/1/78 TO CURRENT PRODUCTION DATE/TIME C CALL W3FS21(IDATE,IDT) IF(IDT.LT.6990480) THEN PRINT 2114 2114 FORMAT('NOTICE: CARSWELL-TINKER REPORTS CANNOT BE', $ ' IDENTIFIED (NOT TAGGED IN ON29 UNTIL 4/17/91)') END IF C KOUNT=0 KNTIN=0 C-CRA CALL XSTORE(KNTOUT,0,5) DO I=1,5 KNTOUT(I)=0 ENDDO TBASE=REAL(IDATE(4)*100.) IF(NINT(TBASE).LT.600) TBASE=TBASE + 2400. C C THE TIME WINDOW UPON INPUT IS SET TO THE LARGER OF 3-HRS 15-MIN OR C "WINDOW" PLUS 15-MINUTES. REMOVE ALL REPORTS OUTSIDE THIS TIME C WINDOW. (THE LARGER INPUT TIME WINDOW ALLOWS THE TRACK CHECKING TO C BE DONE PROPERLY.) C TWNDOW=AMAX1(((WINDOW*100.)+25.0),325.) TMAX=TBASE+TWNDOW TMIN=TBASE-TWNDOW TMAXO=TBASE+(WINDOW * 100.) TMINO=TBASE-(WINDOW * 100.) PRINT 1111, IDATE,TBASE,TMIN,TMAX,TMINO,TMAXO,TIMINC,LATEST 1111 FORMAT(39X,'===> OPERATIONAL AIRCFT FILE HAS DATE: ',5I4,/, $ 41X,'===> TIME BASE IS ',F8.0,/, $ 41X,'===> INPUT TIME WINDOW IS ',F8.0,' TO ',F8.0,/, $ 41X,'===> OUTPUT TIME WINDOW IS ',F8.0,' TO ',F8.0,/, $ 41X,'===> TIME INCREMENT IS ',F5.2,' HOURS/100',/, $ 41X,'===> LATEST AIRCRAFT REPORT AT',I5,' HOURS',//) C WRITE(6,INPUT) C C READ IN N.H. USA-MAINLAND/GULF-OF-AMERICA/S.-ONTARIO MASK (1 DEG GRID) C IF MASK > 0 THEN GRID LOCATED HERE -- THIS IS NEEDED LATER IN PROGRAM C PRINT *,'READING GRID LOCATION CHECK FILE' READ(15,ERR=8814) GDNH READ(15,ERR=8814) GDSH READ(15,ERR=8814) GDUS GO TO 8812 8814 CONTINUE C C PROBLEM W/ READ; INIT. GDUS ARRAY TO 0 - (HAVE TO ASSUME ALL N.H. OBS C ARE OUTSIDE OF U.S. MAINLAND) C C-CRA CALL XSTORE(GDUS,0.0,32942) DO I=1,32942 GDUS(I,1)=0.0 ENDDO PRINT *,' TROUBLE READING U.S. MASK FILE; ASSUME ALL N.H. ', $ 'DATA OUTSIDE U.S. MAINLAND IN ANY U.S. MAINLAND TEST' C 8812 CONTINUE IF(IWRITE) THEN PRINT *,'LISTING OF ORIGINAL DATA BEFORE IDSORT----' PRINT *,' ACID ', $ 'LAT WLON UTC ALT TEMP WDIR WSPD -----TAGS', $ '----- ITYPE RPTIME KNTINI GALT GTEMP GDIR GSPD' ENDIF C C======================================================================= C START OF READ LOOP C======================================================================= C 5 CONTINUE C ALTF=XMSG DIRF=XMSG SPDF=XMSG TMPF=XMSG C C READ IN AIRCRAFT REPORT C IY=43 SPEC5=' ' SPEC6=' ' CALL IBUFR(ALTF,DIRF,SPDF,TMPF,*2) SPEC6(3:3)=CF C C *2 INDICATES GO TO STATEMENT LABEL '2' FOR RETURN1 in IBUFR C RETURN1 CORRESPONDS TO FINISH READING. C KOUNT=KOUNT+1 KNTIN=KNTIN+1 C C FATAL ERROR: THERE ARE MORE RPTS IN INPUT FILE THAN "IRMX" -- ABORT C IF(KOUNT.GT.IRMX) THEN PRINT 53, IRMX, KOUNT 53 FORMAT('THERE ARE MORE THAN',I9,' AIRCRAFT REPORTS IN INPUT ', $ '(',i9,')', $ 'FILE -- MUST INCREASE SIZE OF PARAMETER NAME "IRMX" - ABORT') CALL ABORT END IF C KNTINI(KOUNT)=KNTIN TAG(KOUNT)(12:12)=' ' ALAT(KOUNT)=DATA(1) ALON(KOUNT)=DATA(2) INTP(KOUNT)=IDATA(8) IF(NINT(ALON(KOUNT)).EQ.36000) ALON(KOUNT)=0.0 C C IF MISSING OR UNREASONABLE LAT/LON (SET LATTER TO MISSING), SET POS. C 12 OF TAG TO '@' TO MARK THEM (AT END OF SORT, ISOLATED) C IF(NINT(ALAT(KOUNT)).GT.9000.OR.NINT(ALAT(KOUNT)).LT.-9000) THEN PRINT *,'MISSING/UNREASONABLE LAT SET TO MSG!!' ALAT(KOUNT)=XMSG TAG(KOUNT)(12:12)='@' ELSE ALAT(KOUNT)=ALAT(KOUNT)*.01 END IF C IF(NINT(ALON(KOUNT)).GT.36000.OR.NINT(ALON(KOUNT)).LT.0) THEN PRINT *,'MISSING/UNREASONABLE LON SET TO MSG!!' ALON(KOUNT)=XMSG TAG(KOUNT)(12:12)='@' ELSE ALON(KOUNT)=ALON(KOUNT)*.01 END IF C ACID(KOUNT)=IDENT C TIME(KOUNT)=DATA(4) IF(NINT(TIME(KOUNT)).GT.2400.OR.NINT(TIME(KOUNT)).LT.0) THEN PRINT *,'MISSING/UNREASONABLE TIME, TOSSED?' ENDIF IRTM(KOUNT)=IRCTME C C DO A TIME CHECK ON REPORT -- IF OUTSIDE EXPANDED INPUT WINDOW TOSS IT C ITIME=NINT(TIME(KOUNT)) IF(NINT(TBASE).GT.2300.AND.NINT(TIME(KOUNT)).LE. $ (IDATE(4)*100)+600) THEN TIME(KOUNT)=TIME(KOUNT) + 2400. ENDIF C C SKIP REPORTS OUTSIDE REQUESTED TIME WINDOW C IF(TIME(KOUNT).LT.TMIN.OR.TIME(KOUNT).GT.TMAX) THEN KOUNT=KOUNT - 1 GO TO 5 ENDIF C C CHECK FOR DATA WITH STRANGE RECEIPT TIME COMPARED TO REPORT TIME - C MAY BE YESTERDAY'S REPORT PROCESSED TODAY -- IF THE RECEIPT TIME C IS OUTSIDE THE RANGE OF REPORT TIME MINUS 1-HOUR TO REPORT TIME C PLUS 11.99 HOURS, SKIP THE REPORT AS WE CAN'T DETERMINE ITS VALIDITY C IF(RCPTST.AND.IRCTME.LE.2400) THEN IF(ITIME.LT.100) ITIME=ITIME+2400 IETIME=ITIME-100 ILTIME=ITIME+1199 C C RECEIPT TIME IS OUTSIDE EXPECTED RANGE, BUT MAY BE AROUND 00Z SO ADD C 2400 TO RECEIPT TIME AND TEST AGAIN C IF(IRCTME.LT.IETIME.OR.IRCTME.GT.ILTIME) THEN IRCTMN=IRCTME+2400 C C RECEIPT TIME IS STILL OUTSIDE EXPECTED RANGE, SKIP REPORT C IF(IRCTMN.LT.IETIME.OR.IRCTMN.GT.ILTIME) THEN PRINT *,'THE STRANGE RECEIPT TIME DIFF. HAS OCCURRED' PRINT 9393, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), $ TIME(KOUNT),IRCTME,SPEC6(3:3) 9393 FORMAT('SKIP RPTS WHERE OBS. & RCPT. TIME ARE ', $ 'INCONSISTENT ',I5,2X,A8,2F8.2,F6.0, $ '; REC. TIME',I5,'; CAFB? ',A1) KOUNT=KOUNT-1 GO TO 5 ENDIF ENDIF ENDIF C C C AALT(KOUNT)=DATA(IY) ADIR(KOUNT)=DATA(IY+3) ASPD(KOUNT)=DATA(IY+4) ATMP(KOUNT)=DATA(IY+1) C C FOR INIDST=2, FILL IN FCST VALUES FOR ALT, DIR, SPD & TMP (ELSE MSG) C AALTF(KOUNT)=ALTF ADIRF(KOUNT)=DIRF ASPDF(KOUNT)=SPDF ATMPF(KOUNT)=TMPF ITEVNT(KOUNT)=0 IWEVNT(KOUNT)=0 C C START QMARKI PROCESSING C TAG(KOUNT)(2:4)=' ' TAG(KOUNT)(6:9)=' ' TAG(KOUNT)(11:11)=' ' TAG(KOUNT)(10:10)=SPEC5(3:3) C IF(ACID(KOUNT)(6:6).EQ.'Z') THEN TAG(KOUNT)(3:3)='Z' TAG(KOUNT)(6:6)=SPEC5(4:4) TAG(KOUNT)(7:7)='Z' TAG(KOUNT)(8:8)=QMARKI(3:3) ELSE IF(SPEC6(3:3).EQ.'C') THEN TAG(KOUNT)(7:7)='C' END IF C TAG(KOUNT)(13:14)='88' TAG(KOUNT)(5:5)='N' C IF(QMARKI(4:4).GE.'Q'.AND.QMARKI(4:4).LE.'Z') THEN TAG(KOUNT)(5:5)=QMARKI(4:4) ENDIF C TAG(KOUNT)(1:1)=QMARKI(4:4) C C MARK 'P' C IF(QMARKI(1:1).EQ.'P') THEN TAG(KOUNT)(1:1)='P' C C IF QCAIRCFT PURGE FLAG ON OBSERVATION, TEMP AND WIND Q.M. IS 'P' C IF(QMARKI(2:2).EQ.'P') THEN PRINT 9028, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), $ TIME(KOUNT),TAG(KOUNT) 9028 FORMAT('QCAIRCFT PURGE FLAG, WIND/TEMP Q.M. IS "P"', $ I5,2X,A8,2F8.2,F6.0,2X,A14) TAG(KOUNT)(11:11)='Q' C C IF SDM PURGE FLAG ON OBSERVATION, TEMP AND WIND Q.M. IS 'P' C C-MK ELSEIF(QMARKI(2:2).NE.'this was a number sign') THEN C ELSEIF(QMARKI(2:2).NE.'/') THEN PRINT 9029, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), $ TIME(KOUNT),TAG(KOUNT) 9029 FORMAT('SDM PURGE FLAG, WIND/TEMP Q.M. IS "P"..', $ I5,2X,A8,2F8.2,F6.0,2X,A14) TAG(KOUNT)(11:11)='S' ELSE C C BUFR/PREPDA INPUT DOES NOT INDICATE IF PURGE IS FROM SDM OR QCAIRCFT C PRINT 9030, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), $ TIME(KOUNT),TAG(KOUNT) 9030 FORMAT('PURGE FLAG(SOURCE ?), WND/TMP Q.M. IS "P"', $ I5,2X,A8,2F8.2,F6.0,2X,A14) ENDIF C C SET POS. 12 OF TAG TO '@' TO MARK ALL TYPES OF PURGE FLAG C TAG(KOUNT)(12:12)='@' TAG(KOUNT)(2:2)='P' TAG(KOUNT)(13:13)='1' TAG(KOUNT)(4:4)='P' TAG(KOUNT)(14:14)='1' C C MARK 'H' C ELSE IF(QMARKI(1:1).EQ.'H') THEN C C IF SDM KEEP FLAG ON OBSERVATION, TEMP AND WIND Q.M. IS 'H' C TAG(KOUNT)(1:1)='H' PRINT 9027, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), $ TIME(KOUNT),TAG(KOUNT) 9027 FORMAT('SDM KEEP FLAG, WIND/TEMP Q.M. IS "H"......', $ I5,2X,A8,2F8.2,F6.0,2X,A14) TAG(KOUNT)(2:2)='H' TAG(KOUNT)(13:13)='1' TAG(KOUNT)(4:4)='H' TAG(KOUNT)(14:14)='1' C C MARK OTHER C ELSE IF(ATMP(KOUNT).GE.XMSG) THEN C C IF TEMPERATURE OR WIND IS MISSING KEEP QUALITY MARKERS BLANK C TAG(KOUNT)(13:13)='2' ELSE IF(ATMPF(KOUNT).LT.XMSG) THEN C C IF GUESS TEMP. AVAILABLE, CHECK TEMP. OF RPTS WITH ALT. BETWEEN 2000 C AND 5000 FT. - IF NOT W/I 25 DEG. C OF GUESS TEMP. FLAG THE RPT; SET C POS. 12 OF TAG TO '@' TO MARK THEM C (NOTE: DONE TO FLAG RPTS THAT ARE ACTUALLY AT AN ALT. BETWEEN 20,000 C AND 50,000 FT. BUT ARE REPORTED WITH A '0' DIGIT DROPPED) C IF((AALT(KOUNT).GT.609..AND.AALT(KOUNT).LT.1524.).AND. $ (ABS(ATMP(KOUNT)-ATMPF(KOUNT)).GT.250.)) THEN TAG(KOUNT)(12:12)='@' PRINT *,'HERE IS A RPT WITH INCORRECT? ALTITUDE!!' IF(TAG(KOUNT)(13:13).GT.'3') THEN TAG(KOUNT)(2:2)='F' TAG(KOUNT)(13:13)='3' ITEVNT(KOUNT)=302 END IF IF(TAG(KOUNT)(14:14).GT.'3') THEN TAG(KOUNT)(4:4)='F' TAG(KOUNT)(14:14)='3' IWEVNT(KOUNT)=302 ENDIF ENDIF ENDIF IF(ASPD(KOUNT).GE.XMSG.OR.ADIR(KOUNT).GE.XMSG) THEN TAG(KOUNT)(14:14)='2' ENDIF C C FLAG TEMPERATURES GREATER THAN 12 DEG. C (GROSS CLIMATOLOGICAL CHECK) C IF(TAG(KOUNT)(13:13).GT.'3'.AND.ATMP(KOUNT).GT.120.) THEN TAG(KOUNT)(2:2)='F' TAG(KOUNT)(13:13)='3' ITEVNT(KOUNT)=303 END IF C C FLAG CALM WINDS THAT ARE NOT ASSIGNED A DIRECTION OF 360 DEGREES C IF(TAG(KOUNT)(14:14).GT.'3'.AND.ASPD(KOUNT).EQ.0..AND. $ ADIR(KOUNT).NE.360.) THEN TAG(KOUNT)(4:4)='F' TAG(KOUNT)(14:14)='3' IWEVNT(KOUNT)=304 END IF C C FLAG CARSWELL-TINKER CONVERTED PIREPS; SET POS. 12 OF TAG TO '@' TO C MARK THEM C IF(ACID(KOUNT).EQ.'XX999 ') THEN TAG(KOUNT)(12:12)='@' IF(TAG(KOUNT)(13:13).GT.'3') THEN TAG(KOUNT)(2:2)='F' TAG(KOUNT)(13:13)='3' ITEVNT(KOUNT)=301 END IF IF(TAG(KOUNT)(14:14).GT.'3') THEN TAG(KOUNT)(4:4)='F' TAG(KOUNT)(14:14)='3' IWEVNT(KOUNT)=301 END IF ELSEIF(ACID(KOUNT)(1:1).EQ.'P'.AND. $ ACID(KOUNT)(6:8).EQ.'P '.AND. $ ((TAG(KOUNT)(5:5).GE.'S'.AND.TAG(KOUNT)(5:5).LE.'Z').OR. $ TAG(KOUNT)(5:5).EQ.'N')) THEN C C FLAG OTHER PIREPS IF INCR. MARKER 'S-Z' OR 'N'; SET POS. 12 OF TAG TO C '@' TO MARK THEM C TAG(KOUNT)(12:12)='@' IF(TAG(KOUNT)(13:13).GT.'3') THEN TAG(KOUNT)(2:2)='F' TAG(KOUNT)(13:13)='3' ITEVNT(KOUNT)=305 END IF IF(TAG(KOUNT)(14:14).GT.'3') THEN TAG(KOUNT)(4:4)='F' TAG(KOUNT)(14:14)='3' IWEVNT(KOUNT)=305 END IF END IF END IF C C END OF QMARKI PROCESSING C IF(IWRITE) THEN PRINT 6177, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), $ NINT(TIME(KOUNT)),NINT(AALT(KOUNT)),NINT(ATMP(KOUNT)), $ NINT(ADIR(KOUNT)),NINT(ASPD(KOUNT)),TAG(KOUNT),INTP(KOUNT), $ IRTM(KOUNT),KNTINI(KOUNT),NINT(AALTF(KOUNT)), $ NINT(ATMPF(KOUNT)),NINT(ADIRF(KOUNT)),NINT(ASPDF(KOUNT)) 6177 FORMAT(' ',I5,2X,A8,2F8.2,I6,I7,3I6,3X,A14,I6,2I8,I7,3I6) END IF C C NOW GO BACK AND READ IN REPORT FROM FIRST RECORD WITH DATA C GO TO 5 C C======================================================================= C END OF READ LOOP C======================================================================= C 2 CONTINUE C C ALL MESSAGES READ IN -- FINISHED READING IN REPORTS C PRINT 812, KOUNT 812 FORMAT(/' ALL MESSAGES READ IN BUFR/PREPDA FILE -- KOUNT= ',I9) C NFILE=KOUNT IF(KOUNT.EQ.0) GO TO 6000 C C*********************************************************************** C SORT BY AIRCRAFT STATION ID C*********************************************************************** C CALL IDSORT(NFILE,NASDAR,NEXCLD) IF(IWRITE) THEN PRINT 2177 2177 FORMAT(' LISTING OF ORIGINAL DATA AFTER IDSORT----'/9X,'ACID', $ 7X,'LAT WLON UTC ALT TEMP WDIR WSPD -----TAGS', $ '----- ITYPE RPTIME KNTINI GALT GTEMP GDIR GSPD'/) DO K=1,KOUNT PRINT 6177, K,ACID(K),ALAT(K),ALON(K), $ NINT(TIME(K)),NINT(AALT(K)), $ NINT(ATMP(K)),NINT(ADIR(K)),NINT(ASPD(K)), $ TAG(K),INTP(K),IRTM(K), $ KNTINI(K),NINT(AALTF(K)),NINT(ATMPF(K)),NINT(ADIRF(K)), $ NINT(ASPDF(K)) ENDDO END IF PRINT 6122, KOUNT,NFILE,NASDAR,NEXCLD 6122 FORMAT(' AFTER ID SORT- KOUNT=',I7,', NFILE=',I7,', NASDAR=',I7, $ ', NEXCLD=',I7/) C C SORT COMPLETED C C*********************************************************************** C TRACK CHECK C*********************************************************************** C C CALL TRACK CHECK WITH NASDAR, NEXCLD (ASDAR/AMDAR ARE NEXT TO LAST IN C SORTED ARRAY, REPORTS EXCLUDED FROM ALL CHECKS ARE LAST SORTED ARRAY) C CALL TRACK CHECK WITH NFILE=KOUNT, RETURNS NEW KOUNT (NO DUPS) C CALL TRKCHK(KOUNT,NASDAR,NEXCLD) C C HERE, TAG(KOUNT)(3:3) NOW CONTAINS ' ' OR 'E' FOR SUSPECTED TRKCHK ERR C DO CENSUS ON INCREMENTS C DO K=1,KOUNT IF(TIME(K).GE.TMINO.AND.TIME(K).LE.TMAXO) THEN DO M=1,15 IF(TAG(K)(1:1).EQ.QCACMK(M)) THEN NNQM(M)=NNQM(M) + 1 GO TO 618 END IF ENDDO END IF 618 CONTINUE ENDDO C C INITIALIZE SDM LOOKAT FILE FOR FLAGGED ISOLATED REPORTS -- UNIT 52 C WRITE(52,15) (IDATE(I),I=1,4) 15 FORMAT(' SDM AIRCRAFT QC CHECK FILE FOR ',4I4) WRITE(52,45) LATEST 45 FORMAT(' LATEST A/C REPORT AT ',I4) WRITE(52,16) 16 FORMAT(' ISOLATED REPORTS TOSSED- IF U WANT TO KEEP, USE DELETER') WRITE(52,17) 17 FORMAT(/' AC',8X,'LAT LON UTC ALT TEMP WDIR ', $ ' WSPD INCR SDM'/' IDENT',30X,'(MB) (C)',8X,'(KNOTS)',8X, $ 'FLAG?'/' -------- ----- ------- ----- ----- ----- ----- ', $ ' ----- ---- ---'/) C C INITIALIZE SDM LOOKAT FILE FOR STACKED REPORTS W/ AVERAGE VECTOR WIND C INCREMENT EXCEEDING 'STCLIM' VALUE AND FOR STACKED REPORTS WITH AT C LEAST ONE REPORT CONTAINING SDM KEEP FLAG -- UNIT 53 C WRITE(53,15) (IDATE(I),I=1,4) WRITE(53,6) 6 FORMAT(' ??? STACK, EVALUATE AND USE DELETER -'/' STACKS WITH ', $ 'AT LEAST ONE REPORT CONTAINING SDM KEEP FLAG ALSO HERE') WRITE(53,17) C C INITIALIZE FOR STACK DETERMINATION C NOTE: THE FINAL SORT IS SET-UP S. T. AIREPS/PIREPS ARE FIRST, FOLLOWED C BY ASDARS/AMDARS, AND THEN AT THE END ALL EXLCUDED REPORTS -- ONLY C THE NON-EXCLUDED AIREP/PIREP REPORTS ARE CHECKED FOR STACKS C K=1 INDX=2 NCUM=2 IFLEPT(1)=1 IFLEPT(KOUNT+1)=1 KDUP=NFILE - KOUNT 94 CONTINUE C C FIND COLOCATED OBS- THRU ENTIRE FILE (TOLERANCE IS .55 DEG. LAT/LON) C IQ1=NINT(ABS(ALAT(INDX)-ALAT(INDX-1)) * 100.) IQ2=NINT(ABS(ALON(INDX)-ALON(INDX-1)) * 100.) C C THIS IS A STACK C IF(IQ1.LE.ITOL.AND.(IQ2.LE.ITOL.OR.IQ2.GE.36000-ITOL)) THEN C C FATAL ERROR: THERE ARE MORE REPORTS IN A STACK THAN "ISMX" C IF(NCUM.GT.ISMX) THEN PRINT 63, ISMX 63 FORMAT(' THERE ARE MORE THAN',I9,' AIRCRAFT IN A STACK', $ ' -- MUST INCREASE SIZE OF PARAMETER NAME "ISMX" - ABORT') CALL ABORT END IF IFLEPT(INDX)=NCUM NCUM=NCUM + 1 ELSE C C THIS IS NOT A STACK C IFLEPT(INDX)=1 NCUM=2 END IF C IF(INDX.LT.KOUNT-NASDAR-NEXCLD) THEN INDX=INDX + 1 GO TO 94 END IF C C ALL ASDAR/AMDAR AND EXCLUDED REPORTS ARE TREATED AS ISOLATED C C-CRA CALL XSTORE(IFLEPT(INDX+1),1,NASDAR+NEXCLD) DO I=1,NASDAR+NEXCLD IFLEPT(INDX+1+I-1)=1 ENDDO C C ARRANGE STACK - INDX RUNS FROM 1 TO KOUNT WHILE COUNTER FOR C ISTCPT RUNS FROM 1 TO NUM FOR EACH COLOCATED SET C NUM=1 C-CRA CALL XSTORE(JARRAY,0,IRMX*ISIZE) DO I=1,IRMX*ISIZE JARRAY(I,1)=0 ENDDO C-CRA CALL XSTORE(CTAG,' ',IRMX*14/LW) C-CRA CALL XSTORE(AAID,' ',IRMX*8/LW) DO I=1,IRMX CTAG(I)=' ' ENDDO DO I=1,IRMX AAID(I)=' ' ENDDO C C THIS IS AN ISOLATED OBSERVATION C (NOTE: NO FLAGGING IS DONE FOR CALM WINDS WHEN OBS. IS ISOLATED) C DO 19 INDX=1,KOUNT C C CASE 1: C IF(IFLEPT(INDX).EQ.1.AND.IFLEPT(INDX+1).EQ.1) THEN TAG(INDX)(12:12)='I' SLAT(1)=ALAT(INDX) SLON(1)=ALON(INDX) SAID(1)=ACID(INDX) SHGT(1)=AALT(INDX) STIM(1)=TIME(INDX) SDIR(1)=ADIR(INDX) SSPD(1)=ASPD(INDX) STMP(1)=ATMP(INDX) SHGTF(1)=AALTF(INDX) SDIRF(1)=ADIRF(INDX) SSPDF(1)=ASPDF(INDX) STMPF(1)=ATMPF(INDX) ISTCPT(1)=1 IF(TAG(INDX)(1:1).GE.'W'.AND.TAG(INDX)(1:1).LE.'Z'.AND. $ INDX.LE.KOUNT-NASDAR-NEXCLD) THEN C C IF LARGE VECTOR WIND INCREMENT (W - Z) AND NON-EXCLUDED AIREP/PIREP C REPORT, CALL WAYPOINT TO SEE IF LOCATION NEEDS TO BE CHANGED C JARRAY(INDX,1)=NINT(ALAT(INDX)*100.) JARRAY(INDX,2)=NINT(ALON(INDX)*100.) CTAG(INDX)=TAG(INDX) AAID(INDX)=ACID(INDX) CALL WAYPT(INDX,INDX,NCHNGD) IF(NCHNGD.EQ.1) THEN ALAT(INDX)=JARRAY(INDX,1) * .01 ALON(INDX)=JARRAY(INDX,2) * .01 TAG(INDX)=CTAG(INDX) PRINT *,'WAYPT ERROR FROM CALL IN MAIN' C C SUBR. WAYPT HAS CHANGED LOCATION OF THIS REPORT AND HAS UPGRADED THE C INCREMENT MARKER TO " " (SUSPECT) C PRINT 5768,INDX,ACID(INDX),ALAT(INDX),ALON(INDX), $ ADIR(INDX),ASPD(INDX),TAG(INDX),INDX 5768 FORMAT(' IN MAIN: WAYPT CALL ', $ I5,2X,A8,2F8.2,F6.0,F6.1,2X,A14/ $ 5X,' -- TAG(',I5,')(1:1) CHANGED TO " "'/) ENDIF ENDIF C C CALL FORSDM TO ALERT SDM TO FLAGGED ISOLATED REPORTS C (SKIP EXCLUDED REPORTS AT END OF THE LIST, BUT INCLUDE ASDARS/AMDARS) C IF(INDX.LE.KOUNT-NEXCLD) CALL FORSDM(INDX) C C CALL RPACKR C CALL RPACKR(1,1,INDX) ICNT1=ICNT1 + 1 C C CASE 2: CONTINUE, THERE ARE AT LEAST TWO C ELSE IF(IFLEPT(INDX).EQ.1.AND.IFLEPT(INDX+1).EQ.2) THEN U(1)=-SIN(ADIR(INDX)*RAD) * ASPD(INDX) V(1)=-COS(ADIR(INDX)*RAD) * ASPD(INDX) UF(1)=XMSG VF(1)=XMSG IF(AMAX1(ADIRF(INDX),ASPDF(INDX)).LE.XMSG) THEN UF(1)=-SIN(ADIRF(INDX)*RAD) * ASPDF(INDX) VF(1)=-COS(ADIRF(INDX)*RAD) * ASPDF(INDX) END IF C C JNDX SAVES THE STARTING POINT OF THE STAC C JNDX=INDX C C CASE 3: CONTINUE, THERE ARE STILL MORE C ELSE IF(IFLEPT(INDX).GT.1.AND.IFLEPT(INDX+1).GT.1) THEN NUM=IFLEPT(INDX) U(NUM)=-SIN(ADIR(INDX)*RAD) * ASPD(INDX) V(NUM)=-COS(ADIR(INDX)*RAD) * ASPD(INDX) UF(NUM)=XMSG VF(NUM)=XMSG IF(AMAX1(ADIRF(INDX),ASPDF(INDX)).LE.XMSG) THEN UF(NUM)=-SIN(ADIRF(INDX)*RAD) * ASPDF(INDX) VF(NUM)=-COS(ADIRF(INDX)*RAD) * ASPDF(INDX) END IF C C CASE 4: THERE IT IS FINISHED --- THIS IS A STACK OF 'NUM' OBSERVATIONS C ELSE IF(IFLEPT(INDX).GT.1.AND.IFLEPT(INDX+1).EQ.1) THEN NUM=IFLEPT(INDX) NUMORG=NUM U(NUM)=-SIN(ADIR(INDX)*RAD) * ASPD(INDX) V(NUM)=-COS(ADIR(INDX)*RAD) * ASPD(INDX) UF(NUM)=XMSG VF(NUM)=XMSG IF(AMAX1(ADIRF(INDX),ASPDF(INDX)).LE.XMSG) THEN UF(NUM)=-SIN(ADIRF(INDX)*RAD) * ASPDF(INDX) VF(NUM)=-COS(ADIRF(INDX)*RAD) * ASPDF(INDX) END IF DO K=1,NUM KNDX=JNDX - 1 + K SLAT(K)=ALAT(KNDX) SLON(K)=ALON(KNDX) SAID(K)=ACID(KNDX) SHGT(K)=AALT(KNDX) STIM(K)=TIME(KNDX) SDIR(K)=ADIR(KNDX) SSPD(K)=ASPD(KNDX) STMP(K)=ATMP(KNDX) SHGTF(K)=AALTF(KNDX) SDIRF(K)=ADIRF(KNDX) SSPDF(K)=ASPDF(KNDX) STMPF(K)=ATMPF(KNDX) ISTCPT(K)=K KBAD(K) =K ENDDO C C NOTE THAT AT THIS POINT ISTCPT ARRAY IS JUST DIGITAL COUNT C C CHECK FOR DUPLICATE REPORTS IN THE STACK MISSED BY DECODER C AND TRKCHK ROUTINE C IK=0 KNUM=NUM DO 191 I=1,NUM-1 DO 191 J=I+1,NUM IF(SAID(I).EQ.SAID(J)) THEN IK=IK + 1 IDSTR(IK,1)=I IDSTR(IK,2)=J IF(IK.GE.400) THEN PRINT 445 445 FORMAT(' ** IN DUPL. CHECK A STACK ', $ 'W/ .GT. 400 DUPL. ACID"S ', $ 'FOUND -- MUST BUMP-UP ARRAY -- ', $ 'NO MORE DUPL. CAN BE CHECKED!!') GO TO 1191 END IF END IF 191 CONTINUE 1191 CONTINUE IF(IK.GT.0) THEN DO 1911 K=1,IK KNDX=JNDX - 1 + IDSTR(K,1) LNDX=JNDX - 1 + IDSTR(K,2) IHGT1=AALT(KNDX) IHGT2=AALT(LNDX) ISPD1=ASPD(KNDX) ISPD2=ASPD(LNDX) IDIR1=ADIR(KNDX) IDIR2=ADIR(LNDX) IF(IHGT1.EQ.IHGT2.AND.ISPD1.EQ.ISPD2.AND. $ IDIR1.EQ.IDIR2) THEN L=IDSTR(K,1) M=IDSTR(K,2) IFLEPT(KNDX)=0 ISTCPT(L)=0 KDUP=KDUP + 1 C C ASSIGN 'D' TO POS. 1 OF TAG TO INDICATE DUPLICATE (RPACKR WILL DELETE) C TAG(KNDX)(1:1)='D' TAG(KNDX)(13:13)='0' TAG(KNDX)(14:14)='0' KNUM=KNUM - 1 PRINT 5382, L,KNDX,SAID(L),SHGT(L),STIM(L), $ SDIR(L),SSPD(L),ALAT(KNDX),ALON(KNDX),NUM PRINT 5383, M,LNDX,SAID(M),SHGT(M),STIM(M), $ SDIR(M),SSPD(M),ALAT(LNDX),ALON(LNDX),KNUM 5382 FORMAT(' **DUP CHECKR THROWS ',2I5,2X,A6,', $ AALT=',F7.0,', TIME=', $ F7.0,', DIR=',F5.0,', SPD=',F5.1, $ ', LAT/LON=',2F7.2,' NUM=',I3) 5383 FORMAT(' THE OTHER IS ',2I5,2X,A6, $ ',AALT=',F7.0,', TIME=', $ F7.0,', DIR=',F5.0,', SPD=',F5.1, $ ', LAT/LON=',2F7.2,' KNUM=',I3) END IF 1911 CONTINUE IF(KNUM.EQ.1) THEN C C IF ALL DUPL. BUT ONE ARE REMOVED, THIS REPORT NOW TREATED AS ISOLATED C TAG(JNDX+1)(12:12)='I' CALL RPACKR(1,1,JNDX+1) GO TO 19 END IF END IF C C COUNT CALMS C KNUM=0 DO 1192 KNDX=JNDX,JNDX+NUM-1 IF(ASPD(KNDX).EQ.0.0) KNUM=KNUM + 1 1192 CONTINUE IF(KNUM.LE.3.AND.NUM.LE.6) THEN C C IF NUMBER OF CALMS IN STACK (KNUM) < 3 THEN FLAG WINDS C DO 193 K=1,NUM KNDX=K + JNDX - 1 IF(ASPD(KNDX).EQ.0.0) THEN IFLEPT(KNDX)=0 IF(TAG(KNDX)(14:14).GT.'3') THEN TAG(KNDX)(4:4)='F' TAG(KNDX)(14:14)='3' IWEVNT(KNDX)=306 END IF END IF ISTCPT(K)=IFLEPT(KNDX) 193 CONTINUE END IF LOALT=0 DO 712 I=1,NUM KNDX=JNDX + I - 1 IF(AALT(KNDX).LT.8400.) THEN IFLEPT(KNDX)=-1 ISTCPT(I)=-1 LOALT=LOALT + 1 END IF 712 CONTINUE C C CALLS TO APPROPRIATE ROUTINES C NTOTL=NUM IF(NUM.EQ.2) THEN CALL PRELIM(NUM,JNDX,LOALT,KNUM,STCLIM) IF(DOSPOB) CALL NOEQ2(NUM,JNDX,NTOTL) CALL RPACKR(NUM,NTOTL,JNDX) ICNT2=ICNT2 + 1 NUM=1 ELSE CALL PRELIM(NUM,JNDX,LOALT,KNUM,STCLIM) IF(DOSPOB) CALL SUPROB(NUM,JNDX,NTOTL,LOALT,KNUM) C C CALL RPACKR C CALL RPACKR(NUM,NTOTL,JNDX) C C DO CENSUS ON +S AT POINTS-BOOKEEPING C IF(NUM.GT.10) THEN ICNTX=ICNTX + 1 ELSE IF(NUM.GT.5) THEN ICNT69=ICNT69 + 1 ELSE IF(NUM .GT. 3) THEN ICNT45=ICNT45+ 1 ELSE ICNT3=ICNT3 + 1 END IF NUM=1 END IF END IF C C END OF CASES C 19 CONTINUE 6000 CONTINUE C CALL OBUFR(KOUNT) C C ALL REPORTS HAVE BEEN PROCESSED -- WE ARE DONE C PRINT 8926, KNTOUT(1),KNTOUT(2),KNTOUT(4),KNTOUT(5) 8926 FORMAT('ALL REPORTS PROCESSED: NUMBER OF ORIGINAL ', $ '"AIRCFT" MASS RPTS COPIED TO OUTPUT FILE =',I5/35X,'NUMBER OF ', $ 'ORIGINAL "AIRCFT" WIND REPORTS COPIED TO OUTPUT FILE =',I5/35X, $ 'NUMBER OF SUPEROB MASS RPTS WRITTEN TO OUTPUT FILE =',I5/35X, $ 'NUMBER OF SUPEROB WIND RPTS WRITTEN TO OUTPUT FILE =',I5) C IF(FWRITE) THEN PRINT 8923 8923 FORMAT(26X,' ORIGINAL LISTING OF AIRCRAFT REPORTS NOW ', $ 'WITH NEW QUALITY MARKS'//' K STNID TIME LAT ', $ 'LON ALT TEMP DIR SPD Q.M. -----TAGS----- ITYP RCTME ', $ 'KINI TEVN WEVN GALT GTEMP GDIR GSPD'/16X,'UTC',9X,'WEST', $ 5X,'M C*10 DEG KTS',7X,14('-'),7X,'UTC',21X, $ 'M C*10 DEG ','KTS') KNT=0 DO 200 K=1,KOUNT IF(TAG(K)(1:1).EQ.'D') GO TO 200 KNT=KNT + 1 PRINT 6111, KNT,ACID(K),NINT(TIME(K)),ALAT(K),ALON(K), $ NINT(AALT(K)),NINT(ATMP(K)),NINT(ADIR(K)),NINT(ASPD(K)), $ TAG(K)(2:2),TAG(K)(4:4),TAG(K),INTP(K),IRTM(K),KNTINI(K), $ ITEVNT(K),IWEVNT(K),NINT(AALTF(K)),NINT(ATMPF(K)), $ NINT(ADIRF(K)),NINT(ASPDF(K)) 6111 FORMAT(' ',I5,1X,A8,I4,2F7.2,2I6,2I5,2X,A1,1X,A1,2X,A14,I4, $ 2I6,2I5,I7,3I6) 200 CONTINUE IF(KNTOUT(3).GT.0) THEN PRINT 9925 9925 FORMAT(35X,'>>>>> LISTING OF NEW SUPEROB REPORTS', $ 'IN AIRCFT ', $, 'FILE <<<<<'//5X,'K STNID', $ 4X,'TIME',6X,'LAT',6X,'LON ALT', $ 7X,'TEMP DIR SPEED QUAL GESS: ALT',6X, $ 'TEMP DIR ', $ ' SPEED INCR'/18X,'UTC',14X,'WEST METERS', $ ' DEG.C DEG. ', $ ' KNOTS MARKS --> METERS DEG.C DEG.', $ ' KNOTS -T--W-'/) KNT=0 DO 202 K=1,KNTOUT(3) IF(SSMARK(K)(3:4).EQ.'FF') GO TO 202 KNT=KNT + 1 TEMP=XMSG IF(SSTMP(K).LT.XMSG) TEMP=SSTMP(K)/10. TMPF=XMSG IF(SSTMPF(K).LT.XMSG) TMPF=SSTMPF(K)/10. PRINT 6113, KNT,SSTIM(K),SSLAT(K),SSLON(K),SSHGT(K),TEMP, $ SSDIR(K),SSSPD(K),SSMARK(K)(1:1),SSMARK(K)(2:2), $ SSHGTF(K),TMPF,SSDIRF(K),SSSPDF(K),SSMARK(K)(3:3), $ SSMARK(K)(4:4) 6113 FORMAT(1X,I5,' SUPROB',F8.0,2F9.2,F9.0,F10.2,F7.0,F7.1, $ 4X,A1,1X,A1,6X,F9.0,F9.2,F7.0,F8.1,3X,A1,2X,A1) 202 CONTINUE ENDIF ENDIF C PRINT 5001, NFILE,ICNT1,ICNT2,ICNT3,ICNT45,ICNT69,ICNTX,KDUP 5001 FORMAT(//' ORIGINAL DATA (WITHIN EXPANDED INPUT TIME WINDOW)'/ $ ' TOTAL KOUNTS =',I6,'; =1 -',I6,'; =2 -',I5,'; =3 -',I5, $ '; =4,5 -',I5,'; =6-9 -',I5,'; .GT. 10 -',I5,'+ DUPS -',I5) C PRINT 5012, KTYPS 5012 FORMAT(/' +TYPE1A ',I2,' +TYPE1B ',I2,' +TYPE?? ',I2,' +TYPE1D ', $ I2,' +TYPE2A ',I2,' +TYPE2B ',I2,' +TYPE3 ',I2,10X,I2,' TIME ', $ 'TAGS',I2) C PRINT 5014, QCACMK 5014 FORMAT(//' ORIGINAL DATA (WITHIN OUTPUT TIME WINDOW)'/14X, $ 15(5X,A1)/) C PRINT 5331, NNQM 5331 FORMAT(' TOTAL QM +S=',15I6) C PRINT 5337, KISO 5337 FORMAT(' ISOLA QM +S=',15I6) C PRINT 5338, KNQM 5338 FORMAT(' STACK QM +S=',15I6) C PRINT 5011, KQM2F 5011 FORMAT(' STACK WND QM=F',15I6/) C PRINT 5013, KSDM,KT 5013 FORMAT(' STACK: NO. SDM (ONLY) PURGES',I5,'; NO. SDM KEEPS',I5, $ '; NO. BAD TEMPS/NON-BAD WINDS',I5/) C END FILE 52 REWIND 52 END FILE 53 REWIND 53 C C IF NO DATA PROCESSED (INPUT FILE HAS NO REPORTS) C IF(INIDST.LT.2.AND.KNTOUT(1)+KNTOUT(3).EQ.0) THEN PRINT 73 73 FORMAT(' $$$$$ THERE WERE NO REPORTS PROCESSED - INPUT FILE ', $ 'HAS NO REPORTS -- ABORT'/) PRINT 5015 CALL ABORT END IF PRINT 5015 5015 FORMAT(/49X,'************PROGRAM COMPLETED *********') STOP END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TRKCHK COMPLETE TRACK CHECK FOR ALL FLIGHTS C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 95-04-26 C C ABSTRACT: PERFORMS COMPLETE TRACK CHECK FOR ALL AIRCRAFT FLIGHTS C WITH TWO OR MORE REPORTS. USING REPORTS ALREADY SORTED BY STATION C (FLIGHT) ID, CALULATES GROUND SPEED AND OTHER LOGICAL QUANTITIES C TO ENTER DECISION MAKING ALGORITHM FOR CHOOSING BAD REPORTS. THESE C OBSERVATIONS ARE FLAGGED. DUPLICATE REPORTS ARE ELIMINATED. C C PROGRAM HISTORY LOG: C 93-01-05 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR C 94-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT C 95-02-10 D. A. KEYSER -- ADDED COND. CODE 24 IF NO. RPTS. IN A C TRACK EXCEEDS PARAMETER "ITMX", THIS IS BUMPED UP FROM C 40 TO 500 C 95-03-27 D. A. KEYSER -- ALL ASDAR/AMDAR RPTS IN A TRACK W/ AVG. C INCR. > 70 KTS AMONGST > 14 RPTS. GET FLAGGED WIND (& C LATER TEMP) (& FOR INIDST=2, NEW RSN. CODE 27) C 95-04-26 D. A. KEYSER -- ALL ASDAR/AMDAR RPTS IN A TRACK W/ > 14 C RPTS GET FLAGGED WIND (& LATER TEMP) IF > 9 RPTS HAVE C WIND INCR. > 50 KNOTS (CHANGE FROM PREVIOUS TEST, SEE C PREVIOUS HISTORY LOG) C C 97-02-25 M. KANAMITSU -- MODIFIED TO RUN ON WORKSTATIONS C C USAGE: CALL TRKCHK(NFILE,NASDAR,NEXCLD) C INPUT ARGUMENT LIST: C NFILE - NUMBER OF OBSERVATIONS TO BE TREATED C NASDAR - NUMBER OF ASDAR/AMDAR REPORTS C NEXCLD - NUMBER OF EXCLUDED REPORTS AT END OF SORT C C OUTPUT ARGUMENT LIST: C NFILE - NUMBER OF OBSERVATIONS AFTER DUPLICATES REMOVED C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY MAIN PROGRAM. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS C C$$$ SUBROUTINE TRKCHK(NFILE,NASDAR,NEXCLD) c change wne 10/2000 PARAMETER (IRMX=5000,ISMX=500) PARAMETER (IRMX=100000,ISMX=500) PARAMETER (ISIZE=16) C C PARAMETER NAME "ITMX" IN THIS SUBROUTINE (ONLY) SETS THE MAXIMUM C NUMBER OF ACFT RPTS THAT CAN BE CHECKED IN A SINGLE TRACK C c change wne 10/2000 PARAMETER (ITMX=1000) c PARAMETER (ITMX=2000) c change wne 11/2002 PARAMETER (ITMX=5000) PARAMETER (ITRKL=20) C-CRA LOGICAL LOGLAT,LOGTME,LOGLT1,LOGWND,DUP,LOGTRK,LOGALT,NEW,LOGLON, C-CRA$ LOGLO,LOGTMP,LOGGT3,LOGHI,LPOS25,TRACE,LUTCEQ,LLATEQ,LLONEQ, C-CRA$ LVAREQ,IWRITE LOGICAL LOGLAT,LOGTME,LOGLT1,LOGWND,DUP,LOGTRK,LOGALT,NEW,LOGLON, $ LOGLO,LOGTMP,LOGGT3,LOGHI,LPOS25,TRACE,LUTCEQ,LLATEQ,LLONEQ, $ LVAREQ CHARACTER*1 TOSLIM,CTG CHARACTER*8 ACID,SAAID(IRMX),AAID(IRMX),TYPE(ITRKL) CHARACTER*14 TAG,CTAG(IRMX),STAG(IRMX) CHARACTER*16 CARRAY(IRMX) INTEGER IPTNAD(ITRKL),JPTNAD(ITRKL),IPTADJ(ITRKL),IPTTRK(ITMX), $ DTKNT,IARRAY(ISMX),INDR(IRMX) REAL AVESPD(ITMX),DELPOS(ITMX),DELLAT(ITMX),DELLON(ITMX), $ DELTME(ITMX) COMMON/WORD/LW,ICHTP C-CRA COMMON/WRITE/SWRITE,IWRITE LOGICAL SWRITE,IWRITE COMMON/COMWRITE/SWRITE,IWRITE COMMON/XXXXX/AAID,JARRAY(IRMX,ISIZE),CTAG,KARRAY(IRMX,ISIZE),STAG COMMON/ACCONT/KQM2F(15),KISO(15),KNQM(15),KSDM(2),KT,KTYPS(9) COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), $ ADIRF(IRMX) C KOUNT=NFILE TRACE=.TRUE. TRACE=.FALSE. DG2RAD=(4.0*ATAN(1.0))/180. C C TRANSFER ORIGINAL DATA TO TEMPORARY ARRAYS TO HOLD FOR RE-ARRANGING C (ORIGINAL DATA HAS BEEN SORTED BY FLIGHT ID, WITH ASDARS/AMDARS LAST) C DO J=1,NFILE AAID(J)=ACID(J) SAAID(J)=AAID(J) JARRAY(J,1) =NINT(ALAT(J)*100.) JARRAY(J,2) =NINT(ALON(J)*100.) JARRAY(J,3) =NINT(AALT(J)) JARRAY(J,4) =NINT(TIME(J)) JARRAY(J,5) =NINT(ATMP(J)) JARRAY(J,6) =NINT(ADIR(J)) JARRAY(J,7) =NINT(ASPD(J)) JARRAY(J,8) =INTP(J) JARRAY(J,9) =IRTM(J) JARRAY(J,10)=KNTINI(J) JARRAY(J,11)=ITEVNT(J) JARRAY(J,12)=IWEVNT(J) JARRAY(J,13) =NINT(AALTF(J)) JARRAY(J,14) =NINT(ADIRF(J)) JARRAY(J,15) =NINT(ASPDF(J)) JARRAY(J,16) =NINT(ATMPF(J)) DO JJ=1,ISIZE KARRAY(J,JJ)=JARRAY(J,JJ) ENDDO CTAG(J)=TAG(J) STAG(J)=CTAG(J) ENDDO C NAIREP=NFILE-NASDAR-NEXCLD PRINT 501, KOUNT,NASDAR,NAIREP,NEXCLD 501 FORMAT(1X,128('*')/43X,'AIRCRAFT TRACK CHECK SORT - NMC, ', $ 'WASHINGTON'/128('*')//' FILE KOUNT= ',I4,' + ASDARS= ',I4, $ ' + AIREPS= ',I4,' + EXCLUDED= ',I4) C C*********************************************************************** C DETERMINE TRACK FOR EACH ASDAR/AMDAR FLIGHT ID C*********************************************************************** C PRINT *,' ----------------------------------' PRINT *,'ASDAR/AMDAR REPORTS CURRENTLY NOT TRACK CHECKED' PRINT *,' ----------------------------------' NTRK=0 ITRK=NAIREP + 1 65 CONTINUE C C C IF(ITRK.LT.NFILE-NEXCLD) THEN C JTRK=ITRK + NTRK + 1 IBEG=ITRK IF(AAID(ITRK).EQ.AAID(JTRK)) THEN C C FLIGHT ID'S MATCH - RECORD STARTING POINT AS IBEG C NTRK=NTRK + 1 GO TO 65 ELSE C C END OF TRACK, STORE LAST INDEX C IEND=JTRK - 1 ITRK=IEND + 1 IF(NTRK.NE.0) NTRK=NTRK + 1 LTRK=NTRK END IF C IF(TRACE) PRINT 8810, ITRK,JTRK,NTRK,IBEG,IEND 8810 FORMAT(' TRKEND- ITRK,JTRK,NTRK,IBEG,IEND ',5I5) C C TO GET REASONABLE GROUND SPEED CHECKS TAKE EVERY OTHER REPORT C DO 220 LREP=1,2 LBEG=IBEG + (LREP - 1) DO 221 L=LBEG,IEND-2,2 K=L - IBEG + 1 IF(K.GT.ITMX) GO TO 9999 IF(JARRAY(L,3).LT.8000) GO TO 221 LOGTRK=(CTAG(L)(5:5).GE.'X'.AND.CTAG(L)(5:5).LE.'Z') DELPOS(K)=0.0 DELLAT(K)=0.0 DELLON(K)=0.0 DELTME(K)=0.0 QCOS=COS((JARRAY(L,1)+JARRAY(L+2,1))*0.005*DG2RAD) QDELT=IABS(JARRAY(L,4)-JARRAY(L+2,4))*0.01 DELTME(K)=QDELT IF(QDELT.EQ.0.0) QDELT=0.001 DELLON(K)=IABS(JARRAY(L,2)-JARRAY(L+2,2))*0.01 DELLON(K)=AMIN1(DELLON(K),360.-DELLON(K)) DELLAT(K)=IABS(JARRAY(L,1)-JARRAY(L+2,1))*0.01 C C UNITS FOR POSTION DIFFERENCE- DEGREES C DELPOS(K)=SQRT(DELLAT(K)**2+(DELLON(K)*QCOS)**2) RDELT=999. IF(QDELT.GT.0.0) RDELT=1./QDELT C C UNITS FOR APPARENT AVERAGE SPEED- KNOTS C AVESPD(K)=DELPOS(K)*RDELT*65.3 C C LPOS25=T INDICATES UNREASONABLE GROUND SPEED FOR ASDAR/AMDAR OBS. C LPOS25=(AVESPD(K).LT.250..OR.AVESPD(K).GT.770.) IF(LOGTRK.OR.LPOS25) THEN PRINT 534,AAID(L),JARRAY(L,1),JARRAY(L,2),JARRAY(L,4), $ JARRAY(L,3),JARRAY(L,5),JARRAY(L,6),JARRAY(L,7), $ (CTAG(L)(JJJ:JJJ),JJJ=1,14),DELPOS(K),AVESPD(K) 534 FORMAT('POSSIBLE ASDAR/AMDAR ERROR:',A8,6I7,2X,I3, $ 14(1X,A1),'/',' ',F7.1,2X,F7.1) IF(LOGTRK.AND.LPOS25.AND.CTAG(L)(14:14).GT.'3') THEN PRINT *,'SEE BELOW: EVENT 307 ' CTAG(L)(4:4)='F' STAG(L)(4:4)='F' CTAG(L)(14:14)='3' STAG(L)(14:14)='3' JARRAY(L,12)=307 KARRAY(L,12)=307 ENDIF ENDIF 221 CONTINUE 220 CONTINUE C QSUM =0.0 IQNUM=0 QSUM1=0.0 JQNUM=0 DO 5213 L=IBEG,IEND C C CALCULATE AVERAGE VECTOR INCREMENT FOR TRACK (QSUM) AMONGST THOSE OBS. C WITH A SCALED INCREMENT (BASED ON ORDINAL POS. FOR mova2i -- CHARACTE C CONVERTED TO EBCDIC IF ASCII ON THIS MACHINE) C IF(CTAG(L)(5:5).GE.'Q'.AND.CTAG(L)(5:5).LE.'Z') THEN CTG=CTAG(L)(5:5) IF(ICHTP.EQ.0) CALL W3AI39(CTG,1) ITRANS=0 IF(mova2i(CTG).GE.226) ITRANS=8 SCALE =(10.*(mova2i(CTG) - ITRANS - 215)) - 5. IQNUM=IQNUM + 1 QSUM=QSUM + SCALE C C CALCULATE AVERAGE VECTOR INCREMENT FOR TRACK (QSUM1) AMONGST THOSE C OBS. WITH SCALED INCREMENT > 50 KNOTS C IF(CTAG(L)(5:5).GE.'V') THEN JQNUM=JQNUM + 1 QSUM1=QSUM1 + SCALE END IF END IF 5213 CONTINUE IF(IQNUM.GT.14) THEN QSUM=QSUM/IQNUM PRINT *,'FOR ASDAR TRK BEG AT ',IBEG,' AND ENDING AT ',IEND, $ ' THERE ARE ',IQNUM,' RPTS W/ INCR., MEAN IS ',QSUM IF(JQNUM.GT.9) THEN QSUM1=QSUM1/JQNUM PRINT *,'$$ ALSO FOR THIS ASDAR TRK, THERE ARE ', $ JQNUM,' RPTS W/ INCR. > 50 KNOTS, MEAN INCR. IS ',QSUM1 C C IF > 14 REPORTS IN TRACK AND AMONGST THESE > 9 HAVE VECTOR INCREMENT C > 50 KNOTS, ASSUME ENTIRE FLIGHT IS BAD (FLAG ALL WINDS IN TRACK) C PRINT *,' ----------------------------------' PRINT *,'SEE BELOW: LARGE TRACK INCR. IN ASDARS' PRINT 520 520 FORMAT(' --> FOLLOWING TRACK HAS > 14 ', $ 'REPORTS WITH > 9 HAVING ', $ 'WIND INCR. > 50 KTS, ALL WINDS FLAGGED!!'/) DO 5214 L=IBEG,IEND IF(CTAG(L)(14:14).GT.'3') THEN CTAG(L)(4:4)='F' STAG(L)(4:4)='F' CTAG(L)(14:14)='3' STAG(L)(14:14)='3' JARRAY(L,12)=327 KARRAY(L,12)=327 END IF PRINT 9520, L,AAID(L),REAL(JARRAY(L,1))*.01, $ REAL(JARRAY(L,2))*.01,REAL(JARRAY(L,4)),CTAG(L) 9520 FORMAT(5X,I5,2X,A8,2F8.2,F6.0,2X,A14) 5214 CONTINUE PRINT *,' ----------------------------------' END IF END IF C NTRK=0 GO TO 65 END IF C C END OF IF(ITRK.LT.NFILE-NEXCLD) C PRINT *,' ----------------------------------' C C*********************************************************************** C DETERMINE TRACK FOR EACH NON-EXCLUDED AIREP/PIREP FLIGHT ID C*********************************************************************** C PRINT 2520 2520 FORMAT(' ====> BEGIN TRACK CHECKING OF AIREP/PIREP REPORTS'/) PRINT *,' ----------------------------------' NTRK=0 ITRK=1 C C======================================================================= C START OF EACH TRACK C C NEXT BIG IF STARTS HERE (THERE IS AN ELSEIF) C======================================================================= C MCOUNT=0 66 CONTINUE MCOUNT=MCOUNT+1 WRITE(88,*)'DEBUG PRINT:MCOUNT=',MCOUNT C IF(ITRK.LT.NAIREP) THEN JTRK=ITRK+NTRK+1 IBEG=ITRK C C FLIGHT ID'S MATCH - RECORD STARTING POINT AS IBEG C IF(AAID(ITRK).EQ.AAID(JTRK)) THEN NTRK=NTRK+1 GO TO 66 ELSE C C END OF TRACK, STORE LAST INDEX C IEND=JTRK - 1 IF(IEND-IBEG.GT.ITMX) GO TO 9999 ITRK=IEND + 1 IF(NTRK.NE.0) NTRK=NTRK + 1 LTRK=NTRK END IF C C INITITIALIZE VARIABLES C IF(TRACE) PRINT 8810,ITRK,JTRK,NTRK,IBEG,IEND LOGTRK=.FALSE. LOGTME=.FALSE. LOGLT1=.FALSE. LPOS25=.FALSE. DUP =.FALSE. TOSLIM='S' NAPTS=0 NPTRS=0 NTYPS=0 NTRKP=0 DO I=1,ITRKL TYPE(I)=' ' ENDDO C C----------------------------------------------------------------------- C CHECK PAIRS -- LTRK=2 C----------------------------------------------------------------------- C IF(LTRK.EQ.2) THEN II=IBEG C C CERTAIN RPTS (E.G, 3 CHAR ID,"AIRCFT") ARE NOT CONSIDERED FOR THE TRAC C IF(AAID(II)(4:4).EQ.' '.OR.AAID(II)(1:4).EQ.'AIRC'.OR. $ AAID(II)(1:5).EQ.'COA16') THEN PRINT 8866, ITRK,LTRK,IBEG,IEND,AAID(II) 8866 FORMAT(' SKIP IN TRKCHK ',4I5,2X,' ACID ',A8) NTRK=0 GO TO 66 ENDIF LOGLAT=(JARRAY(II,1).EQ.JARRAY(II+1,1)) LOGLON=(JARRAY(II,2).EQ.JARRAY(II+1,2)) LOGALT=(JARRAY(II,3).EQ.JARRAY(II+1,3)) LOGTMP=(JARRAY(II,5).EQ.JARRAY(II+1,5)) LOGWND=((JARRAY(II,6).EQ.JARRAY(II+1,6)).AND. $ (JARRAY(II,7).EQ.JARRAY(II+1,7))) QCOS=COS((JARRAY(II,1)+JARRAY(II+1,1))*0.005*DG2RAD) QDELT=IABS(JARRAY(II,4)-JARRAY(II+1,4))*0.01 LOGTME=(QDELT.LT.0.04) DELPOS(1)=SQRT(((JARRAY(II,1)-JARRAY(II+1,1))*0.01)**2+ $ ((JARRAY(II,2)-JARRAY(II+1,2))*QCOS*0.01)**2) RDELT=999. AVESPD(1)=-9999.9 IF(QDELT.GT.0.0) THEN RDELT=1./QDELT AVESPD(1)=DELPOS(1)*RDELT*65.3 END IF IF(QDELT.GT.4.0.AND.DELPOS(1).GT.40.) THEN PRINT 301, IBEG,AAID(IBEG),JARRAY(IBEG,1),JARRAY(IBEG,2), $ JARRAY(IBEG,4),JARRAY(IBEG,3),JARRAY(IBEG,5), $ JARRAY(IBEG,6), $ JARRAY(IBEG,7),CTAG(IBEG),DELPOS(1),AVESPD(1) PRINT 301, IEND,AAID(IEND),JARRAY(IEND,1),JARRAY(IEND,2), $ JARRAY(IEND,4),JARRAY(IEND,3),JARRAY(IEND,5), $ JARRAY(IEND,6), $ JARRAY(IEND,7),CTAG(IEND) 301 FORMAT(' PROB 2 FLIGHTS',I5,2X,A8,6I8,2X,I3,3X,A14,3X, $ 2F8.1) END IF C C UNITS FOR APPARENT AVERAGE SPEED- KNOTS C LOGTRK=(DELPOS(1).GT.15.0.AND.AVESPD(1).GT.770.) C C CALIBRATION CONSTANTS <2.0 DEGREES FOR SEPARATION ADJACENT REPORTS C CALIBRATION CONSTANTS >25.0 DEGREES FOR SEPARATION ADJACENT REPORTS C IF(DELPOS(1).LE.2.0) THEN LOGLT1=.TRUE. ELSEIF(DELPOS(1).GE.25.) THEN LPOS25=.TRUE. CALL WAYPT(IBEG,IEND,NCHNGD) IF(NCHNGD.GT.0) THEN PRINT *,'WAYPT(1) ERROR FOR PAIR IN TRACK CHECK' PRINT *,'WAYPOINT(1) HAS CHANGED REPORT LOCATION' DELPOS(1)=SQRT(((JARRAY(II,1)-JARRAY(II+1,1))*0.01) $ **2+ $ ((JARRAY(II,2)-JARRAY(II+1,2))*QCOS*0.01)**2) IF(DELPOS(1).LE.2.0) THEN LPOS25=.FALSE. LOGLT1=.TRUE. ENDIF ENDIF ENDIF C C TIMES MATCH C IF(CTAG(II)(5:5).EQ.'N'.OR.CTAG(II+1)(5:5).EQ.'N') GO TO 812 IF(LOGLT1.AND.LOGALT.AND.LOGWND) THEN C C TYPE IS DUPLICATE, PLACE 'D' IN POSITION 1 OF TAG C NTYPS=NTYPS+1 KTYPS(1)=KTYPS(1)+1 TYPE(NTYPS)='TYPE 1A ' DUP=.TRUE. WRITE(88,*) '1) CHOOSE FOR MCOUNT=',MCOUNT WRITE(88,*) IWHICH,II,II+1,CTAG(II),CTAG(II+1),DUP,NEW CALL CHOOSE(II,II+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'0') THEN CTAG(IWHICH)(1:1)='D' CTAG(IWHICH)(13:13)='0' CTAG(IWHICH)(14:14)='0' ENDIF PRINT 673, IBEG,IEND,CTAG(IBEG),CTAG(IEND) 673 FORMAT(' NTRK=2 TYPE 1A DUP',2(I5,1X),1X,A14,'/',A14) C C TYPE IS NOT A STRICT DUPLICATE, PLACE 'F' IN POSITION 4 OF Q.M. WORD C ELSE IF(LOGLAT.AND.LOGLON) THEN KTYPS(5)=KTYPS(5)+1 NTYPS=NTYPS+1 TYPE(NTYPS)='TYPE 2A ' DUP=.TRUE. WRITE(88,*) '2) CHOOSE FOR MCOUNT=',MCOUNT WRITE(88,*) IWHICH,II,II+1,CTAG(II),CTAG(II+1),DUP,NEW CALL CHOOSE(II,II+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'3') THEN CTAG(IWHICH)(4:4)='F' CTAG(IWHICH)(14:14)='3' JARRAY(IWHICH,12)=308 END IF PRINT 373, IBEG,IEND,CTAG(IBEG),CTAG(IEND) 373 FORMAT(' NTRK=2 TYPE 2 DUP',2(I5,1X),1X,A14,'/',A14) ELSE IF(LOGTME.AND.(LOGTMP.OR.LOGALT).AND.LOGWND) THEN KTYPS(2)=KTYPS(2)+1 NTYPS=NTYPS+1 TYPE(NTYPS)='TYPE 1B ' DUP=.TRUE. WRITE(88,*) '3) CHOOSE FOR MCOUNT=',MCOUNT WRITE(88,*) IWHICH,II,II+1,CTAG(II),CTAG(II+1),DUP,NEW CALL CHOOSE(II,II+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'0') THEN CTAG(IWHICH)(1:1)='D' CTAG(IWHICH)(13:13)='0' CTAG(IWHICH)(14:14)='0' END IF END IF C C CHECK FOR DELPOS AND LOGTRK C IF(LPOS25.AND.LOGWND.AND.LOGALT.AND.(LOGTMP.OR.LOGTME))THEN CALL WAYPT(IBEG,IEND,NCHNGD) IF(NCHNGD.GT.0) THEN PRINT *,'WAYPT(2) ERROR FOR PAIR IN TRACK CHECK' PRINT *,'WAYPOINT(2) HAS CHANGED REPORT LOCATION' KTYPS(6)=KTYPS(6)+1 TYPE(NTYPS)='TYPE 2B ' END IF DELPOS(1)=SQRT(((JARRAY(II,1)-JARRAY(II+1,1))*0.01)**2 $ +((JARRAY(II,2)-JARRAY(II+1,2))*QCOS*0.01)**2) IF(DELPOS(1).LE.2.0) THEN LOGLT1=.TRUE. ELSE IF(DELPOS(1).GE.15.) THEN LPOS25=.TRUE. END IF IF(LPOS25) THEN LOGTRK=.TRUE. DUP=.FALSE. WRITE(88,*) '4) CHOOSE FOR MCOUNT=',MCOUNT WRITE(88,*) IWHICH,II,II+1,CTAG(II),CTAG(II+1),DUP,NEW CALL CHOOSE(II,II+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) IF(NEW) THEN KTYPS(7)=KTYPS(7)+1 NTYPS=NTYPS+1 TYPE(NTYPS)='TYPE 3 ' IF(IWHICH.GT.0) THEN IF(CTAG(IWHICH)(14:14).GT.'3') THEN CTAG(IWHICH)(4:4)='F' CTAG(IWHICH)(14:14)='3' JARRAY(IWHICH,12)=309 END IF ELSEIF(MAYBE.GT.0.AND.CTAG(MAYBE)(14:14).GT.'3')THEN CTAG(MAYBE)(4:4)='F' CTAG(MAYBE)(14:14)='3' JARRAY(MAYBE,12)=309 END IF END IF END IF PRINT 433, IBEG,IEND,DELPOS(1),CTAG(IBEG),CTAG(IEND) 433 FORMAT(' NTRK=2 ERR',2(I5,1X),F5.1,1X,A14,'/',A14) END IF IF(LOGTRK) THEN TOSLIM='U' DUP=.FALSE. WRITE(88,*) '5) CHOOSE FOR MCOUNT=',MCOUNT WRITE(88,*) IWHICH,II,II+1,CTAG(II),CTAG(II+1),DUP,NEW CALL CHOOSE(II,II+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) IF(NEW) THEN KTYPS(7)=KTYPS(7)+1 NTYPS=NTYPS+1 TYPE(NTYPS)='TYPE 3 ' IF(IWHICH.GT.0) THEN IF(CTAG(IWHICH)(14:14).GT.'3') THEN CTAG(IWHICH)(4:4)='F' CTAG(IWHICH)(14:14)='3' JARRAY(IWHICH,12)=309 END IF ELSE IF(MAYBE.GT.0.AND.CTAG(MAYBE)(14:14).GT.'3') THEN CTAG(MAYBE)(4:4)='F' CTAG(MAYBE)(14:14)='3' JARRAY(MAYBE,12)=309 END IF END IF END IF IF(LPOS25.OR.LOGTME.OR.LOGWND.OR.LOGTRK.OR.DUP) THEN PRINT 302, IBEG, AAID(IBEG),JARRAY(IBEG,1),JARRAY(IBEG,2), $ JARRAY(IBEG,4),JARRAY(IBEG,3),JARRAY(IBEG,5), $ JARRAY(IBEG,6), $ JARRAY(IBEG,7),CTAG(IBEG),DELPOS(1),AVESPD(1) PRINT 302, IEND, AAID(IEND),JARRAY(IEND,1),JARRAY(IEND,2), $ JARRAY(IEND,4),JARRAY(IEND,3),JARRAY(IEND,5), $ JARRAY(IEND,6), $ JARRAY(IEND,7),CTAG(IEND) 302 FORMAT(' ',I5,2X,A8,6I8,2X,I3,3X,A14,3X,2F8.1) PRINT 300, TYPE(1) 300 FORMAT(' TYPE ',A8) PRINT 634 END IF 812 CONTINUE C C----------------------------------------------------------------------- C ELSE LOOK AT SEQUENCE FOR LTRK GT 2 C----------------------------------------------------------------------- C ELSE IF(LTRK.GT.2) THEN LUTCEQ=.FALSE. LLATEQ=.FALSE. LLONEQ=.FALSE. LVAREQ=.FALSE. LOGTRK=.FALSE. NCHNGD=0 C C PRELIMINARY LOOP TO CHECK FOR POSSIBLE TWO FLIGHTS AND WAYPOINT C ERRORS - CHECK ADJACENT REPORTS IN LONGITUDE SORT - CALCULATE C DIFFERENCES IN VARIABLES AND COMPUTE AVERAGE SPEED C NO POINTERS SET: COUNTER ON TIME INTERVALS SET C DTKNT=0 DO 212 L=IBEG,IEND-1 C C CERTAIN RPTS (E.G, 3 CHAR ID,"AIRCFT") ARE NOT CONSIDERED FOR THE TRAC C IF(AAID(L)(4:4).EQ.' '.OR.AAID(L)(1:4).EQ.'AIRC'.OR. $ AAID(L)(1:5).EQ.'COA16') THEN PRINT 8866, ITRK,LTRK,IBEG,IEND,AAID(L) NTRK=0 GO TO 66 END IF K=L-IBEG+1 DELPOS(K)=0.0 DELLAT(K)=0.0 DELLON(K)=0.0 DELTME(K)=0.0 QCOS=COS((JARRAY(L,1)+JARRAY(L+1,1))*0.005 *DG2RAD) QDELT=IABS(JARRAY(L,4)-JARRAY(L+1,4))*0.01 DELTME(K)=QDELT C C ADJUSTABLE CONSTANT FOR TIME DIFF BETWEEN SUCCESSIVE REPORTS=2.5 HRS C IF(QDELT.GT.2.5) DTKNT=DTKNT+1 DELLON(K)=IABS(JARRAY(L,2)-JARRAY(L+1,2))*0.01 DELLON(K)=AMIN1(DELLON(K),360.-DELLON(K)) DELLAT(K)=IABS(JARRAY(L,1)-JARRAY(L+1,1))*0.01 C C UNITS FOR POSTION DIFFERENCE- DEGREES C DELPOS(K)=SQRT(DELLAT(K)**2+(DELLON(K)*QCOS)**2) RDELT=999. IF(QDELT.GT.0.0) RDELT=1./QDELT C C UNITS FOR APPARENT AVERAGE SPEED- KNOTS C AVESPD(K)=DELPOS(K) * RDELT * 65.3 IF(DELLON(K).GT.11.0.AND.AVESPD(K).GT.770..AND.K.EQ.1) $ PRINT 510, K,DELLON(K),AVESPD(K) 510 FORMAT(' $$$$$POSSIBLE CORRECTABLE ERROR IN LON ', $ I3,2F8.1) IF(DELLON(K).GT.15..AND.AVESPD(K).GT.770.) LOGTRK=.TRUE. 212 CONTINUE DELPOS(LTRK)=-9999.9 AVESPD(LTRK)=-9999.9 IF(LOGTRK) THEN CALL WAYPT(IBEG,IEND,NCHNGD) PRINT 544, IBEG,IEND 544 FORMAT(' WAYPOINT(3) CALL AT ',2I6) END IF IF(DTKNT.GT.0) PRINT 669, IBEG,IEND,DTKNT 669 FORMAT(' POSSIBLE TWO FLIGHTS AT ',2I5,' DTKNT ',I3) C C POSSIBLE TWO OR MORE FLIGHTS IN AIR DURING SIX-HOUR TIME BLOCK C IF(DTKNT.GT.1.OR.NCHNGD.GT.0) THEN IF(NCHNGD.GT.0) $ PRINT *, 'WAYPOINT(3) HAS CHANGED REPORT LOCATION' IF(NCHNGD.GT.0) $ PRINT *,'WAYPT(3) ERROR FOR .GT. 2 IN TRACK CHECK' PRINT 4442, ITRK,JTRK,IBEG,IEND,DTKNT,NCHNGD 4442 FORMAT(' ITRK',I5,' JTRK ',I5,' IBEG,IEND ',2I6, $ ' DTKNT ',I3,' NCHNGD ',I2) DO 401 I=1,LTRK K=IBEG+I-1 IARRAY(I)=KARRAY(K,4) 401 CONTINUE IF(LTRK.GT.0) CALL INDEXF(LTRK,IARRAY,INDR) DO 402 J=1,LTRK K=IBEG-1+J L=IBEG-1+INDR(J) AAID(K)=SAAID(L) CTAG(K)=STAG(L) DO 701 JJ=1,ISIZE JARRAY(K,JJ)=KARRAY(L,JJ) 701 CONTINUE 402 CONTINUE DTKNT=0 DO 232 L=IBEG,IEND-1 K=L-IBEG+1 DELPOS(K)=0.0 DELLAT(K)=0.0 DELLON(K)=0.0 DELTME(K)=0.0 QCOS=COS((JARRAY(L,1)+JARRAY(L+1,1))*0.005*DG2RAD) QDELT=IABS(JARRAY(L,4)-JARRAY(L+1,4))*0.01 DELTME(K)=QDELT C C ADJUSTABLE CONSTANT FOR TIME DIFF BETWEEN SUCCESSIVE REPORTS=2.5 HRS C IF(QDELT.GT.2.5) DTKNT=DTKNT+1 DELLON(K)=IABS(JARRAY(L,2)-JARRAY(L+1,2))*0.01 DELLON(K)=AMIN1(DELLON(K),360.-DELLON(K)) DELLAT(K)=IABS(JARRAY(L,1)-JARRAY(L+1,1))*0.01 C C UNITS FOR POSTION DIFFERENCE- DEGREES C DELPOS(K)=SQRT(DELLAT(K)**2+(DELLON(K)*QCOS)**2) RDELT=999. IF(QDELT.GT.0.0) RDELT=1./QDELT C C UNITS FOR APPARENT AVERAGE SPEED- KNOTS C AVESPD(K)=DELPOS(K)*RDELT*65.3 IF(DELLON(K).GT.15..AND.AVESPD(K).GT.770.)THEN LOGTRK=.TRUE. ENDIF 232 CONTINUE DELPOS(LTRK)=-9999.9 AVESPD(LTRK)=-9999.9 END IF DO 210 K=1,ITRKL TYPE(K)=' ' 210 CONTINUE C-CRA CALL XSTORE(JPTNAD,0,ITRKL) C-CRA CALL XSTORE(IPTNAD,0,ITRKL) C-CRA CALL XSTORE(IPTTRK,0,ITMX) DO I=1,ITRKL JPTNAD(I)=0 IPTNAD(I)=0 ENDDO DO I=1,ITMX IPTTRK(I)=0 ENDDO C C FIND POINTERS FOR NON-ADJACENT REPORTS C IF(TRACE) PRINT 8888,LTRK,IBEG,IEND 8888 FORMAT(' TRACE AT 211 ',3(1X,I6)) DO 211 L=IBEG,IEND-2 DO 211 M=L+2,IEND IF(JARRAY(L,4).EQ.JARRAY(M,4)) LUTCEQ=.TRUE. IF(JARRAY(L,1).EQ.JARRAY(M,1)) LLATEQ=.TRUE. IF(JARRAY(L,2).EQ.JARRAY(M,2)) LLONEQ=.TRUE. IF((JARRAY(L,5).EQ.JARRAY(M,5)).AND. $ (JARRAY(L,6).EQ.JARRAY(M,6)).AND. $ (JARRAY(L,7).EQ.JARRAY(M,7)).AND. $ (JARRAY(L,4).EQ.JARRAY(M,4)).AND. $ (JARRAY(L,3).EQ.JARRAY(M,3))) THEN NPTRS=NPTRS + 1 LVAREQ=.TRUE. IPTNAD(NPTRS)=L JPTNAD(NPTRS)=M IF(TRACE) PRINT 756, LLATEQ,LLONEQ,LVAREQ, $ IPTNAD(NPTRS),JPTNAD(NPTRS) 756 FORMAT('DBUG- NONADJ LOGICALS ', $ 3(L1,1X),3X,'POINTERS ',2X,2I8) END IF 211 CONTINUE IF(NPTRS.EQ.1) THEN I1=IPTNAD(1) I2=JPTNAD(1) DUP=.TRUE. WRITE(88,*) '6) CHOOSE FOR MCOUNT=',MCOUNT WRITE(88,*) IWHICH,II,II+1,CTAG(II),CTAG(II+1),DUP,NEW CALL CHOOSE(I1,I2,TOSLIM,DUP,IWHICH,MAYBE,NEW) IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'0') THEN CTAG(IWHICH)(1:1)='D' CTAG(IWHICH)(13:13)='0' CTAG(IWHICH)(14:14)='0' END IF NTYPS=NTYPS+1 TYPE(NTYPS)='TYPE 1D ' KTYPS(4)=KTYPS(4) + 1 END IF IF(NPTRS.GT.1) PRINT 719, NPTRS 719 FORMAT(' WARNING, NPTRS=',I4) IF(TRACE) PRINT 8889, LTRK,IBEG,IEND 8889 FORMAT(' TRACE AT 213 ',3(1X,I6)) C-CRA CALL XSTORE(IPTADJ,0,ITRKL) DO I=1,ITRKL IPTADJ(I)=0 ENDDO NPRNT=0 C C BIG LOOP TO FIND BADDIES C IF(TRACE) PRINT 8890, LTRK,IBEG,IEND 8890 FORMAT(' TRACE AT 216 ',3(1X,I6)) DO 216 L=IBEG,IEND-1 K=L - IBEG + 1 LOGTRK=.FALSE. TOSLIM='S' C C THIS IS A LIST OF IDS TO SKIP BECAUSE OF THE LACK OF 7-CHAR IDS C (WHEN OSO SENDS US 7 FULL CHARS, THIS CAN BE REMOVED) C &&& DAK: 8/25/94: SHOULD BE OK NOW, GETTING FULL 7-CHARACTER ID C C THIS IS A LIST OF NON-UNIQUE IDS C IF(AAID(L)(1:5).EQ.'AIRCF') GO TO 216 DQLAT=ABS(JARRAY(L,1)-JARRAY(L+1,1)) LOGLAT=(DQLAT.LT..03) DQLON=ABS(JARRAY(L,2)-JARRAY(L+1,2)) LOGLON=(DQLON.LT..03) LOGALT=(JARRAY(L,3).EQ.JARRAY(L+1,3)) LOGTMP=(JARRAY(L,5).GT.999.OR.JARRAY(L+1,5).GT.999 $ .OR.JARRAY(L,5).EQ.JARRAY(L+1,5)) LOGWND=((JARRAY(L,6).EQ.JARRAY(L+1,6)).AND. $ (JARRAY(L,7).EQ.JARRAY(L+1,7))) QDELT=IABS(JARRAY(L,4)-JARRAY(L+1,4))*0.01 LOGTME=(QDELT.LT.0.20.AND.AVESPD(K).GT.770.) LOGGT3=(QDELT.GT.3.01) LOGLT1=(DELPOS(K).LE.1.1) LOGLO=(JARRAY(L,3).LT.8000) LOGHI=(JARRAY(L,3).GT.13411) LOGEQ=0 IF(LOGTMP) LOGEQ=LOGEQ+1 IF(LOGTME) LOGEQ=LOGEQ+1 IF(LOGALT) LOGEQ=LOGEQ+1 IF(.NOT.LOGLO.AND..NOT.LOGHI) THEN C C ADJUSTABLE CONSTANTS FOR AIRCRAFT GROUND SPEED LIMITS C IF(AVESPD(K).GT.770.0.OR.AVESPD(K).LT.200.0) THEN NAPTS=NAPTS + 1 IPTADJ(NAPTS)=L LOGTRK=.TRUE. END IF ELSE IF(LOGHI) THEN IF(AVESPD(K).GT.1450.0.OR.AVESPD(K).LT.500.0) THEN NAPTS=NAPTS + 1 IPTADJ(NAPTS)=L LOGTRK=.TRUE. END IF END IF C C START DECISION MAKING C TUNING HERE- CHECK INCREMENT .GE. 'T' AS BAD C IF(LOGLT1.AND.LOGWND.AND.LOGEQ.GE.2) THEN C C CLASS 1 (SIMPLE) DUPLICATE, PLACE 'D' IN POSITION 1 OF TAG C DUP=.TRUE. WRITE(88,*) '7) CHOOSE FOR MCOUNT=',MCOUNT WRITE(88,*) IWHICH,II,II+1,CTAG(II),CTAG(II+1),DUP,NEW CALL CHOOSE(L,L+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'0') THEN CTAG(IWHICH)(1:1)='D' CTAG(IWHICH)(13:13)='0' CTAG(IWHICH)(14:14)='0' END IF IF(NEW) THEN PRINT 721, IWHICH,MAYBE 721 FORMAT(' 1A- IWHICH,MAYBE ',2I5) NTYPS=NTYPS+1 KTYPS(1)=KTYPS(1)+1 TYPE(NTYPS)='TYPE 1A ' END IF ELSE IF(LOGWND.AND.LOGALT.AND.LOGTMP.AND.LOGTME) THEN C C COME HERE IF NOT A STRICT DUPLICATE -- POSSIBLE POSITION ERROR C CTAG(L)(3:3)='E' CTAG(L+1)(3:3)='E' DUP=.TRUE. WRITE(88,*) '8) CHOOSE FOR MCOUNT=',MCOUNT WRITE(88,*) IWHICH,II,II+1,CTAG(II),CTAG(II+1),DUP,NEW CALL CHOOSE(L,L+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'0') THEN CTAG(IWHICH)(1:1)='D' CTAG(IWHICH)(13:13)='0' CTAG(IWHICH)(14:14)='0' END IF IF(NEW) THEN PRINT 722, IWHICH,MAYBE 722 FORMAT(' 1B- IWHICH,MAYBE ',2I5) NTYPS=NTYPS+1 KTYPS(2)=KTYPS(2) + 1 TYPE(NTYPS)='TYPE 1B ' END IF ELSE IF(LOGTME.AND..NOT.LOGLT1.AND..NOT.LOGWND.AND. $ .NOT.LOGTRK) THEN DUP=.FALSE. TOSLIM='V' WRITE(88,*) '9) CHOOSE FOR MCOUNT=',MCOUNT WRITE(88,*) IWHICH,II,II+1,CTAG(II),CTAG(II+1),DUP,NEW CALL CHOOSE(L,L+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) IF(IWHICH.GT.0) THEN IF(CTAG(IWHICH)(14:14).GT.'3') THEN CTAG(IWHICH)(4:4)='F' CTAG(IWHICH)(14:14)='3' JARRAY(IWHICH,12)=310 END IF NTYPS=NTYPS+1 KTYPS(7)=KTYPS(7)+1 TYPE(NTYPS)='TYPE 3 ' ELSE NTYPS=NTYPS+1 KTYPS(9)=KTYPS(9)+1 TYPE(NTYPS)='TIME TAG' END IF C======================================================================= C ELSE IF CORRESPONDING TO THE BIG IF C======================================================================= ELSE IF(LOGTME.AND.LOGALT.AND.LOGWND.AND.(LOGLAT.OR.LOGLON))THEN CTAG(L)(3:3)='E' CTAG(L+1)(3:3)='E' DUP=.TRUE. WRITE(88,*) '10) CHOOSE FOR MCOUNT=',MCOUNT WRITE(88,*) IWHICH,II,II+1,CTAG(II),CTAG(II+1),DUP,NEW CALL CHOOSE(L,L+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'3') THEN CTAG(IWHICH)(4:4)='F' CTAG(IWHICH)(14:14)='3' JARRAY(IWHICH,12)=311 END IF IF(NEW) THEN PRINT 723, IWHICH,MAYBE 723 FORMAT(' 2B- IWHICH,MAYBE ',2I5) NTYPS=NTYPS+1 KTYPS(6)=KTYPS(6)+1 TYPE(NTYPS)='TYPE 2B ' END IF ELSE IF(LOGTME.AND.LOGALT.AND.LOGTMP.AND.LOGLT1) THEN CTAG(L)(3:3)='E' CTAG(L+1)(3:3)='E' DUP=.TRUE. WRITE(88,*) '11) CHOOSE FOR MCOUNT=',MCOUNT WRITE(88,*) IWHICH,II,II+1,CTAG(II),CTAG(II+1),DUP,NEW CALL CHOOSE(L,L+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'3') THEN CTAG(IWHICH)(4:4)='F' CTAG(IWHICH)(14:14)='3' JARRAY(IWHICH,12)=311 END IF IF(NEW) THEN PRINT 723, IWHICH,MAYBE NTYPS=NTYPS+1 KTYPS(6)=KTYPS(6) + 1 TYPE(NTYPS)='TYPE 2B ' END IF ELSE IF(LOGLAT.AND.LOGLON.AND..NOT.LOGGT3) THEN DUP=.TRUE. WRITE(88,*) '12) CHOOSE FOR MCOUNT=',MCOUNT WRITE(88,*) IWHICH,II,II+1,CTAG(II),CTAG(II+1),DUP,NEW CALL CHOOSE(L,L+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) CTAG(IWHICH)(3:3)='E' IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'3') THEN CTAG(IWHICH)(4:4)='F' CTAG(IWHICH)(14:14)='3' JARRAY(IWHICH,12)=312 END IF IF(NEW) THEN PRINT 724,IWHICH,MAYBE 724 FORMAT(' 2A- IWHICH,MAYBE ',2I5) NTYPS=NTYPS+1 KTYPS(5)=KTYPS(5)+1 TYPE(NTYPS)='TYPE 2A ' END IF ELSE IF(LOGTRK) THEN I1=IPTADJ(1) IF(DELPOS(K).GT.50.0) TOSLIM='R' I2=I1 + 1 DUP=.FALSE. NEW=.FALSE. IF(QDELT.NE.0..AND..NOT.LOGWND.AND.(.NOT.LOGLAT.OR. $ .NOT.LOGLON)) THEN WRITE(88,*) '13) CHOOSE FOR MCOUNT=',MCOUNT WRITE(88,*) IWHICH,II,II+1,CTAG(II),CTAG(II+1),DUP,NEW CALL CHOOSE(I1,I2,TOSLIM,DUP,IWHICH,MAYBE,NEW) IF(.NOT.NEW.AND.NAPTS.EQ.1) THEN IF(IWHICH.GT.0.AND.IWHICH.EQ.IPTADJ(1).AND. $ CTAG(IWHICH)(14:14).GT.'3') THEN CTAG(IWHICH)(4:4)='F' CTAG(IWHICH)(14:14)='3' JARRAY(IWHICH,12)=310 END IF ELSE IF(NEW.AND.TOSLIM.EQ.'R') THEN PRINT 725, IWHICH,MAYBE 725 FORMAT(' 3 - IWHICH,MAYBE ',2I5) IF(MAYBE.GT.0) CTAG(MAYBE)(3:3)='E' IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'3')THEN CTAG(IWHICH)(4:4)='F' CTAG(IWHICH)(14:14)='3' JARRAY(IWHICH,12)=310 END IF ELSE IF(NEW) THEN C PRINT 725, IWHICH,MAYBE IF(MAYBE.GT.0) CTAG(MAYBE)(3:3)='E' IF(IWHICH.GT.0.AND. 1 CTAG(IWHICH)(14:14).GT.'0') THEN CTAG(IWHICH)(1:1)='D' CTAG(IWHICH)(13:13)='0' CTAG(IWHICH)(14:14)='0' END IF END IF IF(IWHICH.NE.L) THEN CTAG(L)(3:3)='E' ELSE CTAG(L+1)(3:3)='E' END IF IF(NEW.AND.IWHICH.NE.0) THEN NTYPS=NTYPS+1 KTYPS(7)=KTYPS(7)+1 TYPE(NTYPS)='TYPE 3 ' END IF ELSE NTYPS=NTYPS+1 KTYPS(9)=KTYPS(9)+1 TYPE(NTYPS)='TIME TAG' END IF PRINT 667, L,L+1,AVESPD(K),DELPOS(K),LOGLAT,LOGLON, $ LOGTME,LOGALT,LOGTMP,LOGWND,NEW,IWHICH,MAYBE 667 FORMAT(' TYP3 ',2(1X,I4),' AVESPD(KTS)',F10.0, $ ' DELPOS',F5.1, $ ' LOGICALS ',6(L1,1X),'NEW ',L1,' IWHICH ', $ I5,' MAYBE ',I5) END IF 216 CONTINUE C C CHECK IF LAST REPORT IS BAD C IF(((DELPOS(LTRK-1).GT.35.0.AND.JARRAY(IEND,1).EQ.0).OR. $ (DELPOS(LTRK-1).GT.35.0.AND.JARRAY(IEND,2).EQ.0)).AND. $ CTAG(IEND)(14:14).GT.'3') THEN CTAG(IEND)(4:4)='F' CTAG(IEND)(14:14)='3' JARRAY(IEND,12)=313 END IF QSUM =0.0 IQNUM =0 C C LOOP SETS POINTERS IF POSITION DIFFERENCES ARE TOO LARGE C WRITE(88,*) 'DELPOS=' WRITE(88,*) (K,DELPOS(K),K=1,IEND-IBEG+1) DO 213 L=IBEG,IEND K=L - IBEG + 1 IF(DELPOS(K).GT.25.0) THEN IF(L.LT.IEND) THEN NTRKP=NTRKP+1 IPTTRK(NTRKP)=L NTRKP=NTRKP+1 IPTTRK(NTRKP)=L+1 ELSE NTRKP=NTRKP+1 IPTTRK(NTRKP)=L END IF END IF C C CALCULATE AVERAGE VECTOR INCREMENT FOR TRACK (QSUM) AMONGST THOSE OBS. C WITH A SCALED INCREMENT (BASED ON ORDINAL POS. FOR mova2i -- CHARACTE C CONVERTED TO EBCDIC IF ASCII ON THIS MACHINE) C IF(CTAG(L)(5:5).GE.'Q'.AND.CTAG(L)(5:5).LE.'Z') THEN CTG=CTAG(L)(5:5) IF(ICHTP.EQ.0) CALL W3AI39(CTG,1) ITRANS=0 IF(mova2i(CTG).GE.226) ITRANS=8 SCALE =(10.*(mova2i(CTG)-ITRANS-215))-5. IQNUM=IQNUM+1 QSUM=QSUM+SCALE END IF 213 CONTINUE IF(IQNUM.NE.0) THEN QSUM=QSUM/IQNUM ELSE QSUM=0.0 END IF C C CHECK IF NTRKP INDICATES INTERIOR BAD C it did not go through here !!! C WRITE(88,*) '14) NTRKP=',NTRKP WRITE(88,*) 'IPTTRK=',(IPTTRK(KK),KK=1,NTRKP) DO 488 KK=1,NTRKP-1 DO 488 JJ=KK+1,NTRKP WRITE(88,*) 'JJ,KK,IPTTRK(KK).EQ.IPTTRK(JJ)=', 1 JJ,KK,IPTTRK(KK).EQ.IPTTRK(JJ) IF(IPTTRK(KK).EQ.IPTTRK(JJ)) THEN I1=IPTTRK(KK) I2=IPTTRK(JJ) DUP=.TRUE. WRITE(88,*) '14) CHOOSE FOR MCOUNT=',MCOUNT WRITE(88,*) IWHICH,II,II+1,CTAG(II),CTAG(II+1),DUP,NEW CALL CHOOSE(I1,I2,TOSLIM,DUP,IWHICH,MAYBE,NEW) IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'3') THEN CTAG(IWHICH)(4:4)='F' CTAG(IWHICH)(14:14)='3' JARRAY(IWHICH,12)=314 END IF PRINT 727, IWHICH,MAYBE 727 FORMAT(' INT-IWHICH,MAYBE ',2I5) NTYPS=NTYPS+1 KTYPS(7)=KTYPS(7)+1 TYPE(NTYPS)='TYPE 3 ' END IF 488 CONTINUE C NPRNT=NPTRS+NTYPS+NAPTS+DTKNT IF(NPRNT.GT.0.OR.LUTCEQ.OR.LVAREQ.OR.NCHNGD.GT.0) THEN IF(TRACE) THEN PRINT 480 480 FORMAT(' POINTER SUMMARY--K-- ADJ TRK', $ ' NADI NADJ') DO 481 KK=1,LTRK PRINT 482,KK,IPTADJ(KK),IPTTRK(KK),IPTNAD(KK), $ JPTNAD(KK) 482 FORMAT(' ',15X,I3,3X,4(I4,2X)) 481 CONTINUE PRINT 8891, LTRK,IBEG,IEND 8891 FORMAT(' TRACE AT 215 ',3(1X,I6)) END IF DO 215 L=IBEG,IEND K=L - IBEG + 1 PRINT 334, K,L,AAID(L),JARRAY(L,1),JARRAY(L,2), $ JARRAY(L,4), $ JARRAY(L,3),JARRAY(L,5),JARRAY(L,6),JARRAY(L,7), $ (CTAG(L)(JJJ:JJJ),JJJ=1,14),DELPOS(K),AVESPD(K) 334 FORMAT(' K=',I3,' L=',I5,2X,A8,6I7,2X,I3,14(1X,A1), $ '/',' ',F7.1,2X,F11.1) 215 CONTINUE PRINT 314, NAPTS,NTRKP,NPTRS,QSUM,(TYPE(M),M=1,NTYPS) 314 FORMAT(' END /POINTERS +ADJS,+TRKS,+NADJ',3(1X,I4), $ ' QSUM ',F5.1,/,' TYPES ',7(2X,A8)) IF(TRACE) PRINT 8892, LTRK,IBEG,IEND,I 8892 FORMAT(' TRACE AT END, LTRK,IBEG,IEND,I!',4(1X,I6)) PRINT 634 634 FORMAT(' ----------------------------------') END IF END IF C NTRK=0 C C GO BACK TO 66 TO START NEXT TRACK C GO TO 66 C END IF C C======================================================================= C END OF BIG IF(ITRK.LT.NAIREP) C======================================================================= C PRINT *,' ----------------------------------' C C RESORT FOR STACK DETERMINATION: 1ST ORDER -LATITUDE (SOUTH TO NORTH); C 2ND ORDER -LONGITUDE (WEST, INCREASING); 3RD ORDER -TIME (INCREASING) C SORT BY CONCATENATING LAT, LON, TIME INTO CHARACTER ARRAY C (DO NOT INCLUDE ASDARS/AMDARS AND EXCLUDED REPORTS IN THIS SORT) C DO 736 J=1,NAIREP WRITE(CARRAY(J)(1:5),'(I5.5)') JARRAY(J,1) + 9000 WRITE(CARRAY(J)(6:10),'(I5.5)') JARRAY(J,2) WRITE(CARRAY(J)(11:14),'(I4.4)') JARRAY(J,4) CARRAY(J)(15:16)='00' 736 CONTINUE C C CALL SORT ROUTINE- PUTS POINTERS INTO IPOINT ARRAY/DOES NOT REARRANGE C IF(NAIREP.GT.0) CALL INDEXC(NAIREP,CARRAY,INDR) C C WRITE SORTED REPORTS INTO SAAID, KARRAY, AND STAG ARRAYS (REMAINING C ASDAR/AMDAR AND EXCLUDED REPORTS ALREADY IN THESE ARRAYS IN PROPER C POSITION FROM STORE MADE AT BEGINNING OF SUBROUTINE) C DO 737 I=1,NAIREP J=INDR(I) SAAID(I)=AAID(J) STAG(I)=CTAG(J) DO 702 JJ=1,ISIZE KARRAY(I,JJ)=JARRAY(J,JJ) 702 CONTINUE 737 CONTINUE C C WRITE SORTED REPORTS BACK INTO ORIGINAL ARRAYS AND ELIMINATE DUPS C IF(IWRITE) PRINT 557 557 FORMAT(/' FINAL LISTING OF SORTED DATA LEAVING TRKCHK----'/9X, $ 'ACID',7X,'LAT WLON UTC ALT TEMP WDIR WSPD -----', $ 'TAGS----- ITYPE RPTIME KNTINI GALT GTEMP GDIR GSPD'/) M=0 DO 219 I=1,KOUNT IF(STAG(I)(1:1).EQ.'D') THEN PRINT 9022, I,SAAID(I),REAL(KARRAY(I,1))*.01, $ REAL(KARRAY(I,2))*.01,REAL(KARRAY(I,4)),STAG(I) 9022 FORMAT('TRKCHK; DUPLICATE REMOVED AT END OF SUBR..', $ I5,2X,A8,2F8.2,F6.0,2X,A14) GO TO 219 END IF IF(STAG(I)(3:3).EQ.'Z') STAG(I)(3:3)=' ' M=M + 1 ACID(M) =SAAID(I) ALAT(M) =KARRAY(I,1) * .01 ALON(M) =KARRAY(I,2) * .01 AALT(M) =KARRAY(I,3) TIME(M) =KARRAY(I,4) ATMP(M) =KARRAY(I,5) ADIR(M) =KARRAY(I,6) ASPD(M) =KARRAY(I,7) INTP(M) =KARRAY(I,8) IRTM(M) =KARRAY(I,9) KNTINI(M)=KARRAY(I,10) ITEVNT(M)=KARRAY(I,11) IWEVNT(M)=KARRAY(I,12) AALTF(M) =KARRAY(I,13) ADIRF(M) =KARRAY(I,14) ASPDF(M) =KARRAY(I,15) ATMPF(M) =KARRAY(I,16) TAG(M) =STAG(I) IF(IWRITE) PRINT 331, M,ACID(M),ALAT(M),ALON(M),NINT(TIME(M)), $ NINT(AALT(M)),NINT(ATMP(M)),NINT(ADIR(M)),NINT(ASPD(M)), $ TAG(M),INTP(M),IRTM(M),KNTINI(M),NINT(AALTF(M)),NINT(ATMPF(M)) $ , NINT(ADIRF(M)),NINT(ASPDF(M)) 331 FORMAT(' ',I5,2X,A8,2F8.2,I6,I7,3I6,3X,A14,I6,2I8,I7,3I6) 219 CONTINUE NFILE=M PRINT 681, NFILE 681 FORMAT(1X,128('*')/47X,'OUT OF TRACK CHECK - NFILE =',I7/128('*')) RETURN C 9999 CONTINUE C C FATAL ERROR: THERE ARE MORE RPTS IN TRACK THAN "ITMX" -- ABORT C PRINT 953, ITMX 953 FORMAT(/' THERE ARE MORE THAN',I9,' REPORTS IN A SINGLE TRACK ', $ '-- MUST INCREASE SIZE OF PARAMETER NAME "ITMX" - ABORT'/) CALL ABORT END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: WAYPT CORRECTS WAYPOINT LOCATIONS FOR ACFT RPTS C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 95-05-30 C C ABSTRACT: LOOPS THRU FLIGHT FROM POINTER IBEG TO IEND CHECKING IF C LAT/LON IS ON LIST OF KNOWN INCORRECT WAYPOINT LOCATIONS. IF C SO, THE LAT/LON IS CHANGED TO THE CORRECT WAYPOINT LOCATION. C THIS SUBROUTINE CAN BE CALLED ONLY FOR AIREP/PIREP REPORTS. C C PROGRAM HISTORY LOG: C 93-01-05 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR C 94-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT C 95-02-10 D. A. KEYSER -- MINOR CHANGE TO ALLOW WAYPOINT CORRECTED C LAT/LON TO BE CARRIED BACK TO CALLING SUBROUTINE FOR C WAYPOINT CALL REASON + 3 (WASN'T BEING DONE BEFORE) C 95-05-30 D. A. KEYSER -- ADDED PARAMETER NAME "LSIZE" FOR MAX. C NO. OF LAT/LON CORRECTIONS IN WAYPOINT FILE, ADDED C COND. CODE 25 IF PARAMETER NAME "LSIZE" IS EXCEEDED C 97-02-25 M. KANAMITSU -- MODIFIED TO RUN ON WORKSTATIONS C C USAGE: CALL WAYPT(IBEG,IEND,NCHNGD) C INPUT ARGUMENT LIST: C IBEG - POINTER FOR START OF FLIGHT SEGMENT C IEND - POINTER FOR END OF FLIGHT SEGMENT C C OUTPUT ARGUMENT LIST: C NCHNGD - NUMBER OF REPORT LOCATIONS CHANGED IN A SINGLE CALL C - TO THIS SUBROUTINE C C INPUT FILES: C UNIT 23 - TEXT FILE CONTAINING WAYPOINT CORRECTIONS C (READ IN WHEN NAMELIST SWITCH WAYPIN=.TRUE.) C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY MAIN PROGRAM AND BY SUBROUTINE 'TRKCHK'. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS, SGI, SUN, HP, DEC C C$$$ SUBROUTINE WAYPT(IBEG,IEND,NCHNGD) PARAMETER (IRMX=100000) PARAMETER (ISIZE= 16) C C PARAMETER NAME "LSIZE" IN THIS SUBROUTINE REFERS TO THE MAXIMUM C NUMBER OF LATITUDES AND LONGITUDES IN THE WAYPOINT CORRECTION FILE C PARAMETER (LSIZE= 26) PARAMETER (LSIZ23= LSIZE-23) C-CRA LOGICAL WAYPIN COMMON/WORD/LW,ICHTP CHARACTER*80 BUFF1 CHARACTER*8 AAID(IRMX) CHARACTER*14 CTAG(IRMX),STAG(IRMX) INTEGER OLDLAT(LSIZE),NEWLAT(LSIZE),OLDLON(LSIZE),NEWLON(LSIZE) C-CRA COMMON/INPT/DOSPOB,DOACRS,TMAXO,TMINO,TIMINC,WAYPIN,INIDST,IFLGUS, C-CRA$ JAMASS(6),JAWIND(6),RCPTST COMMON/INPT/TMAXO,TMINO,TIMINC COMMON/INPTI/INIDST,IFLGUS,JAMASS(6),JAWIND(6) LOGICAL DOSPOB,DOACRS,WAYPIN,RCPTST COMMON/INPTL/DOSPOB,DOACRS,WAYPIN,RCPTST COMMON/XXXXX/AAID,JARRAY(IRMX,ISIZE),CTAG,KARRAY(IRMX,ISIZE),STAG C-CRA COMMON/WRITE/SWRITE,IWRITE LOGICAL SWRITE,IWRITE COMMON/COMWRITE/SWRITE,IWRITE SAVE C DATA ITKNT/0/,INUM/23/ DATA OLDLAT/ 2017, 3717, 1067, 3000, 3383, 4850, 5683, 4283, 2617, 1 3417, 3783, 4500, 3417, 3717, 4033, 3100, 6217,-0583, 2 -0950,-0667, 0817, 4017, 2783,LSIZ23*99999/ DATA NEWLAT/-2983, 6000, 3967,-2750,-2683,-2533, 3504, 3007, 3648, 1 3019, 3845,-0511, 4092, 4056,-0813,-3123, 3950,-0583, 2 2431, 1478, 4195, 0090, 3746,LSIZ23*99999/ DATA OLDLON/35333,11367,28567, 8550,11650,11233,13550, 7150,31267, 1 9717,11300, 7467,11783, 9700, 7845, 8467, 2050,19000, 2 21300, 7633,26117,11017,13050,LSIZ23*99999/ DATA NEWLON/ 6200, 4317, 3167, 5700, 6050, 4917,33384,32180, 0422, 1 0923,34367, 3721,34562,34567, 3488, 5406, 3117,16900, 2 10450, 9237, 7183, 7000, 2405,LSIZ23*99999/ C NCHNGD=0 IF(ITKNT.EQ.0) THEN IF(WAYPIN) THEN C C FIRST TIME IN, READ WAYPOINTS FROM EXTERNAL FILE IF WAYPIN=TRUE C READ(23,230) BUFF1 READ(23,230) BUFF1 READ(23,231) INUM IF(INUM.GT.LSIZE) THEN C C FATAL ERROR: THERE ARE MORE LAT/LON CORRECTIONS IN WAYPOINT FILE THAN C WHAT IS EXPECTED HERE IN "LSIZE" C PRINT 53, LSIZE,INUM 53 FORMAT(/' THERE ARE MORE THAN THE',I9,' EXPECTED LAT/LON ', $ 'CORRECTIONS IN THE WAYPOINT FILE'/5X,'-- MUST INCREASE SIZE OF', $ ' PARAMETER NAME "LSIZE" TO AT LEAST',I5,' - ABORT'/) CALL ABORT C END IF READ(23,230) BUFF1 READ(23,232) (OLDLAT(J),J=1,INUM) READ(23,230) BUFF1 READ(23,232) (NEWLAT(J),J=1,INUM) READ(23,230) BUFF1 READ(23,232) (OLDLON(J),J=1,INUM) READ(23,230) BUFF1 READ(23,232) (NEWLON(J),J=1,INUM) 230 FORMAT(A80) 231 FORMAT(I5) 232 FORMAT(12I6) ELSE INUM=23 END IF PRINT 2999, WAYPIN PRINT 3000, (OLDLAT(K),K=1,INUM) PRINT 3001, (NEWLAT(K),K=1,INUM) PRINT 3002, (OLDLON(K),K=1,INUM) PRINT 3003, (NEWLON(K),K=1,INUM) 2999 FORMAT(/' FIRST CALL TO SUBROUTINE WAYPT, WAYPIN=',L4) 3000 FORMAT(' OLDLAT ',12I6) 3001 FORMAT(' NEWLAT ',12I6) 3002 FORMAT(' OLDLON ',12I6) 3003 FORMAT(' NEWLON ',12I6) ITKNT=1 END IF C C C DO 10 L=IBEG,IEND DO 10 J=1,INUM IF(JARRAY(L,1).EQ.OLDLAT(J).AND.JARRAY(L,2).EQ.OLDLON(J)) THEN PRINT 2000, L,J 2000 FORMAT(' WAYPT MATCH L,J ',I5,1X,I2) NCHNGD=NCHNGD + 1 JARRAY(L,1)=NEWLAT(J) JARRAY(L,2)=NEWLON(J) CTAG(L)(1:1)=' ' C C SET TAG POSITION 9 TO 'C' TO INDICATE WAYPOINT CORRECTION C CTAG(L)(9:9)='C' C C UPDATE KARRAY AS WELL - WAYPOINT(3) SORTS BY TIME (SEE SUBR. TRKCHK) C KARRAY(L,1)=NEWLAT(J) KARRAY(L,2)=NEWLON(J) C C UPDATE STAG AS WELL - WAYPOINT(3) SORTS BY TIME (SEE SUBR. TRKCHK) C STAG(L)(1:1)=' ' C C SET TAG POSITION 9 TO 'C' TO INDICATE WAYPOINT CORRECTION C STAG(L)(9:9)='C' PRINT *,'~~~~~ WAYPT CORRECTION MADE (PRINT IN WAYPT)' PRINT 1000, IBEG,IEND,JARRAY(L,1),JARRAY(L,2) 1000 FORMAT(' WAYPT ERR ',2(I5,1X),' NEW POS ',2I6) END IF 10 CONTINUE RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: CHOOSE CHOOSES WORST/DUPL. BETWEEN PAIR OF RPTS C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 94-08-25 C C ABSTRACT: USES SCALED VECTOR INCREMENTS TO EITHER CHOOSE UNEQUIVICALLY C ONE OF A PAIR OF REPORTS (E.G. A DUPLICATE) OR TO CHOOSE THE C 'WORST' AMONGST TWO REPORTS BASED UPON THE SCALED INCREMENTS C OF THE PAIR OF REPORTS. C C PROGRAM HISTORY LOG: C 93-01-05 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR C 94-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT C C USAGE: CALL CHOOSE(I,J,TOSLIM,DUP,IWHICH,MAYBE,NEW) C INPUT ARGUMENT LIST: C I - POINTER FOR FIRST OF THE PAIR C J - POINTER FOR SECOND OF THE PAIR C TOSLIM - LIMITING SCALED QUALITY MARKER C DUP - LOGICAL: =.TRUE. CHOOSE WHICH OF PAIR IS DUPLICATE; C - =.FALSE. CHOOSE WHICH OF PAIR IS WORST C C OUTPUT ARGUMENT LIST: C IWHICH - POINTER (I OR J) FOR THE ONE OF THE PAIR CHOSEN C - (DUP=T) OR FOR THE ONE OF THE PAIR CHOSEN BECAUSE C - IT EXCEEDED THE 'TOSLIM' (DUP=F) C MAYBE - POINTER (I OR J) FOR THE ONE OF THE PAIR CHOSEN C - BUT NOT BECAUSE IT EXCEEDED 'TOSLIM' (DUP=F ONLY) C NEW - SET TO TRUE UNLESS REPORT ALREADY HAD A DUPLICATE C - OR FAILED FLAG IN QUALITY MARKER C C REMARKS: CALLED BY SUBROUTINE 'TRKCHK'. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS C C$$$ SUBROUTINE CHOOSE(I,J,TOSLIM,DUP,IWHICH,MAYBE,NEW) PARAMETER (IRMX=100000) PARAMETER (ISIZE= 16) CHARACTER*1 TOSLIM CHARACTER*8 AAID(IRMX) CHARACTER*14 CTAG(IRMX),STAG(IRMX) LOGICAL LIGS,LIGX,LJGS,LJGX,LIGJ,LIEQJ,LJGI,DUP,NEW COMMON/XXXXX/AAID,JARRAY(IRMX,ISIZE),CTAG,KARRAY(IRMX,ISIZE),STAG C NEW=.FALSE. IWHICH=0 MAYBE =0 C C IF DUPL. AND 2ND INCREMENT NOT CHECKED, SET 2ND INCREMENT TO THAT OF 1 C IF(CTAG(J)(5:5).EQ.'N'.AND.DUP) CTAG(J)(5:5)=CTAG(I)(5:5) IF(CTAG(I)(1:1).EQ.'D'.OR.CTAG(I)(4:4).EQ.'F') THEN C C IF FIRST OF PAIR HAS DUPLICATE OR BAD Q. MARK IT IS SELECTED C IWHICH=I PRINT 1116, IWHICH,I,J,CTAG(I),CTAG(J),DUP,NEW 1116 FORMAT(' CHOICE= ',I5,' I&J= ',2I5,' TAGS= ',A14,'/',A14, $ ' DUP? ',L1,' NEW? ',L1) ELSE IF(CTAG(J)(1:1).EQ.'D'.OR.CTAG(J)(4:4).EQ.'F') THEN C C ELSE, IF SECOND OF PAIR HAS DUPLICATE OR BAD Q. MARK IT IS SELECTED C IWHICH=J PRINT 1116, IWHICH,I,J,CTAG(I),CTAG(J),DUP,NEW ELSE IF(.NOT.DUP) THEN C C ELSE, IF NOT CHECKING FOR DUPLICATES, FIND THE WORST OF THE PAIR C NEW=.TRUE. LIEQJ=.FALSE. IF((CTAG(I)(5:5).EQ.'Q'.AND.CTAG(J)(5:5).EQ.'Q').OR. $ (CTAG(I)(5:5).EQ.'R'.AND.CTAG(J)(5:5).EQ.'R')) THEN C C IF BOTH HAVE Q.M. OF 'Q' OR 'R' THEN RETAIN THEM BOTH C LIEQJ=.TRUE. RETURN END IF C C LIGJ=T IF 1ST WORSE THAN OR SAME AS 2ND; =F IF 1ST BETTER THAN 2ND C LIGJ=(CTAG(I)(5:5).GE.CTAG(J)(5:5)) C C LIGS=T IF 1ST BETWEEN S AND Z C LIGS=(CTAG(I)(5:5).GE.'S'.AND.CTAG(I)(5:5).LE.'Z') C C LIGX=T IF 1ST WORSE THAN OR SAME AS 'TOSLIM' C LIGX=(CTAG(I)(5:5).GE.TOSLIM.AND.CTAG(I)(5:5).LE.'Z') C C LJGS=T IF 2ND BETWEEN S AND Z C LJGS=(CTAG(J)(5:5).GE.'S'.AND.CTAG(J)(5:5).LE.'Z') C C LJGX=T IF 2ND WORSE THAN OR SAME AS 'TOSLIM' C LJGX=(CTAG(J)(5:5).GE.TOSLIM.AND.CTAG(J)(5:5).LE.'Z') IF(LIGX.AND..NOT.LJGX) THEN C C 1ST WORSE THAN/SAME AS 'TOSLIM' & 2ND BETTER THAN 'TOSLIM': CHOOSE 1ST C IWHICH=I ELSE IF(LJGX.AND..NOT.LIGX) THEN C C 2ND WORSE THAN/SAME AS 'TOSLIM' & 1ST BETTER THAN 'TOSLIM': CHOOSE 2ND C IWHICH=J ELSE IF(LIGX.AND.LJGX) THEN C C BOTH WORSE THAN/SAME AS 'TOSLIM' .. CHECK CARSWELL-TINKER INDICATOR C IF(CTAG(I)(7:7).EQ.'C'.AND.CTAG(J)(7:7).NE.'C') THEN C C ...1ST IS CARSWELL-TINKER, CHOOSE 1ST C IWHICH=I ELSE IF(CTAG(J)(7:7).EQ.'C'.AND.CTAG(I)(7:7).NE.'C') THEN C C ...2ND IS CARSWELL-TINKER, CHOOSE 2ND C IWHICH=J ELSE IF(LIGJ) THEN C C ...BOTH EITHER ARE OR AREN'T CARSWELL-TINKER, CHOOSE 1ST IF WORSE C THAN 2ND C IWHICH=I ELSE C C ...BOTH EITHER ARE OR AREN'T CARSWELL-TINKER, CHOOSE 2ND IF WORSE C THAN 1ST C IWHICH=J END IF ELSE IF(LIGS.AND..NOT.LJGS.AND.CTAG(J)(5:5).NE.'N') THEN C C 1ST BETWEEN S AND Z & 2ND IS Q OR R, CHOOSE 1ST MAYBE C MAYBE=I ELSE IF(LJGS.AND..NOT.LIGS.AND.CTAG(I)(5:5).NE.'N') THEN C C 2ND BETWEEN S AND Z & 1ST IS Q OR R, CHOOSE 2ND MAYBE C MAYBE=J ELSE IF(LIGS.AND.LJGS) THEN C C BOTH BETWEEN S AND Z .. CHECK CARSWELL-TINKER INDICATOR C IF(CTAG(I)(7:7).EQ.'C'.AND.CTAG(J)(7:7).NE.'C') THEN C C ...1ST IS CARSWELL-TINKER, CHOOSE 1ST MAYBE C MAYBE=I ELSE IF(CTAG(J)(7:7).EQ.'C'.AND.CTAG(I)(7:7).NE.'C') THEN C C ...2ND IS CARSWELL-TINKER, CHOOSE 2ND MAYBE C MAYBE=J ELSE IF(LIGJ) THEN C C ...BOTH EITHER ARE/AREN'T CARSWELL-TINKER, CHOOSE 1ST MAYBE IF WORSE C THAN 2ND C MAYBE=I ELSE C C ...BOTH EITHER ARE/AREN'T CARSWELL-TINKER, CHOOSE 2ND MAYBE IF WORSE C THAN 1ST C MAYBE=J END IF END IF PRINT 1117, IWHICH,LIGS,LJGS,LIGX,LJGX,LIGJ,I,J,CTAG(I), $ CTAG(J),DUP,NEW 1117 FORMAT(' CHOICE= ',I5,' W/ LOGICALS: LIGS=',L1,' LJGS=',L1, $ ' LIGX=',L1,' LJGX=',L1,' LIGJ=',L1,' I&J=',2I5,' TAGS=', $ A14,'/',A14,' DUP? ',L1,' NEW? ',L1) ELSE C C ELSE IF CHECKING FOR DUPLICATES, FIND THE DUPLICATE C NEW =.TRUE. C C LIGJ=T IF 1ST WORSE THAN 2ND; =F IF 1ST BETTER THAN OR SAME AS 2ND C LIGJ=(CTAG(I)(5:5).GT.CTAG(J)(5:5)) C C LJGI=T IF 2ND WORSE THAN 1ST; =F IF 2ND BETTER THAN OR SAME AS 1ST C LJGI=(CTAG(J)(5:5).GT.CTAG(I)(5:5)) IF(CTAG(I)(5:5).EQ.CTAG(J)(5:5)) THEN C C BOTH HAVE SAME QUALITY .. CHECK CARSWELL-TINKER INDICATOR C IF(CTAG(J)(7:7).EQ.'C'.AND.CTAG(I)(7:7).NE.'C') THEN C C ...2ND IS CARSWELL-TINKER, CHOOSE 2ND C IWHICH=J ELSE IF(CTAG(I)(7:7).EQ.'C'.AND.CTAG(J)(7:7).NE.'C') THEN C C ...1ST IS CARSWELL-TINKER, CHOOSE 1ST C IWHICH=I ELSE C C ...BOTH EITHER ARE OR AREN'T CARSWELL-TINKER, CHOOSE 1ST C IWHICH=I END IF ELSE IF(LIGJ) THEN C C 1ST IS WORSE THAN 2ND, CHOOSE 1ST C IWHICH=I ELSE IF(LJGI) THEN C C 2ND IS WORSE THAN 1ST, CHOOSE 2ND C IWHICH=J END IF PRINT 1118, IWHICH,LIGJ,LJGI,I,J,CTAG(I),CTAG(J),DUP,NEW 1118 FORMAT(' CHOICE= ',I5,' FROM LOGICALS: LIGJ=',L1,' LJGI=',L1, $ ' I&J= ',2I5,' TAGS= ',A14,'/',A14,' DUP? ',L1,' NEW? ',L1) C END IF RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: SHEAR CHECKS WIND DIFFERENCE AGAINST STATISTICS C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 94-08-25 C C ABSTRACT: DOES WIND DIFFERENCING BOTH AT SAME AND AT DIFFERENT C LEVELS AND ASSIGNS DIGITAL FLAGS DEPENDING UPON THE MAGNITUDES C COMPARED WITH A STATISTICAL DISTRIBUTION OF SUCH DIFFERENCES C AND USING THE OBSERVED VECTOR INCREMENTS. FLAGS BAD OBSERVATIONS. C THERE MUST BE AT LEAST TWO HIGH-ALTITUDE OBSERVATIONS IN STACK C FOR THIS CHECK TO BE PERFORMED. C C PROGRAM HISTORY LOG: C 89-04-01 P. JULIAN -- ORIGINAL AUTHOR C 93-01-05 P. JULIAN -- CHANGES TO UTILIZE SCALED OBS INCREMENTS C 94-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT C 97-02-25 M. KANAMITSU -- MODIFIED TO RUN ON WORKSTATIONS C C USAGE: CALL SHEAR(NUM,INDX) C INPUT ARGUMENT LIST: C NUM - NUMBER OF OBSERVATIONS TO BE TREATED C INDX - POINTER TO POSITION IN ORIGINAL AIRCRAFT ARRAY C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTINE 'PRELIM'. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS, SGI, SUN, HP, DEC C C$$$ SUBROUTINE SHEAR(NUM,INDX) PARAMETER (IRMX=100000, ISMX= 500) C C PRINT LOGICALS- PRNTA:PRINT ALL; PRNTT:PRINT TITLE; PRNTL: PRINT LINE C LOGICAL PRNTA,PRNTT,PRNTL CHARACTER*1 CTG CHARACTER*8 ACID,SAID CHARACTER*14 TAG INTEGER COUNT(ISMX),LOUNT(ISMX),CHKSUM(ISMX),KPOINT(ISMX), $ GOUNT(ISMX),IARRAY(ISMX),INDR(ISMX) REAL TABLE(7,7),VPOINT(ISMX) COMMON/CMPNTS/U(ISMX),V(ISMX),UF(ISMX),VF(ISMX) C-CRA COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), C-CRA$ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), C-CRA$ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), $ KBAD(ISMX),SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) COMMON/SUMDATI/NUMORG COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), $ ADIRF(IRMX) COMMON/WORD/LW,ICHTP C VECTOR ERROR (TABLE(IALT,ITIM),ITIM=1,6)/ KNOTS / DATA (TABLE(1,ITIM),ITIM=1,7)/ 38.,39.,40.,41.,42.,43.,44./ DATA (TABLE(2,ITIM),ITIM=1,7)/ 49.,50.,51.,52.,53.,54.,55./ DATA (TABLE(3,ITIM),ITIM=1,7)/ 60.,61.,62.,63.,64.,65.,66./ DATA (TABLE(4,ITIM),ITIM=1,7)/ 71.,72.,73.,74.,75.,76.,77./ DATA (TABLE(5,ITIM),ITIM=1,7)/ 82.,83.,84.,85.,86.,87.,88./ DATA (TABLE(6,ITIM),ITIM=1,7)/ 93.,94.,95.,96.,97.,98.,99./ DATA (TABLE(7,ITIM),ITIM=1,7)/ 97.,98.,99.,99.,99.,99.,99./ DATA KNO/5/ C C CALL STATS TO OBTAIN AVG. SPEED & VECTOR DIFFERENCE C CALL STATS(KNO,INDX,NUM,SBAR,VPOINT) LOOP=0 C C CALIBX IS ADJUSTABLE CONSTANT FOR ON-LEVEL DIFFERENCE CHECK C CALIBX=0.30 SLIGHTLY MORE PERMISSIVE IS C CALIBX=0.45 C C GOUNT IS INTEGER WEIGHTING FROM SCALED OBSERVED VECTOR INCREMENT C DO 45 K=1,NUM GOUNT(K)=0 KNDX=INDX + K - 1 IF(IFLEPT(KNDX).LE.0.OR.KBAD(K).LE.0) GO TO 45 SCALE=25.0 C C SCALE IS BASED ON ORDINAL POSITION FOR mova2i -- (CHARACTER CONVERTED C TO EBCDIC IF ASCII ON THIS MACHINE) C IF(TAG(KNDX)(5:5).GE.'Q'.AND.TAG(KNDX)(5:5).LE.'Z') THEN CTG=TAG(KNDX)(5:5) IF(ICHTP.EQ.0) CALL W3AI39(CTG,1) ITRANS=0 IF(mova2i(CTG).GE.226) ITRANS=8 SCALE=10. * (mova2i(CTG) - ITRANS - 215) END IF C C NOTE: GOUNT WILL BE -1 FOR OBS. W/O SCALED VECTOR INCREMENT VALUE C GOUNT(K)=NINT((SCALE - 30) * 0.2) C C IF SUSPECTED TRACK CHECK ERROR ADD 2 TO GOUNT C IF(TAG(KNDX)(3:3).EQ.'E') GOUNT(K)=GOUNT(K) + 2 45 CONTINUE C C START OF ITERATION CHECKING AND TOSSING C 1010 CONTINUE LOOP=LOOP + 1 C C COUNT IS INTEGER SUM OF QUALITY UNITS FOR OFF-LEVEL(SHEAR) CHECKS C LOUNT IS SAME BUT FOR ON-LEVEL CHECKS C DO 5 K=1,NUM IARRAY(K)=NINT(VPOINT(K)*100.) COUNT(K)=0 LOUNT(K)=0 CHKSUM(K)=-99 IF(KBAD(K).LE.0) GOUNT(K)=0 5 CONTINUE C C EACH ITERATION MUST RESORT VECTOR DIFFERENCE AMONGST "GOOD" C OBS. IN STACK C IF(NUM.GT.0) CALL INDEXF(NUM,IARRAY,KPOINT) DIFF=0.0 IMAXK=0 IMAXJ=0 PRNTT =.TRUE. PRNTA =.FALSE. C DO 1 K=1,NUM IF(IARRAY(KPOINT(K)).LT.0) KPOINT(K)=-9 KNDX=INDX + K - 1 IF(IFLEPT(KNDX).GT.0.AND.KBAD(K).GT.0) THEN DO 2 J=K+1,NUM PRNTL =.FALSE. JNDX=INDX + J - 1 IF(IFLEPT(JNDX).LE.0.OR.KBAD(J).LE.0) GO TO 2 TIMDIF=ABS(TIME(JNDX)-TIME(KNDX)) * .01 ALTDIF=ABS(AALT(JNDX)-AALT(KNDX)) IALT=(ALTDIF + 50.) * 0.001637 ITIM=MAX0(1,NINT(TIMDIF)) IF(IALT.GT.9.OR.ITIM.GT.7) GO TO 999 QUAN=SQRT((U(K) - U(J))**2 + (V(K) - V(J))**2) IF(IALT.LE.0) THEN C C ON-LEVEL CHECK C CALIBX=0.45 IS ADJUSTABLE CONSTANT FOR ON-LEVEL DIFFERENCE CHECK C CHEK=9.0 + (TIMDIF * SBAR * CALIBX) IF((QUAN-CHEK).GT.DIFF) THEN DIFF=QUAN - CHEK C C IMAXJ AND IMAXK ARE THE TWO LEVELS EXCEEDING THE LIMITS C IMAXJ=J IMAXK=K PRNTL=.TRUE. PRNTA=.TRUE. END IF IF(QUAN.LT.0.25*CHEK) THEN LOUNT(K)=LOUNT(K) - 2 LOUNT(J)=LOUNT(J) - 2 ELSE IF(QUAN.LT.0.5*CHEK) THEN LOUNT(K)=LOUNT(K) - 1 LOUNT(J)=LOUNT(J) - 1 ELSE IF(QUAN.GT.2.*CHEK) THEN LOUNT(K)=LOUNT(K) + 2 LOUNT(J)=LOUNT(J) + 2 ELSE IF(QUAN.GT.CHEK) THEN LOUNT(K)=LOUNT(K) + 1 LOUNT(J)=LOUNT(J) + 1 END IF ELSE C C OFF-LEVEL CHECK C IF(IALT.GT.5) GO TO 2 CHEK=TABLE(IALT,ITIM) + (SBAR * 0.14) IF((QUAN-CHEK).GT.DIFF) THEN DIFF= QUAN - CHEK C C IMAXJ AND IMAXK ARE THE TWO LEVELS EXCEEDING THE LIMITS C IMAXJ=J IMAXK=K PRNTL=.TRUE. PRNTA=.TRUE. END IF IF(QUAN.GT.2.8*CHEK) THEN COUNT(K)=COUNT(K) + 4 COUNT(J)=COUNT(J) + 4 ELSE IF(QUAN.GT.1.4*CHEK) THEN COUNT(K)=COUNT(K) + 2 COUNT(J)=COUNT(J) + 2 ELSE IF(QUAN.GT.CHEK) THEN COUNT(K)=COUNT(K) + 1 COUNT(J)=COUNT(J) + 1 END IF END IF CHKSUM(J)=LOUNT(J) + COUNT(J) + GOUNT(J) CHKSUM(K)=LOUNT(K) + COUNT(K) + GOUNT(K) IF(PRNTT.AND.PRNTL) THEN PRINT 441 441 FORMAT(' SHEAR/ I J ALTDIF TIMDIF SHEARVEC LIMIT') PRNTT=.FALSE. END IF IF(PRNTL) PRINT 401, K,J,ALTDIF,TIMDIF,QUAN,CHEK 401 FORMAT(' ',2I4,3X,F8.0,F8.2,2X,F7.1,2X,F7.1) 2 CONTINUE END IF 1 CONTINUE C IF(KPOINT(NUM).LT.1.OR.KPOINT(NUM-1).LT.1) RETURN IPOINT=KPOINT(NUM) JPOINT=KPOINT(NUM-1) IF(DIFF.GT.0.0) THEN IF(NUM.GT.0) CALL INDEXF(NUM,CHKSUM,INDR) C C HOW MANY OBS. DO WE ACTUALLY HAVE TO EVALUATE (NUMT) ? C (THERE MUST BE AT LEAST TWO) C NUMT=0 DO 444 I=1,NUM IF(CHKSUM(I).GT.-99) NUMT=NUMT + 1 444 CONTINUE ICHK1=INDR(NUM) ICHK2=INDR(NUM-1) C C*********************************************************************** C LOGIC TREE FOR DECIDING WHATS WRONG C ITERATE IF MAJOR BADS-ONLY 4 BADS ALLOWED C THIS IS SET FOR MAXIMUM TOSSES C*********************************************************************** C IF(NUMT.GT.3) THEN C C FOUR OR MORE OBSERVATIONS IN THE STACK CAN BE EVALUATED C ICHK3=INDR(NUM-2) ICHK4=INDR(NUM-3) ICDIF1=CHKSUM(ICHK1) - CHKSUM(ICHK2) ICDIF2=CHKSUM(ICHK2) - CHKSUM(ICHK3) ICDIF3=CHKSUM(ICHK3) - CHKSUM(ICHK4) IF(ICDIF1.EQ.0.AND.ICDIF2.EQ.0.AND.ICDIF3.EQ.0) RETURN IF(PRNTA) THEN IF(NUM.LE.24) THEN PRINT 136, (COUNT(I),I=1,NUM) PRINT 138, (LOUNT(I),I=1,NUM) PRINT 139, (GOUNT(I),I=1,NUM) PRINT 148, ICHK1,ICHK2,ICHK3,(CHKSUM(I),I=1,NUM) ELSE PRINT 9136, (COUNT(I),I=1,NUM) PRINT 9138, (LOUNT(I),I=1,NUM) PRINT 9139, (GOUNT(I),I=1,NUM) PRINT 9148, ICHK1,ICHK2,ICHK3,(CHKSUM(I),I=1,NUM) END IF END IF C C CALCULATE TOLERANCE LEVEL FOR CHECKING BADS- FUNCTION OF AVG. SPEED C DLIM=2.5 IF(SBAR.GT.70.) DLIM=DLIM + ((SBAR - 70.) * 0.02857) C C START LOGIC TREE CHECK C IF(DIFF.GT.DLIM) THEN C C NOTE: IN GENERAL, ALL THE CALC. FOR NEW IPOINT AND JPOINT IN THE IF C BLOCKS BELOW ARE NEEDED ONLY IF ONE OF THE LOOPS ENDS UP GOING INTO C THE TOSSKEY=2 OR 3 IF BLOCKS IN THE NEXT ELSE BLOCK .... C ---> ELSE IF(DIFF.GT.2.5.AND.ICDIF1.EQ.0) THEN C THIS NEXT ELSE BLOCK CAN ONLY BE ATTAINED IF SBAR > 70 AND DIFF IS C BETWEEN 2.5 AND SOME NUMBER NOT MUCH LARGER THAN 2.5 -- SELDOM C OCCURS AND WHEN IT DOES, NEXT IF TEST IS ALMOST NEVER SATISFIED C -- OTHERWISE DLIM IS 2.5 AND THE FIRST ELSE BLOCK ALWAYS ENTERED C PRINT 177, DIFF,DLIM,SBAR,ICHK1,IMAXJ,ICHK2,IMAXK,IPOINT,JPOINT 177 FORMAT(' FOR SHEAR & NUMT> 3: DIFF=',F6.1,', DLIM=',F5.1, $ ', SBAR=',F5.1,', ICHK1=',I3,', IMAXJ=',I3,', ICHK2=',I3, $ ', IMAXK=',I3,', IPOINT=',I3,', JPOINT=',I3) IF(ICHK1.EQ.IMAXJ.OR.ICHK1.EQ.IMAXK) THEN KBAD(ICHK1)=0 ITOSSK=0 PRINT 152, ITOSSK,LOOP,ICHK1 IF(LOOP.EQ.4) RETURN VPOINT(ICHK1)=-999.0 GO TO 1010 ELSE IF(ICHK2.EQ.IMAXJ.OR.ICHK2.EQ.IMAXK) THEN KBAD(ICHK2)=0 ITOSSK=1 PRINT 152, ITOSSK,LOOP,ICHK2 IF(LOOP.EQ.4) RETURN VPOINT(ICHK2)=-999.0 GO TO 1010 END IF ELSE IF(DIFF.GT.2.5.AND.ICDIF1.EQ.0) THEN PRINT *,'~~~~~ DIFF .GT. 2.5 AMD ICDIF1.EQ.0' PRINT 3177, DIFF,DLIM,SBAR,ICHK3,IMAXJ,IMAXK,IPOINT,JPOINT,ICDIF1 3177 FORMAT(' FOR SHEAR & NUMT> 3: DIFF=',F6.1,', DLIM=',F5.1, $ ', SBAR=',F5.1,', ICHK3=',I3,', IMAXJ=',I3,', IMAXK=',I3, $ ', IPOINT=',I3,', JPOINT=',I3,', ICDIF1=',I3) IF((ICHK3.EQ.IMAXJ.AND.ICHK3.EQ.IPOINT).OR. $ (ICHK3.EQ.IMAXK.AND.ICHK3.EQ.IPOINT)) THEN PRINT *,'~~~~~ TOSSKEY=2 FOUND!!' KBAD(ICHK3)=0 ITOSSK=2 PRINT 152, ITOSSK,LOOP,ICHK3 IF(LOOP.EQ.4) RETURN VPOINT(ICHK3)=-999.0 GO TO 1010 ELSE IF((ICHK3.EQ.IMAXJ.AND.ICHK3.EQ.JPOINT).OR. $ (ICHK3.EQ.IMAXK.AND.ICHK3.EQ.JPOINT)) THEN PRINT *,'~~~~~ TOSSKEY=3 FOUND!!' KBAD(ICHK3)=0 ITOSSK=3 PRINT 152, ITOSSK,LOOP,ICHK3 RETURN END IF END IF ELSE IF(NUMT.GT.1) THEN C C ONLY TWO OR THREE OBSERVATIONS IN THE STACK CAN BE EVALUATED C PRNTA=.FALSE. ITOSSK=-99 IF((CHKSUM(ICHK1)-CHKSUM(ICHK2)).GT.3) THEN KBAD(ICHK1)=0 ITOSSK=4 PRNTA=.TRUE. ELSE IF(DIFF.GT.9.) THEN KBAD(ICHK1)=0 ITOSSK=5 PRNTA=.TRUE. END IF IF(PRNTA) THEN PRINT 136, (COUNT(I),I=1,NUM) PRINT 138, (LOUNT(I),I=1,NUM) PRINT 139, (GOUNT(I),I=1,NUM) PRINT 158, ICHK1,ICHK2,(CHKSUM(I),I=1,NUM) PRINT 9177, DIFF,ICHK1,ICHK2 9177 FORMAT(' FOR SHEAR & NUMT< 4: DIFF=',F6.1,', ICHK1=',I6, $ '; ICHK2=',I6) PRINT 149, ITOSSK,ICHK1 END IF C END IF END IF 136 FORMAT(' SHEAR CHKSUM',29X,24I3) 138 FORMAT(' ONLVL CHKSUM',29X,24I3) 139 FORMAT(' OBSINCCHKSUM',29X,24I3) 148 FORMAT(' SUM RANK(1ST 3)',3I4,' SUM CHKSUMS ',24I3) 158 FORMAT(' SUM RANK(1ST 2)',2I4,4X,' SUM CHKSUMS ',24I3) 9136 FORMAT(' SHEAR CHKSUM',/,40I3) 9138 FORMAT(' ONLVL CHKSUM',/,40I3) 9139 FORMAT(' OBSINCCHKSUM',/,40I3) 9148 FORMAT(' SUM RANK(1ST 3)',3I4,' SUM CHKSUMS ',/,40I3) 149 FORMAT(' FOR NUMT< 4 TOSSKEY IS ',I4,' TOSSES +',I4) 152 FORMAT(' TOSSKEY IS ',I4,' LOOP ',I3,' TOSSES +',I4) RETURN 999 CONTINUE PRINT 200, K,J,TIMDIF,ALTDIF 200 FORMAT(' DISASTER AT ',2I4,2F8.0) RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: LAPSE CHECKS TEMPERATURES WITH LAPSE-RATE CHECK C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 94-08-25 C C ABSTRACT: DOES TEMPERATURE CHECK BOTH AT SAME AND AT DIFFERENT C LEVELS AND ASSIGNS DIGITAL FLAGS DEPENDING UPON THE MAGNITUDES C COMPARED WITH POSSIBLE LAPSE RATES. THERE MUST BE AT LEAST THREE C HIGH-ALTITUDE OBS. IN STACK FOR THIS CHECK TO BE PERFORMED. C C PROGRAM HISTORY LOG: C 93-01-05 P. JULIAN -- ORIGINAL AUTHOR C 94-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT C 97-02-25 M. KANAMITSU -- MODIFIED TO RUN ON WORKSTATIONS C C USAGE: CALL LAPSE(NUM,INDX) C INPUT ARGUMENT LIST: C NUM - NUMBER OF OBSERVATIONS TO BE TREATED C INDX - POINTER TO POSITION IN ORIGINAL AIRCRAFT ARRAY C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTINE 'PRELIM'. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS, SGI, SUN, HP, DEV C C$$$ SUBROUTINE LAPSE(NUM,INDX) PARAMETER (IRMX=100000, ISMX= 500) LOGICAL PRNTT CHARACTER*8 ACID,SAID CHARACTER*14 TAG INTEGER COUNT(ISMX),LOUNT(ISMX),CHKSUM(ISMX),INDR(ISMX) REAL TABLE(7,7) C-CRA COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), C-CRA$ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), C-CRA$ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), $ KBAD(ISMX),SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) COMMON/SUMDATI/NUMORG COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), $ ADIRF(IRMX) COMMON/WORD/LW,ICHTP C C LAPSE RATE CHECK (TABLE(IALT,ITIM),ITIM=1,6)/ DEG.C/KM / C DATA(TABLE(1,ITIM),ITIM=1,7)/-12.,-12.,-13.,-13.,-13.,-14.,-14./ DATA(TABLE(2,ITIM),ITIM=1,7)/-12.,-12.,-13.,-13.,-13.,-14.,-14./ DATA(TABLE(3,ITIM),ITIM=1,7)/-12.,-12.,-13.,-14.,-14.,-15.,-15./ DATA(TABLE(4,ITIM),ITIM=1,7)/-12.,-12.,-13.,-14.,-14.,-15.,-15./ DATA(TABLE(5,ITIM),ITIM=1,7)/-13.,-13.,-14.,-14.,-14.,-15.,-16./ DATA(TABLE(6,ITIM),ITIM=1,7)/-13.,-13.,-14.,-15.,-15.,-16.,-16./ DATA(TABLE(7,ITIM),ITIM=1,7)/-14.,-14.,-15.,-15.,-15.,-16.,-16./ C C CALIBX IS ADJUSTABLE CONSTANT FOR ON-LEVEL DIFFERENCE CHECK C CALIBX=0.70 C C START OF CHECKING AND TOSSING (NO ITERATION - ONLY ONCE THROUGH) C COUNT IS INTEGER SUM OF QUALITY UNITS FOR OFF-LEVEL(LAPSE) CHECKS C LOUNT IS SAME BUT FOR ON-LEVEL CHECKS C C-CRA CALL XSTORE(COUNT,0,NUM) C-CRA CALL XSTORE(LOUNT,0,NUM) C-CRA CALL XSTORE(CHKSUM,-99,NUM) DO I=1,NUM COUNT(I)=0 LOUNT(I)=0 CHKSUM(I)=-99 ENDDO DIFF=0.0 PRNTT=.TRUE. DO 1 K=1,NUM IF(STMP(K).GT.100.) GO TO 1 IMAXK=0 ISUPK=0 KNDX=INDX + K - 1 IF(IFLEPT(KNDX).GT.0.AND.KBAD(K).GT.0) THEN DO 2 J=K+1,NUM IF(STMP(J).GT.100.) GO TO 2 QUAN=0.0 QTDF=0.0 CHEK=0.0 CHEC=0.0 IMAXJ=0 ISUPJ=0 JNDX=INDX + J - 1 IF(IFLEPT(JNDX).LE.0.OR.KBAD(J).LE.0) GO TO 2 TIMDIF=ABS(TIME(JNDX)-TIME(KNDX)) * .01 ALTDIF=ABS(AALT(JNDX)-AALT(KNDX)) IALT=(ALTDIF + 50.) * 0.001637 ITIM=MAX0(1,NINT(TIMDIF)) IF(IALT.GT.9.OR.ITIM.GT.7) GO TO 999 IF(IALT.LE.0) THEN C C ON-LEVEL CHECK C QUAN=ABS(STMP(K)-STMP(J)) * 0.1 C C CALIBX=0.70 IS ADJUSTABLE CONSTANT FOR ON-LEVEL DIFFERENCE CHECK C CHEK=2.5 + (TIMDIF * CALIBX) IF((QUAN-CHEK).GT.DIFF) DIFF=QUAN - CHEK IF(QUAN.LT.0.25*CHEK) THEN LOUNT(K)=LOUNT(K) - 2 LOUNT(J)=LOUNT(J) - 2 ELSE IF(QUAN.LT.0.5*CHEK) THEN LOUNT(K)=LOUNT(K) - 1 LOUNT(J)=LOUNT(J) - 1 ELSE IF(QUAN.GT.CHEK) THEN IMAXJ=J IMAXK=K IFPC=QUAN/CHEK + 1.0 LOUNT(K)=IFPC + LOUNT(K) LOUNT(J)=IFPC + LOUNT(J) END IF ELSE C C OFF-LEVEL CHECK C QQQ=AALT(KNDX) - AALT(JNDX) QTDF=((STMP(K) - STMP(J)) * 0.1)/(QQQ * .001) IF(IALT.GT.5) GO TO 2 CHEC=TABLE(IALT,ITIM) IF((ABS(QTDF)-ABS(CHEC)).GT.DIFF)DIFF=ABS(QTDF)-ABS(CHEC) IF((QTDF-CHEC).LT.0.0) THEN C C LAPSE CHECK C ISUPJ=J ISUPK=K IF(QTDF.LT.1.3*CHEC) THEN COUNT(K)=COUNT(K) + 4 COUNT(J)=COUNT(J) + 4 ELSE IF(QTDF.LT.1.15*CHEC) THEN COUNT(K)=COUNT(K) + 2 COUNT(J)=COUNT(J) + 2 ELSE IF(QTDF.LT.CHEC) THEN COUNT(K)=COUNT(K) + 1 COUNT(J)=COUNT(J) + 1 END IF END IF C C INVERSION CHECK C IF(QTDF.GT.16.0) THEN COUNT(K)=COUNT(K) + 4 COUNT(J)=COUNT(J) + 4 ELSE IF(QTDF.GT.10.0) THEN COUNT(K)=COUNT(K) + 2 COUNT(J)=COUNT(J) + 2 END IF END IF CHKSUM(J)=LOUNT(J) + COUNT(J) CHKSUM(K)=LOUNT(K) + COUNT(K) IF(IMAXJ.NE.0.OR.ISUPJ.NE.0) THEN IF(DIFF.GT.4.0) THEN IF(PRNTT) THEN PRINT 161 161 FORMAT(' LAPSE/ ONLVL INDX STABE INDX ALTDIF TIMDIF TDIF ', $ ' CHEK LAPSERATE CHEC') PRNTT=.FALSE. END IF PRINT 401, IMAXJ,IMAXK,ISUPJ,ISUPK,ALTDIF,TIMDIF, $ QUAN,CHEK,QTDF,CHEC 401 FORMAT(' ',4I6,F8.0,F8.2,4F9.1) END IF END IF 2 CONTINUE END IF 1 CONTINUE IF(DIFF.GT.4.0) THEN IF(NUM.GT.0) CALL INDEXF(NUM,CHKSUM,INDR) C HOW MANY OBS. DO WE ACTUALLY HAVE TO EVALUATE (NUMT) ? C (THERE MUST BE AT LEAST THREE) NUMT=0 DO 444 I=1,NUM IF(CHKSUM(I).GT.-99) NUMT=NUMT + 1 444 CONTINUE ICHK1=INDR(NUM) ICHK2=INDR(NUM-1) ICHK3=INDR(NUM-2) ICDIF2=CHKSUM(ICHK2) - CHKSUM(ICHK3) ICHK4=0 C C********************************************************************** C LOGIC TREE FOR DECIDING WHATS WRONG - NO ITERATION HERE (ONCE ONLY) C********************************************************************** C IF(NUMT.GT.3) THEN C C FOUR OR MORE OBSERVATIONS IN THE STACK CAN BE EVALUATED C ICHK4=INDR(NUM-3) ICDIF3=CHKSUM(ICHK3) - CHKSUM(ICHK4) IF(NUM.LE.24) THEN PRINT 136, (COUNT(I),I=1,NUM) PRINT 138, (LOUNT(I),I=1,NUM) PRINT 148, ICHK1,ICHK2,ICHK3,(CHKSUM(I),I=1,NUM) ELSE PRINT 9136, (COUNT(I),I=1,NUM) PRINT 9138, (LOUNT(I),I=1,NUM) PRINT 9148, ICHK1,ICHK2,ICHK3,(CHKSUM(I),I=1,NUM) END IF PRINT 177, DIFF,CHKSUM(ICHK1),CHKSUM(ICHK2),ICDIF2,ICDIF3 177 FORMAT(' FOR LAPSE & NUMT> 3: DIFF=',F6.1,', CHKSUM(ICHK1)=',I6, $ ', CHKSUM(ICHK2)=',I6,', ICDIF2=',I6,', ICDIF3=',I6) IF(CHKSUM(ICHK1).GE.7.AND.CHKSUM(ICHK2).GE.7) THEN KBAD(ICHK1)=0 KBAD(ICHK2)=0 I1TOSS=ICHK1 I2TOSS=ICHK2 ITOSSK=0 PRINT 149, ITOSSK,I1TOSS,I2TOSS ELSE IF(CHKSUM(ICHK1).GE.6.AND.ICDIF2.LT.5.AND.ICDIF3.LT.5) THEN KBAD(ICHK1)=0 I1TOSS=ICHK1 ITOSSK=1 PRINT 1149, ITOSSK,I1TOSS 1149 FORMAT(' FOR NUMT> 3 TOSSKEY IS ',I4,' TOSSES +',I4) ELSE IF(CHKSUM(ICHK1).GE.6.AND.ICDIF2.GE.5) THEN KBAD(ICHK1)=0 KBAD(ICHK2)=0 I1TOSS=ICHK1 I2TOSS=ICHK2 ITOSSK=2 PRINT 149, ITOSSK,I1TOSS,I2TOSS END IF ELSE IF(NUMT.EQ.3) THEN C C ONLY THREE OBSERVATIONS IN THE STACK CAN BE EVALUATED C ICDIF1=CHKSUM(ICHK1) - CHKSUM(ICHK2) PRINT 136, (COUNT(I),I=1,NUM) PRINT 138, (LOUNT(I),I=1,NUM) PRINT 148, ICHK1,ICHK2,ICHK3,(CHKSUM(I),I=1,NUM) PRINT 9177, DIFF,ICDIF1,ICDIF2 9177 FORMAT(' FOR LAPSE & NUMT= 3: DIFF=',F6.1,', ICDIF1=',I6, $ ', ICDIF2=',I6) IF(ICDIF1.GT.4.AND.ICDIF2.LT.2) THEN KBAD(ICHK1)=0 I1TOSS=ICHK1 ITOSSK=3 PRINT 147, ITOSSK,I1TOSS ELSE IF(DIFF.GT.2.9) THEN KBAD(ICHK1)=0 I1TOSS=ICHK1 ITOSSK=4 PRINT 147, ITOSSK,I1TOSS END IF C END IF END IF 136 FORMAT(' STABIL (LAPSE) CHKSUM',20X,24I3) 138 FORMAT(' ONLVL CHKSUM ',20X,24I3) 148 FORMAT(' SUM RANK(1ST 3)',3I4,' SUM CHKSUMS ',24I3) 9136 FORMAT(' STABIL (LAPSE) CHKSUM',/,40I3) 9138 FORMAT(' ONLVL CHKSUM ',/,40I3) 9148 FORMAT(' SUM RANK(1ST 3)',3I4,' SUM CHKSUMS ',/,40I3) 147 FORMAT(' FOR NUMT= 3 TOSSKEY IS ',I4,' TOSSES +',I4) 149 FORMAT(' FOR NUMT> 3 TOSSKEY IS ',I4,' TOSSES +',I4,' &',I4) RETURN 999 CONTINUE PRINT 200, K,J,TIMDIF,ALTDIF 200 FORMAT(' DISASTER AT ',2I4,2F8.0) RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: AVEROB COMPUTES SIMPLE AVG. OF WINDS (SUPEROB) C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 95-03-27 C C ABSTRACT: COMPUTES SIMPLE AVERAGE VECTOR WIND FOR ALL OBSERVATIONS C MEETING SPECIFIED TOLERANCES IN ALTITUDE, TIME, AND VECTOR C DIFFERENCE. THESE OBSERVATIONS ARE SUPEROBS. C C PROGRAM HISTORY LOG: C 89-04-01 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR C 90-06-14 D. A. KEYSER -- CORRECTED TO HONOR ALL SDM/QCAIRCFT PURGES C FOR STACKED OBS.; FIXED ERROR IN Q. MARK DESIGNATOR C 90-07-03 D. A. KEYSER -- SOME OMIT Q.M. INCORRECTLY CHANGED BACK C TO 'N' OR 'C', FIXED C 93-01-05 P. JULIAN -- MINOR CHNAGES TO REFLECT USE OF SCALED INCRS C 94-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT C 95-03-27 D. A. KEYSER -- FOR INIDST=2, SUPEROBS NOW CONTAIN C SUPEROBED FORECAST(GUESS) P-ALT, WIND DIR, WIND SPEED & C TEMP (IF AVAILABLE FROM INDIV. RPTS MAKING UP SUPEROBS) C 97-02-25 M. KANAMITSU -- MODIFIED TO RUN ON WORKSTATIONS C C USAGE: CALL AVEROB(NUM,INDX,LK) C INPUT ARGUMENT LIST: C NUM - NUMBER OF OBSERVATIONS TO BE TREATED C INDX - POINTER TO POSITION IN ORIGINAL AIRCRAFT ARRAY C C OUTPUT ARGUMENT LIST: C LK - POINTER INDICATING ' NUM + NO. OF AVERAGES FORMED ' C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTINE 'SUPROB'. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS, SGI, SUN, HP, DEC C C$$$ SUBROUTINE AVEROB(NUM,INDX,LK) PARAMETER (IRMX=100000, ISMX= 500) CHARACTER*8 ACID,SAID CHARACTER*14 TAG INTEGER SUPMRK(ISMX) C-CRA COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), C-CRA$ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), C-CRA$ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), $ KBAD(ISMX),SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) COMMON/SUMDATI/NUMORG COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), $ ADIRF(IRMX) COMMON/CMPNTS/U(ISMX),V(ISMX),UF(ISMX),VF(ISMX) C-CRA COMMON/WRITE/SWRITE,IWRITE LOGICAL SWRITE,IWRITE COMMON/COMWRITE/SWRITE,IWRITE DATA XMSG/99999./ C NUMGT=MAX0(NUMORG,NUM) LK=NUMGT NOOK=0 DO 699 K=1,NUM JNDX=INDX + K - 1 IF(KBAD(K).EQ.0) ISTCPT(K)=0 C ASK PAUL: IS BELOW LOGIC CORRECT?? IF(IFLEPT(JNDX).NE.0.OR.ISTCPT(K).NE.0.OR.TAG(JNDX)(4:4).NE. $ 'F') THEN NOOK=NOOK + 1 ELSE KBAD(K)=0 END IF CCCCC PRINT 1315, K,JNDX,IFLEPT(JNDX),ISTCPT(K),(TAG(JNDX)(II:II), CCCCC$ II=2,4,2) C1315 FORMAT(' AVEROB K,JNDX,IFLEPT,ISTCPT,QFS',4I5,2X,A1,2X,A1) 699 CONTINUE IF(NOOK.EQ.2) THEN CALL NOEQ2(NUM,INDX,LK) RETURN END IF C-CRA CALL XSTORE(SUPMRK,65,ISMX) DO I=1,ISMX SUPMRK(I)=65 ENDDO DO 701 K=1,NUM JNDX=INDX + K - 1 C ASK PAUL: IS BELOW LOGIC CORRECT?? IF(IFLEPT(JNDX).GT.0.OR.ISTCPT(K).GT.0.AND.TAG(JNDX)(4:4).NE. $ 'F') THEN IF(SUPMRK(K).GT.K) THEN SUPMRK(K)=K DO 702 KK=K+1,NUM KNDX=INDX + KK - 1 C ASK PAUL: IS BELOW LOGIC CORRECT?? IF(IFLEPT(KNDX).GT.0.OR.ISTCPT(KK).GT.0.AND. $ TAG(JNDX)(4:4).NE.'F') THEN ALTDIF=ABS(AALT(JNDX)-AALT(KNDX)) TIMDIF=ABS(TIME(JNDX)-TIME(KNDX)) VECDIF=SQRT((U(K)-U(KK))**2 + (V(K)-V(KK))**2) IF(ALTDIF.LT.150..AND.TIMDIF.LT.550..AND.VECDIF.LT. $ 16.0) SUPMRK(KK)=K END IF 702 CONTINUE END IF END IF 701 CONTINUE DO 704 K=1,NUM KNDX=INDX + K - 1 IF(ISTCPT(K).NE.0) THEN SUMU =0.0 SUMV =0.0 SUMS =0.0 SUMT =0.0 SUMTMP=0.0 KOUNTM=0 SUMUF =0.0 SUMVF =0.0 SUMSF =0.0 SUMTMF=0.0 KOUNTF=0 KOUNWF=0 KOUNT=0 DO 705 KK=K,NUM JNDX=INDX + KK - 1 IF(SUPMRK(KK).EQ.K.AND.ISTCPT(KK).NE.0) THEN SUMU=SUMU + U(KK) SUMV=SUMV + V(KK) SUMS=SUMS + SSPD(KK) SUMT=TIME(JNDX) + SUMT IF(AMAX1(UF(KK),VF(KK),SSPDF(KK)).LT.XMSG) THEN SUMUF=SUMUF + UF(KK) SUMVF=SUMVF + VF(KK) SUMSF=SUMSF + SSPDF(KK) KOUNWF=KOUNWF + 1 END IF IF(TAG(JNDX)(2:2).NE.'F'.AND.ATMP(JNDX).LT.XMSG) THEN SUMTMP=ATMP(JNDX) + SUMTMP KOUNTM=KOUNTM + 1 IF(ATMPF(JNDX).LT.XMSG) THEN SUMTMF=ATMPF(JNDX) + SUMTMF KOUNTF=KOUNTF + 1 END IF END IF KOUNT=KOUNT + 1 END IF CCCCC PRINT 2215,K,JNDX,IFLEPT(JNDX),KK,KNDX,IFLEPT(KNDX),KOUNT C2215 FORMAT(' TEST K,JNDX,IFLEPT,KK,KNDX,IFLEPT ',7I6) 705 CONTINUE IF(KOUNT.GT.1) THEN C C THERE IS AT LEAST ONE OTHER REPORT AT THE SAME LEVEL C SUMU=SUMU/KOUNT SUMV=SUMV/KOUNT SUMS=SUMS/KOUNT TBAR=SUMT/KOUNT LK=LK + 1 SSPD(LK)=SUMS SDIR(LK)=AVEDIR(SUMU,SUMV,SUMS) SHGT(LK)=AALT(KNDX) SSPDF(LK)=XMSG SDIRF(LK)=XMSG IF(KOUNWF.GT.1) THEN SSPDF(LK)=SUMSF/KOUNWF SDIRF(LK)=AVEDIR(SUMUF/KOUNWF,SUMVF/KOUNWF,SUMSF/KOUNWF) END IF STMP(LK)=XMSG STMPF(LK)=XMSG IF(KOUNTM.GT.1) THEN STMP(LK)=SUMTMP/KOUNTM IF(KOUNTF.GT.1) STMPF(LK)=SUMTMF/KOUNTF END IF SHGTF(LK)=AALTF(KNDX) SLAT(LK)=ALAT(KNDX) SLON(LK)=ALON(KNDX) STIM(LK)=TBAR ISTCPT(LK)=KOUNT CTEMP=STMP(LK) IF(STMP(LK).LT.XMSG) CTEMP=STMP(LK)/10. CTMPF=STMPF(LK) IF(STMPF(LK).LT.XMSG) CTMPF=STMPF(LK)/10. PRINT 6427, LK,KOUNT,NINT(SDIR(LK)),SSPD(LK),CTEMP,NINT(SHGT(LK)), $ NINT(STIM(LK)),NINT(SDIRF(LK)),SSPDF(LK),CTMPF,NINT(SHGTF(LK)) 6427 FORMAT(' SUPROB(AVEROB)',I3,',KOUNT=',I3,',DIR/SPD=',I3,'/',F5.1, $ ',TMP=',F7.1,',ALT=',I5,',TIME=',I4,',GES: DIR/SPD=',I5,'/',F7.1, $ ',TMP=',F7.1,',ALT=',I5) END IF IF(SUPMRK(K).EQ.65) IFLEPT(KNDX)=MIN0(IFLEPT(KNDX),0) END IF 704 CONTINUE IF(LK.GT.NUMGT) THEN DO 777 K=1,NUM-1 KNDX=INDX + K - 1 DO 777 KK=K+1,NUM JNDX=INDX + KK - 1 IF(SUPMRK(KK).EQ.SUPMRK(K)) THEN IF(TAG(KNDX)(14:14).GT.'4') THEN TAG(KNDX)(4:4)='O' TAG(KNDX)(14:14)='4' IWEVNT(KNDX)=315 END IF IF(TAG(JNDX)(14:14).GT.'4') THEN TAG(JNDX)(4:4)='O' TAG(JNDX)(14:14)='4' IWEVNT(JNDX)=315 END IF IF(TAG(KNDX)(13:13).GT.'4') THEN TAG(KNDX)(2:2)='O' TAG(KNDX)(13:13)='4' ITEVNT(KNDX)=315 END IF IF(TAG(JNDX)(13:13).GT.'4') THEN TAG(JNDX)(2:2)='O' TAG(JNDX)(13:13)='4' ITEVNT(JNDX)=315 END IF END IF 777 CONTINUE END IF PRINT 7070, (SUPMRK(M),M=1,NUM) PRINT 7071, (KBAD(M),M=1,NUM) 7070 FORMAT(' FROM AVEROB, SUPMRK=',21I5) 7071 FORMAT(' FROM AVEROB, KBAD =',21I5) IF(NUM.LT.NUMORG) THEN DO 714 K=1,NUMORG KNDX=INDX + K - 1 ISTCPT(K)=IFLEPT(KNDX) 714 CONTINUE END IF NUM=NUMGT NUMORG=0 RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FORSDM WRITES FLAGGED ISOLATED RPTS TO SDM FILE C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 94-08-25 C C ABSTRACT: WRITES ALL ISOLATED REPORTS CONTAINING A WIND WHICH HAS C BEEN FLAGGED FOR NON-USE TO A TEXT FILE WHICH THE SDM CAN EXAMINE C ON TSO. THIS ALLOWS THE SDM TO USE DELETER TO 'KEEP' ANY OF THESE C REPORTS IN THE NEXT NETWORK RUN. AIREP/PIREP REPORTS WITHIN THE C CONTINENTAL U.S. ARE EXCLUDED FROM THE WRITE IF: FOR INIDST=2, C IFLGUS=1 OR 2 AND KTACAR > 1; OR FOR INIDST < 2 IFLGUS=1 OR 2 C (WHICH IT ALWAYS IS!) C C PROGRAM HISTORY LOG: C 93-01-05 P. JULIAN -- NEW SUBPROGRAM C 94-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT C C USAGE: CALL FORSDM(INDX) C INPUT ARGUMENT LIST: C INDX - POINTER TO POSITION IN ORIGINAL AIRCRAFT ARRAY C C OUTPUT FILES: C UNIT 52 - TEXT FILE FOR SDM PERUSAL (LIST OF ISOLATED REPORTS C - THAT ARE FLAGGED FOR NON-USE BY THIS PROGRAM) C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS C C$$$ SUBROUTINE FORSDM(INDX) PARAMETER (IRMX=100000) CHARACTER*1 CTG,CLON,C1 CHARACTER*8 ACID CHARACTER*14 TAG COMMON/WORD/LW,ICHTP COMMON/TSTACAR/KTACAR C-CRA COMMON/INPT/DOSPOB,DOACRS,TMAXO,TMINO,TIMINC,WAYPIN,INIDST,IFLGUS, C-CRA$ JAMASS(6),JAWIND(6),RCPTST COMMON/INPT/TMAXO,TMINO,TIMINC COMMON/INPTI/INIDST,IFLGUS,JAMASS(6),JAWIND(6) LOGICAL DOSPOB,DOACRS,WAYPIN,RCPTST COMMON/INPTL/DOSPOB,DOACRS,WAYPIN,RCPTST COMMON/MASK/GDNH(362,91),GDSH(145,37),GDUS(362,91) COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), $ ADIRF(IRMX) C C NOTE: ALL CONV'L AIREP/PIREP (NOT ASDAR/AMDAR) RPTS OVER CONTINENTAL C U.S AND OVER SO. ONTARIO AND THE GULF OF AMERICA NORTH OF 25 DEG. N C LAT WILL BE EXCLUDED FROM ALL NMC ANALYSES IF: FOR INIDST=2, IFLGUS= C 1 OR 2 & KTACAR>1; OR FOR INIDST<2, IFLGUS=1 OR 2(WHICH IT ALWAYS IS) C BASED ON THESE SWITCHES, THIS SUBR. MAY CHECK FOR OBS. OVER THIS C REGION AND NOT WRITE ANY FLAGGED REPORTS TO THE SDM TEXT FILE HERE C IF((TAG(INDX)(1:1).GE.'U'.AND.TAG(INDX)(1:1).LE.'Z').OR. $ TAG(INDX)(4:4).EQ.'F') THEN IF(NINT(ALAT(INDX)).GT.0.AND.TAG(INDX)(7:7).NE.'Z'.AND. $ IFLGUS.GT.0) THEN IF(INIDST.LT.2.OR.(INIDST.EQ.2.AND.KTACAR.GT.1)) THEN KXI=(360.0 - ALON(INDX)) + 0.005 + 1.0 KYJ=ALAT(INDX) + 1.0 IF(KYJ.LT.91.AND.(GDUS(KXI,KYJ).GT.0.5.OR.GDUS(KXI+1,KYJ).GT.0.5 $ .OR.GDUS(KXI,KYJ+1).GT.0.5.OR.GDUS(KXI+1,KYJ+1).GT.0.5)) RETURN END IF END IF C SKIP WRITING OF ANY FLAGED REPORTS OUTSIDE REQUESTED TIME WINDOW IF(TIME(INDX).LT.TMINO.OR.TIME(INDX).GT.TMAXO) RETURN C WRITE SDM WINDS W/ VECTOR INCR. U-Z OR FLAGGED BY THIS PROGRAM; SCALE C BASED ON ORDINAL POSITION FOR mova2i -- (CHARACTER CONVERTED TO EBCDI C IF ASCII ON THIS MACHINE), IF INCREMENT NOT AVAIL. SCALE SET TO MSG SCALE=99999. IF(TAG(INDX)(1:1).GE.'U'.AND.TAG(INDX)(1:1).LE.'Z') THEN CTG=TAG(INDX)(1:1) IF(ICHTP.EQ.0) CALL W3AI39(CTG,1) ITRANS=0 IF(mova2i(CTG).GE.226) ITRANS=8 SCALE=10. * (mova2i(CTG) - ITRANS - 215) END IF IF(AALT(INDX).LE.11000.) THEN PRALT=1013.25 * $ (((288.15 - (.0065*AALT(INDX)))/288.15)**5.256) ELSE PRALT=226.3 * EXP(1.576106E-4*(11000.-AALT(INDX))) END IF QTIME=MOD(TIME(INDX),2400.) QTEMP=99999. IF(ATMP(INDX).LT.99999.) QTEMP=ATMP(INDX) * 0.1 QLON=ALON(INDX) CLON='W' IF(NINT(QLON).GT.180) THEN QLON=(360. - QLON) CLON='E' END IF C1=' ' IF(TAG(INDX)(1:1).EQ.'H'.OR.TAG(INDX)(1:1).EQ.'P') THEN C1=TAG(INDX)(1:1) ENDIF WRITE(52,25) ACID(INDX),ALAT(INDX),QLON,CLON,QTIME,PRALT, $ QTEMP,ADIR(INDX),ASPD(INDX),SCALE,C1 25 FORMAT(' ',A8,2F8.2,A1,3F7.0,F6.0,F7.1,F7.0,4X,A1) END IF RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: RPACKR PREPARES OBS. FOR PACKING, FOR ON29 PACKS C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 95-07-06 C C ABSTRACT: PREPARES OBSERVATIONS FOR FINAL PACKING TO OUTPUT FILE. C FINAL CHECK TO REMOVE DUPLICATES, FINAL ASSIGNMENT OF TEMPERATURE C AND WIND QUALITY MARKERS (IF APPLICABLE) AND ACCUMULATION OF NEW C SUPEROBS IN HOLDING ARRAYS (IF APPLICABLE). IN ADDITION, FOR C OFFICE NOTE 29 OUTPUT (NAMELIST SWITCH INIDST < 2), WILL RE-PACK C ORIGINAL OBSERVATIONS PLUS SUPEROBS (IF APPLICABLE) INTO ON29 C FORMAT AND WRITE OUT FILLED RECORDS TO NEW "AIRCFT" FILE (HERE, C NEW QUALITY CONTROL DECISIONS ARE INCLUDED). C C PROGRAM HISTORY LOG: C 89-04-01 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR C 90-04-16 P. JULIAN -- MODIFIED TO PACK SUPEROBS ONE AT A C TIME ON SINGLE LEVELS ONLY C 90-06-14 D. A. KEYSER -- INCLUDED PROCESSING OF TEMP; CORRECTED C ERROR LEADING TO LOSS OF SOME OBS. IN REPACKING; C CORRECTED TO HONOR ALL SDM/QCAIRCFT PURGES FOR STACKED C OBS. & ALL SDM KEEPS FOR ISOL. OBS.; CORRECTED SLIGHT C ERROR IN LAT/LON IN OUTPUT FILE FOR SOME OBS. C 90-07-03 D. A. KEYSER -- ADDED 1 TO OUTPUT TIME FOR MULTIPLE C SUPEROBS IN SAME STACK W/ SAME ORIG. TIME (SO OI WON'T C TOSS AS DUPLICATES); ROUNDED OUTPUT TIME OFF TO NEAREST C INTEGER (FOR AVG'D SUPEROBS), WAS TRUNCATED C 91-02-26 G. J. DIMEGO -- MADE INCREMENT TO-BE-ADDED 11 (SEE ABOVE) C 94-01-01 P. JULIAN -- CHANGES TO RE-DO ON29(REV) QUAL MARKS C 94-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT; ADDED C REPACKING OF ORIGINAL RESERVE CHARACTER INFO PLUS OTHER C META-DATA IN CATEGORY 8 FOR NON-SUPEROBED REPORTS FOR C ON29 OUTPUT; ADDED STORAGE OF ALL SUPEROBS IN HOLDING C ARRAYS C 95-03-27 D. A. KEYSER -- ASDAR/AMDAR TMP/WND RPTS NOT FLAGGED BY C OTHER CHKS NOW GET "GOOD" Q.M. (& FOR INIDST=2, NEW RSN. C CODE 28) REGARDLESS OF SCALED VECTOR INCR. (BEFORE Q.M. C BASED ON SCALED VECTOR INCR.) C 95-07-06 D. A. KEYSER -- REPORTS IN A STACK OF TWO NOW GET C TEMPERATURE AND WIND FLAGGED AS BAD (AND ARE ASSIGNED C THE NEW REASON CODE "329" FOR OUTPUT TO BUFR/PREPDA C FILE) IF THE SCALED VECTOR WIND INCREMENT IS LARGE C (IN THE RANGE 'V' TO 'Z'), A SUPEROB IS NEVER STORED C C USAGE: CALL RPACKR(NUM,NOBS,INDX) C INPUT ARGUMENT LIST: C NUM - NUMBER OF OBSERVATIONS IN ORIGINAL STACK C NOBS - NUMBER OF OBSERVATIONS TO BE PACKED C INDX - POINTER TO POSITION IN ORIGINAL AIRCRAFT ARRAY C C OUTPUT FILES: C UNIT 06 - PRINTOUT C UNIT 51 - ON29 AIRCRAFT FILE CONTAINING NEW Q.C.'D OBS. C - PLUS SUPEROBS C C REMARKS: CALLED BY MAIN PROGRAM. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS C C$$$ SUBROUTINE RPACKR(NUM,NOBS,INDX) PARAMETER (IRMX=100000, ISMX= 500) PARAMETER (ISUP= 250) CHARACTER*1 CBUF CHARACTER*4 CECTME,KPACK(1608),HOLDIT,SSMARK CHARACTER*8 ACID,SAID,COB CHARACTER*14 TAG C-CRA INTEGER IDATA(1608) REAL ORIGTM(10),DATA(1608) COMMON/WORD/LW,ICHTP C-CRA COMMON/INPT/DOSPOB,DOACRS,TMAXO,TMINO,TIMINC,WAYPIN,INIDST,IFLGUS, C-CRA$ JAMASS(6),JAWIND(6),RCPTST COMMON/INPT/TMAXO,TMINO,TIMINC COMMON/INPTI/INIDST,IFLGUS,JAMASS(6),JAWIND(6) LOGICAL DOSPOB,DOACRS,WAYPIN,RCPTST COMMON/INPTL/DOSPOB,DOACRS,WAYPIN,RCPTST COMMON/BUFF/CBUF(6432) COMMON/OUTPUT/KNTOUT(5) C-CRA COMMON/WRITE/SWRITE,IWRITE LOGICAL SWRITE,IWRITE COMMON/COMWRITE/SWRITE,IWRITE C-CRA COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), C-CRA$ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), C-CRA$ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), $ KBAD(ISMX),SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) COMMON/SUMDATI/NUMORG COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), $ ADIRF(IRMX) COMMON/SUPOBS/SSLAT(ISUP),SSLON(ISUP),SSTIM(ISUP),SSHGT(ISUP), $ SSTMP(ISUP),SSDIR(ISUP),SSSPD(ISUP),SSHGTF(ISUP),SSTMPF(ISUP), $ SSDIRF(ISUP),SSSPDF(ISUP),SSMARK(ISUP) INTEGER*8 IDATA(1608),IOB EQUIVALENCE (COB,IOB),(IDATA,DATA) DATA XMSG/99999./,NBY/6432/,MNEXT/0/ C N2DO=NOBS C C NSPOB IS NO. OF SUPEROBS FORMED FOR THE STACK (NSPOB IS LIMITED TO 5) C NSPOB=N2DO - NUM C C INVENTORY INCREMENTS C CALL ACOUNT(NUM,INDX) IF(NOBS.GE.2) THEN PRINT 8000, NOBS,NUM,NSPOB,INDX 8000 FORMAT(' ENTERING RPACKR WITH NOBS =',I4,', NUM =',I4,', AND', $ ' NO. OF SPROBS =',I3,' AND INDX= ',I5) ELSE ISTCPT(1)=-2 END IF DO 1 I=1,NUM JNDX=INDX + I - 1 IF(TAG(JNDX)(1:1).EQ.'D') THEN C C SKIP REPACKING OF ORIGINAL REPORT IF IT IS INDEED A DUPLICATE REPORT C PRINT 9026, JNDX,ACID(JNDX),ALAT(JNDX),ALON(JNDX), $ TIME(JNDX),TAG(JNDX) 9026 FORMAT(/' ++++++++++: RPACKR; DUPLICATE REMOVED AT BEG OF SUBR..', $ I5,2X,A8,2F8.2,F6.0,2X,A14/) KNTINI(JNDX)=99999 GO TO 1 END IF C C SKIP REPACKING OF ORIGINAL REPORT IF IT IS OUTSIDE REQ. TIME WINDOW C IF(TIME(JNDX).LT.TMINO.OR.TIME(JNDX).GT.TMAXO) THEN C C SET POS.1 OF TAG TO 'D' TO REMOVE FROM FINAL LISTING OF ORIG. REPORTS C TAG(JNDX)(1:1)='D' CCCCC PRINT 9002, JNDX,ACID(JNDX),ALAT(JNDX),ALON(JNDX), CCCCC$ TIME(JNDX),TAG(JNDX) 9002 FORMAT(/' ++++++++++: RPACKR; RPTS OUTSIDE TIME WINDOW SKIPPED..', $ I5,2X,A8,2F8.2,F6.0,2X,A14/) KNTINI(JNDX)=99999 GO TO 1 END IF C C----------------------------------------------------------------------- C ALL INIDST: MAKE FINAL ASSIGNMENT OF TEMP AND WIND Q. MARKS (IF APPL.) C----------------------------------------------------------------------- C C NOW, MAKE FINAL ASSIGNMENT OF TEMPERATURE AND WIND Q. MARKS (IF APPL.) C IF(TAG(JNDX)(1:1).EQ.'H') THEN C C SDM KEEP OBSERVATIONS HAVE ALREADY BEEN MARKED C ELSE IF(TAG(JNDX)(1:1).EQ.'P') THEN C C SDM/QCAIRCFT PURGE OBSERVATIONS HAVE ALREADY BEEN MARKED C ELSE IF(N2DO.EQ.1) THEN C C ISOLATED OBSERVATIONS COME HERE C IF(TAG(JNDX)(1:1).EQ.'Q'.OR.TAG(JNDX)(1:1).EQ.'R'.OR. $ TAG(JNDX)(7:7).EQ.'Z') THEN C C IF AIREP/PIREP WITH SMALL VECTOR WIND INCREMENT (Q - R) OR IF "GOOD" C ASDAR/AMDAR REPORT, TEMP & WIND Q.M. IS 'A' C IF(TAG(JNDX)(13:13).GT.'6') THEN IF(TAG(JNDX)(7:7).EQ.'Z') THEN TAG(JNDX)(2:2)='A' TAG(JNDX)(13:13)='6' ITEVNT(JNDX)=328 ELSE TAG(JNDX)(2:2)='A' TAG(JNDX)(13:13)='6' ITEVNT(JNDX)=317 END IF END IF IF(TAG(JNDX)(14:14).GT.'6') THEN IF(TAG(JNDX)(7:7).EQ.'Z') THEN TAG(JNDX)(4:4)='A' TAG(JNDX)(14:14)='6' IWEVNT(JNDX)=328 ELSE TAG(JNDX)(4:4)='A' TAG(JNDX)(14:14)='6' IWEVNT(JNDX)=317 END IF END IF ELSE IF(TAG(JNDX)(1:1).GE.'V'.AND.TAG(JNDX)(1:1).LE.'Z')THEN C C IF AIREP/PIREP WITH LARGE VECTOR WIND INCREMENT (V - Z), TEMP AND C WIND Q.M. IS 'F' C IF(TAG(JNDX)(13:13).GT.'3') THEN TAG(JNDX)(2:2)='F' TAG(JNDX)(13:13)='3' ITEVNT(JNDX)=316 END IF IF(TAG(JNDX)(14:14).GT.'3') THEN TAG(JNDX)(4:4)='F' TAG(JNDX)(14:14)='3' IWEVNT(JNDX)=316 END IF ELSE IF((TAG(JNDX)(1:1).GE.'S'.AND.TAG(JNDX)(1:1).LE.'U') $ .OR.TAG(JNDX)(1:1).EQ.' ') THEN C C IF AIREP/PIREP WITH INTERMEDIATE VECTOR WIND INCREMENT (S - U) OR C WAYPOINT LOCATION CHANGED (BLANK), TEMP AND WIND Q.M. IS 'Q' C IF(TAG(JNDX)(13:13).GT.'5') THEN TAG(JNDX)(2:2)='Q' TAG(JNDX)(13:13)='5' ITEVNT(JNDX)=318 END IF IF(TAG(JNDX)(14:14).GT.'5') THEN TAG(JNDX)(4:4)='Q' TAG(JNDX)(14:14)='5' IWEVNT(JNDX)=318 END IF ELSE IF(TAG(JNDX)(1:1).EQ.'C') THEN C C IF AIREP/PIREP W/ VECTOR WIND INCREMENT NOT CALCULATED ('C'), TEMP & C WIND Q.M. IS ' ' (FOR INIDST=0,1, INCLUDES ALL RPTS OUTSIDE +/- 3-HR C WINDOW; FOR INIDST=2, INCLUDES ALL RPTS OUTSIDE +/- 3.33-HR WINDOW) C IF(TAG(JNDX)(13:13).GT.'7') THEN TAG(JNDX)(13:13)='7' END IF IF(TAG(JNDX)(14:14).GT.'7') THEN TAG(JNDX)(14:14)='7' END IF ELSE END IF ELSE C C STACKED OBSERVATIONS COME HERE C IF(TAG(JNDX)(1:1).GE.'V'.AND.TAG(JNDX)(1:1).LE.'Z'.AND. $ NUM.LT.3) THEN C C IF NO. IN STACK IS TWO, THEN AIREP/PIREP WITH LARGE VECTOR WIND INCR. C (V - Z) HAVE TEMP & WIND Q.M. SET TO 'F' (AS WITH ISOLATED REPORTS) C IF(TAG(JNDX)(13:13).GT.'3') THEN PRINT *,'~~~~~ NUM=2 & THIS OBS. HAS A LARGE INCR., FLAG TEMP' TAG(JNDX)(2:2)='F' TAG(JNDX)(13:13)='3' ITEVNT(JNDX)=329 END IF IF(TAG(JNDX)(14:14).GT.'3') THEN PRINT *,'~~~~~ NUM=2 & THIS OBS. HAS A LARGE INCR., FLAG WIND' TAG(JNDX)(4:4)='F' TAG(JNDX)(14:14)='3' IWEVNT(JNDX)=329 END IF C C WILL NOT STORE ANY SUPEROB REPORTS IN THIS CASE C IF(NSPOB.GT.0) PRINT 9903 CVVVVV IF(NSPOB.GT.0) $ PRINT *,'~~~~~ THE SUPEROB HERE IS NOT STORED' CAAAAA 9903 FORMAT(/' ++++++++++: RPACKR; SUPEROB IS SKIPPED - ONE OR BOTH ', $ 'ORIG. OBS. IN A STACK OF TWO ORIG. OBS. HAVE LARGE INCREMENT'/) NSPOB=0 END IF IF(TAG(JNDX)(14:14).GT.'6') THEN C IF WIND IS NEITHER BAD NOR SUSPECT AT THIS POINT, SET Q.M. TO GOOD TAG(JNDX)(4:4)='A' TAG(JNDX)(14:14)='6' IWEVNT(JNDX)=320 END IF IF(TAG(JNDX)(13:13).GT.'6') THEN C IF TEMP IS NEITHER BAD NOR SUSPECT AT THIS POINT, SET Q.M. TO GOOD TAG(JNDX)(2:2)='A' TAG(JNDX)(13:13)='6' ITEVNT(JNDX)=320 END IF END IF C C C IF(TAG(JNDX)(4:4).EQ.'F'.AND.TAG(JNDX)(13:13).GT.'3') THEN C C IF WIND IS FLAGGED, THEN TEMPERATURE IS ALWAYS ALSO FLAGGED C TAG(JNDX)(2:2)='F' TAG(JNDX)(13:13)='3' ITEVNT(JNDX)=319 END IF C 1 CONTINUE NPT=NUM C C*********************************************************************** C S U P E R O B S C*********************************************************************** C IF(NSPOB.GT.0) THEN DO 2 I=1,NSPOB NPT=NPT + 1 C C----------------------------------------------------------------------- C ALL INIDST: CORRECT OBSERVATION TIME (IF APPL.) C----------------------------------------------------------------------- C C RE-STORE TIME IN WORD 4 C DATA(4)=NINT(MOD(STIM(NPT),2400.)) IF(DATA(4).LT.0.0) THEN DATA(4)=DATA(4) + 2400. STIM(NPT)=STIM(NPT) + 2400. END IF C C MULT. SUPEROBS IN STACK W/ SAME ORIG. TIME HAVE OUTPUT TIME INCR. BY C 'TIMINC' FOR EACH OCCURRENCE OF A DUPL. TIME (PREVENTS OI DUPL. TOSS) C ORIGTM(I)=DATA(4) DO 77 J=1,I-1 IF(ORIGTM(I).EQ.ORIGTM(J)) THEN DATA(4)=MOD(DATA(4)+TIMINC,2400.) STIM(NPT)=STIM(NPT) + TIMINC END IF 77 CONTINUE C C SKIP PACKING OF SUPEROB REPORT IF IT IS OUTSIDE REQ. TIME WINDOW C IF(STIM(NPT).LT.TMINO.OR.STIM(NPT).GT.TMAXO) THEN PRINT 9003, I,SLAT(NPT),SLON(NPT),STIM(NPT) 9003 FORMAT(/' ++++++++++: RPACKR; SUPOBS OUTSIDE TIME WINDOW SKIPPED', $ I5,2X,'SUPROB ',2F8.2,F6.0/) GO TO 2 END IF C C----------------------------------------------------------------------- C ALL INIDST: STORE ALL SUPEROBS IN HOLDING ARRAYS (IF APPL.) C----------------------------------------------------------------------- C KNTOUT(3)=KNTOUT(3) + 1 IF(KNTOUT(3).GT.ISUP) THEN C C FATAL ERROR: THERE ARE MORE SUPEROBED RPTS THAN "ISUP" C PRINT 53, ISUP 53 FORMAT(/' THERE ARE MORE THAN',I9,' SUPEROBED REPORTS GENERATED', $ ' -- MUST INCREASE SIZE OF PARAMETER NAME "ISUP" - ABORT'/) CALL ABORT END IF C SSLAT(KNTOUT(3))=SLAT(NPT) SSLON(KNTOUT(3))=SLON(NPT) SSTIM(KNTOUT(3))=STIM(NPT) SSHGT(KNTOUT(3))=SHGT(NPT) SSTMP(KNTOUT(3))=STMP(NPT) SSDIR(KNTOUT(3))=SDIR(NPT) SSSPD(KNTOUT(3))=SSPD(NPT) SSHGTF(KNTOUT(3))=SHGTF(NPT) SSTMPF(KNTOUT(3))=STMPF(NPT) SSDIRF(KNTOUT(3))=SDIRF(NPT) SSSPDF(KNTOUT(3))=SSPDF(NPT) SSMARK(KNTOUT(3))='SS ' 2 CONTINUE C----------------------------------------------------------------------- END IF IF(NOBS.GE.2.OR.NOBS.NE.NUM) PRINT 8378 8378 FORMAT(1X,'***********************************************') RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: ACOUNT DOES SIMPLE ACCOUNTING OF REPORTS C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 94-08-25 C C ABSTRACT: DOES SIMPLE ACCOUNTING BY LOGGING NUMBER OF REPORTS BY C SCALED VECTOR INCREMENT. FURTHER ACCOUNTING ACCORDING TO ISOLATED C OR STACKED REPORTS ALSO PERFORMED. IN ADDITION, LOGS THE NUMBER OF C SDM KEEPS AND SDM/QCAIRCFT PURGES. THE NUMBER OF BAD TEMPERATURES C IS ALSO ACCOUNTED FOR HERE. C C PROGRAM HISTORY LOG: C 94-01-01 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR C 94-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT C C USAGE: CALL ACOUNT(NUM,INDX) C INPUT ARGUMENT LIST: C NUM - NUMBER OF OBSERVATIONS TO BE TREATED C INDX - POINTER TO POSITION IN ORIGINAL AIRCRAFT ARRAY C C REMARKS: CALLED BY SUBROUTINE 'RPACKR'. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS C C$$$ SUBROUTINE ACOUNT(NUM,INDX) PARAMETER (IRMX=100000) CHARACTER*1 QCACMK(15) CHARACTER*8 ACID CHARACTER*14 TAG COMMON/ACCONT/KQM2F(15),KISO(15),KNQM(15),KSDM(2),KT,KTYPS(9) COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), $ ADIRF(IRMX) C-CRA COMMON/INPT/DOSPOB,DOACRS,TMAXO,TMINO,TIMINC,WAYPIN,INIDST,IFLGUS, C-CRA$ JAMASS(6),JAWIND(6),RCPTST COMMON/INPT/TMAXO,TMINO,TIMINC COMMON/INPTI/INIDST,IFLGUS,JAMASS(6),JAWIND(6) LOGICAL DOSPOB,DOACRS,WAYPIN,RCPTST COMMON/INPTL/DOSPOB,DOACRS,WAYPIN,RCPTST DATA QCACMK/'Q','R','S','T','U','V','W','X','Y','Z','C','P','H', $ ' ','D'/ IF(NUM.EQ.1) THEN IF(TIME(INDX).GE.TMINO.AND.TIME(INDX).LE.TMAXO) THEN DO 619 M=1,15 IF(TAG(INDX)(1:1).EQ.QCACMK(M)) THEN KISO(M)=KISO(M) + 1 GO TO 618 END IF 619 CONTINUE 618 CONTINUE END IF ELSE DO 1 K=INDX,INDX+NUM-1 IF(TIME(K).GE.TMINO.AND.TIME(K).LE.TMAXO) THEN DO 719 M=1,15 IF(TAG(K)(1:1).EQ.QCACMK(M)) THEN KNQM(M)=KNQM(M) + 1 IF(TAG(K)(4:4).EQ.'F') KQM2F(M)=KQM2F(M) + 1 GO TO 718 END IF 719 CONTINUE 718 CONTINUE IF(TAG(K)(1:1).EQ.'P') KSDM(1)=KSDM(1) + 1 IF(TAG(K)(1:1).EQ.'H') KSDM(2)=KSDM(2) + 1 IF(TAG(K)(2:2).EQ.'F'.AND.TAG(K)(4:4).NE.'F') KT=KT +1 END IF 1 CONTINUE END IF RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: IDSORT SORTS INPUT AIRCFT REPORTS BY STATION ID C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 95-07-06 C C ABSTRACT: USES LOCAL SORT ROUTINE TO SORT ENTIRE AIRCRAFT FILE C BY THE 8-CHARACTER STATION (FLIGHT) IDENTIFICATION. C C PROGRAM HISTORY LOG: C 93-01-05 P. JULIAN -- THIS IS A NEW SUBPROGRAM-ALL CODE WAS C WRITTEN TO ENABLE LOCAL SORT PROGRAM TO BE USED. C 94-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT C 95-07-06 D. A. KEYSER -- NO LONGER SETS CHAR. ' ' TO '0' IN C WORKING STNID ARRAY PRIOR TO IDSORT (WAS BREAKING-UP C SOME TRACKS AND WAS NEVER NEEDED FOR ANY OTHER REASON) C C USAGE: CALL IDSORT(NFILE,NASDAR,NEXCLD) C INPUT ARGUMENT LIST: C NFILE - NUMBER OF OBSERVATIONS TO SORT C C OUTPUT ARGUMENT LIST: C NASDAR - NUMBER OF ASDAR AND AMDAR REPORTS IN SORT C NEXCLD - NUMBER OF EXCLUDED REPORTS AT END OF SORT C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY MAIN PROGRAM. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS C C$$$ SUBROUTINE IDSORT(NFILE,NASDAR,NEXCLD) PARAMETER (IRMX=100000) PARAMETER (ISIZE= 16) CHARACTER*8 ACID,AAID(IRMX) CHARACTER*14 TAG,STAG(IRMX) CHARACTER*16 CARRAY(IRMX) REAL SARRAY(IRMX,ISIZE) INTEGER INDR(IRMX) COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), $ ADIRF(IRMX) COMMON/WORD/LW,ICHTP NASDAR=0 NEXCLD=0 C FILL IN CARRAY FOR SORT ROUTINE DO 111 J=1,NFILE IF(TAG(J)(12:12).EQ.'@') THEN C EXCLUDED RPTS ARE COUNTED AND WILL BE AT VERY END OF SORT C (DO THIS BY CHANGING CHARACTER STRING TO '99999' SINCE SORT WILL BE C BY EBCDIC CHARACTERS) NEXCLD=NEXCLD + 1 CARRAY(J)(1:5)='99999' CARRAY(J)(6:16)=ACID(J)(1:7)//'0000' C RESET POS. 8 OF ID BACK TO BLANK (LATER USED TO TAG ISOLATED REPORTS) TAG(J)(12:12)=' ' ELSE IF(TAG(J)(7:7).EQ.'Z') THEN C ASDAR/AMDAR RPTS ARE COUNTED AND WILL BE AFTER AIREPS IN SORT C (DO THIS BY CHANGING CHARACTER STRING TO '999' SINCE SORT WILL BE BY C EBCDIC CHARACTERS) NASDAR=NASDAR + 1 CARRAY(J)(1:3)='999' CARRAY(J)(4:9)=ACID(J)(1:6) WRITE(CARRAY(J)(10:14),'(I5.5)') NINT(TIME(J)) CARRAY(J)(15:16)='00' ELSE C AIREPS WILL BE AT BEGINNING OF SORT CARRAY(J)(1:7)=ACID(J)(1:7) WRITE(CARRAY(J)(8:12),'(I5.5)') NINT(ALON(J)*100.) WRITE(CARRAY(J)(13:16),'(I4.4)') NINT(TIME(J)) END IF C REMOVED THIS FOR 6 JUL 1995 VERSION (WAS SPLITTING UP SOME TRACKS) CCCCCCCCCDO 331 K=1,12 CCCCCCCCC IF(CARRAY(J)(K:K).EQ.' ') CARRAY(J)(K:K)='0' CC331 CONTINUE C TRANSFER ORIGINAL DATA TO TEMPORARY ARRAYS TO HOLD FOR RE-ARRANGING AAID(J)=ACID(J) SARRAY(J,1) =ALAT(J) SARRAY(J,2) =ALON(J) SARRAY(J,3) =AALT(J) SARRAY(J,4) =TIME(J) SARRAY(J,5) =ATMP(J) SARRAY(J,6) =ADIR(J) SARRAY(J,7) =ASPD(J) SARRAY(J,8) =REAL(INTP(J)) SARRAY(J,9) =REAL(IRTM(J)) SARRAY(J,10)=REAL(KNTINI(J)) SARRAY(J,11)=REAL(ITEVNT(J)) SARRAY(J,12)=REAL(IWEVNT(J)) SARRAY(J,13)=AALTF(J) SARRAY(J,14)=ADIRF(J) SARRAY(J,15)=ASPDF(J) SARRAY(J,16)=ATMPF(J) STAG(J)=TAG(J) CCCCC LON=99999 CCCCC IF(ALON(J).LT.99999.) LON=NINT(ALON(J)*100.) CCCCC PRINT 1927, AAID(J),NINT(TIME(J)),LON,CARRAY(J) C1927 FORMAT(' ',A8,2X,2I8,3X,A16) CCCCC PRINT 100, J,AAID(J),SARRAY(J,1),SARRAY(J,2),SARRAY(J,4), CCCCC$ SARRAY(J,3),SARRAY(J,5),SARRAY(J,6),SARRAY(J,7),STAG(J)(1:4) CD100 FORMAT(' ', I7,2X,A8,2X,2F9.2,5F9.0,1X,A4) 111 CONTINUE C C CALL SORT ROUTINE- PUTS POINTERS INTO IPOINT ARRAY/DOES NOT REARRANGE C (IF CHARACTERS ON THIS MACHINE ARE ASCII CONVERT TO EBCDIC) C IF(ICHTP.EQ.0) CALL W3AI39(CARRAY,16*NFILE) IF(NFILE.GT.0) CALL INDEXC(NFILE,CARRAY,INDR) DO 11 I=1,NFILE J=INDR(I) C C WRITE SORTED REPORTS BACK INTO ORIGINAL ARRAYS C ACID(I) =AAID(J) ALAT(I) =SARRAY(J,1) ALON(I) =SARRAY(J,2) AALT(I) =SARRAY(J,3) TIME(I) =SARRAY(J,4) ATMP(I) =SARRAY(J,5) ADIR(I) =SARRAY(J,6) ASPD(I) =SARRAY(J,7) INTP(I) =NINT(SARRAY(J,8)) IRTM(I) =NINT(SARRAY(J,9)) KNTINI(I)=NINT(SARRAY(J,10)) ITEVNT(I)=NINT(SARRAY(J,11)) IWEVNT(I)=NINT(SARRAY(J,12)) AALTF(I)=SARRAY(J,13) ADIRF(I)=SARRAY(J,14) ASPDF(I)=SARRAY(J,15) ATMPF(I)=SARRAY(J,16) TAG(I) =STAG(J) 11 CONTINUE RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: PRELIM SUPERVISES QUALITY CONTROL C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 94-08-25 C C ABSTRACT: DOES BASIC SCREENING OF OBS. CALCULATES STATISTICAL C QUANTITIES AND BRANCHES DEPENDING UPON HOW MANY OBS ARE CO- C LOCATED (STACKED). USES STATISTICS TO CHECK ON MUTUAL AGREEMENT C OR DISAGREEMENT WITHIN OBSERVATION STACKS. C C PROGRAM HISTORY LOG: C 93-01-05 P. JULIAN -- THIS IS A NEW SUBPROGRAM-ALL CODE WAS C PREVIOUSLY A PART OF SUBPROGRAM SUPROB (WHICH NOW C STANDS ALONE); THIS SUBPROGRAM IS CALLED REGARDLESS C OF LOGICAL DOSPOB C 94-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT C C USAGE: CALL PRELIM(NUM,INDX,LOALT,KNUM,STCLIM) C INPUT ARGUMENT LIST: C NUM - NUMBER OF OBSERVATIONS C INDX - POINTER TO POSITION IN ORIGINAL AIRCRAFT ARRAY C LOALT - NUMBER OF OBSERVATIONS AT LOW ALTITUDE C STCLIM - VECTOR WIND INCREMENT THRESHOLD FOR SDM PRINT (UNIT 53) C C OUTPUT ARGUMENT LIST: C KNUM - NUMBER OF GOOD WIND OBSERVATIONS C C OUTPUT FILES: C UNIT 06 - PRINTOUT C UNIT 53 - TEXT FILE FOR SDM PERUSAL (LIST OF STACKED REPORTS C - WITH AVERAGE VECTOR WIND INCREMENT .GT. NAMELIST C - VARIABLE 'STCLIM', ALSO LIST OF STACKED REPORTS WITH C - AT LEAST ONE REPORT CONTAINING SDM KEEP FLAG) C C REMARKS: CALLED BY MAIN PROGRAM. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS C C$$$ SUBROUTINE PRELIM(NUM,INDX,LOALT,KNUM,STCLIM) PARAMETER (IRMX=100000, ISMX= 500) CHARACTER*1 CTG,CLON,C1 CHARACTER*8 ACID,SAID CHARACTER*14 TAG REAL SCALE(ISMX) COMMON/WORD/LW,ICHTP C-CRA COMMON/WRITE/SWRITE,IWRITE LOGICAL SWRITE,IWRITE COMMON/COMWRITE/SWRITE,IWRITE C-CRA COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), C-CRA$ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), C-CRA$ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), $ KBAD(ISMX),SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) COMMON/SUMDATI/NUMORG COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), $ ADIRF(IRMX) DATA XMSG/99999./ KNUM=0 NUMORG=NUM C NUMH IS THE NUMBER OF OBSERVATIONS AT MID- AND HIGH ALTITUDES NUMH=NUM - LOALT PRINT 6001, NUM,INDX,ALAT(INDX),ALON(INDX),NUMH,LOALT 6001 FORMAT(' ******* IN PRELIM FOR A STACK ======> NUM =',I6, $ ', INDX =',I6,' AT LAT',F7.1,', LON',F7.1,', NUMH=',I3, $ ', LOALT=',I3,' <==========') IF(NUMH.LT.2) GO TO 1369 C IF 2 OR MORE HI-ALT. OBS, CALL SHEAR TO CALC. ON- & OFF-LVL DIFFS CALL SHEAR(NUM,INDX) C UPDATE STAC ARRAY INDICATORS AND QUALITY INDICATORS DO 723 I=1,NUM JNDX=INDX + I - 1 IF(TAG(JNDX)(4:4).EQ.'F') ISTCPT(I)=0 IF(ISTCPT(I).GT.0) KNUM=KNUM + 1 IF(ISTCPT(I).EQ.0.OR.KBAD(I).EQ.0) THEN ISTCPT(I)=0 IFLEPT(JNDX)=0 IF(TAG(JNDX)(14:14).GT.'3') THEN TAG(JNDX)(4:4)='F' TAG(JNDX)(14:14)='3' IWEVNT(JNDX)=321 END IF KBAD(I)=I END IF 723 CONTINUE C IF 3 OR MORE HI-ALT. OBS, CALL LAPSE TO FIND BAD TEMPS, MAKE DECISIONS IF(NUMH.GT.2) CALL LAPSE(NUM,INDX) 1369 CONTINUE C UPDATE STAC ARRAY INDICATORS AND QUALITY INDICATORS C FROM HERE ON SUPEROB QUANTITIES ARE DETERMINED BY GOOD WINDS ONLY - C ANY GOOD TEMPS WITH BAD WIND REPORTS ARE IGNORED (C'EST LA VI) QSUM =0.0 IQNUM=0 C-CRA CALL XSTORE(SCALE,XMSG,ISMX) DO I=1,ISMX SCALE(I)=XMSG ENDDO IFLAG=0 DO 773 I=1,NUM JNDX=INDX + I - 1 IF(ISTCPT(I).EQ.0.OR.KBAD(I).EQ.0) THEN IF(TAG(JNDX)(13:13).GT.'3') THEN IF(KBAD(I).EQ.0) THEN ITEVNT(JNDX)=322 ELSE ITEVNT(JNDX)=319 END IF TAG(JNDX)(2:2)='F' TAG(JNDX)(13:13)='3' END IF KBAD(I)=I END IF C AMONGST THOSE OBS. WITH A SCALED VECTOR INCREMENT, SCALE IS BASED ON C ORDINAL POSITION FOR mova2i -- (CHARACTER CONVERTED TO EBCDIC IF ASCI C ON THIS MACHINE) IF(TAG(JNDX)(5:5).GE.'Q'.AND.TAG(JNDX)(5:5).LE.'Z'.AND. $ ISTCPT(I).GT.0) THEN C WE WANT ONLY GOOD HIGH-ALTITUDE OBSERVED VECTOR INCREMENTS HERE CTG=TAG(JNDX)(5:5) IF(ICHTP.EQ.0) CALL W3AI39(CTG,1) ITRANS=0 IF(mova2i(CTG).GE.226) ITRANS=8 SCALE(I) =(10.* (mova2i(CTG) - ITRANS - 215)) - 5. IQNUM=IQNUM + 1 QSUM=QSUM + SCALE(I) END IF C IF ANY OBS. IN STACK HAS A KEEP FLAG (SDM), WILL ALWAYS FORCE THIS C STACK TO GO TO SDMSTAC D-SET FOR SDM PERUSAL AND POSSIBLE DELETING C OF THE STACK, REGARDLESS OF QSUM VALUE IF(TAG(JNDX)(1:1).EQ.'H') IFLAG=1 CCCCC CTEMP=ATMP(JNDX) CCCCC IF(ATMP(JNDX).LT.XMSG) CTEMP=ATMP(JNDX)/10. CCCCC PRINT 6003, I,ACID(JNDX),ADIR(JNDX),ASPD(JNDX),AALT(JNDX),CTEMP, CCCCC$ TIME(JNDX),KBAD(I),ISTCPT(I),(TAG(JNDX)(J:J),J=1,14), CCCCC$ SCALE,IQNUM C6003 FORMAT(' ',I3,1X,A8,F6.0,F6.1,1X,F7.0,F6.1,2X,F5.0,2I4,2X, CCCCC$ 14(A1,1X),F4.1,1X,I3) 773 CONTINUE IF(IQNUM.NE.0) THEN QSUM=QSUM/IQNUM ELSE QSUM=0.0 END IF PRINT 111, INDX,KNUM,IQNUM,QSUM 111 FORMAT(' FROM PRELIM, INDX,KNUM,IQNUM,QSUM ',3I5,F7.1) IF(QSUM.GT.STCLIM.OR.IFLAG.EQ.1) THEN C IF VECTOR WIND INCREMENT THRESHOLD EXEEDED, OR IF AT LEAST ONE REPORT C IN STACK CONTAINS SDM KEEP FLAG, SEND PRINT TO SDM IN UNIT 53 DO 775 I=1,NUM JNDX=INDX + I - 1 QTEMP=99999. IF(ATMP(JNDX).LT.99999.) QTEMP=ATMP(JNDX) * 0.1 QLON=ALON(JNDX) QTIME=MOD(TIME(JNDX),2400.) CLON='W' IF(NINT(QLON).GT.180) THEN QLON=360. - QLON CLON='E' END IF IF(AALT(JNDX).LE.11000.) THEN PRALT = $ 1013.25*(((288.15 - (.0065*AALT(JNDX)))/288.15)**5.256) ELSE PRALT=226.3 * EXP(1.576106E-4 * (11000. - AALT(JNDX))) END IF C1=' ' IF(TAG(JNDX)(1:1).EQ.'H'.OR.TAG(JNDX)(1:1).EQ.'P') $ C1=TAG(JNDX)(1:1) WRITE(53,26) ACID(JNDX),ALAT(JNDX),QLON,CLON,QTIME,PRALT, $ QTEMP,ADIR(JNDX),ASPD(JNDX),SCALE(I),C1 26 FORMAT(' ',A8,2F8.2,A1,3F7.0,F6.0,F7.1,F7.0,4X,A1) 775 CONTINUE WRITE(53,27) 27 FORMAT(' ','-------------------') END IF RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: SUPROB DOES SUPEROBING C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 95-04-26 C C ABSTRACT: DOES BASIC SCREENING OF OBS. CALCULATES STATISTICAL C QUANTITIES AND BRANCHES DEPENDING UPON HOW MANY OBS ARE CO- C LOCATED (STACKED). USES STATISTICS TO CHECK ON MUTUAL AGREEMENT C OR DISAGREEMENT WITHIN OBSERVATION STACKS. C C PROGRAM HISTORY LOG: C 89-04-01 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR C 90-03-29 P. JULIAN -- MODIFIED TO HONOR SDM/QCAIRCFT PURGE FOR C STACKED OBSERVATIONS (OBS. INCRMENT CHECK) C 90-06-14 D. A. KEYSER -- CORRECTED TO HONOR ALL SDM/QCAIRCFT PURGES C FOR STACKED OBS.; FIXED ERROR IN Q. MARK DESIGNATOR C 90-07-03 D. A. KEYSER -- ALT. CORRESP. TO PRESS. OF 300 & 200 MB C FOR REGRESS. CALC. OF SUPEROBS OFF SLIGHTLY, FIXED C 90-09-18 D. A. KEYSER -- MINOR ERROR IN LOGIC CORRECTED, SOME ORIG. C REPORTS WERE BEING GIVEN 'O' Q. MARK BY MISTAKE C 93-01-05 P. JULIAN -- SUBPROGRAM PRELIM CREATED FROM THE FIRST C PORTION OF THE OLD VERSION C 94-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT C 95-03-27 D. A. KEYSER -- FOR INIDST=2, SUPEROBS NOW CONTAIN C SUPEROBED FORECAST(GUESS) P-ALT, WIND DIR, WIND SPEED & C TEMP (IF AVAILABLE FROM INDIV. RPTS MAKING UP SUPEROBS) C 95-04-26 D. A. KEYSER -- CORRECTED PROBLEM IN SUPEROBING GUESS C (OCCASIONALLY OCCURRED) C C USAGE: CALL SUPROB(NUM,INDX,LK,LOALT,KNUM) C INPUT ARGUMENT LIST: C NUM - NUMBER OF OBSERVATIONS TO BE TREATED C INDX - POINTER TO POSITION IN ORIGINAL AIRCRAFT ARRAY C LOALT - NUMBER OF OBSERVATIONS AT LOW ALTITUDE C KNUM - NUMBER OF GOOD WIND OBS C C OUTPUT ARGUMENT LIST: C LK - POINTER INDICATING ' NUM + NO. OF SUPEROBS FORMED ' C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY MAIN PROGRAM. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS C C$$$ SUBROUTINE SUPROB(NUM,INDX,LK,LOALT,KNUM) PARAMETER (IRMX=100000, ISMX= 500) DIMENSION UOB(5),VOB(5),SALT(3),ALTNRM(5),QSPD(5),QDIR(5),TOB(5), $ UOBF(5),VOBF(5),ALTNRF(5),QSPDF(5),QDIRF(5),TOBF(5),KFLAG(ISMX) CHARACTER*8 ACID,SAID CHARACTER*14 TAG INTEGER IARRAY(ISMX),INDR(ISMX) C-CRA COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), C-CRA$ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), C-CRA$ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), $ KBAD(ISMX),SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) COMMON/SUMDATI/NUMORG COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), $ ADIRF(IRMX) COMMON/CMPNTS/U(ISMX),V(ISMX),UF(ISMX),VF(ISMX) C-CRA COMMON/WRITE/SWRITE,IWRITE LOGICAL SWRITE,IWRITE COMMON/COMWRITE/SWRITE,IWRITE COMMON/STUFF/SDALT,TBAR C FOLLOWING IS NUMBER OF OBS SEPARATING TREATMENT OF STACK DATA KNO/5/ C FOLLOWING ARE STANDARD ALT PRESS LEVELS FOR ANALYSIS(M) DATA SALT/9160.,10360.,11780./,XMSG/99999./ NUMORG=NUM C NUMH IS THE NUMBER OF OBSERVATIONS AT MID- AND HIGH ALTITUDES NUMH=NUM - LOALT IF((NUMH.EQ.0.AND.NUM.GT.0).OR.NUMH.EQ.2) THEN C FOR NUMH=2 -- AVERAGE WHAT IS THERE CALL AVEROB(NUM,INDX,LK) RETURN ELSE IF(NUMH.LT.2) THEN LK=NUM RETURN END IF IF(KNUM.GT.KNO) THEN C*********************************************************************** C FIND SUPEROBS FOR NUMBER LEFT .GT. 5 (=KNO ) C*********************************************************************** C START SUPEROBING CRSDA=400. IF(NUMH.GE.10) CRSDA=300. IF(SDALT.LT.CRSDA) THEN C SUPEROB SINGLE LEVEL REPORTS, STND DEV OF ALTS NOT ENOUGH FOR INTERP SUMU =0.0 SUMV =0.0 SUMS =0.0 SUMH =0.0 SUMTMP=0.0 NTEMP =0 SUMUF =0.0 SUMVF =0.0 SUMSF =0.0 SUMHF =0.0 SUMTMF=0.0 NTEMPF=0 NWINDF=0 NHGHTF=0 NT =0 DO 77 K=1,NUM KNDX=INDX + K - 1 IF(ISTCPT(K).GT.0) THEN NT=NT + 1 IF(TAG(KNDX)(2:2).NE.'F'.AND.ATMP(KNDX).LT.XMSG) THEN NTEMP=NTEMP + 1 SUMTMP=SUMTMP + ATMP(KNDX) IF(ATMPF(KNDX).LT.XMSG) THEN NTEMPF=NTEMPF + 1 SUMTMF=SUMTMF + ATMPF(KNDX) END IF END IF SUMU=SUMU + U(K) SUMV=SUMV + V(K) SUMS=SUMS + SSPD(K) SUMH=SUMH + SHGT(K) IF(AMAX1(UF(K),VF(K),SSPDF(K)).LT.XMSG) THEN NWINDF=NWINDF + 1 SUMUF=SUMUF + UF(K) SUMVF=SUMVF + VF(K) SUMSF=SUMSF + SSPDF(K) END IF IF(SHGTF(K).LT.XMSG) THEN NHGHTF=NHGHTF + 1 SUMHF=SUMHF + SHGTF(K) END IF IF(TAG(KNDX)(13:13).GT.'4') THEN TAG(KNDX)(2:2)='O' TAG(KNDX)(13:13)='4' ITEVNT(KNDX)=315 END IF IF(TAG(KNDX)(14:14).GT.'4') THEN TAG(KNDX)(4:4)='O' TAG(KNDX)(14:14)='4' IWEVNT(KNDX)=315 END IF END IF 77 CONTINUE IF(NT.GE.2) THEN LK=NUM + 1 SUMH=SUMH/NT SUMU=SUMU/NT SUMV=SUMV/NT SUMS=SUMS/NT SSPD(LK)=SUMS SHGT(LK)=SUMH STMP(LK)=XMSG IF(NTEMP.GT.0) STMP(LK)=SUMTMP/NTEMP SDIRF(K)=AVEDIR(SUMUF,SUMVF,SUMSF) STIM(LK)=TBAR SLAT(LK)=ALAT(INDX) SLON(LK)=ALON(INDX) SDIR(LK)=AVEDIR(SUMU,SUMV,SUMS) SSPDF(K)=XMSG SDIRF(K)=XMSG IF(NWINDF.GT.0) THEN SSPDF(K)=SUMSF/NWINDF SDIRF(K)=AVEDIR(SUMUF/NWINDF,SUMVF/NWINDF,SUMSF/NWINDF) END IF SHGTF(LK)=XMSG IF(NHGHTF.GT.0) SHGTF(LK)=SUMHF/NHGHTF STMPF(LK)=XMSG IF(NTEMPF.GT.0) STMPF(LK)=SUMTMF/NTEMPF ISTCPT(LK)=NT CTEMP=STMP(LK) IF(STMP(LK).LT.XMSG) CTEMP=STMP(LK)/10. CTMPF=STMPF(LK) IF(STMPF(LK).LT.XMSG) CTMPF=STMPF(LK)/10. PRINT 6412, NINT(SDIR(LK)),SSPD(LK),CTEMP,NINT(SHGT(LK)), $ ISTCPT(LK),NT,NINT(SDIRF(LK)),SSPDF(LK),CTMPF,NINT(SHGTF(LK)) 6412 FORMAT(' SNG LVL: DIR/SPD=',I3,'/',F5.1,', TMP=',F6.1,', ALT=',I5, $ ', ISTCPT=',I4,', + USED=',I3,', GES: DIR/SPD=',I5,'/',F7.1, $ ', TMP=',F6.1,', ALT=',I5) ELSE RETURN END IF ELSE C NOT SINGLE LEVEL, USE 2-D INTERP (TIME AND ALTITUDE) SUMU =0.0 SUMV =0.0 SUMT =0.0 SUMA =0.0 SUMS =0.0 SSQU =0.0 SSQV =0.0 SSQT =0.0 SSQA =0.0 SSQS =0.0 CSPAU =0.0 CSPAV =0.0 CSPTU =0.0 CSPTV =0.0 CSPAS =0.0 CSPAT =0.0 CSPTS =0.0 CSPATM=0.0 CSPTTM=0.0 SUMUF =0.0 SUMVF =0.0 SUMTF =0.0 SUMAF =0.0 SSQUF =0.0 SSQVF =0.0 SSQTF =0.0 SSQAF =0.0 CSPAUF=0.0 CSPAVF=0.0 CSPTUF=0.0 CSPTVF=0.0 CFPATM=0.0 CFPTTM=0.0 C LOOP THRU ALL REPORTS CACLULATING REGRESSION INFO-WIND NWIND =0 NWINDF=0 DO 104 I=1,NUM JNDX=INDX + I - 1 IF(IFLEPT(JNDX).GT.0) THEN NWIND=NWIND + 1 SUMU =SUMU + U(I) SUMV =SUMV + V(I) SUMS =SUMS + ASPD(JNDX) SUMT =SUMT + TIME(JNDX) SUMA =SUMA + AALT(JNDX) SSQU =SSQU + (U(I) * U(I)) SSQV =SSQV + (V(I) * V(I)) SSQS =SSQS + (ASPD(JNDX) * ASPD(JNDX)) SSQT =SSQT + (TIME(JNDX) * TIME(JNDX)) SSQA =SSQA + (AALT(JNDX) * AALT(JNDX)) CSPAU=CSPAU + (U(I) * AALT(JNDX)) CSPAV=CSPAV + (V(I) * AALT(JNDX)) CSPTU=CSPTU + (U(I) * TIME(JNDX)) CSPTV=CSPTV + (V(I) * TIME(JNDX)) CSPAS=CSPAS + (ASPD(JNDX) * AALT(JNDX)) CSPTS=CSPTS + (ASPD(JNDX) * TIME(JNDX)) CSPAT=CSPAT + (TIME(JNDX) * AALT(JNDX)) IF(AMAX1(UF(I),VF(I),ASPDF(JNDX)).LT.XMSG) THEN NWINDF=NWINDF + 1 SUMUF =SUMUF + UF(I) SUMVF =SUMVF + VF(I) SUMTF =SUMTF + TIME(JNDX) SUMAF =SUMAF + AALT(JNDX) SSQUF =SSQUF + (UF(I) * UF(I)) SSQVF =SSQVF + (VF(I) * VF(I)) SSQTF =SSQTF + (TIME(JNDX) * TIME(JNDX)) SSQAF =SSQAF + (AALT(JNDX) * AALT(JNDX)) CSPAUF=CSPAUF + (UF(I) * AALT(JNDX)) CSPAVF=CSPAVF + (VF(I) * AALT(JNDX)) CSPTUF=CSPTUF + (UF(I) * TIME(JNDX)) CSPTVF=CSPTVF + (VF(I) * TIME(JNDX)) END IF END IF 104 CONTINUE RNDF=1./NWIND RFNO=1./NWIND IF(NWIND.GT.3) RNDF=1./(NWIND - 1) UBAR=SUMU * RFNO VBAR=SUMV * RFNO TBAR=SUMT * RFNO ABAR=SUMA * RFNO SBAR=SUMS * RFNO QQQ=(SSQU - (UBAR * UBAR * NWIND)) * RNDF IF(QQQ.LE.0.0) QQQ=.0001 SDU=SQRT(QQQ) QQQ=(SSQV - (VBAR * VBAR * NWIND)) * RNDF IF(QQQ.LE.0.0) QQQ=.0001 SDV=SQRT(QQQ) QQQ=(SSQT - (TBAR * TBAR * NWIND)) * RNDF IF(QQQ.LE.0.0) QQQ=.0001 SDT=SQRT(QQQ) QQQ =(SSQA - (ABAR * ABAR * NWIND)) * RNDF IF(QQQ.LE.0.0) QQQ=.0001 SDALT=SQRT(QQQ) QQQ=(SSQS - (SBAR * SBAR * NWIND)) * RNDF IF(QQQ.LE.0.0) QQQ=.0001 SDS=SQRT(QQQ) RUA=((CSPAU - (UBAR * ABAR * NWIND)) * RNDF)/(SDU *SDALT) RVA=((CSPAV - (VBAR * ABAR * NWIND)) * RNDF)/(SDV *SDALT) RUT=((CSPTU - (UBAR * TBAR * NWIND)) * RNDF)/(SDU * SDT) RVT=((CSPTV - (VBAR * TBAR * NWIND)) * RNDF)/(SDV * SDT) RSA=((CSPAS - (SBAR * ABAR * NWIND)) * RNDF)/(SDS *SDALT) RST=((CSPTS - (SBAR * TBAR * NWIND)) * RNDF)/(SDS * SDT) RAT=((CSPAT - (TBAR * ABAR * NWIND)) * RNDF)/(SDT *SDALT) RNDFF=XMSG ABARF=XMSG UBARF=XMSG VBARF=XMSG TBARF=XMSG IF(NWINDF.GT.0) THEN RNDFF=1./NWINDF RFNOF=1./NWINDF IF(NWINDF.GT.3) RNDFF=1./(NWINDF - 1) UBARF=SUMUF * RFNOF VBARF=SUMVF * RFNOF TBARF=SUMTF * RFNOF ABARF=SUMAF * RFNOF END IF SDUF =XMSG SDALTF=XMSG RUAF =XMSG RUTF =XMSG RVAF =XMSG RVTF =XMSG IF(NWINDF.GT.1) THEN QQQF=(SSQUF - (UBARF * UBARF * NWINDF)) * RNDFF IF(QQQF.LE.0.0) QQQF=.0001 SDUF=SQRT(QQQF) QQQF=(SSQVF - (VBARF * VBARF * NWINDF)) * RNDFF IF(QQQF.LE.0.0) QQQF=.0001 SDVF=SQRT(QQQF) QQQF=(SSQTF - (TBARF * TBARF * NWINDF)) * RNDFF IF(QQQF.LE.0.0) QQQF=.0001 SDTF=SQRT(QQQF) QQQF=(SSQAF - (ABARF * ABARF * NWINDF)) * RNDFF IF(QQQF.LE.0.0) QQQF=.0001 SDALTF=SQRT(QQQF) RUAF =((CSPAUF-(UBARF*ABARF*NWINDF))*RNDFF)/(SDUF*SDALTF) RVAF =((CSPAVF-(VBARF*ABARF*NWINDF))*RNDFF)/(SDVF*SDALTF) RUTF =((CSPTUF-(UBARF*TBARF*NWINDF))*RNDFF)/(SDUF*SDTF) RVTF =((CSPTVF-(VBARF*TBARF*NWINDF))*RNDFF)/(SDVF*SDTF) END IF C LOOP THRU ALL REPORTS CACLULATING REGRESSION INFO FOR TEMPERATURES SUMTT =0.0 SUMAT =0.0 SUMTMP=0.0 SSQTT =0.0 SSQAT =0.0 SSQTMP=0.0 CSPATM=0.0 CSPTTM=0.0 NTEMP =0 SUMTTF=0.0 SUMATF=0.0 SUMTMF=0.0 SSQTTF=0.0 SSQATF=0.0 SSQTMF=0.0 CFPATM=0.0 CFPTTM=0.0 NTEMPF=0 DO 105 JNDX=INDX,INDX+NUM-1 IF(TAG(JNDX)(2:2).NE.'F'.AND.ATMP(JNDX).LT.XMSG) THEN NTEMP =NTEMP + 1 SUMTT =SUMTT + TIME(JNDX) SUMAT =SUMAT + AALT(JNDX) SUMTMP=SUMTMP + ATMP(JNDX) SSQTT =SSQTT + (TIME(JNDX) * TIME(JNDX)) SSQAT =SSQAT + (AALT(JNDX) * AALT(JNDX)) SSQTMP=SSQTMP + (ATMP(JNDX) * ATMP(JNDX)) CSPATM=CSPATM + (ATMP(JNDX) * AALT(JNDX)) CSPTTM=CSPTTM + (ATMP(JNDX) * TIME(JNDX)) IF(ATMPF(JNDX).LT.XMSG) THEN NTEMPF =NTEMPF + 1 SUMTTF =SUMTTF + TIME(JNDX) SUMATF =SUMATF + AALT(JNDX) SUMTMF =SUMTMF + ATMPF(JNDX) SSQTTF =SSQTTF + (TIME(JNDX) * TIME(JNDX)) SSQATF =SSQATF + (AALT(JNDX) * AALT(JNDX)) SSQTMF =SSQTMF + (ATMPF(JNDX) * ATMPF(JNDX)) CFPATM =CFPATM + (ATMPF(JNDX) * AALT(JNDX)) CFPTTM =CFPTTM + (ATMPF(JNDX) * TIME(JNDX)) END IF END IF 105 CONTINUE TTBAR=XMSG ATBAR=XMSG TMPBAR=XMSG IF(NTEMP.GT.0) THEN CVVVVV FIX BY DAK 3/14/95 (ADDED NEXT LINE) RNDF=1./NTEMP CAAAAA FIX BY DAK 3/14/95 RFNO=1./NTEMP IF(NTEMP.GT.3) RNDF=1./(NTEMP - 1) TMPBAR=SUMTMP * RFNO TTBAR =SUMTT * RFNO ATBAR =SUMAT * RFNO END IF QQQ=0.0 RTTT =XMSG RTMA =XMSG SDTMP=XMSG IF(NTEMP.GT.1) THEN QQQ=(SSQTMP - (TMPBAR * TMPBAR * NTEMP)) * RNDF IF(QQQ.LE.0.0) QQQ=.0001 SDTMP=SQRT(QQQ) QQQ=(SSQTT - (TTBAR * TTBAR * NTEMP)) * RNDF IF(QQQ.LE.0.0) QQQ=.0001 SDTT=SQRT(QQQ) QQQ=(SSQAT - (ATBAR * ATBAR * NTEMP)) * RNDF IF(QQQ.LE.0.0) QQQ=.0001 SDAT=SQRT(QQQ) CCCCC PRINT 6346, TMPBAR,TTBAR,SDTMP,SDTT,ATBAR,SDAT C6346 FORMAT(' STATS ',6F12.3) RTTT=((CSPTTM-(TMPBAR*TTBAR*NTEMP))*RNDF)/(SDTMP*SDTT) RTMA=((CSPATM-(TMPBAR*ATBAR*NTEMP))*RNDF)/(SDTMP*SDAT) PRINT 6017, RTTT,RTMA,NTEMP 6017 FORMAT(' CORR COEFFS TEMP-TIME,TEMP-ALT ', $ 2F7.2,' WITH NTEMP=',I3) END IF TTBARF=XMSG ATBARF=XMSG TMFBAR=XMSG IF(NTEMPF.GT.0) THEN RNDFF=1./NTEMPF RFNOF=1./NTEMPF IF(NTEMPF.GT.3) RNDFF=1./(NTEMPF - 1) TMFBAR=SUMTMF * RFNOF TTBARF=SUMTTF * RFNOF ATBARF=SUMATF * RFNOF END IF QQQF=0.0 RTTTF =XMSG RTMAF =XMSG SDTMPF=XMSG IF(NTEMPF.GT.1) THEN QQQF=(SSQTMF - (TMFBAR * TMFBAR * NTEMPF)) * RNDFF IF(QQQF.LE.0.0) QQQF=.0001 SDTMPF=SQRT(QQQF) QQQF=(SSQTTF - (TTBARF * TTBARF * NTEMPF)) * RNDFF IF(QQQF.LE.0.0) QQQF=.0001 SDTTF=SQRT(QQQF) QQQF=(SSQATF - (ATBARF * ATBARF * NTEMPF)) * RNDFF IF(QQQF.LE.0.0) QQQF=.0001 SDATF=SQRT(QQQF) CCCCC PRINT 7346, TMFBAR,TTBARF,SDTMPF,SDTTF,ATBARF,SDATF C7346 FORMAT(' GESS STATS ',6F12.3) RTTTF=((CFPTTM-(TMFBAR*TTBARF*NTEMPF))*RNDFF)/(SDTMPF*SDTTF) RTMAF=((CFPATM-(TMFBAR*ATBARF*NTEMPF))*RNDFF)/(SDTMPF*SDATF) PRINT 7017, RTTTF,RTMAF,NTEMPF 7017 FORMAT(' GESS CORR COEFFS TEMP-TIME,TEMP-ALT ', $ 2F7.2,' WITH NTEMPF=',I3) END IF C CALCULATE MULTIPLE CORRELATIONS RUMULT=((RUA*RUA+RUT*RUT-2.*RUA*RUT*RAT)/(1.-RAT*RAT)) IF(RUMULT.LE.0.0) RUMULT=.0001 RUMULT=SQRT(RUMULT) RVMULT=((RVA*RVA+RVT*RVT-2.*RVA*RVT*RAT)/(1.-RAT*RAT)) IF(RVMULT.LE.0.0) RVMULT=.0001 RVMULT=SQRT(RVMULT) PRINT 6016, RUA,RUT,RVA,RVT,RSA,RST,NWIND 6016 FORMAT(' CORR COEFFS RUA,RUT,RVA,RVT,RSPDA,RSPDT ', $ 3(2F7.2,4X),'WITH NWIND=',I3) PRINT 6416, RUMULT,RVMULT,RAT 6416 FORMAT(' MULT CORR COEFFS, U-COMP, V-COMP ',2F9.2,';ALT,TIME ', $ 'CORR= ',F9.2) KOUNT=0 C CHECK ON NUMBER LEFT IF(NWIND.GT.KNO) THEN C CHECK ON TIME DEVIATION TIMCHK=ABS(TBASE-TBAR)/SDT IF(TIMCHK.LE.2.8) THEN C FIND MAX & MIN WIND SPEED DO 514 I=1,NUM IARRAY(I)=NINT(SSPD(I)*100.) 514 CONTINUE IF(NUM.GT.0) CALL INDEXF(NUM,IARRAY,INDR) TIMCHK=(TBASE-TBAR)/SDT SPDMAX=SSPD(INDR(NUM)) SPDMIN=SSPD(INDR(1)) C FIND MAX & MIN TEMPERATURE DO 515 I=1,NUM IARRAY(I)=NINT(STMP(I)*100.) 515 CONTINUE IF(NUM.GT.0) CALL INDEXF(NUM,IARRAY,INDR) TMPMAX=STMP(INDR(NUM)) IF(TMPMAX.GE.XMSG) TMPMAX=STMP(INDR(NUM-1)) TMPMIN=STMP(INDR(1)) C TRY TO INTERPOLATE TO THREE STANDARD LEVELS DO 551 JA=1,3 UOB(JA) =XMSG VOB(JA) =XMSG QSPD(JA)=XMSG QDIR(JA)=XMSG TOB(JA) =XMSG ALTNRM(JA)=(SALT(JA) - ABAR)/SDALT UOBF(JA) =XMSG VOBF(JA) =XMSG QSPDF(JA) =XMSG QDIRF(JA) =XMSG TOBF(JA) =XMSG ALTNRF(JA)=XMSG IF(NWINDF.GT.1) ALTNRF(JA) =(SALT(JA)-ABARF)/SDALTF C THE FOLLOWING VALUES OF VARIABLE QQQ ARE SELECTABLE CONSTANTS C SPECIFYING THE ALLOWABLE SPREAD IN ALT; THEY ARE FUNCTIONS OF C THE MULT CORRELATIONS (WIND COMPS WITH TIME AND ALTITIUDE) IF(RUMULT.GT.0.85.OR.RVMULT.GT.0.85) THEN QQQ=1.8 ELSE IF(RUMULT.GT.0.70.OR.RVMULT.GT.0.70) THEN QQQ=1.6 ELSE QQQ=1.2 END IF C IF ALT DEVIATION TOO GREAT, SKIP LEVEL IF(ABS(ALTNRM(JA)).LE.QQQ) THEN C TRY IT UOB(JA)=(RUT * SDU * TIMCHK) + (RUA * SDU * ALTNRM(JA)) + UBAR C KEYSER: ASK PAUL: ANY CHANCE BELOW SHOULD BE 'SDV' INSTEAD OF 'SDU' VOB(JA)=(RVT * SDU * TIMCHK) + (RVA * SDU * ALTNRM(JA)) + VBAR QSPD(JA)=SQRT(UOB(JA)**2 + VOB(JA)**2) QDIR(JA)=AVEDIR(UOB(JA),VOB(JA),QSPD(JA)) IF(NTEMP.GT.1) TOB(JA)=(RTTT * SDTMP * $ TIMCHK) + (RTMA * SDTMP * ALTNRM(JA)) + TMPBAR IF(NWINDF.GT.1) THEN UOBF(JA)=(RUTF * SDUF * TIMCHK)+(RUAF * SDUF * ALTNRF(JA))+UBARF C KEYSER: ASK PAUL: ANY CHANCE BELOW SHOULD BE 'SDVF' INSTEAD OF 'SDUF' VOBF(JA)=(RVTF * SDUF * TIMCHK)+(RVAF * SDUF * ALTNRF(JA))+VBARF QSPDF(JA)=SQRT(UOBF(JA)**2 + VOBF(JA)**2) QDIRF(JA)=AVEDIR(UOBF(JA),VOBF(JA),QSPDF(JA)) END IF IF(NTEMPF.GT.1) TOBF(JA)=(RTTTF * SDTMPF * $ TIMCHK) + (RTMAF * SDTMPF * ALTNRF(JA)) + TMFBAR C ADJUSTABLE LIMITS TUNING OPTION QMAX=SPDMAX * 1.09 QMIN=SPDMIN * 0.91 C IF ESTIMATED WIND OUTSIDE LIMITS, SKIP IT (W.R.T. REGRESSION) IF(QSPD(JA).LE.QMAX.AND.QSPD(JA).GE.QMIN) THEN C OTHERWISE, GO ON KOUNT=KOUNT + 1 LK=KOUNT + NUM SDIR(LK)=QDIR(JA) SSPD(LK)=QSPD(JA) SLAT(LK)=ALAT(INDX) SLON(LK)=ALON(INDX) SHGT(LK)=SALT(JA) STIM(LK)=TBASE SDIRF(LK)=QDIRF(JA) SSPDF(LK)=QSPDF(JA) SHGTF(LK)=XMSG IF(NWINDF.GT.1) SHGTF(LK)=SALT(JA) QMAX=TMPMAX * 0.91 QMIN=TMPMIN * 1.05 STMP(LK)=XMSG STMPF(LK)=XMSG IF(TOB(JA).LE.QMAX.AND.TOB(JA).GE.QMIN) THEN STMP(LK)=TOB(JA) STMPF(LK)=TOBF(JA) END IF ISTCPT(LK)=LK END IF END IF CTEMP=TOB(JA) IF(TOB(JA).LT.XMSG) CTEMP=TOB(JA)/10. CTMPF=TOBF(JA) IF(TOBF(JA).LT.XMSG) CTMPF=TOBF(JA)/10. PRINT 6712, NINT(SALT(JA)),NINT(QDIR(JA)),QSPD(JA),ALTNRM(JA), $ TIMCHK,KOUNT,CTEMP,NINT(QDIRF(JA)),QSPDF(JA),CTMPF 6712 FORMAT(' FOR ALT=',I5,',DIR/SPD=',I5,'/',F7.1,',NORM ALT=',F4.1, $ ',NORM TIME=',F4.1,',KOUNT=',I3,',TMP=',F7.1,',GES: DIR/SPD=',I5, $ '/',F7.1,',TMP=',F7.1) 551 CONTINUE END IF END IF C ALL INTERPS HAVE BEEN TRIED, RESULT IS KOUNT IF(KOUNT.GT.0) THEN DO 424 I=1,NUM KNDX=INDX + I - 1 IF(ISTCPT(I).GT.0) THEN C Q.MARKS WILL BE SET TO 'O' --> OMIT IF(TAG(KNDX)(13:13).GT.'4') THEN TAG(KNDX)(2:2)='O' TAG(KNDX)(13:13)='4' ITEVNT(KNDX)=315 END IF IF(TAG(KNDX)(14:14).GT.'4') THEN TAG(KNDX)(4:4)='O' TAG(KNDX)(14:14)='4' IWEVNT(KNDX)=315 END IF ELSE IF(ISTCPT(I).EQ.0) THEN IF(TAG(KNDX)(13:13).GT.'3') THEN TAG(KNDX)(2:2)='F' TAG(KNDX)(13:13)='3' ITEVNT(KNDX)=323 END IF IF(TAG(KNDX)(14:14).GT.'3') THEN TAG(KNDX)(4:4)='F' TAG(KNDX)(14:14)='3' IWEVNT(KNDX)=323 END IF ELSE IF(ISTCPT(I).LT.0) THEN IF(TAG(KNDX)(13:13).GT.'7') THEN TAG(KNDX)(13:13)='7' END IF IF(TAG(KNDX)(14:14).GT.'7') THEN TAG(KNDX)(14:14)='7' END IF END IF 424 CONTINUE ELSE C INTERPOLATION FAILED SO TRANSFER TO AVEROB CALL AVEROB(NUM,INDX,LK) END IF C SUPEROB ANY LOW ALTITUDE REPORTS IF(LOALT.GE.2) THEN C-CRA CALL XSTORE(KFLAG,0,ISMX) DO I=1,ISMX KFLAG(I)=0 ENDDO DO 705 K=1,NUM IF(K.EQ.NUM) GO TO 705 JNDX=INDX + K - 1 IF(ISTCPT(K).LT.0.AND.KFLAG(K).EQ.0) THEN KOUNT =1 KOUNTM=0 KOUNWF=0 KOUNTF=0 KOUNHF=0 SUMD=SDIR(K) SUMS=SSPD(K) SUMT=STIM(K) SUMH=SHGT(K) SUMDF=XMSG SUMSF=XMSG IF(AMAX1(SDIRF(K),SSPDF(K)).LT.XMSG) THEN SUMDF=SDIRF(K) SUMSF=SSPDF(K) KOUNWF=KOUNWF + 1 END IF SUMTMP=XMSG SUMTMF=XMSG IF(STMP(K).LT.XMSG) THEN SUMTMP=STMP(K) KOUNTM=1 IF(STMPF(K).LT.XMSG) THEN SUMTMF=STMPF(K) KOUNTF=1 END IF END IF SUMHF=XMSG IF(SHGTF(K).LT.XMSG) THEN SUMHF=SHGTF(K) KOUNHF=1 END IF DO 706 KK=K+1,NUM KNDX=INDX + KK - 1 IF(ISTCPT(KK).LT.0.AND.ABS(SHGT(K)-SHGT(KK)).LT.150..AND. $ ABS(STIM(K)-STIM(KK)).LT.350..AND.KFLAG(KK).EQ.0) THEN SUMD=SDIR(KK) + SUMD SUMS=SSPD(KK) + SUMS SUMT=STIM(KK) + SUMT SUMH=SHGT(KK) + SUMH KOUNT=KOUNT + 1 KFLAG(KK)=-1 IF(AMAX1(SDIRF(KK),SSPDF(KK)).LT.XMSG.AND.KOUNWF.GT.0) THEN SUMDF=SDIRF(KK) + SUMDF SUMSF=SSPDF(KK) + SUMSF KOUNWF=KOUNWF + 1 END IF IF(STMP(KK).LT.XMSG.AND.KOUNTM.GT.0) THEN SUMTMP=STMP(KK) + SUMTMP KOUNTM=KOUNTM + 1 IF(STMPF(KK).LT.XMSG.AND.KOUNTF.GT.0) THEN SUMTMF=STMPF(KK) + SUMTMF KOUNTF=KOUNTF + 1 END IF END IF IF(SHGTF(KK).LT.XMSG.AND.KOUNHF.GT.0) THEN SUMHF=SHGTF(KK) + SUMHF KOUNHF=KOUNHF + 1 END IF IF(TAG(JNDX)(13:13).GT.'4') THEN TAG(JNDX)(2:2)='O' TAG(JNDX)(13:13)='4' ITEVNT(JNDX)=315 END IF IF(TAG(JNDX)(14:14).GT.'4') THEN TAG(JNDX)(4:4)='O' TAG(JNDX)(14:14)='4' IWEVNT(JNDX)=315 END IF IF(TAG(KNDX)(13:13).GT.'4') THEN TAG(KNDX)(2:2)='O' TAG(KNDX)(13:13)='4' ITEVNT(KNDX)=315 END IF IF(TAG(KNDX)(14:14).GT.'4') THEN TAG(KNDX)(4:4)='O' TAG(KNDX)(14:14)='4' IWEVNT(KNDX)=315 END IF END IF 706 CONTINUE IF(KOUNT.GT.1) THEN SUMD=SUMD/KOUNT SUMS=SUMS/KOUNT TBAR=SUMT/KOUNT SUMH=SUMH/KOUNT LK=LK + 1 SSPD(LK)=SUMS SDIR(LK)=SUMD SHGT(LK)=SUMH SSPDF(LK)=XMSG SDIRF(LK)=XMSG IF(KOUNWF.GT.0) THEN SSPDF(LK)=SUMSF/KOUNWF SDIRF(LK)=SUMDF/KOUNWF END IF STMP(LK) =XMSG STMPF(LK)=XMSG IF(KOUNTM.GT.0) THEN STMP(LK)=SUMTMP/KOUNTM IF(KOUNTF.GT.0) STMPF(LK)=SUMTMF/KOUNTF END IF SHGTF(LK)=XMSG IF(KOUNHF.GT.0) SHGTF(LK)=SUMHF/KOUNHF SLAT(LK)=ALAT(INDX) SLON(LK)=ALON(INDX) STIM(LK)=TBAR ISTCPT(LK)=KOUNT CTEMP=STMP(LK) IF(STMP(LK).LT.XMSG) CTEMP=STMP(LK)/10. CTMPF=STMPF(LK) IF(STMPF(LK).LT.XMSG) CTMPF=STMPF(LK)/10. CVVVVVV PRINT *, ' ~~~~~ HERE IS LOW ALT FIX-UP FOR SUPEROBING' CAAAAAA PRINT 6427, LK,KOUNT,NINT(SDIR(LK)),SSPD(LK),CTEMP,NINT(SHGT(LK)), $ NINT(SDIRF(LK)),SSPDF(LK),CTMPF,NINT(SHGTF(LK)) 6427 FORMAT(' LOALT(SUPROB)',I3,',KOUNT=',I5,',DIR/SPD=',I3,'/',F5.1, $ ',TMP=',F7.1,',ALT=',I5,',GES: DIR/SPD=',I5,'/',F7.1,',TMP=', $ F7.1,',ALT=',I5) END IF END IF 705 CONTINUE END IF END IF RETURN ELSE C*********************************************************************** C FIND SUPEROBS FOR NUMBER LEFT .LE. 5 C*********************************************************************** IF(NUM.LE.2) RETURN C SUPEROB SINGLE LEVEL REPORTS NUMGT=MAX0(NUMORG,NUM) LK=NUMGT IF(SDALT.LT.400.) THEN SUMU =0.0 SUMV =0.0 SUMS =0.0 SUMA =0.0 SUMTMP=0.0 NTEMP =0 SUMUF =0.0 SUMVF =0.0 SUMSF =0.0 SUMAF =0.0 SUMTMF=0.0 NTEMPF=0 NWINDF=0 NHGHTF=0 NT=0 DO 85 K=1,NUMGT JNDX=INDX + K - 1 IF(IFLEPT(JNDX).EQ.0.OR.TAG(JNDX)(4:4).EQ.'F') THEN ISTCPT(K)=IFLEPT(JNDX) ELSE IF(ISTCPT(K).GT.0) THEN NT=NT + 1 IF(ATMP(JNDX).LT.XMSG.AND.TAG(JNDX)(2:2).NE.'F') THEN NTEMP=NTEMP + 1 SUMTMP=SUMTMP + ATMP(JNDX) IF(ATMPF(JNDX).LT.XMSG) THEN NTEMPF=NTEMPF + 1 SUMTMF=SUMTMF + ATMPF(JNDX) END IF END IF SUMU=SUMU + U(K) SUMV=SUMV + V(K) SUMS=SUMS + SSPD(K) SUMA=SUMA + SHGT(K) IF(AMAX1(UF(K),VF(K),SSPDF(K)).LT.XMSG) THEN NWINDF=NWINDF + 1 SUMUF=SUMUF + UF(K) SUMVF=SUMVF + VF(K) SUMSF=SUMSF + SSPDF(K) END IF IF(SHGTF(K).LT.XMSG) THEN NHGHTF=NHGHTF + 1 SUMAF=SUMAF + SHGTF(K) END IF IF(TAG(JNDX)(13:13).GT.'4') THEN TAG(JNDX)(2:2)='O' TAG(JNDX)(13:13)='4' ITEVNT(JNDX)=315 END IF IF(TAG(JNDX)(14:14).GT.'4') THEN TAG(JNDX)(4:4)='O' TAG(JNDX)(14:14)='4' IWEVNT(JNDX)=315 END IF END IF 85 CONTINUE IF(NT.EQ.0.OR.NT.EQ.1) RETURN IF(NT.EQ.2) THEN CALL NOEQ2(NUM,INDX,LK) ELSE LK=LK + 1 SUMU=SUMU/NT SUMV=SUMV/NT SUMS=SUMS/NT SHGT(LK)=SUMA/NT STIM(LK)=TBAR SLAT(LK)=ALAT(INDX) SLON(LK)=ALON(INDX) ISTCPT(LK)=IFLEPT(INDX) SSPD(LK)=SUMS SDIR(LK)=AVEDIR(SUMU,SUMV,SUMS) SSPDF(LK)=XMSG SDIRF(LK)=XMSG IF(NWINDF.GT.0) THEN SSPDF(LK)=SUMSF/NWINDF SDIRF(LK)=AVEDIR(SUMUF/NWINDF,SUMVF/NWINDF,SUMSF/NWINDF) END IF SHGTF(LK)=XMSG IF(NHGHTF.GT.0) SHGTF(LK)=SUMAF/NHGHTF STMP(LK)=XMSG STMPF(LK)=XMSG IF(NTEMP.GT.0) THEN STMP(LK)=SUMTMP/NTEMP IF(NTEMPF.GT.0) STMPF(LK)=SUMTMF/NTEMPF END IF END IF DO 423 I=1,NUM KNDX=INDX + I - 1 IF(ISTCPT(I).GT.0) THEN IF(TAG(KNDX)(13:13).GT.'4') THEN TAG(KNDX)(2:2)='O' TAG(KNDX)(13:13)='4' ITEVNT(KNDX)=315 END IF IF(TAG(KNDX)(14:14).GT.'4') THEN TAG(KNDX)(4:4)='O' TAG(KNDX)(14:14)='4' IWEVNT(KNDX)=315 END IF END IF 423 CONTINUE CTEMP=STMP(K) IF(STMP(K).LT.XMSG) CTEMP=STMP(K)/10. CTMPF=STMPF(K) IF(STMPF(K).LT.XMSG) CTMPF=STMPF(K)/10. PRINT 8412, LK,NINT(SDIR(LK)),SSPD(LK),NINT(STIM(LK)), $ NINT(SHGT(LK)),CTEMP,NT,NINT(SDIRF(LK)),SSPDF(LK), $ NINT(SHGTF(LK)),CTMPF 8412 FORMAT(' LK=',I3,' SDALT <400, DIR/SPD=',I3,'/',F5.1,',TIME=',I4, $ ',ALT=',I5,',TMP=',F7.1,I4,' OBS, GES: DIR/SPD=',I5,'/',F7.1, $ ',ALT=',I5,',TMP=',F7.1) C ELSE NOT SINGLE LEVEL ELSE CALL AVEROB(NUM,INDX,LK) END IF END IF RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: NOEQ2 DOES SUPEROBING FOR TWO OBSERVATIONS ONLY C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 95-03-27 C C ABSTRACT: CALCULATES SUPEROB FOR CASE OF TWO OBSERVATIONS ONLY. C C PROGRAM HISTORY LOG: C 89-04-01 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR C 90-03-29 P. JULIAN -- MODIFIED TO HONOR SDM/QCAIRCFT PURGE FOR C STACKED OBSERVATIONS (OBS. INCRMENT CHECK) C 90-06-14 D. A. KEYSER -- CORRECTED TO HONOR ALL SDM/QCAIRCFT PURGES C FOR STACKED OBS.; FIXED ERROR IN Q. MARK DESIGNATOR C 90-07-03 D. A. KEYSER -- ALT. CORRESP. TO PRESS. OF 300 & 200 MB C FOR REGRESS. CALC. OF SUPEROBS OFF SLIGHTLY, FIXED C 90-09-18 D. A. KEYSER -- MINOR ERROR IN LOGIC CORRECTED, SOME ORIG. C REPORTS WERE BEING GIVEN 'O' Q. MARK BY MISTAKE C 94-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT C 95-03-27 D. A. KEYSER -- FOR INIDST=2, SUPEROBS NOW CONTAIN C SUPEROBED FORECAST(GUESS) P-ALT, WIND DIR, WIND SPEED & C TEMP (IF AVAILABLE FROM INDIV. RPTS MAKING UP SUPEROBS) C C USAGE: CALL NOEQ2(NUM,INDX,LK) C INPUT ARGUMENT LIST: C NUM - NUMBER OF OBSERVATIONS TO BE TREATED C INDX - POINTER TO POSITION IN ORIGINAL AIRCRAFT ARRAY C C OUTPUT ARGUMENT LIST: C LK - POINTER INDICATING ' NUM + NO. OF SUPEROBS FORMED ' C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY MAIN PROGRAM AND BY SUBROUTINES 'AVEROB' AND C 'SUPROB'. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS C C$$$ SUBROUTINE NOEQ2(NUM,INDX,LK) PARAMETER (IRMX=100000, ISMX= 500) C-CRA LOGICAL L1L,L2L LOGICAL L1L,L2L CHARACTER*8 ACID,SAID CHARACTER*14 TAG C-CRA COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), C-CRA$ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), C-CRA$ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), $ KBAD(ISMX),SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) COMMON/SUMDATI/NUMORG COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), $ ADIRF(IRMX) C-CRA COMMON/WRITE/SWRITE,IWRITE LOGICAL SWRITE,IWRITE COMMON/COMWRITE/SWRITE,IWRITE COMMON/CMPNTS/U(ISMX),V(ISMX),UF(ISMX),VF(ISMX) DATA XMSG/99999./ LK=NUMORG C LK IS INITIALIZED TO NUMBER IN STACK C K1 AND K2 ARE RELATIVE TO STACK; I1 AND I2 ARE RELATIVE TO ALL OBS. K1=0 K2=0 DO 724 K=1,NUM KNDX=INDX + K - 1 IF(ISTCPT(K).NE.0.AND.TAG(KNDX)(4:4).NE.'F') THEN IF(K1.EQ.0) THEN K1 =K KBAD(K)=K ELSE K2 =K KBAD(K)=K END IF END IF 724 CONTINUE C BOTH OBS. MUST BE GOOD, MID- OR HIGH-ALTITUDE IF(K1.EQ.0.OR.K2.EQ.0) RETURN I1=INDX + K1 - 1 I2=INDX + K2 - 1 C L1L & L2L ARE TRUE FOR LARGE VECTOR INCREMENT (V-Z) L1L=(TAG(I1)(1:1).GE.'V'.AND.TAG(I1)(1:1).LE.'Z') L2L=(TAG(I2)(1:1).GE.'V'.AND.TAG(I2)(1:1).LE.'Z') IF(L1L.AND.TAG(I1)(3:3).EQ.'E') THEN IF(TAG(I1)(13:13).GT.'3') THEN TAG(I1)(2:2)='F' TAG(I1)(13:13)='3' ITEVNT(I1)=324 END IF IF(TAG(I1)(14:14).GT.'3') THEN TAG(I1)(4:4)='F' TAG(I1)(14:14)='3' IWEVNT(I1)=324 END IF RETURN END IF IF(L2L.AND.TAG(I2)(3:3).EQ.'E') THEN IF(TAG(I2)(13:13).GT.'3') THEN TAG(I2)(2:2)='F' TAG(I2)(13:13)='3' ITEVNT(I2)=324 END IF IF(TAG(I2)(14:14).GT.'3') THEN TAG(I2)(4:4)='F' TAG(I2)(14:14)='3' IWEVNT(I2)=324 END IF RETURN END IF IF(ABS(SHGT(K1)-SHGT(K2)).LE.700..AND.ABS(STIM(K1)-STIM(K2)).LE. $ 300.) THEN LK=NUM + 1 SUMU=(U(K1) + U(K2)) * 0.5 SUMV=(V(K1) + V(K2)) * 0.5 SUMS=(SSPD(K1) + SSPD(K2)) * 0.5 DDD=AVEDIR(SUMU,SUMV,SUMS) SUMA=(SHGT(K1) + SHGT(K2)) * 0.5 SUMSF=XMSG DDDF =XMSG IF(AMAX1(UF(K1),UF(K2),VF(K1),VF(K2),SSPDF(K1),SSPDF(K2)) $ .LT.XMSG) THEN SUMUF=(UF(K1) + UF(K2)) * 0.5 SUMVF=(VF(K1) + VF(K2)) * 0.5 SUMSF=(SSPDF(K1) + SSPDF(K2)) * 0.5 DDDF=AVEDIR(SUMUF,SUMVF,SUMSF) END IF SUMAF=XMSG IF(AMAX1(SHGTF(K1),SHGTF(K2)).LT.XMSG) SUMAF=(SHGTF(K1) + $ SHGTF(K2)) * 0.5 SUMTMP=XMSG SUMTMF=XMSG IF(STMP(K1).LT.XMSG.AND.STMP(K2).LT.XMSG.AND. $ TAG(I1)(2:2).NE.'F'.AND.TAG(I2)(2:2).NE.'F') THEN SUMTMP=(STMP(K1) + STMP(K2)) * 0.5 IF(STMPF(K1).LT.XMSG.AND.STMPF(K2).LT.XMSG) THEN SUMTMF=(STMPF(K1) + STMPF(K2)) * 0.5 ELSE IF(STMPF(K1).LT.XMSG) THEN SUMTMF=STMPF(K1) ELSE IF(STMPF(K2).LT.XMSG) THEN SUMTMF=STMPF(K2) END IF ELSE IF(STMP(K1).LT.XMSG.AND.TAG(I1)(2:2).NE.'F') THEN SUMTMP=STMP(K1) IF(STMPF(K1).LT.XMSG) SUMTMF=STMPF(K1) ELSE IF(STMP(K2).LT.XMSG.AND.TAG(I2)(2:2).NE.'F') THEN SUMTMP=STMP(K2) IF(STMPF(K2).LT.XMSG) SUMTMF=STMPF(K2) END IF SUMT=(STIM(K1) + STIM(K2)) * 0.5 IF(TAG(I1)(13:13).GT.'4') THEN TAG(I1)(2:2)='O' TAG(I1)(13:13)='4' ITEVNT(I1)=315 END IF IF(TAG(I1)(14:14).GT.'4') THEN TAG(I1)(4:4)='O' TAG(I1)(14:14)='4' IWEVNT(I1)=315 END IF IF(TAG(I2)(13:13).GT.'4') THEN TAG(I2)(2:2)='O' TAG(I2)(13:13)='4' ITEVNT(I2)=315 END IF IF(TAG(I2)(14:14).GT.'4') THEN TAG(I2)(4:4)='O' TAG(I2)(14:14)='4' IWEVNT(I2)=315 END IF SDIR(LK)=DDD STIM(LK)=SUMT SHGT(LK)=SUMA STMP(LK)=SUMTMP SLAT(LK)=ALAT(INDX) SLON(LK)=ALON(INDX) KBAD(LK)=LK SSPD(LK)=SUMS SDIRF(LK)=DDDF SHGTF(LK)=SUMAF STMPF(LK)=SUMTMF SSPDF(LK)=SUMSF CTEMP=STMP(LK) IF(STMP(LK).LT.XMSG) CTEMP=STMP(LK)/10. CTMPF=STMPF(LK) IF(STMPF(LK).LT.XMSG) CTMPF=STMPF(LK)/10. PRINT 8666, INDX,NUM,NINT(SDIR(LK)),SSPD(LK),NINT(SHGT(LK)), $ CTEMP,K1,K2,I1,I2,NINT(SDIRF(LK)),SSPDF(LK),CTMPF, $ NINT(SHGTF(LK)) 8666 FORMAT(' NOEQ2',I5,',NM=',I2,',DIR/SPD=',I3,'/',F5.1,',AL=',I5, $ ',T=',F7.1,',K1-2;I1-2=',2I3,2I5,',GES: DIR/SPD=',I5,'/',F7.1, $ ',T=',F7.1,',AL=',I5) END IF RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: STATS CALCS. STATS W/ AND W/O EACH OBS. IN TURN C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 94-08-25 C C ABSTRACT: CALCULATES MEANS AND VARIANCES WITH AND WITHOUT EACH C OBSERVATION IN TURN. IF THERE ARE MORE THAN 'KNO' OBSERVATIONS C NORMALIZED STANDARD DEVIATIONS ARE CALCULATED. OTHERWISE UN- C NORMALIZED STANDARD DEVIATIONS ARE CALCULATED. C C PROGRAM HISTORY LOG: C 89-04-01 P. JULIAN -- ORIGINAL AUTHOR C 94-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT C C USAGE: CALL STATS(KNO,INDX,NUM,SBAR,VPOINT) C INPUT ARGUMENT LIST: C KNO - NO. OF OBS. SEPARATING TREATMENT & STATS CALCULATED C INDX - POINTER TO POSITION IN ORIGINAL AIRCRAFT ARRAY C NUM - NUMBER OF OBSERVATIONS IN STACK C C OUTPUT ARGUMENT LIST: C VPOINT - ARRAY CONTAINING VECTOR DIFFERENCE TO AVERAGE VECTOR C - FOR ALL OBS. IN STACK (IN ORDER OF OBS. IN STACK) C SBAR - AVERAGE SPEED IN STACK C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTINE 'SHEAR'. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS C C$$$ SUBROUTINE STATS(KNO,INDX,NUM,SBAR,VPOINT) PARAMETER (IRMX=100000, ISMX= 500) DIMENSION SQQ(ISMX),DU(ISMX),DV(ISMX),VECT(ISMX),ALTNRM(ISMX), $ UN(ISMX),VN(ISMX),UECT(ISMX),TIMNRM(ISMX),SSDN(ISMX),VPOINT(ISMX) C-CRA LOGICAL SWRITE CHARACTER*8 ACID,SAID CHARACTER*14 TAG C-CRA COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), C-CRA$ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), C-CRA$ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), $ KBAD(ISMX),SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) COMMON/SUMDATI/NUMORG COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), $ ADIRF(IRMX) COMMON/CMPNTS/U(ISMX),V(ISMX),UF(ISMX),VF(ISMX) COMMON/STUFF/SDALT,TBAR COMMON/WORD/LW,ICHTP C-CRA COMMON/WRITE/SWRITE,IWRITE LOGICAL SWRITE,IWRITE COMMON/COMWRITE/SWRITE,IWRITE DATA XMSG/99999./ C THE FOLLOWING IS CALIBRATION CONSTANT - EMPIRICALLY TUNED FOR C SELECTING SIGNIFICANT VECTOR RMS DIFFERENCE DATA CALIBX/1.40/ CRITCN=5.35 ITIMCK=0 IBAD =0 IBADSV=0 ISUSP =0 IREFB =0 IREFS =0 SUMT =0.0 SUMA =0.0 SUMTMP=0.0 SSSTMP=0.0 SUMS =0.0 SSST =0.0 SSSA =0.0 SSSS =0.0 PDV =0.0 SDU =0.0 SQV =0.0 SQU =0.0 SUMU =0.0 SUMV =0.0 SSSU =0.0 SSSV =0.0 KNUM =0 JNUM =0 KNUMT =0 C-CRA CALL XSTORE(UN,XMSG,ISMX) C-CRA CALL XSTORE(DU,XMSG,ISMX) C-CRA CALL XSTORE(VN,XMSG,ISMX) C-CRA CALL XSTORE(DV,XMSG,ISMX) C-CRA CALL XSTORE(SSDN,XMSG,ISMX) C-CRA CALL XSTORE(UECT,-999.0,ISMX) C-CRA CALL XSTORE(VECT,-999.0,ISMX) C-CRA CALL XSTORE(ALTNRM,XMSG,ISMX) C-CRA CALL XSTORE(TIMNRM,XMSG,ISMX) DO I=1,ISMX UN(I)=XMSG DU(I)=XMSG VN(I)=XMSG DV(I)=XMSG SSDN(I)=XMSG UECT(I)=-999.0 VECT(I)=-999.0 ALTNRM(I)=XMSG TIMNRM(I)=XMSG ENDDO DO 101 K=1,NUM KNDX=INDX + K - 1 C INITIALIZE VPOINT AS THE ORIGINAL STACK ORDER VPOINT(K)=REAL(K) IF(IFLEPT(KNDX).LE.0.OR.ISTCPT(K).LE.0) GO TO 101 KNUM=KNUM + 1 IF(ATMP(KNDX).LT.XMSG) THEN KNUMT=KNUMT + 1 SUMTMP=SUMTMP + ATMP(KNDX) SSSTMP=SSSTMP + (ATMP(KNDX) * ATMP(KNDX)) END IF SUMU=SUMU + U(K) SUMV=SUMV + V(K) SUMS=SUMS + ASPD(KNDX) SUMT=SUMT + TIME(KNDX) QQ =AALT(KNDX) - 8000. SUMA=SUMA + QQ SSSU=SSSU + (U(K) * U(K)) SSSV=SSSV + (V(K) * V(K)) SSSS=SSSS + (ASPD(KNDX) * ASPD(KNDX)) SSST=SSST + (TIME(KNDX) * TIME(KNDX)) SSSA=SSSA + (QQ * QQ) SMQU=0.0 SMQV=0.0 SSQU=0.0 SSQV=0.0 C NOTE: JNUM COMES OUT OF 1 LOOP WITH SAME VALUE EVERY TIME (=FINAL C VALUE OF KNUM COMING OUT OF 101 LOOP MINUS 1; THUS IT COMES OUT C OF 101 LOOP WITH THE VALUE KNUM - 1) JNUM=0 DO 1 J=1,NUM JNDX=INDX + J - 1 IF(J.EQ.K.OR.(ISTCPT(J).LE.0.AND.IFLEPT(JNDX).LE.0)) GO TO 1 JNUM=JNUM + 1 SMQU=SMQU + U(J) SMQV=SMQV + V(J) SSQU=SSQU + (U(J) * U(J)) SSQV=SSQV + (V(J) * V(J)) 1 CONTINUE C IF JNUM .GT. KNO CALCULATE NORMALIZED QUANTITIES IF(JNUM.GT.KNO) THEN RFNO=1./JNUM UQAR=SMQU * RFNO VQAR=SMQV * RFNO RNDF=1.0 IF(JNUM.GE.2) RNDF=1./(JNUM - 1) QQQ=(SSQU - (UQAR * UQAR * JNUM)) * RNDF IF(QQQ.LE.0.0) QQQ=.0001 SQU=SQRT(QQQ) QQQ=(SSQV - (VQAR * VQAR * JNUM)) * RNDF IF(QQQ.LE.0.0) QQQ=.0001 SQV=SQRT(QQQ) UN(K)=(U(K) - UQAR)/SQU VN(K)=(V(K) - VQAR)/SQV UECT(K)=SQRT((UN(K) * UN(K)) + (VN(K) * VN(K))) ELSE IF(JNUM.NE.0) THEN RFNO=1./JNUM UQAR=SMQU * RFNO VQAR=SMQV * RFNO DU(K)=U(K) - UQAR DV(K)=V(K) - VQAR VECT(K)=SQRT((DU(K) * DU(K)) + (DV(K) * DV(K))) END IF 101 CONTINUE RNUM=1. IF(KNUM.GT.0) RNUM=1./KNUM SBAR=SUMS * RNUM C IF 2 OR FEWER GOOD HIGH-ALT. OBS. IN STACK, NO MORE NEED BE DONE IF(KNUM.LE.2) RETURN TMPBAR=XMSG RNUMTM=1. IF(KNUMT.GT.0) THEN RNUMTM=1./KNUMT TMPBAR=SUMTMP * RNUMTM END IF IF(KNUMT.GT.1) RNUMTM=1./(KNUMT - 1) UBAR=SUMU * RNUM VBAR=SUMV * RNUM TBAR=SUMT * RNUM ABAR=SUMA * RNUM IF(KNUM.GT.1) RNUM=1./(KNUM - 1) QQQ=(SSSU - (UBAR * UBAR * KNUM)) * RNUM IF(QQQ.LE.0.0) QQQ=.0001 SDU=SQRT(QQQ) QQQ=(SSSV - (VBAR * VBAR * KNUM)) * RNUM IF(QQQ.LE.0.0) QQQ=.0001 SDV=SQRT(QQQ) SDT=SQRT((SSST - (TBAR * TBAR * KNUM)) * RNUM) QQQ=(SSSA - (ABAR * ABAR * KNUM)) * RNUM IF(QQQ.LE.0.0) QQQ=.0001 SDALT=SQRT(QQQ) ABAR=ABAR + 8000. QQQ=(SSSS - (SBAR * SBAR * KNUM)) * RNUM IF(QQQ.LE.0.0) QQQ=.0001 SDS=SQRT(QQQ) SDTMP=XMSG QQQ=0.0 IF(KNUMT.GT.1) QQQ=(SSSTMP - (TMPBAR * TMPBAR * KNUMT)) * RNUMTM IF(QQQ.LE.0.0) QQQ=.0001 SDTMP=SQRT(QQQ) KNUM=0 DO 102 K=1,NUM KNDX=INDX + K - 1 IF(IFLEPT(KNDX).LE.0) GO TO 102 SQ =0.0 SSQ =0.0 C NOTE: KNUM COMES OUT OF 1030 LOOP WITH SAME VALUE EVERY TIME C (=NUMBER OF TIMES 1030 LOOP IS EXECUTED MINUS 1) KNUM=0 DO 1030 J=1,NUM IF(J.EQ.K.OR.ISTCPT(J).LE.0) GO TO 1030 KNUM=KNUM + 1 IF(JNUM.GT.KNO) THEN SQ=SQ + UECT(J) SSQ=SSQ + (UECT(J) * UECT(J)) ELSE SQ=SQ + VECT(J) SSQ=SSQ + (VECT(J) * VECT(J)) END IF 1030 CONTINUE IF(KNUM.NE.0) THEN SQ=SQ/KNUM QNDF=0.0 IF(KNUM.GT.1) QNDF=1./(KNUM - 1) QARG=(SSQ - (SQ * SQ * KNUM)) * QNDF IF(QARG.LE.0.0) QARG=.00001 SSDN(K)=SQRT(QARG) IF(JNUM.GT.KNO) SSDN(K)=SSDN(K) * CRITCN END IF 102 CONTINUE IF(KNUM.GT.KNO) THEN C*********************************************************************** C MORE THAN KNO OBSERVATIONS C*********************************************************************** C-CRA CALL XSTORE(SQQ,XMSG,ISMX) DO I=1,ISMX SQQ(I)=XMSG ENDDO C-CRA CALL XMOVEX(VPOINT,UECT,NUM*LW) DO I=1,NUM VPOINT(I)=UECT(I) ENDDO DO 117 I=1,NUM JNDX=INDX + I - 1 IF(ISTCPT(I).LE.0) GO TO 117 ALTNRM(I)=0. IF(SDALT.EQ.0.) PRINT *, '~~~~~ SDALT=0 IN STATS' IF(SDALT.NE.0.) ALTNRM(I)=ABS((AALT(JNDX)-ABAR)/SDALT) TIMNRM(I)=0. IF(SDT.EQ.0.) PRINT *, '~~~~~ SDT=0 IN STATS' IF(SDT.NE.0.) TIMNRM(I)=ABS((TIME(JNDX)-TBAR)/SDT) QNORM=SQRT(ALTNRM(I) * ALTNRM(I) + TIMNRM(I) * TIMNRM(I)) SQQ(I)=2.50 + (QNORM * CALIBX) IF(UECT(I).GT.SQQ(I).AND.ISTCPT(I).GT.0) IBAD=IBAD + 1 117 CONTINUE PRINT 6006, UBAR,SDU,VBAR,SDV,KNUM,JNUM CTEMP=TMPBAR CTSD =SDTMP IF(TMPBAR.LT.XMSG) CTEMP=TMPBAR/10. IF(SDTMP.LT.XMSG) CTSD =SDTMP/10. PRINT 6106, TBAR,SDT,ABAR,SDALT,SBAR,SDS,CTEMP,CTSD CCCCC IF(IBAD.GT.0) PRINT 1627, (L,UECT(L),SQQ(L),KBAD(L), CCCCC$ ISTCPT(L),ALTNRM(L),TIMNRM(L),L=1,NUM) C1627 FORMAT(' L=',I4,', UECT=',F9.3,', SQQ=',F9.3,', KBAD=',I6, CCCCC$', ISTCPT=',I6,', ALTNRM=',F9.2,', TIMNRM=',F9.2) ELSE C*********************************************************************** C LESS THAN KNO OBSERVATIONS C*********************************************************************** C-CRA CALL XMOVEX(VPOINT,VECT,NUM*LW) DO I=1,NUM VPOINT(I)=VECT(I) ENDDO PRINT 6006, UBAR,SDU,VBAR,SDV,KNUM,JNUM 6006 FORMAT(' UBAR,SDU,VBAR,SDV ',2(F8.1,F8.1),'; KNUM,JNUM ',2I4) CTEMP=TMPBAR CTSD =SDTMP IF(TMPBAR.LT.XMSG) CTEMP=TMPBAR/10. IF(SDTMP.LT.XMSG) CTSD =SDTMP/10. PRINT 6106, TBAR,SDT,ABAR,SDALT,SBAR,SDS,CTEMP,CTSD 6106 FORMAT(' TBAR,SDT ',2F7.0,'; ABAR,SDALT ',2F8.0,'; SBAR,SDS ', $ 2F7.0,'; TMPBAR,SDTMP ',2F7.1) END IF C*********************************************************************** C PRINT SECTION C*********************************************************************** IF(SWRITE) THEN IF(JNUM.GT.KNO) THEN PRINT 6332 6332 FORMAT(6X,'DIR SPD U V DELU DELV D VECT ', $ 'SQQ NALT NTIM ALT TEMP TIME KBAD ISTCPT TAGS') DO 105 I=1,NUM JNDX=INDX + I - 1 CTEMP=ATMP(JNDX) IF(ATMP(JNDX).LT.XMSG) CTEMP=ATMP(JNDX)/10. PRINT 6003, I,ADIR(JNDX),ASPD(JNDX),U(I),V(I),UN(I),VN(I),UECT(I), $ SQQ(I),ALTNRM(I),TIMNRM(I),AALT(JNDX),CTEMP,TIME(JNDX),KBAD(I), $ ISTCPT(I),TAG(JNDX) 6003 FORMAT(' ',I3,F6.0,F6.1,1X,2F7.1,2F8.2,4F8.2,F8.0,F7.1,F7.0,I4,I5, $ 6X,A14) 105 CONTINUE ELSE PRINT 6472 6472 FORMAT(7X,'DIR SPD U V DELU DELV D VECT ', $ 'SSDN ALT TEMP TIME KBAD ISTCPT TAGS') DO 145 I=1,NUM JNDX=INDX + I - 1 CTEMP=ATMP(JNDX) IF(ATMP(JNDX).LT.XMSG) CTEMP=ATMP(JNDX)/10.0 C FOR COMPARISON DAK VS. PRJ SWITCH COMMENTS PRINT 6002, I,ADIR(JNDX),ASPD(JNDX),U(I),V(I),DU(I),DV(I),VECT(I), $ SSDN(I),AALT(JNDX),CTEMP,TIME(JNDX),KBAD(I),ISTCPT(I),TAG(JNDX) 6002 FORMAT(' ',I3,F6.0,F6.1,1X,2F7.1,4F8.2,F9.0,F9.1,F7.0,2I5,6X,A14) 145 CONTINUE END IF END IF RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: AVEDIR CALC. AVG. WIND DIR. FROM AVG. U-/V-COMPS C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 94-08-25 C C ABSTRACT: FUNCTION -- CALCULATES THE AVERAGE METEROLOGICAL WIND C DIRECTION FROM THE AVERAGE OF A NUMBER OF ZONAL AND MERIDIONAL C WIND COMPONENTS. C C PROGRAM HISTORY LOG: C 94-01-01 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR C 94-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT C C USAGE: XX=AVEDIR(SUMU,SUMV,SUMS) C INPUT ARGUMENT LIST: C SUMU - THE AVERAGE OF THE ZONAL WIND COMPONENTS C SUMV - THE AVERAGE OF THE MERIDIONAL WIND COMPONENTS C SUMS - THE AVERAGE OF THE WIND SPEEDS C C REMARKS: REAL VARIABLE 'AVEDIR' RETURNED IS THE AVERAGE WIND C DIRECTION. CALLED BY SUBROUTINES 'AVEROB', 'SUPROB' AND 'NOEQ2'. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS C C$$$ REAL FUNCTION AVEDIR(SUMU,SUMV,SUMS) IF(SUMV.EQ.0.0) SUMV=.001 AVEDIR=(ATAN2( -SUMV, SUMU) * (180./3.14159)) + 270. IF(AVEDIR.GT.360.) AVEDIR=AVEDIR - 360. IF(SUMS.LT.0.5.OR.AVEDIR.LT.0.4) AVEDIR=360. RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: INDEXC GENERAL SORT ROUTINE FOR CHARACTER ARRAY C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 95-05-30 C C ABSTRACT: USES EFFICIENT SORT ALGORITHM TO PRODUCE INDEX SORT LIST C FOR A 16-CHARACTER ARRAY. DOES NOT REARRANGE THE FILE. C C PROGRAM HISTORY LOG: C 93-06-05 R KISTLER --- FORTRAN VERSION OF C-PROGRAM C 93-07-15 P. JULIAN ---- MODIFIED TO SORT 12-CHARACTER ARRAY C 94-08-25 D. A. KEYSER - MODIFIED TO SORT 16-CHARACTER ARRAY C 95-05-30 D. A. KEYSER - TESTS FOR < 2 ELEMENTS IN SORT LIST, C IF SO RETURNS WITHOUT SORTING (BUT FILLS INDX ARRAY) C C USAGE: CALL INDEXC(N,CARRIN,INDX) C INPUT ARGUMENT LIST: C N - SIZE OF ARRAY TO BE SORTED C CARRIN - 16-CHARACTER ARRAY TO BE SORTED C C OUTPUT ARGUMENT LIST: C INDX - ARRAY OF POINTERS GIVING SORT ORDER OF CARRIN IN C - ASCENDING ORDER {E.G., CARRIN(INDX(I)) IS SORTED IN C - ASCENDING ORDER FOR ORIGINAL I=1, ... ,N} C C REMARKS: CALLED BY SUBROUTINES 'TRKCHK' AND 'IDSORT'. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS C C$$$ SUBROUTINE INDEXC(N,CARRIN,INDX) CHARACTER*16 CARRIN(N),CC INTEGER INDX(N) DO 10 J=1,N INDX(J)=J 10 CONTINUE C MUST BE > 1 ELEMENT IN SORT LIST, ELSE RETURN IF(N.LE.1) RETURN L=N/2 + 1 IR=N 33 CONTINUE IF(L.GT.1) THEN L=L - 1 INDXT=INDX(L) CC=CARRIN(INDXT) ELSE INDXT=INDX(IR) CC=CARRIN(INDXT) INDX(IR)=INDX(1) IR=IR - 1 IF(IR.EQ.1) THEN INDX(1)=INDXT RETURN END IF END IF I=L J=L * 2 30 CONTINUE IF(J.LE.IR) THEN IF(J.LT.IR) THEN IF(CARRIN(INDX(J)).LT.CARRIN(INDX(J+1))) J=J + 1 END IF IF(CC.LT.CARRIN(INDX(J))) THEN INDX(I)=INDX(J) I=J J=J + I ELSE J=IR + 1 ENDIF END IF IF(J.LE.IR) GO TO 30 INDX(I)=INDXT GO TO 33 END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: INDEXF GENERAL SORT ROUTINE FOR INTEGER ARRAY C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 95-05-30 C C ABSTRACT: USES EFFICIENT SORT ALGORITHM TO PRODUCE INDEX SORT LIST C FOR AN INTEGER ARRAY. DOES NOT REARRANGE THE FILE. C C PROGRAM HISTORY LOG: C 93-06-05 R KISTLER -- FORTRAN VERSION OF C-PROGRAM C 95-05-30 D. A. KEYSER - TESTS FOR < 2 ELEMENTS IN SORT LIST, C IF SO RETURNS WITHOUT SORTING (BUT FILLS INDX ARRAY) C C USAGE: CALL INDEXF(N,IARRIN,INDX) C INPUT ARGUMENT LIST: C N - SIZE OF ARRAY TO BE SORTED C IARRIN - INTEGER ARRAY TO BE SORTED C C OUTPUT ARGUMENT LIST: C INDX - ARRAY OF POINTERS GIVING SORT ORDER OF IARRIN IN C - ASCENDING ORDER {E.G., IARRIN(INDX(I)) IS SORTED IN C - ASCENDING ORDER FOR ORIGINAL I=1, ... ,N} C C REMARKS: CALLED BY SUBROUTINES 'TRKCHK', 'SHEAR', 'LAPSE', 'SUPROB', C 'STATS' AND 'OBUFR'. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS C C$$$ SUBROUTINE INDEXF(N,IARRIN,INDX) INTEGER INDX(N),IARRIN(N) DO 10 J=1,N INDX(J)=J 10 CONTINUE C MUST BE > 1 ELEMENT IN SORT LIST, ELSE RETURN IF(N.LE.1) RETURN L=N/2 + 1 IR=N 33 CONTINUE IF(L.GT.1) THEN L=L - 1 INDXT=INDX(L) II=IARRIN(INDXT) ELSE INDXT=INDX(IR) II=IARRIN(INDXT) INDX(IR)=INDX(1) IR=IR - 1 IF(IR.EQ.1) THEN INDX(1)=INDXT RETURN END IF END IF I=L J=L * 2 30 CONTINUE IF(J.LE.IR) THEN IF(J.LT.IR) THEN IF(IARRIN(INDX(J)).LT.IARRIN(INDX(J+1))) J=J + 1 END IF IF(II.LT.IARRIN(INDX(J))) THEN INDX(I)=INDX(J) I=J J=J + I ELSE J=IR + 1 END IF END IF IF(J.LE.IR) GO TO 30 INDX(I)=INDXT GO TO 33 END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: DBUFR GETS THE DATE FROM A BUFR/PREPDA FILE C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 94-08-25 C C ABSTRACT: READS THRU SUCCESSIVE BUFR MESSAGES UNTIL THE BUFR TABLE C A ENTRY "AIRCFT" (CONVENTIONAL AIREP/PIREP AND ASDAR/AMDAR AIRCRAFT C REPORTS) IS FOUND IN A BUFR/PREPDA FILE. RETURNS THE DATE OF THIS C MESSAGE TO THE CALLING PROGRAM. C C PROGRAM HISTORY LOG: C 94-08-25 D. A. KEYSER -- ORIGINAL AUTHOR C C USAGE: CALL DBUFR(IDATE8) C OUTPUT ARGUMENT LIST: C IDATE8 - DATE FROM FIRST TABLE A "AIRCFT" MESSAGE (YYMMDDHH) C C INPUT FILES: C UNIT 14 - BUFR/PREPDA FILE CONTAINING ALL DATA C C OUTPUT FILES: C UNIT06 - PRINTOUT C C REMARKS: CALLED BY MAIN PROGRAM. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS C C$$$ SUBROUTINE DBUFR(IDATE8) CHARACTER*8 SUBSET COMMON/WORD/LW,ICHTP COMMON/TSTACAR/KTACAR CALL CLOSBF(14) CALL OPENBF(14,'IN',14) 10 CONTINUE CALL READMG(14,SUBSET,IDATE8,IRET) IF(IRET.NE.0) GO TO 999 IF(SUBSET.EQ.'AIRCAR ') KTACAR=KTACAR + 1 IF(SUBSET.NE.'AIRCFT ') GO TO 10 RETURN 999 CONTINUE C C BUFR/PREPDA DATA SET CONTAINS NO "AIRCFT" TABLE A MSGS C PRINT 14 14 FORMAT(/' BUFR/PREPDA DATA SET CONTAINS NO "AIRCFT" TABLE A ', $ 'MESSAGES - ABORT'/) CALL CLOSBF(14) CALL ABORT END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: IBUFR DECODES ACFT OBS. FROM BUFR/PREPDA FILE C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 2008-12-16 C C ABSTRACT: DECODES A CONVENTIONAL AIREP/PIREP OR ASDAR/AMDAR AIRCRAFT C OBSERVATION FROM A TABLE A ENTRY "AIRCFT" MESSAGE IN A BUFR/PREPDA C FILE FOR EACH CALL. IF ALL SUBSETS HAVE BEEN DECODED IN A MESSAGE C THE NEXT TABLE A ENTRY "AIRCFT" MESSAGE IN READ IN AND DECODED. C A RETURN 1 OCCURS WHEN ALL TABLE A ENTRY "AIRCFT" MESSAGES HAVE C BEEN PROCESSED. SPECIAL LOGIC COMBINES THE SEPARATE WIND AND C MASS REPORT "PIECES" INTO A SINGLE OBSERVATION PRIOR TO RETURN TO C CALLING PROGRAM. C C PROGRAM HISTORY LOG: C 94-08-25 D. A. KEYSER -- ORIGINAL AUTHOR C 95-03-27 D. A. KEYSER -- STORES FORECAST (GUESS) P-ALTITUDE, WIND C DIRECTION, WIND SPEED AND TEMPERATURE FOR EACH DECODED C REPORT (DIRECTION/SPEED OBTAINED FROM FORECAST U/V) C (I/O ARGUMENTS ADDED TO TRANSFER VALUES TO CALLING PGM) C 2008-12-16 D. A. KEYSER -- IN RESPONSE TO CHANGE FROM SINGLE LEVEL C TO DELAYED REPLICATION FOR "AIRCFT" REPORT LEVEL DATA NOW C IN PREPBUFR FILE {IN PREPARATION FOR NRL AIRCRAFT QC C PROGRAM WHICH WILL REPLACE THE REAL-TIME PRODCUTION C VERSION OF THIS PROGRAM (PREPOBS_PREPACQC) IN THE RUC, C NAM, NDAS, GFS, GDAS AND CDAS NETWORKS AND CAN GENERATE C AIRCRAFT "PROFILES"}, RECEIPT TIME (RCT) (WHICH IS NOW C PART OF LEVEL DATA) IS NO LONGER RETRIEVED IN SAME CALL C TO UFBINT AS REMAINING SINGLE-LEVEL HEADER DATA (TO AVOID C BUFRLIB ERROR) (ALL LEVEL DATA HERE STILL HAS JUST ONE C REPLICATION AT THIS POINT) C C USAGE: CALL IBUFR(ALTF,DIRF,SPDF,TMPF,*) C INPUT ARGUMENT LIST: C ALTF - INITIAL FORECAST VALUE FOR PRESSURE ALTITUDE, MISSING C DIRF - INITIAL FORECAST VALUE FOR WIND DIRECTION, MISSING C SPDF - INITIAL FORECAST VALUE FOR WIND SPEED, MISSING C TMPF - INITIAL FORECAST VALUE FOR TEMPERATURE, MISSING C C OUTPUT ARGUMENT LIST: C ALTF - FORECAST VALUE FOR PRESSURE ALTITUDE (METERS) C DIRF - FORECAST VALUE FOR WIND DIRECTION (DEGREES) C SPDF - FORECAST VALUE FOR WIND SPEED (KNOTS) C TMPF - FORECAST VALUE FOR TEMPERATURE (DEG. C X 10) C C INPUT FILES: C UNIT 14 - BUFR/PREPDA FILE CONTAINING ALL DATA C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY MAIN PROGRAM. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS C C$$$ SUBROUTINE IBUFR(ALTF,DIRF,SPDF,TMPF,*) CHARACTER*1 CIQMMK(10),CF CHARACTER*4 QMARKI CHARACTER*8 SUBSET,IDENT CHARACTER*40 HEADR,OBLVL,FCLVL REAL OBS(8),HDR(9),FST(4),ACAT(9),RCT C-CRA COMMON/CBUFR/IRCTME,DATA(1608),IDENT,QMARKI,CF COMMON/CBUFR/DATA(1608),QMARKI,CF COMMON/CBUFRI/IDENT,IRCTME COMMON/WORD/LW,ICHTP COMMON/XDATE/IDATE(5) C-CRA COMMON/INPT/DOSPOB,DOACRS,TMAXO,TMINO,TIMINC,WAYPIN,INIDST,IFLGUS, C-CRA$ JAMASS(6),JAWIND(6),RCPTST COMMON/INPT/TMAXO,TMINO,TIMINC COMMON/INPTI/INIDST,IFLGUS,JAMASS(6),JAWIND(6) LOGICAL DOSPOB,DOACRS,WAYPIN,RCPTST COMMON/INPTL/DOSPOB,DOACRS,WAYPIN,RCPTST INTEGER*8 IRPTYP EQUIVALENCE (IDENT,HDR6),(IRPTYP,DATA(8)) DATA CIQMMK/'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z'/ DATA ACAT/10.5,20.5,30.5,40.5,50.5,60.5,70.5,80.5,90.5/ DATA HEADR/'YOB XOB NUL DHR TSB SID ITP TYP SQN '/ DATA OBLVL/'ZOB TOB DDO FFO TQM WQM UOB VOB '/ DATA FCLVL/'UFC VFC TFC ZFC '/ DATA XMSG/99999./,IMSG/99999/,IFLAG/0/,ILOOP/1/,KI/0/,SQNL/0/ C C ON INPUT: IFLAG =0 - 1ST "PIECE" OF NEXT OBS. HAS NOT YET BEEN DECODED C IFLAG =1 - 1ST "PIECE" OF NEXT OBS. DECODED IN PREVIOUS CALL C IF(IFLAG.EQ.1) GO TO 45 C-CRA CALL XSTORE(DATA,XMSG,1608) DO I=1,1608 DATA(I)=XMSG ENDDO 30 CONTINUE CALL READSB(14,IRET) IF(IRET.NE.0) THEN 20 CONTINUE CALL READMG(14,SUBSET,IDATE8,IRET) IF(IRET.NE.0) THEN PRINT *,'BUFR/PREPDA DATA SET IN UNIT 14 SUCCESSFULLY', $ ' CLOSED FROM INITIAL READ OF AIRCFT OBS.' RETURN 1 END IF IF(SUBSET.NE.'AIRCFT ') GO TO 20 GO TO 30 END IF C CALL UFBINT(14,HDR,9,1,N1LEV,HEADR) CALL UFBINT(14,OBS,8,1,NLEV ,OBLVL) CALL UFBINT(14,FST,4,1,NLEV2,FCLVL) CALL UFBINT(14,RCT,1,1,N3LEV,'RCT') IF(N1LEV.NE.NLEV.OR.NLEV2.NE.NLEV.OR.NLEV.NE.1.OR.N3LEV.NE.NLEV) $ GO TO 999 KI=NINT(HDR(8))/100 C C COMPARE RPT SEQ. NUMBERS IN HEADERS OF TWO "PIECES" DECODED IN THIS C CALL - IF THEY AGREE THEN BOTH ARE PART OF SAME OBS., OTHERWISE THIS C OBS. CONSISTS OF ONLY ONE "PIECE" AND IT IS RETURNED TO CALLING PGM C (IFLAG=1 ON RETURN INDICATES NEXT OBS. 1ST "PIECE" HAS BEEN DECODED) C IF(ILOOP.EQ.2) THEN IF(HDR(9).EQ.SQNL) GO TO 40 ILOOP=1 IFLAG=1 RETURN END IF 45 CONTINUE C C CONSTRUCT OBSERVATION HEADER(ONLY DONE FOR 1ST DECODED REPORT "PIECE") C CF =' ' QMARKI=' C' DATA(1)=MIN0(IMSG,NINT(HDR(1)*100.)) DATA(2)=MIN0(IMSG,NINT(36000.-(HDR(2)*100.))) IRCTME =MIN0(IMSG,NINT(RCT*100.)) NDT=MIN0(IMSG,NINT(HDR(4)*100.)) DATA(4)=NDT + (IDATE(4) * 100) DATA(4)=MOD(NINT(DATA(4)),2400) IF(NINT(DATA(4)).LT.0) DATA(4)=NINT(2400. + DATA(4)) IF(NINT(HDR(5)).EQ.1) CF='C' IRPTYP =MIN0(99,NINT(HDR(7))) HDR6=HDR(6) 40 CONTINUE C C CONSTRUCT WIND PART OF OBSERVATION FROM DECODED WIND REPORT "PIECE" C C QMARKI(4:4) HOLDS SCALED VECTOR WIND INCREMENT MARKER (IF APPLICABLE) C OBTAINED FROM THE CALCULATED VECTOR INCREMENT (NOTE: IF REPORT TIME C IS > 3.33-HOURS FROM CYCLE TIME THE DEFAULT SCALE='C' IS STORED) C IF(KI.EQ.2) THEN IF(AMAX1(FST(1),FST(2)).LT.XMSG) THEN IF(AMAX1(OBS(7),OBS(8)).LT.XMSG.AND.(ABS(DATA(4)- $ REAL(IDATE(4)*100.)).LE.333..OR.(DATA(4)- $ REAL(IDATE(4)*100.)).GE.2067.)) THEN VDIF=SQRT((FST(1)-OBS(7))**2+(FST(2)-OBS(8))**2)*1.9425 QMARKI(4:4)='Z' DO 150 J=1,9 IF(VDIF.LT.ACAT(J)) THEN QMARKI(4:4)=CIQMMK(J) GO TO 175 END IF 150 CONTINUE 175 CONTINUE END IF C C CONSTRUCT FCST WIND DIR. (DEG) & SPD (KTS) FROM FCST WIND COMPONENTS C ISUNIT=1 CALL CMDDFF(ISUNIT,FST(1),FST(2),DIRF,SPDF) DIRF=NINT(DIRF) SPDF=NINT(SPDF) END IF C C DATA(43) HOLDS PRESSURE ALTITUDE (METERS) C DATA(43)=MIN0(IMSG,NINT(OBS(1))) C C ALTF HOLDS FORECAST PRESSURE ALTITUDE (METERS) C IF(FST(4).LT.XMSG) ALTF=NINT(FST(4)) C C DATA(46) HOLDS WIND DIRECTION (DEGREES) C DATA(46)=MIN0(IMSG,NINT(OBS(3))) C C DATA(46) HOLDS WIND SPEED (KNOTS) C DATA(47)=MIN0(IMSG,NINT(OBS(4))) C C QMARKI(1:1) HOLDS QCAIRCFT OR SDM PURGE FLAG (IF APPLICABLE) -- OR -- C HOLDS SDM KEEP FLAG (IF APPLICABLE) C IF(NINT(OBS(6)).EQ.14) THEN QMARKI(1:1)='P' C C QMARKI(2:2) HOLDS INDICATOR THAT THE SOURCE OF THE PURGE (EITHER SDM C OR QCAIRCFT) IS NOT KNOWN (IF APPLICABLE) C QMARKI(2:2)='this was a number sign' C QMARKI(2:2)='/' ELSE IF(NINT(OBS(6)).EQ.0) THEN QMARKI(1:1)='H' END IF ELSE C C CONSTRUCT MASS PART OF OBSERVATION FROM DECODED MASS REPORT "PIECE" C C DATA(44) HOLDS TEMPERATURE (DEGREES CELSIUS X 10) C DATA(44)=MIN0(IMSG,NINT(OBS(2)*10.)) C C TMPF HOLDS FORECAST TEMPERATURE (DEGREES CELSIUS X 10) C IF(FST(3).LT.XMSG) TMPF=NINT(FST(3) * 10.) C C QMARKI(1:1) HOLDS QCAIRCFT OR SDM PURGE FLAG (IF APPLICABLE) -- OR -- C HOLDS SDM KEEP FLAG (IF APPLICABLE) C IF(NINT(OBS(5)).EQ.14) THEN QMARKI(1:1)='P' C C QMARKI(2:2) HOLDS INDICATOR THAT THE SOURCE OF THE PURGE (EITHER SDM C OR QCAIRCFT) IS NOT KNOWN (IF APPLICABLE) C QMARKI(2:2)='This was a number sign' C QMARKI(2:2)='/' ELSE IF(NINT(OBS(5)).EQ.0) THEN QMARKI(1:1)='H' END IF END IF IF(ILOOP.EQ.1) THEN C C IF ONLY ONE "PIECE" HAS BEEN DECODED IN THIS CALL, DECODE NEXT "PIECE" C TO DETERMINE IF IT IS THE SECOND "PIECE" OF THE AIRCRAFT OBSERVATION C (SAVE RPT SEQ. + OF 1ST "PIECE" FOR LATER COMPARISON AGAINST SECOND) C SQNL=HDR(9) ILOOP=2 GO TO 30 END IF C C IF TWO "PIECES" HAVE BEEN DECODED IN THIS CALL, READY TO RETURN C COMPLETE AIRCRAFT OBSERVATION TO CALLING PROGRAM C ILOOP=1 IFLAG=0 RETURN C 999 CONTINUE C C THE NUMBER OF DECODED LEVELS IS NOT 1!! C PRINT *,' THE NUMBER OF DECODED LEVELS FOR A REPORT IS NOT 1 -- ', $ 'ABORT' CALL ABORT C END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: OBUFR WRITES AIRCRAFT RPTS TO BUFR/PREPDA FILE C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 95-04-26 C C ABSTRACT: RESORTS ALL OBS. IN HOLDING ARRAYS BACK TO ORIGINAL ORDER, C THEN FOR ALL TABLE A ENTRY MESSAGES EXCEPT "AIRCFT" DOES A C STRAIGHT COPY OF EACH SUBSET (REPORT) FROM THE INPUT BUFR/PREPDA C FILE TO THE OUTPUT BUFR/PREPDA FILE. FOR TABLE A ENTRY "AIRCFT" C MESSAGES, ALSO COPIES ALL SUBSETS (RPTS) THAT ARE NOT DUPLICATES C OR NOT OUTSIDE USER-SPECIFIED TIME WINDOW. HOWEVER, FROM RESORTED C OBS. HOLDING ARRAYS, DETERMINES IF AN "EVENT" HAS OCCURRED (I.E., C A CHANGED TEMPERATURE OR WIND QUALITY MARKER). IF SO, PUSHES DOWN C TEMPERATURE OR WIND STACKED EVENTS AND RECORDS THIS EVENT (REASON C CODE) ALONG WITH THE NEW QUALITY MARKER PRIOR TO WRITING THE SUBSET C TO THE OUTPUT BUFR/PREPDA FILE. WILL ALSO UPDATE LAT/LON IF IT WAS C CHANGED DUE TO A WAYPOINT ERROR (THIS IS NOT A STACKED EVENT, C HOWEVER). C C PROGRAM HISTORY LOG: C 94-08-25 D. A. KEYSER -- ORIGINAL AUTHOR C 95-03-27 D. A. KEYSER -- N-LIST SWITCHES "JAMASS" & "JAWIND" NOW C 6-WORD ARRAYS, RPTS CAN NOW BE EXCLUDED FROM OUTPUT C ACCORDING TO LAT. BAND; N-LIST SWITCH "FLAGUS"(LOGICAL) C REPLACED BY "IFLGUS"(INTEGER), WHERE IFLGUS=0(1) EQUATES C TO FLAGUS=F(T) AND NEW CHOICE IFLGUS=2 MEANS EXCLUDE RPTS C OVER U.S. FROM OUTPUT RATHER THAN JUST FLAGGING C 95-04-26 D. A. KEYSER -- PROGRAM CODE STILL ENCODED INTO BUFR C BUT ITS VALUE HARDWIRED TO 7 (IN PREP. FOR NEW BUFR C USER TABLE WHICH WILL NO LONGER HAVE PGM CODE) C C USAGE: CALL OBUFR(KOUNT) C INPUT ARGUMENT LIST: C KOUNT - THE NUMBER OF AIRCRAFT OBSERVATIONS IN HOLDING ARRAYS C C INPUT FILES: C UNIT 14 - BUFR/PREPDA FILE CONTAINING ALL DATA C C OUTPUT FILES: C UNIT 06 - PRINTOUT C UNIT 61 - BUFR/PREPDA FILE CONTAINING ALL DATA (NOW WITH ACFT QC) C C REMARKS: CALLED BY MAIN PROGRAM. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS C C$$$ SUBROUTINE OBUFR(KOUNT) PARAMETER (IRMX=100000) PARAMETER (ISIZE= 16) C-CRA LOGICAL LTEST,DOSPOB LOGICAL LTEST CHARACTER*1 CHRQM(6) CHARACTER*8 LAST,ACID,AAID(IRMX),SUBSET,POSITN,HEADR CHARACTER*14 TAG,STAG(IRMX) CHARACTER*20 QM1LVL,QM2LVL REAL POS(2),QMS1(4),QMS2(5),RQM(6),HDR(2),SARRAY(IRMX,ISIZE), $ PHIACF(7) INTEGER INDR(IRMX),IARRAY(IRMX),MFLAG(2) COMMON/ALLDAT/IFLEPT(IRMX),ACID(IRMX),ALAT(IRMX),ALON(IRMX), $ AALT(IRMX),TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE, $ ATMP(IRMX),TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX), $ ITEVNT(IRMX),IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX), $ ADIRF(IRMX) COMMON/WORD/LW,ICHTP COMMON/OUTPUT/KNTOUT(5) C-CRA COMMON/INPT/DOSPOB,DOACRS,TMAXO,TMINO,TIMINC,WAYPIN,INIDST,IFLGUS, C-CRA$ JAMASS(6),JAWIND(6),RCPTST COMMON/INPT/TMAXO,TMINO,TIMINC COMMON/INPTI/INIDST,IFLGUS,JAMASS(6),JAWIND(6) LOGICAL DOSPOB,DOACRS,WAYPIN,RCPTST COMMON/INPTL/DOSPOB,DOACRS,WAYPIN,RCPTST COMMON/TSTACAR/KTACAR COMMON/MASK/GDNH(362,91),GDSH(145,37),GDUS(362,91) DATA QM1LVL/'TOB TQM TPC TRC '/ DATA QM2LVL/'UOB WQM WPC WRC VOB '/ DATA HEADR/'TYP SQN '/ DATA POSITN/'YOB XOB '/ DATA KNTBFR/0/,KKK/0/,IFLAG/0/,SQNL/0/ DATA RQM / 0., 1., 3.,13.,10.,14./ DATA CHRQM/'H','A','Q','F','O','P'/ DATA LAST/'XXXXXXXX'/,ISUBO/0/,ISUBOT/0/,IRECOL/0/,IRECO/0/ DATA PHIACF/-90.,-70.,-20.,0.,20.,70.,90./ DATA MFLAG/2*0/ PRINT 199 199 FORMAT(/5X,'===> ALL REPORTS Q.C.ED AND READY FOR REPACKING'/) LTEST=(IFLGUS.GT.0.AND.KTACAR.GT.1) C TRANSFER ORIGINAL DATA TO TEMPORARY ARRAYS TO HOLD FOR RE-ARRANGING DO 50 J=1,KOUNT IF(LTEST.AND.NINT(ALAT(J)).GT.0.AND.TAG(J)(7:7).NE.'Z') THEN C TEST FOR AIREP/PIREP OBS. OVER CONTINENTAL U.S. WHEN IFLGUS=1 OR 2 C AND THERE ARE AT LEAST TWO "AIRCAR" TABLE A ENTRY BUFR MESSAGES KXI=(360.0 - ALON(J)) + 0.005 + 1.0 KYJ=ALAT(J) + 1.0 IF(KYJ.LT.91.AND.(GDUS(KXI,KYJ).GT..5.OR.GDUS(KXI+1,KYJ).GT. $ .5.OR.GDUS(KXI,KYJ+1).GT..5.OR.GDUS(KXI+1,KYJ+1).GT..5))THEN IF(IFLGUS.EQ.1) THEN C ..IN SUCH A CASE, FOR IFLGUS=1 ADD 400 TO TEMPERATURE AND WIND EVENT C VALUE (THIS WILL LATER BECOME EVENT 325 & FLAG TEMP/WIND W/ 15'S) ITEVNT(J)=ITEVNT(J) + 400 IWEVNT(J)=IWEVNT(J) + 400 ELSE C ..IN SUCH A CASE, FOR IFLGUS=2, SET KNTINI TO 99999 (THIS WILL LATER C EXCLUDE SUCH REPORTS FROM BEING OUTPUT) AND SET TAG POS. 1 TO "D" KNTINI(J)=99999 TAG(J)(1:1)='D' END IF END IF END IF AAID(J)=ACID(J) SARRAY(J,1) =ALAT(J) SARRAY(J,2) =ALON(J) SARRAY(J,3) =AALT(J) SARRAY(J,4) =TIME(J) SARRAY(J,5) =ATMP(J) SARRAY(J,6) =ADIR(J) SARRAY(J,7) =ASPD(J) SARRAY(J,8) =REAL(INTP(J)) SARRAY(J,9) =REAL(IRTM(J)) SARRAY(J,10)=REAL(KNTINI(J)) SARRAY(J,11)=REAL(ITEVNT(J)) SARRAY(J,12)=REAL(IWEVNT(J)) SARRAY(J,13)=AALTF(J) SARRAY(J,14)=ADIRF(J) SARRAY(J,15)=ASPDF(J) SARRAY(J,16)=ATMPF(J) STAG(J)=TAG(J) IARRAY(J)=KNTINI(J) 50 CONTINUE C NEED TO RESORT OBS. ACCORDING TO ORIGINAL ORDER THAT WAS READ IN C CALL SORT ROUTINE- PUTS POINTERS INTO IPOINT ARRAY/DOES NOT REARRANGE IF(KOUNT.GT.0) CALL INDEXF(KOUNT,IARRAY,INDR) C WRITE SORTED REPORTS BACK INTO ORIGINAL ARRAYS DO 11 I=1,KOUNT J=INDR(I) ACID(I) =AAID(J) ALAT(I) =SARRAY(J,1) ALON(I) =SARRAY(J,2) AALT(I) =SARRAY(J,3) TIME(I) =SARRAY(J,4) ATMP(I) =SARRAY(J,5) ADIR(I) =SARRAY(J,6) ASPD(I) =SARRAY(J,7) INTP(I) =NINT(SARRAY(J,8)) IRTM(I) =NINT(SARRAY(J,9)) KNTINI(I)=NINT(SARRAY(J,10)) ITEVNT(I)=NINT(SARRAY(J,11)) IWEVNT(I)=NINT(SARRAY(J,12)) AALTF(I) =SARRAY(J,13) ADIRF(I) =SARRAY(J,14) ASPDF(I) =SARRAY(J,15) ATMPF(I) =SARRAY(J,16) TAG(I) =STAG(J) 11 CONTINUE CALL CLOSBF(14) CALL OPENBF(14,'IN',14) PRINT 200 200 FORMAT(/5X,'+++> BUFR/PREPDA DATA SET IN UNIT 14 SUCCESSFULLY', $ ' OPENED FOR INPUT; FIRST MESSAGE CONTAINS BUFR TABLES A,B,D'/) CALL OPENBF(61,'OUT',14) PRINT 100 100 FORMAT(/5X,'+++> BUFR/PREPDA DATA SET IN UNIT 61 SUCCESSFULLY', $ ' OPENED FOR OUTPUT; CUSTOMIZED BUFR TABLES A,B,D IN UNIT 14'/ $ 12X,'READ IN AND ENCODED INTO MESSAGE NO. 1 OF OUTPUT DATA SET'/) IF(LTEST) THEN IF(IFLGUS.EQ.1) PRINT 300, KTACAR IF(IFLGUS.EQ.2) PRINT 323, KTACAR END IF 300 FORMAT(/8X,'==> CONVL AIREP/PIREP RPTS OVER U.S. MAINLAND/G. MEX' $,'ICO/SO.ONTARIO WILL BE FLAGGED, NO. ACARS MSGS PREV=',I5,' <==') 323 FORMAT(/8X,'==> CONVL AIREP/PIREP RPTS OVER U.S. MAINLAND/G. MEXI' $,'CO/SO.ONTARIO WILL BE EXCLUDED, NO. ACARS MSGS PREV=',I5,' <==') 10 CONTINUE C READ IN NEXT BUFR MESSAGE FROM INPUT FILE CALL READMG(14,SUBSET,IDATE8,IRET) IF(IRET.NE.0) THEN C NON-ZERO IRET IN READMG MEANS ALL BUFR MESSAGES IN FILE HAVE BEEN READ C CLOSE INPUT DATA SET IF(LAST.EQ.'AIRCFT ') THEN C CALL SUBR. SBUFR IF SUPEROBS ARE TO BE INCLUDED IF(DOSPOB.AND.KNTOUT(3).GT.0) $ CALL SBUFR(LTEST,SQNL,IRECOL,ISUBO,ISUBOT) CALL UFBCNT(61,IRECO,ISUBO) ISUBOT=ISUBOT + ISUBO PRINT 1254, IRECO,LAST,ISUBO,ISUBOT 1254 FORMAT(/' --- WROTE BUFR DATA MSG NO. ',I10,' -- TABLE A ENTRY "', $A8,'" - CONTAINS',I6,' REPORTS (TOTAL NO. RPTS WRITTEN =',I7,')'/) END IF PRINT 9101, IRECO,ISUBOT 9101 FORMAT(/' --- ALL TOTAL OF',I11,' BUFR MESSAGES WRITTEN OUT -- TO' $,'TAL NUMBER OF REPORTS WRITTEN =',I7//5X,'===> BUFR/PREPDA DATA ' $,'SET IN UNIT 14 SUCCESSFULLY CLOSED FROM FINAL READ OF ALL OBS') CALL CLOSBF(14) CALL CLOSBF(61) PRINT 9102 9102 FORMAT(/5X,'===> BUFR/PREPDA DATA SET IN UNIT 61 SUCCESSFULLY ', $ 'CLOSED AFTER WRITING OF ALL OBS'/25X,' *** ALL DONE ***'/) RETURN END IF CALL UFBCNT(14,IRECI,ISUBI) CCCCC PRINT 1364, IRECI,SUBSET IF(SUBSET.EQ.'AIRCFT ') PRINT 1364, IRECI,SUBSET 1364 FORMAT(' --- READ IN BUFR DATA MESSAGE NUMBER',I6,' WITH TABLE ', $ 'A ENTRY "',A8,'"') IF(LAST.NE.SUBSET) THEN IF(LAST.EQ.'AIRCFT ') THEN C CALL SUBR. SBUFR IF SUPEROBS ARE TO BE INCLUDED IF(DOSPOB.AND.KNTOUT(3).GT.0) $ CALL SBUFR(LTEST,SQNL,IRECOL,ISUBO,ISUBOT) CALL UFBCNT(61,IRECO,ISUBO) ISUBOT=ISUBOT + ISUBO PRINT 1254, IRECO,LAST,ISUBO,ISUBOT C MUST CLOSE THE LAST "AIRCFT" TABLE A ENTRY MESSAGE CALL CLOSMG(61) END IF PRINT 105, SUBSET,IDATE8 105 FORMAT(/' ===> NEXT MESSAGE IN OUTPUT BUFR/PREPDA DATA SET IN ', $ 'UNIT 61 HAS NEW TABLE A ENTRY OF "',A6,'" -- DATE IS',I9) CALL UFBCNT(61,IRECOL,ISUBO) IRECOL=IRECOL + 1 END IF LAST=SUBSET IF(SUBSET.NE.'AIRCFT ') THEN C ALL TABLE A ENTRY BUFR MESSAGES THAT ARE NOT "AIRCFT" ARE SIMPLY C COPIED FROM INPUT FILE TO OUTPUT FILE AS IS (NO DECODING OF SUBSETS) CALL COPYMG(14,61) CALL UFBCNT(61,IRECO,ISUBO) ISUBOT=ISUBOT + ISUBO CCCCC PRINT 1254, IRECO,SUBSET,ISUBO,ISUBOT GO TO 10 END IF C TABLE A ENTRY "AIRCFT" MESSAGES COME HERE TO DECODE/ENCODE EACH SUBSET CALL OPENMB(61,SUBSET,IDATE8) 2 CONTINUE C READ IN NEXT SUBSET (REPORT) FROM THIS BUFR MESSAGE CALL READSB(14,IRET) C NON-ZERO IRET IN READSB MEANS ALL SUBSETS IN BUFR MSG HAVE BEEN READ C GO ON TO READ NEXT BUFR MESSAGE IF(IRET.NE.0) GO TO 10 C OTHERWISE, MUST LOOK AT RPT SEQ. NUMBER TO SEE IF THIS IS PIECE 1 OF A C 1- OR 2-PIECE(MASS/WIND) OBS. (KNEW=1) OR IF THIS IS PIECE 2 (KNEW=0) CALL UFBINT(14,HDR,2,1,N1LEV,HEADR) IF(N1LEV.NE.1) GO TO 999 KNEW=0 IF(HDR(2).NE.SQNL) THEN KNEW =1 IF(IFLAG.EQ.0) THEN C TEST BELOW SATISFIED WHEN BOTH JAMASS & JAWIND ARE 9999 FOR LAT BAND C (SET POS. 1 OF TAG TO 'D' TO REMOVE FROM FINAL PRINTOUT LISTING) IF(MIN0(MFLAG(1),MFLAG(2)).EQ.1) TAG(KKK)(1:1)='D' KKK=KKK + 1 MFLAG(1)=1 MFLAG(2)=1 END IF IFLAG=0 KNTBFR=KNTBFR + 1 END IF SQNL=HDR(2) C DETERMINE IF THIS "AIRCFT" OBS SHOULD INDEED BE WRITTEN TO OUTPUT FILE IF(KNTBFR.NE.KNTINI(KKK)) THEN C -- COME HERE IF NOT AND SET IFLAG=1 IN CASE NEXT PIECE READ IN IS C PART OF THIS SAME OBS. IFLAG=1 GO TO 2 END IF C DETERMINE LATITUDE BAND INDEX (IBNDA) DO 6700 IBNDA=1,5 IF(ALAT(KKK).LT.(PHIACF(IBNDA+1)-0.005)) GO TO 6701 6700 CONTINUE IBNDA=6 6701 CONTINUE KI=NINT(HDR(1))/100 IF((JAMASS(IBNDA).NE.0.AND.KI.EQ.1).OR.(JAWIND(IBNDA).NE.0.AND. $ KI.EQ.2)) GO TO 3 MFLAG(KI)=0 C ALL SUBSETS THAT ARE TO BE RETAINED ARE FIRST COPIED FROM INPUT BUFFER C TO OUTPUT BUFFER AS IS CALL UFBCPY(14,61) IF(KI.EQ.1.AND.ITEVNT(KKK).GT.0) THEN C --> COME HERE IF THERE IS A TEMPERATURE EVENT (NEW Q. MARKER) C STACK NEW Q.MARK, PGM CODE, REASON CODE (EVENT) AND TEMP. OB CALL UFBINT(14,QMS1,4,1,N1LEV,QM1LVL) IF(N1LEV.NE.1) GO TO 999 IF(MOD(ITEVNT(KKK),400).GT.0) THEN C ----> COME HERE FOR ALL EVENTS EXCEPT 325 QMS1(2)=2. QMS1(3)=7. QMS1(4)=REAL(MOD(ITEVNT(KKK),400)) CVVVVVTEMPORARY C UNTIL NEW USER TABLE SET-UP, MUST SUBTRACT 300 FROM REASON CODE QMS1(4)=QMS1(4) - 300. CAAAAATEMPORARY DO 202 I=1,6 IF(TAG(KKK)(2:2).EQ.CHRQM(I)) THEN QMS1(2)=RQM(I) GO TO 203 END IF 202 CONTINUE 203 CONTINUE CALL UFBINT(61,QMS1,4,1,IRET,QM1LVL) END IF IF(ITEVNT(KKK).GE.400) THEN C ----> COME HERE FOR EVENT 325 QMS1(2)= 15. QMS1(3)= 7. QMS1(4)=325. CVVVVVTEMPORARY C UNTIL NEW USER TABLE SET-UP, MUST SUBTRACT 300 FROM REASON CODE QMS1(4)=QMS1(4) - 300. CAAAAATEMPORARY CALL UFBINT(61,QMS1,4,1,IRET,QM1LVL) END IF ELSE IF(KI.EQ.2.AND.IWEVNT(KKK).GT.0) THEN C --> COME HERE IF THERE IS A WIND EVENT (NEW Q. MARKER) C STACK NEW Q.MARK, PGM CODE, REASON CODE (EVENT) AND WIND OB CALL UFBINT(14,QMS2,5,1,N1LEV,QM2LVL) IF(N1LEV.NE.1) GO TO 999 IF(MOD(IWEVNT(KKK),400).GT.0) THEN C ----> COME HERE FOR ALL EVENTS EXCEPT 325 QMS2(2)=2. QMS2(3)=7. QMS2(4)=REAL(MOD(IWEVNT(KKK),400)) CVVVVVTEMPORARY C UNTIL NEW USER TABLE SET-UP, MUST SUBTRACT 300 FROM REASON CODE QMS2(4)=QMS2(4) - 300. CAAAAATEMPORARY DO 302 I=1,6 IF(TAG(KKK)(4:4).EQ.CHRQM(I)) THEN QMS2(2)=RQM(I) GO TO 303 END IF 302 CONTINUE 303 CONTINUE CALL UFBINT(61,QMS2,5,1,IRET,QM2LVL) END IF IF(IWEVNT(KKK).GE.400) THEN C ----> COME HERE FOR EVENT 325 QMS2(2)= 15. QMS2(3)= 7. QMS2(4)=325. CVVVVVTEMPORARY C UNTIL NEW USER TABLE SET-UP, MUST SUBTRACT 300 FROM REASON CODE QMS2(4)=QMS2(4) - 300. CAAAAATEMPORARY CALL UFBINT(61,QMS2,5,1,IRET,QM2LVL) END IF END IF IF(TAG(KKK)(9:9).EQ.'C') THEN C --> COME HERE IF LAT/LON WAS CHANGED DUE TO WAYPOINT ERROR C WRITE NEW LAT/LON OUT (NOT A STACKED EVENT, OLD LAT/LON GONE!!) POS(1)=ALAT(KKK) POS(2)=360. - ALON(KKK) CALL UFBINT(61,POS,2,1,IRET,POSITN) END IF IF(KI.EQ.1) THEN KNTOUT(1)=KNTOUT(1) + 1 ELSE KNTOUT(2)=KNTOUT(2) + 1 END IF C FINALLY, WRITE SUBSET (REPORT) WITH ANY ADDED EVENTS (IF APPL.) TO C OUTPUT FILE CALL WRITSB(61) CALL UFBCNT(61,IRECO,ISUBON) IF(IRECO.GT.IRECOL) THEN IRECOL=IRECO ISUBOT=ISUBOT + ISUBO PRINT 1264, IRECO-1,ISUBO,ISUBOT 1264 FORMAT(/' --- THIS REPORT OPENS NEW MSG (SAME TABLE A): LAST ', $ 'DATA MSG WAS NO.',I10,' WITH',I5,' REPORTS (TOTAL NO. REPORTS ', $ 'WRITTEN =',I7,')'/) END IF ISUBO=ISUBON 3 CONTINUE CCCCC IF(KNEW.EQ.1) THEN CCCCC TEMP=99999. CCCCC IF(ATMP(KKK).LT.99999.) TEMP=ATMP(KKK)/10. CCCCC PRINT 6111, KKK,ACID(KKK),TIME(KKK),ALAT(KKK),ALON(KKK), CCCCC$ AALT(KKK),TEMP,ADIR(KKK),ASPD(KKK),TAG(KKK)(2:2),TAG(KKK)(4:4), CCCCC$ TAG(KKK),INTP(KKK),IRTM(KKK),KNTINI(KKK),ITEVNT(KKK),IWEVNT(KKK) C6111 FORMAT(' ',I5,2X,A8,F7.0,2F9.2,F7.0,F9.2,F7.0,F8.1,4X,A1,1X,A1, CCCCC$ 3X,A14,2I6,I8,2I6) CCCCC END IF GO TO 2 C----------------------------------------------------------------------- 999 CONTINUE C THE NUMBER OF DECODED HEADER AND/OR OBS. LEVELS IS NOT 1 PRINT 217 217 FORMAT(/' THE NUMBER OF DECODED HEADER AND/OR OBS. LEVELS FOR', $ ' A REPORT IS NOT 1 -- ABORT'/) CALL ABORT C----------------------------------------------------------------------- END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: SBUFR WRITES SUPEROB RPTS TO BUFR/PREPDA FILE C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 95-03-27 C C ABSTRACT: ENCODES SUPEROB AIRCRAFT MASS AND WIND REPORTS INTO THE C OUTPUT BUFR/PREPDA FILE. THESE ARE CONSIDERED EVENT 326 FOR C TEMPERATURE AND WIND. MAY ALSO PUSH DOWN TEMPERATURE AND WIND C STACK AND RECORD AN EVENT IF REPORT IS OVER CONTINENTAL U.S. AND C ACARS DATA ARE PRESENT (EVENT IS SETTING QUALITY MARKER TO 15, C VALID ONLY FOR NAMELIST SWITCH IFLGUS=1). C C PROGRAM HISTORY LOG: C 94-08-25 D. A. KEYSER -- ORIGINAL AUTHOR C 95-03-27 D. A. KEYSER -- SUPEROBS NOW CONTAIN S-OBED FCST P-ALT, C WIND DIR, WIND SPEED & TEMP (IF AVAIL. FROM INDIV. RPTS C MAKING UP SUPEROBS), FCST INFO. ENCODED IN BUFR ALONG W/ C REST OF SUPEROBED DATA (FCST DIR/SPEED CONVERTED TO U/V); C N-LIST SWITCHES "JAMASS" & "JAWIND" NOW 6-WORD ARRAYS, C REPORTS CAN NOW BE EXCLUDED FROM OUTPUT ACCORDING TO C LAT. BAND; N-LIST SWITCH "FLAGUS"(LOGICAL) REPLACED BY C "IFLGUS"(INTEGER), WHERE IFLGUS=0(1) EQUATES TO C FLAGUS=F(T) AND NEW CHOICE IFLGUS=2 MEANS EXCLUDE RPTS C OVER U.S. FROM OUTPUT RATHER THAN JUST FLAGGING C C USAGE: CALL SBUFR(LTEST,COUNT,IRECOL,ISUBO,ISUBOT) C INPUT ARGUMENT LIST: C LTEST - LOGICAL TO INDICATE IF REPORTS OVER CONTINENTAL U.S. C - SHOULD BE FLAGGED (BASED ON NUMBER OF ACARS REPORTS C - AND NAMELIST SWITCH IFLGUS) C COUNT - REPORT SEQUENCE NUMBER OF LAST ORIGINAL AIRCRAFT C - REPORT PROCESSED IN SUBROUTINE OBUFR C IRECOL - CURRENT RECORD (MESSAGE) NUMBER BEING WRITTEN INTO C - IN BUFR/PREPDA DATA SET C ISUBO - CURRENT NUMBER OF SUBSETS THAT HAVE BEEN WRITTEN INTO C - CURRENT RECORD (MESSAGE) IN BUFR/PREPDA DATA SET C ISUBOT - TOTAL NUMBER OF SUBSETS THAT HAVE BEEN WRITTEN INTO C - BUFR/PREPDA DATA SET PRIOR TO THE CURRENT RECORD C C OUTPUT ARGUMENT LIST: C ISUBOT - TOTAL NUMBER OF SUBSETS THAT HAVE BEEN WRITTEN INTO C - BUFR/PREPDA DATA SET PRIOR TO THE CURRENT RECORD C C OUTPUT FILES: C UNIT 06 - PRINTOUT C UNIT 61 - BUFR/PREPDA FILE CONTAINING ALL DATA (NOW WITH ACFT QC C - AND SUPEROBS) C C REMARKS: CALLED BY SUBROUTINE OBUFR. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS C C$$$ SUBROUTINE SBUFR(LTEST,COUNT,IRECOL,ISUBO,ISUBOT) PARAMETER (ISUP= 250) LOGICAL LTEST CHARACTER*1 CIQMMK(10) CHARACTER*4 SSMARK CHARACTER*8 IDENT CHARACTER*16 QMSLV(2),FSTLV(2) CHARACTER*32 OBSLV(2),EVNLV(2) CHARACTER*40 HEADR REAL HDR(10),OBS(8),QMS(4),EVN(8),QFLG(5),FST(4),ACAT(9),PHIACF(7) INTEGER LCAT(9),MFLAG(2) COMMON/TSTACAR/KTACAR COMMON/MASK/GDNH(362,91),GDSH(145,37),GDUS(362,91) COMMON/SUPOBS/SSLAT(ISUP),SSLON(ISUP),SSTIM(ISUP),SSHGT(ISUP), $ SSTMP(ISUP),SSDIR(ISUP),SSSPD(ISUP),SSHGTF(ISUP),SSTMPF(ISUP), $ SSDIRF(ISUP),SSSPDF(ISUP),SSMARK(ISUP) COMMON/OUTPUT/KNTOUT(5) COMMON/XDATE/IDATE(5) C-CRA COMMON/INPT/DOSPOB,DOACRS,TMAXO,TMINO,TIMINC,WAYPIN,INIDST,IFLGUS, C-CRA$ JAMASS(6),JAWIND(6),RCPTST COMMON/INPT/TMAXO,TMINO,TIMINC COMMON/INPTI/INIDST,IFLGUS,JAMASS(6),JAWIND(6) LOGICAL DOSPOB,DOACRS,WAYPIN,RCPTST COMMON/INPTL/DOSPOB,DOACRS,WAYPIN,RCPTST EQUIVALENCE (IDENT,HDR1) DATA HEADR/'SID XOB YOB DHR TYP T29 TSB ITP ELV SQN '/ DATA OBSLV/'POB TOB ZOB CAT NUL NUL NUL NUL ', $ 'POB NUL ZOB CAT UOB VOB DDO FFO '/ DATA QMSLV/'PQM NUL TQM ZQM ', $ 'PQM WQM NUL ZQM '/ DATA FSTLV/'NUL NUL TFC ZFC ', $ 'UFC VFC NUL ZFC '/ DATA EVNLV/'PPC PRC ZPC ZRC TPC TRC NUL NUL ', $ 'PPC PRC ZPC ZRC NUL NUL WPC WRC '/ DATA IDENT/'SUPROB '/,XMSG/99998./ DATA CIQMMK/'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z'/ DATA ACAT/10.5,20.5,30.5,40.5,50.5,60.5,70.5,80.5,90.5/ DATA LCAT/ 20, 40, 60, 80, 100, 120, 140, 160, 180/ DATA PHIACF/-90.,-70.,-20.,0.,20.,70.,90./ C FCNS PRS, PR CALC. PRESS. FROM ALT. FOR Z > 11000M, Z < 11000M; RESP C (U.S. STANDARD ATMOSPHERE) PRS(Z)=226.3 * EXP(1.576106E-4 * (11000. - Z)) PR(Z)=1013.25 * (((288.15 - (.0065 * Z))/288.15)**5.256) PRINT 299 299 FORMAT(/25X,'**** READY TO ENCODE SUPEROB MASS AND WIND REPORTS', $ ' IN THE BUFR/PREPDA FILE ****'/) IF(LTEST) THEN IF(IFLGUS.EQ.1) PRINT 300, KTACAR IF(IFLGUS.EQ.2) PRINT 323, KTACAR END IF 300 FORMAT(8X,'==> SUPEROBED REPORTS OVER U.S. MAINLAND/G. AMERICA/SO', $ '.ONTARIO WILL ALSO BE FLAGGED, NO. ACARS MSGS PREV=',I5,' <=='/) 323 FORMAT(8X,'==> SUPEROBED REPORTS OVER U.S. MAINLAND/G. AMERICA/SO', $'.ONTARIO WILL ALSO BE EXCLUDED, NO. ACARS MSGS PREV=',I5,' <=='/) C INITIALIZE THE CONSTANTS HDR(1) =HDR1 HDR(6) = 41. HDR(7) = 0. HDR(8) = 99. OBS(4) = 6. QMS(1) = 2. QMS(4) = 2. EVN(1) = 7. EVN(2) =326. CVVVVVTEMPORARY C UNTIL NEW USER TABLE SET-UP, MUST SUBTRACT 300 FROM REASON CODE EVN(2)=EVN(2) - 300. CAAAAATEMPORARY EVN(3) = 7. EVN(4) =326. CVVVVVTEMPORARY C UNTIL NEW USER TABLE SET-UP, MUST SUBTRACT 300 FROM REASON CODE EVN(4)=EVN(4) - 300. CAAAAATEMPORARY QFLG(2)= 15. QFLG(3)= 7. QFLG(4)=325. CVVVVVTEMPORARY C UNTIL NEW USER TABLE SET-UP, MUST SUBTRACT 300 FROM REASON CODE QFLG(4)=QFLG(4) - 300. CAAAAATEMPORARY C LOOP THROUGH ALL THE SUPEROBS DO 1 I=1,KNTOUT(3) SSMARK(I)='SS ' IFLAG=0 C CONVERT PRESSURE ALTITUDE TO PRESSURE (VIA U.S. STD. ATMOS. EST.) IF(SSHGT(I).GE.XMSG) THEN SSMARK(I)(3:4)='FF' GO TO 1 END IF IF(LTEST.AND.NINT(SSLAT(I)).GT.0) THEN C TEST FOR SUPEROBS OVER CONTINENTAL U.S. WHEN IFLGUS=1 OR 2 AND THERE C ARE AT LEAST TWO "AIRCAR" TABLE A ENTRY BUFR MESSAGES KXI=(360.0 - SSLON(I)) + 0.005 + 1.0 KYJ=SSLAT(I) + 1.0 IF(KYJ.LT.91.AND.(GDUS(KXI,KYJ).GT..5.OR.GDUS(KXI+1,KYJ).GT. $ .5.OR.GDUS(KXI,KYJ+1).GT..5.OR.GDUS(KXI+1,KYJ+1).GT..5))THEN IF(IFLGUS.EQ.1) THEN C ..IN SUCH A CASE, IF IFLGUS=1 SET IFLAG=1 (WILL LATER FLAG TEMP/ C (WIND WITH 15'S) IFLAG=1 SSMARK(I)(1:2)='PP' ELSE C ..IN SUCH A CASE, IF IFLGUS=2 EXCLUDE REPORT FROM PROCESSING C (WIND WITH 15'S) SSMARK(I)(3:4)='FF' GO TO 1 END IF END IF END IF CCCCC TEMP=99999. CCCCC IF(SSTMP(I).LT.99999.) TEMP=SSTMP(I)/10. CCCCC PRINT 6111, I,SSTIM(I),SSLAT(I),SSLON(I),SSHGT(I),TEMP, CCCCC$ SSDIR(I),SSSPD(I),IFLAG C6111 FORMAT(' ',I5,' SUPROB',F9.0,2F9.2,F7.0,F9.2,F7.0,F8.1,4X, CCCCC$ 'S S',I5) C FILL THE HEADER INFORMATION FOR THIS SUPEROB REPORT OBS(1)=PR(SSHGT(I)) IF(SSHGT(I).GT.11000.) OBS(1)=PRS(SSHGT(I)) HDR(2) =360. - SSLON(I) HDR(3) =SSLAT(I) DT=SSTIM(I) - REAL(IDATE(4)*100) IF(DT.GT. 1200.) DT=DT - 2400. IF(DT.LT.-1200.) DT=DT + 2400. HDR(4) =DT * .01 HDR(9) =SSHGT(I) HDR(10)=COUNT + REAL(I) OBS(3) =SSHGT(I) IF(SSHGTF(I).LT.XMSG) FST(4) =SSHGTF(I) C DETERMINE LATITUDE BAND INDEX (IBNDA) DO 6700 IBNDA=1,5 IF(HDR(3).LT.(PHIACF(IBNDA+1)-0.005)) GO TO 6701 6700 CONTINUE IBNDA=6 6701 CONTINUE MFLAG(1)=1 MFLAG(2)=1 IF(SSTMP(I).LT.XMSG.AND.JAMASS(IBNDA).EQ.0) THEN MFLAG(1)=0 C FILL THE MASS PIECE INFORMATION FOR THIS SUPEROB REPORT HDR(5)=131. OBS(2)=SSTMP(I)/10. IF(SSTMPF(I).LT.XMSG) THEN FST(3)=SSTMPF(I)/10. IF(ABS(HDR(4)).LE.3.33) THEN TDIF=ABS(FST(3)-OBS(2)) SSMARK(I)(3:3)='Z' DO 1150 J=1,9 IF(NINT(TDIF*10.).LT.LCAT(J)) THEN SSMARK(I)(3:3)=CIQMMK(J) GO TO 1175 END IF 1150 CONTINUE 1175 CONTINUE END IF END IF QMS(3)= 1. EVN(5)= 7. EVN(6)=326. CVVVVVTEMPORARY C UNTIL NEW USER TABLE SET-UP, MUST SUBTRACT 300 FROM REASON CODE EVN(6)=EVN(6) - 300. CAAAAATEMPORARY CALL UFBINT(61,HDR,10,1,IRET,HEADR) CALL UFBINT(61,OBS,08,1,IRET,OBSLV(1)) CALL UFBINT(61,QMS,04,1,IRET,QMSLV(1)) CALL UFBINT(61,FST,04,1,IRET,FSTLV(1)) CALL UFBINT(61,EVN,08,1,IRET,EVNLV(1)) IF(IFLAG.EQ.1) THEN C ----> COME HERE FOR EVENT 325 QFLG(1)=OBS(2) CALL UFBINT(61,QFLG,4,1,IRET,'TOB TQM TPC TRC') END IF KNTOUT(4)=KNTOUT(4) + 1 C WRITE SUBSET (SUPEROB MASS REPORT) TO OUTPUT FILE CALL WRITSB(61) CALL UFBCNT(61,IRECO,ISUBON) IF(IRECO.GT.IRECOL) THEN IRECOL=IRECO ISUBOT=ISUBOT + ISUBO PRINT 1264, IRECO-1,ISUBO,ISUBOT 1264 FORMAT(/' --- THIS REPORT OPENS NEW MSG (SAME TABLE A): LAST ', $ 'DATA MSG WAS NO.',I10,' WITH',I5,' REPORTS (TOTAL NO. REPORTS ', $ 'WRITTEN =',I7,')'/) END IF ISUBO=ISUBON END IF IF(SSDIR(I).LT.XMSG.AND.SSSPD(I).LT.XMSG.AND. $ JAWIND(IBNDA).EQ.0) THEN MFLAG(2)=0 C FILL THE WIND PIECE INFORMATION FOR THIS SUPEROB REPORT HDR(5)=231. OBS(7)=SSDIR(I) OBS(8)=SSSPD(I) IF(SSSPD(I).GT.0.) THEN OBS(5)=(-SSSPD(I) * 0.5148) * SIN(SSDIR(I)*0.017453293) OBS(6)=(-SSSPD(I) * 0.5148) * COS(SSDIR(I)*0.017453293) ELSE OBS(5)=0. OBS(6)=0. END IF IF(SSDIRF(I).LT.XMSG.AND.SSSPDF(I).LT.XMSG) THEN FST(1)=(-SSSPDF(I)* 0.5148) * SIN(SSDIRF(I)*0.017453293) FST(2)=(-SSSPDF(I)* 0.5148) * COS(SSDIRF(I)*0.017453293) IF(ABS(HDR(4)).LE.3.33) THEN VDIF=SQRT((FST(1)-OBS(5))**2+(FST(2)-OBS(6))**2)*1.9425 SSMARK(I)(4:4)='Z' DO 150 J=1,9 IF(VDIF.LT.ACAT(J)) THEN SSMARK(I)(4:4)=CIQMMK(J) GO TO 175 END IF 150 CONTINUE 175 CONTINUE END IF END IF QMS(2)= 1. EVN(7)= 7. EVN(8)=326. CVVVVVTEMPORARY C UNTIL NEW USER TABLE SET-UP, MUST SUBTRACT 300 FROM REASON CODE EVN(8)=EVN(8) - 300. CAAAAATEMPORARY CALL UFBINT(61,HDR,10,1,IRET,HEADR) CALL UFBINT(61,OBS,08,1,IRET,OBSLV(2)) CALL UFBINT(61,QMS,04,1,IRET,QMSLV(2)) CALL UFBINT(61,FST,04,1,IRET,FSTLV(2)) CALL UFBINT(61,EVN,08,1,IRET,EVNLV(2)) IF(IFLAG.EQ.1) THEN C ----> COME HERE FOR EVENT 325 QFLG(1)=OBS(5) QFLG(5)=OBS(6) CALL UFBINT(61,QFLG,5,1,IRET,'UOB WQM WPC WRC VOB') END IF KNTOUT(5)=KNTOUT(5) + 1 C WRITE SUBSET (SUPEROB WIND REPORT) TO OUTPUT FILE CALL WRITSB(61) CALL UFBCNT(61,IRECO,ISUBON) IF(IRECO.GT.IRECOL) THEN IRECOL=IRECO ISUBOT=ISUBOT + ISUBO PRINT 1264, IRECO-1,ISUBO,ISUBOT END IF ISUBO=ISUBON END IF C TEST BELOW SATISFIED WHEN BOTH JAMASS & JAWIND ARE 9999 FOR LAT BAND C (SET POS. 1 & 2 OF SSMARK TO 'FF' REMOVE FROM FINAL PRINTOUT LISTING) IF(MIN0(MFLAG(1),MFLAG(2)).EQ.1) SSMARK(I)(3:4)='FF' 1 CONTINUE RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CMDDFF CONVERTS WIND U/V COMPONENTS TO DIR/SPD C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 95-03-27 C C ABSTRACT: CONVERTS GRID U AND V COMPONENTS OF VELOCITY (M/S) TO WIND C DIRECTION AND SPEED. SEE ARGUMENT 'ISUNIT' FOR OUTPUT SPEED UNITS. C C PROGRAM HISTORY LOG: C UNKNOWN C 95-03-27 D. A. KEYSER -- ORIGINAL AUTHOR C C USAGE: CALL CMDDFF(ISUNIT,U,V,DD,FF) C INPUT ARGUMENT LIST: C ISUNIT - OUTPUT SPEED UNIT INDICATOR (=1 - KNOTS, =2 - M/S) C U - U-COMPONENT OF WIND VELOCITY (M/S) C V - V-COMPONENT OF WIND VELOCITY (M/S) C C OUTPUT ARGUMENT LIST: C DD - DIRECTION OF WIND (DEGREES) C FF - SPEED OF WIND (SEE 'ISUNIT' FOR UNITS) C C REMARKS: CALLED BY SUBROUTINE IBUFR. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN/IBM VS FORTRAN C MACHINE: CRAY Y-MP8/832, NAS C C$$$ SUBROUTINE CMDDFF(ISUNIT,U,V,DD,FF) REAL FACTOR(2) DATA FACTOR/0.5148,1.0/,CONV2R/0.017453293/ IF(U.EQ.0.0) THEN DD=0. IF(V.GT.0.0) DD=180. ELSE IF(V.EQ.0.0) THEN DD= 90. IF(U.GT.0.0) DD=270. ELSE DD=(ATAN2(U,V)/CONV2R) + 180. DD=AMOD(DD,360.) END IF END IF FF=SQRT(U**2 + V**2)/FACTOR(ISUNIT) RETURN END SUBROUTINE W3AI39 (NFLD, N) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: W3AI39 TRANSLATE 'ASCII' FIELD TO 'EBCDIC' C PRGMMR: DESMARAIS ORG: W342 DATE: 93-10-06 C C ABSTRACT: TRANSLATE AN 'ASCII' FIELD TO 'EBCDIC', ALL ALPHANUMERICS, C SPECIAL CHARCATERS, FILL SCATTER, BROCKEN< CLEAR, OVERCAST, BELL, C HT AND VT (FOR AFOS). SPACE, '6D' TO '5E' CONVERSION (HDROLOGY), C CHANGERS WERE MADE TO W3AI38 TO GIVE REVERSE TABLE TRANSLATION C C PROGRAM HISTORY LOG: C 93-10-06 R.E.JONES CONVERT IBM370 ASSEBLER VERSION TO FORTRAN C 94-04-28 R.E.JONES CHANGES FOR CRAY C C USAGE: CALL W3AI39 (NFLD,N) C INPUT ARGUMENT LIST: C NFLD - CHARACTER*1 ARRAY OF ASCII DATA C N - INTEGER, CONTAINS CHARACTER COUNT TO CONVERT.... C C OUTPUT ARGUMENT LIST: C NFLD - CHARACTER*1 ARRAY OF EBCDIC DATA C C REMARKS: SOFTWARE VERSION OF IBM370 TRANSLATE INSTRUCTION, BY C CHANGING THE TABLE WE COULD DO A 64, 96, ASCII C CHARACTER SET, CHANGE LOWER CASE TO UPPER, ETC. C TR CONVERT DATA AT A RATE OF 5.4 MILLION CHARACTERS PER SEC. C TR IS IN LIBRARY /USR/LIB/LIBCOS.A ADD TO SEGLDR CARD. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN C MACHINE: CRAY Y-MP8/864 C C$$$ C C-CRA INTEGER IEBCDC(32) INTEGER*8 IEBCDC(32) C CHARACTER*1 NFLD(*) CHARACTER*1 EBCDIC(0:255) C SAVE C EQUIVALENCE (IEBCDC(1),EBCDIC(0)) C C*** EBCDIC CONTAINS HEX. REPRESENTATION OF EBCDIC CHARACTERS C C DATA IEBCDC/ C & X'00010203372D2E2F',X'1605250B0C0D0E0F', C & X'101112003C3D3226',X'18193F2722003500', C & X'405A7F7B5B6C507D',X'4D5D5C4E6B604B61', C & X'F0F1F2F3F4F5F6F7',X'F8F97A5E4C7E6E6F', C & X'7CC1C2C3C4C5C6C7',X'C8C9D1D2D3D4D5D6', C & X'D7D8D9E2E3E4E5E6',X'E7E8E9ADE0BD5F6D', C & X'7981828384858687',X'8889919293949596', C & X'979899A2A3A4A5A6',X'A7A8A9C06AD0A107', C & 16*X'4040404040404040'/ C C THIS TABLE IS THE SAME AS HDS ASSEMBLER VERSION C DATA IEBCDC/ & X'007D006C000000E0',X'00657C66004C0000', & X'0000000000000000',X'0000000000005B00', & X'40D07F7B5000506E',X'4D5D5C4F6B604B61', & X'F0F1F2F3F4F5F6F7',X'F8F90000007E00C0', & X'64C1C2C3C4C5C6C7',X'C8C9D1D2D3D4D5D6', & X'D7D8D9E2E3E4E5E6',X'E7E8E90062636D00', & X'0000000000000000',X'0000000000000000', & X'0000000000000000',X'000000000000005F', & 16 * X'0000000000000000'/ C IF (N .LE. 0) RETURN C C*** CONVERT STRING ... ASCII TO EBCDIC, N CHARACTERS C DO 20 J=1, N NFLD(J)=EBCDIC(mova2i(NFLD(J))) 20 CONTINUE C RETURN END SUBROUTINE W3FS21(IDATE, NMIN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: W3FS21 NUMBER OF MINUTES SINCE JAN 1, 1978 C PRGMMR: REJONES ORG: NMC421 DATE: 89-07-17 C C ABSTRACT: CALCULATES THE NUMBER OF MINUTES SINCE 0000, C 1 JANUARY 1978. C C PROGRAM HISTORY LOG: C 84-06-21 A. DESMARAIS C 89-07-14 R.E.JONES CONVERT TO CYBER 205 FORTRAN 200, C CHANGE LOGIC SO IT WILL WORK IN C 21 CENTURY. C 89-11-02 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN C C USAGE: CALL W3FS21 (IDATE, NMIN) C INPUT ARGUMENT LIST: C IDATE - INTEGER SIZE 5 ARRAY CONTAINING YEAR OF CENTURY, C MONTH, DAY, HOUR AND MINUTE. IDATE(1) MAY BE C A TWO DIGIT YEAR OR 4. IF 2 DIGITS AND GE THAN 78 C 1900 IS ADDED TO IT. IF LT 78 THEN 2000 IS ADDED C TO IT. IF 4 DIGITS THE SUBROUTINE WILL WORK C CORRECTLY TO THE YEAR 3300 A.D. C C OUTPUT ARGUMENT LIST: C NMIN - INTEGER NUMBER OF MINUTES SINCE 1 JANUARY 1978 C C SUBPROGRAMS CALLED: C LIBRARY: C W3LIB - IW3JDN C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN C MACHINE: CRAY Y-MP8/832 C C$$$ C INTEGER IDATE(5) INTEGER NMIN INTEGER JDN78 C DATA JDN78 / 2443510 / C C*** IDATE(1) YEAR OF CENTURY C*** IDATE(2) MONTH OF YEAR C*** IDATE(3) DAY OF MONTH C*** IDATE(4) HOUR OF DAY C*** IDATE(5) MINUTE OF HOUR C NMIN =0 C IYEAR=IDATE(1) C IF (IYEAR.LE.99) THEN IF (IYEAR.LT.78) THEN IYEAR=IYEAR + 2000 ELSE IYEAR=IYEAR + 1900 ENDIF ENDIF C C COMPUTE JULIAN DAY NUMBER FROM YEAR, MONTH, DAY C IJDN =IW3JDN(IYEAR,IDATE(2),IDATE(3)) C C SUBTRACT JULIAN DAY NUMBER OF JAN 1,1978 TO GET THE C NUMBER OF DAYS BETWEEN DATES C NDAYS=IJDN - JDN78 C C*** NUMBER OF MINUTES C NMIN=NDAYS * 1440 + IDATE(4) * 60 + IDATE(5) C RETURN END